diff --git a/.github/workflows/Intel.yml b/.github/workflows/Intel.yml index e4c18ba7..038060af 100644 --- a/.github/workflows/Intel.yml +++ b/.github/workflows/Intel.yml @@ -32,6 +32,38 @@ jobs: sudo apt-get install intel-oneapi-dev-utilities intel-oneapi-mpi-devel intel-oneapi-openmp intel-oneapi-compiler-fortran intel-oneapi-compiler-dpcpp-cpp-and-cpp-classic echo "source /opt/intel/oneapi/setvars.sh" >> ~/.bash_profile + - name: checkout-bacio + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-bacio + path: bacio + ref: develop + + - name: build-bacio + run: | + cd bacio + mkdir build + cd build + cmake .. -DCMAKE_INSTALL_PREFIX=~/bacio + make -j2 + make install + + - name: checkout-w3emc + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-w3emc + path: w3emc + ref: develop + + - name: build-w3emc + run: | + cd w3emc + mkdir build + cd build + cmake .. -DCMAKE_PREFIX_PATH=~/bacio -DCMAKE_INSTALL_PREFIX=~/w3emc + make -j2 + make install + - name: checkout-jasper uses: actions/checkout@v2 with: @@ -65,7 +97,7 @@ jobs: cd g2 mkdir build cd build - cmake .. -DOPENMP=ON -DJasper_ROOT=~/Jasper + cmake -DOPENMP=ON -DCMAKE_PREFIX_PATH="~/Jasper;~/bacio;~/w3emc" .. make -j2 - name: test diff --git a/.github/workflows/Linux_versions.yml b/.github/workflows/Linux_versions.yml new file mode 100644 index 00000000..8940dacf --- /dev/null +++ b/.github/workflows/Linux_versions.yml @@ -0,0 +1,133 @@ +name: Linux_versions +on: [push, pull_request] + +jobs: + Linux_versions: + runs-on: ubuntu-latest + env: + FC: gfortran + CC: gcc + LD_LIBRARY_PATH: /home/runner/jasper/lib + strategy: + matrix: + jasper-version: [2.0.33, 3.0.5] + bacio-version: [2.4.1, 2.5.0] + w3emc-version: [2.9.2, 2.9.3] + + steps: + + - name: install-dependencies + run: | + sudo apt-get update + sudo apt-get install libpng-dev zlib1g-dev libjpeg-dev + + - name: cache-bacio + id: cache-bacio + uses: actions/cache@v2 + with: + path: ~/bacio + key: bacio-${{ runner.os }}-${{ matrix.bacio-version }} + + - name: checkout-bacio + if: steps.cache-bacio.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-bacio + path: bacio + ref: v${{ matrix.bacio-version }} + + - name: build-bacio + if: steps.cache-bacio.outputs.cache-hit != 'true' + run: | + cd bacio + mkdir build + cd build + cmake .. -DCMAKE_INSTALL_PREFIX=~/bacio + make -j2 + make install + + - name: cache-w3emc + id: cache-w3emc + uses: actions/cache@v2 + with: + path: ~/w3emc + key: w3emc-${{ runner.os }}-${{ matrix.w3emc-version }}-${{ matrix.bacio-version }} + + - name: checkout-w3emc + if: steps.cache-w3emc.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-w3emc + path: w3emc + ref: v${{ matrix.w3emc-version }} + + - name: build-w3emc + if: steps.cache-w3emc.outputs.cache-hit != 'true' + run: | + cd w3emc + mkdir build + cd build + cmake .. -DCMAKE_PREFIX_PATH=~/bacio -DCMAKE_INSTALL_PREFIX=~/w3emc + make -j2 + make install + + - name: cache-jasper + id: cache-jasper + uses: actions/cache@v2 + with: + path: ~/jasper + key: jasper-${{ runner.os }}-${{ hashFiles('jasper/VERSION') }} + + - name: checkout-jasper + if: steps.cache-jasper.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: jasper-software/jasper + path: jasper + ref: version-${{ matrix.jasper-version }} + + - name: build-jasper + if: steps.cache-jasper.outputs.cache-hit != 'true' + run: | + cd jasper + mkdir build-jasper && cd build-jasper + cmake .. -DCMAKE_INSTALL_PREFIX=~/jasper + make -j2 + make install + + - name: checkout-g2c + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-g2c + path: g2c + ref: develop + + - name: build-g2c + run: | + cd g2c + mkdir build + cd build + cmake .. -DCMAKE_INSTALL_PREFIX=~/g2c -DJasper_ROOT=~/jasper + make -j2 + make install + + - name: checkout + uses: actions/checkout@v2 + with: + path: g2 + + - name: ${{ matrix.config.name }} + run: | + set -x + cd g2 + mkdir build + cd build + cmake -DJasper_ROOT=~/jasper -DCMAKE_PREFIX_PATH="~/g2c;~/bacio;~/w3emc" -DLOGGING=ON -DCMAKE_BUILD_TYPE=Debug .. + make -j2 VERBOSE=1 + + - name: test + run: | + cd $GITHUB_WORKSPACE/g2/build + ctest --verbose --rerun-failed --output-on-failure + + diff --git a/.github/workflows/MacOS.yml b/.github/workflows/MacOS.yml new file mode 100644 index 00000000..986d0647 --- /dev/null +++ b/.github/workflows/MacOS.yml @@ -0,0 +1,140 @@ +name: MacOS +on: + push: + branches: + - develop + paths-ignore: + - README.md + pull_request: + branches: + - develop + paths-ignore: + - README.md + +jobs: + MacOS: + runs-on: macos-latest + env: + FC: gfortran-12 + CC: gcc + + strategy: + fail-fast: true + matrix: + jasper-version: [3.0.3] + bacio-version: [2.4.1, 2.5.0] + steps: + - name: install-dependencies + run: | + find /Library/Frameworks/ -name "png*" + sudo rm -rf /Library/Frameworks/Mono.framework + brew update + brew install libpng + brew install jpeg-turbo + + - name: cache-bacio + id: cache-bacio + uses: actions/cache@v2 + with: + path: ~/bacio + key: bacio-${{ runner.os }}-${{ matrix.bacio-version }} + + - name: checkout-bacio + if: steps.cache-bacio.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-bacio + path: bacio + ref: v${{ matrix.bacio-version }} + + - name: build-bacio + if: steps.cache-bacio.outputs.cache-hit != 'true' + run: | + cd bacio + mkdir build + cd build + cmake .. -DCMAKE_INSTALL_PREFIX=~/bacio + make -j2 + make install + + - name: cache-w3emc + id: cache-w3emc + uses: actions/cache@v2 + with: + path: ~/w3emc + key: w3emc-${{ runner.os }}-2.9.2-bacio-${{ matrix.bacio-version }} + + - name: checkout-w3emc + if: steps.cache-w3emc.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-w3emc + path: w3emc + ref: v2.9.2 + + - name: build-w3emc + if: steps.cache-w3emc.outputs.cache-hit != 'true' + run: | + cd w3emc + mkdir build + cd build + cmake .. -DCMAKE_PREFIX_PATH=~/bacio -DCMAKE_INSTALL_PREFIX=~/w3emc + make -j2 + make install + + - name: cache-jasper + id: cache-jasper + uses: actions/cache@v2 + with: + path: ~/jasper + key: jasper-${{ runner.os }}-${{ matrix.jasper-version }} + + - name: checkout-jasper + if: steps.cache-jasper.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: jasper-software/jasper + path: jasper + ref: version-${{ matrix.jasper-version }} + + - name: build-jasper + if: steps.cache-jasper.outputs.cache-hit != 'true' + run: | + cd jasper + mkdir build-jasper && cd build-jasper + cmake .. -DCMAKE_INSTALL_PREFIX=~/jasper + make -j2 + make install + + - name: checkout-g2c + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-g2c + path: g2c + ref: develop + + - name: build-g2c + run: | + cd g2c + mkdir build + cd build + cmake .. -DCMAKE_PREFIX_PATH=~/jasper -DCMAKE_INSTALL_PREFIX=~/g2c + make -j2 + make install + - name: checkout + uses: actions/checkout@v2 + with: + path: g2 + + - name: build + run: | + cd g2 + mkdir build + cd build + cmake -DCMAKE_PREFIX_PATH="~/jasper;~/bacio;~/w3emc;~/g2c" -DCMAKE_BUILD_TYPE=Debug .. + make -j2 VERBOSE=1 + + - name: test + run: | + cd $GITHUB_WORKSPACE/g2/build + ctest --output-on-failure diff --git a/.github/workflows/developer.yml b/.github/workflows/developer.yml new file mode 100644 index 00000000..0bb848d3 --- /dev/null +++ b/.github/workflows/developer.yml @@ -0,0 +1,111 @@ +# This is a GitHub actions workflow for NCEPLIBS-g2. +# +# This builds the devleper branch with checking. +# +# Ed Hartnett, 12/22/22 +name: developer +on: [push, pull_request] + +jobs: + developer: + runs-on: ubuntu-latest + env: + FC: gfortran + CC: gcc + + strategy: + fail-fast: true + + steps: + + - name: install-dependencies + run: | + sudo apt-get update + sudo apt-get install libpng-dev zlib1g-dev libjpeg-dev doxygen + python3 -m pip install gcovr + + - name: checkout-bacio + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-bacio + path: bacio + ref: develop + + - name: build-bacio + run: | + cd bacio + mkdir build + cd build + cmake .. -DCMAKE_INSTALL_PREFIX=~/bacio + make -j2 + make install + + - name: checkout-w3emc + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-w3emc + path: w3emc + ref: develop + + - name: build-w3emc + run: | + cd w3emc + mkdir build + cd build + cmake .. -DCMAKE_PREFIX_PATH=~/bacio -DCMAKE_INSTALL_PREFIX=~/w3emc + make -j2 + make install + + - name: cache-jasper + id: cache-jasper + uses: actions/cache@v2 + with: + path: ~/Jasper + key: jasper-${{ runner.os }}-3.0.3 + + - name: checkout-jasper + if: steps.cache-jasper.outputs.cache-hit != 'true' + uses: actions/checkout@v2 + with: + repository: jasper-software/jasper + path: jasper + ref: version-3.0.3 + + - name: build-jasper + if: steps.cache-jasper.outputs.cache-hit != 'true' + run: | + cd jasper + mkdir build-jasper && cd build-jasper + cmake .. -DCMAKE_INSTALL_PREFIX=~/Jasper + make -j2 + make install + + - name: checkout + uses: actions/checkout@v2 + with: + path: g2 + + - name: build + run: | + set -x + cd g2 + mkdir build + doxygen --version + cd build + cmake .. -DENABLE_DOCS=On -DJasper_ROOT=~/Jasper -DCMAKE_PREFIX_PATH="~/bacio;~/w3emc" -DCMAKE_Fortran_FLAGS="-g -fprofile-abs-path -fprofile-arcs -ftest-coverage -O0 -Wall -fsanitize=address" -DCMAKE_C_FLAGS="-g -fprofile-abs-path -fprofile-arcs -ftest-coverage -O0 -Wall -fsanitize=address" -DCMAKE_BUILD_TYPE=Debug + make -j2 VERBOSE=1 + + - name: test + run: | + cd $GITHUB_WORKSPACE/g2/build + ctest --verbose --output-on-failure --rerun-failed + gcovr --root .. -v --html-details --exclude ../tests --exclude CMakeFiles --print-summary -o test-coverage.html &> /dev/null + + - name: upload-test-coverage + uses: actions/upload-artifact@v2 + with: + name: g2-test-coverage + path: | + g2/build/*.html + g2/build/*.css + diff --git a/.github/workflows/gcc_docs_test-coverage.yml b/.github/workflows/gcc_docs_test-coverage.yml index 3bbacda5..1d91b8e2 100644 --- a/.github/workflows/gcc_docs_test-coverage.yml +++ b/.github/workflows/gcc_docs_test-coverage.yml @@ -17,6 +17,38 @@ jobs: sudo apt-get install libpng-dev zlib1g-dev libjpeg-dev doxygen python3 -m pip install gcovr + - name: checkout-bacio + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-bacio + path: bacio + ref: develop + + - name: build-bacio + run: | + cd bacio + mkdir build + cd build + cmake .. -DCMAKE_INSTALL_PREFIX=~/bacio + make -j2 + make install + + - name: checkout-w3emc + uses: actions/checkout@v2 + with: + repository: NOAA-EMC/NCEPLIBS-w3emc + path: w3emc + ref: develop + + - name: build-w3emc + run: | + cd w3emc + mkdir build + cd build + cmake .. -DCMAKE_PREFIX_PATH=~/bacio -DCMAKE_INSTALL_PREFIX=~/w3emc + make -j2 + make install + - name: checkout-jasper uses: actions/checkout@v2 with: @@ -50,7 +82,7 @@ jobs: cd g2 mkdir build cd build - cmake .. -DJasper_ROOT=~/Jasper -DENABLE_DOCS=Yes -DCMAKE_Fortran_FLAGS="-g -fprofile-abs-path -fprofile-arcs -ftest-coverage -O0" + cmake -DCMAKE_PREFIX_PATH="~/Jasper;~/bacio;~/w3emc" .. make -j2 - name: test diff --git a/CMakeLists.txt b/CMakeLists.txt index 01411618..3bfc3805 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,8 +1,9 @@ # This is the main CMake file for NCEPLIBS-g2. # -# Mark Potts, Kyle Gerheiser +# Mark Potts, Kyle Gerheiser, Ed Hartnett cmake_minimum_required(VERSION 3.15) +# Read the current version number from file VERSION. file(STRINGS "VERSION" pVersion) project( @@ -12,6 +13,7 @@ project( include(GNUInstallDirs) +# Handle build type. if(NOT CMAKE_BUILD_TYPE MATCHES "^(Debug|Release|RelWithDebInfo|MinSizeRel)$") message(STATUS "Setting build type to 'Release' as none was specified.") set(CMAKE_BUILD_TYPE @@ -21,18 +23,61 @@ if(NOT CMAKE_BUILD_TYPE MATCHES "^(Debug|Release|RelWithDebInfo|MinSizeRel)$") "MinSizeRel" "RelWithDebInfo") endif() -find_package(Jasper REQUIRED) +# Set flags. +if(CMAKE_C_COMPILER_ID MATCHES "^(Intel)$") + set(CMAKE_C_FLAGS "-g ${CMAKE_C_FLAGS}") + set(CMAKE_C_FLAGS_RELEASE "-O3") + set(CMAKE_Fortran_FLAGS "-g -assume noold_ldout_format ${CMAKE_Fortran_FLAGS}") + set(fortran_d_flags "-r8") +elseif(CMAKE_C_COMPILER_ID MATCHES "^(GNU|Clang|AppleClang)$") + set(CMAKE_C_FLAGS "-g ${CMAKE_C_FLAGS}") + set(CMAKE_C_FLAGS_DEBUG "-ggdb -Wall") + set(CMAKE_Fortran_FLAGS "-g -fno-range-check -funroll-loops ${CMAKE_Fortran_FLAGS}") + set(CMAKE_Fortran_FLAGS_DEBUG "-ggdb -Wall") + set(fortran_d_flags "-fdefault-real-8") +endif() + +# The GNU compilers (after version 10) require the -fallow-argument-mismatch flag. +if(${CMAKE_Fortran_COMPILER_ID} MATCHES "^(GNU)$" AND ${CMAKE_Fortran_COMPILER_VERSION} VERSION_GREATER_EQUAL 10) + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -w -fallow-argument-mismatch") +endif() + +# Handle user build options. +option(ENABLE_DOCS "Enable generation of doxygen-based documentation." OFF) +option(BUILD_4 "Build libg2_4.a" ON) +option(BUILD_D "Build libg2_d.a" ON) + +# There was a bug in jasper for the intel compiler that was fixed in +# 2.0.25. +find_package(Jasper 2.0.25 REQUIRED) find_package(PNG REQUIRED) +find_package(bacio REQUIRED) +if(bacio_VERSION LESS 2.5.0) + add_library(bacio::bacio ALIAS bacio::bacio_4) +endif() +find_package(w3emc 2.9.0 REQUIRED) +# Figure whether user wants a _4, a _d, or both libraries. +if(BUILD_4 AND BUILD_D) + set(kinds "4" "d") +elseif(BUILD_4 AND NOT BUILD_D) + set(kinds "4") +elseif(BUILD_D AND NOT BUILD_4) + set(kinds "d") +else() + message(FATAL_ERROR "At least one of BUILD_4 or BUILD_D must be turned on") +endif() + +# Build the code in the source directory. add_subdirectory(src) +# Unit testing. include(CTest) if(BUILD_TESTING) add_subdirectory(tests) endif() # Determine whether or not to generate documentation. -option(ENABLE_DOCS "Enable generation of doxygen-based documentation." OFF) if(ENABLE_DOCS) find_package(Doxygen REQUIRED) endif() diff --git a/VERSION b/VERSION index 4f5e6973..1cf82530 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -3.4.5 +3.4.6 diff --git a/docs/CMakeLists.txt b/docs/CMakeLists.txt index 48d6b208..fcc972d2 100644 --- a/docs/CMakeLists.txt +++ b/docs/CMakeLists.txt @@ -6,6 +6,7 @@ IF(ENABLE_DOCS) # Create doxyfile. SET(abs_top_srcdir "${CMAKE_SOURCE_DIR}") + SET(abs_top_builddir "${CMAKE_BINARY_DIR}") CONFIGURE_FILE(${CMAKE_CURRENT_SOURCE_DIR}/Doxyfile.in ${CMAKE_CURRENT_BINARY_DIR}/Doxyfile @ONLY) ADD_CUSTOM_TARGET(doc ALL ${DOXYGEN_EXECUTABLE} ${CMAKE_CURRENT_BINARY_DIR}/Doxyfile diff --git a/docs/Doxyfile.in b/docs/Doxyfile.in index 3d08c361..31b18eb4 100644 --- a/docs/Doxyfile.in +++ b/docs/Doxyfile.in @@ -1,4 +1,4 @@ -# Doxyfile 1.8.17 +# Doxyfile 1.9.1 # This file describes the settings to be used by the documentation system # doxygen (www.doxygen.org) for a project. @@ -217,6 +217,14 @@ QT_AUTOBRIEF = YES MULTILINE_CPP_IS_BRIEF = YES +# By default Python docstrings are displayed as preformatted text and doxygen's +# special commands cannot be used. By setting PYTHON_DOCSTRING to NO the +# doxygen's special commands can be used and the contents of the docstring +# documentation blocks is shown as doxygen documentation. +# The default value is: YES. + +PYTHON_DOCSTRING = YES + # If the INHERIT_DOCS tag is set to YES then an undocumented member inherits the # documentation from any documented member that it re-implements. # The default value is: YES. @@ -253,12 +261,6 @@ TAB_SIZE = 4 ALIASES = -# This tag can be used to specify a number of word-keyword mappings (TCL only). -# A mapping has the form "name=value". For example adding "class=itcl::class" -# will allow you to use the command class in the itcl::class meaning. - -TCL_SUBST = - # Set the OPTIMIZE_OUTPUT_FOR_C tag to YES if your project consists of C sources # only. Doxygen will then generate output that is more tailored for C. For # instance, some of the names that are used will be different. The list of all @@ -300,18 +302,21 @@ OPTIMIZE_OUTPUT_SLICE = NO # extension. Doxygen has a built-in mapping, but you can override or extend it # using this tag. The format is ext=language, where ext is a file extension, and # language is one of the parsers supported by doxygen: IDL, Java, JavaScript, -# Csharp (C#), C, C++, D, PHP, md (Markdown), Objective-C, Python, Slice, +# Csharp (C#), C, C++, D, PHP, md (Markdown), Objective-C, Python, Slice, VHDL, # Fortran (fixed format Fortran: FortranFixed, free formatted Fortran: # FortranFree, unknown formatted Fortran: Fortran. In the later case the parser # tries to guess whether the code is fixed or free formatted code, this is the -# default for Fortran type files), VHDL, tcl. For instance to make doxygen treat -# .inc files as Fortran files (default is PHP), and .f files as C (default is -# Fortran), use: inc=Fortran f=C. +# default for Fortran type files). For instance to make doxygen treat .inc files +# as Fortran files (default is PHP), and .f files as C (default is Fortran), +# use: inc=Fortran f=C. # # Note: For files without extension you can use no_extension as a placeholder. # # Note that for custom extensions you also need to set FILE_PATTERNS otherwise -# the files are not read by doxygen. +# the files are not read by doxygen. When specifying no_extension you should add +# * to the FILE_PATTERNS. +# +# Note see also the list of default file extension mappings. EXTENSION_MAPPING = @@ -445,6 +450,19 @@ TYPEDEF_HIDES_STRUCT = NO LOOKUP_CACHE_SIZE = 0 +# The NUM_PROC_THREADS specifies the number threads doxygen is allowed to use +# during processing. When set to 0 doxygen will based this on the number of +# cores available in the system. You can set it explicitly to a value larger +# than 0 to get more control over the balance between CPU load and processing +# speed. At this moment only the input processing can be done using multiple +# threads. Since this is still an experimental feature the default is set to 1, +# which efficively disables parallel processing. Please report any issues you +# encounter. Generating dot graphs in parallel is controlled by the +# DOT_NUM_THREADS setting. +# Minimum value: 0, maximum value: 32, default value: 1. + +NUM_PROC_THREADS = 1 + #--------------------------------------------------------------------------- # Build related configuration options #--------------------------------------------------------------------------- @@ -508,6 +526,13 @@ EXTRACT_LOCAL_METHODS = NO EXTRACT_ANON_NSPACES = YES +# If this flag is set to YES, the name of an unnamed parameter in a declaration +# will be determined by the corresponding definition. By default unnamed +# parameters remain unnamed in the output. +# The default value is: YES. + +RESOLVE_UNNAMED_PARAMS = YES + # If the HIDE_UNDOC_MEMBERS tag is set to YES, doxygen will hide all # undocumented members inside documented classes or files. If set to NO these # members will be included in the various overviews, but no documentation @@ -545,11 +570,18 @@ HIDE_IN_BODY_DOCS = NO INTERNAL_DOCS = NO -# If the CASE_SENSE_NAMES tag is set to NO then doxygen will only generate file -# names in lower-case letters. If set to YES, upper-case letters are also -# allowed. This is useful if you have classes or files whose names only differ -# in case and if your file system supports case sensitive file names. Windows -# (including Cygwin) ands Mac users are advised to set this option to NO. +# With the correct setting of option CASE_SENSE_NAMES doxygen will better be +# able to match the capabilities of the underlying filesystem. In case the +# filesystem is case sensitive (i.e. it supports files in the same directory +# whose names only differ in casing), the option must be set to YES to properly +# deal with such files in case they appear in the input. For filesystems that +# are not case sensitive the option should be be set to NO to properly deal with +# output files written for symbols that only differ in casing, such as for two +# classes, one named CLASS and the other named Class, and to also support +# references to files without having to specify the exact matching casing. On +# Windows (including Cygwin) and MacOS, users should typically set this option +# to NO, whereas on Linux or other Unix flavors it should typically be set to +# YES. # The default value is: system dependent. CASE_SENSE_NAMES = YES @@ -788,10 +820,13 @@ WARN_IF_DOC_ERROR = YES WARN_NO_PARAMDOC = YES # If the WARN_AS_ERROR tag is set to YES then doxygen will immediately stop when -# a warning is encountered. +# a warning is encountered. If the WARN_AS_ERROR tag is set to FAIL_ON_WARNINGS +# then doxygen will continue running as if WARN_AS_ERROR tag is set to NO, but +# at the end of the doxygen process doxygen will return with a non-zero status. +# Possible values are: NO, YES and FAIL_ON_WARNINGS. # The default value is: NO. -WARN_AS_ERROR = NO +WARN_AS_ERROR = YES # The WARN_FORMAT tag determines the format of the warning messages that doxygen # can produce. The string should contain the $file, $line, and $text tags, which @@ -820,13 +855,14 @@ WARN_LOGFILE = # Note: If this tag is empty the current directory is searched. INPUT = @abs_top_srcdir@/docs/user_guide.md \ - @abs_top_srcdir@/src + @abs_top_builddir@/src \ + @abs_top_srcdir@/src # This tag can be used to specify the character encoding of the source files # that doxygen parses. Internally doxygen uses the UTF-8 encoding. Doxygen uses # libiconv (or the iconv built into libc) for the transcoding. See the libiconv -# documentation (see: https://www.gnu.org/software/libiconv/) for the list of -# possible encodings. +# documentation (see: +# https://www.gnu.org/software/libiconv/) for the list of possible encodings. # The default value is: UTF-8. INPUT_ENCODING = UTF-8 @@ -839,15 +875,17 @@ INPUT_ENCODING = UTF-8 # need to set EXTENSION_MAPPING for the extension otherwise the files are not # read by doxygen. # +# Note the list of default checked file patterns might differ from the list of +# default file extension mappings. +# # If left blank the following patterns are tested:*.c, *.cc, *.cxx, *.cpp, # *.c++, *.java, *.ii, *.ixx, *.ipp, *.i++, *.inl, *.idl, *.ddl, *.odl, *.h, # *.hh, *.hxx, *.hpp, *.h++, *.cs, *.d, *.php, *.php4, *.php5, *.phtml, *.inc, # *.m, *.markdown, *.md, *.mm, *.dox (to be provided as doxygen C comment), -# *.doc (to be provided as doxygen C comment), *.txt (to be provided as doxygen -# C comment), *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, *.f, *.for, *.tcl, *.vhd, -# *.vhdl, *.ucf, *.qsf and *.ice. +# *.py, *.pyw, *.f90, *.f95, *.f03, *.f08, *.f18, *.f, *.for, *.vhd, *.vhdl, +# *.ucf, *.qsf and *.ice. -FILE_PATTERNS = *.f *.F *.c +FILE_PATTERNS = *.f *.F *.c *.h *.F90 # The RECURSIVE tag can be used to specify whether or not subdirectories should # be searched for input files as well. @@ -1059,35 +1097,6 @@ USE_HTAGS = NO VERBATIM_HEADERS = YES -# If the CLANG_ASSISTED_PARSING tag is set to YES then doxygen will use the -# clang parser (see: http://clang.llvm.org/) for more accurate parsing at the -# cost of reduced performance. This can be particularly helpful with template -# rich C++ code for which doxygen's built-in parser lacks the necessary type -# information. -# Note: The availability of this option depends on whether or not doxygen was -# generated with the -Duse_libclang=ON option for CMake. -# The default value is: NO. - -CLANG_ASSISTED_PARSING = NO - -# If clang assisted parsing is enabled you can provide the compiler with command -# line options that you would normally use when invoking the compiler. Note that -# the include paths will already be set by doxygen for the files and directories -# specified with INPUT and INCLUDE_PATH. -# This tag requires that the tag CLANG_ASSISTED_PARSING is set to YES. - -CLANG_OPTIONS = - -# If clang assisted parsing is enabled you can provide the clang parser with the -# path to the compilation database (see: -# http://clang.llvm.org/docs/HowToSetupToolingForLLVM.html) used when the files -# were built. This is equivalent to specifying the "-p" option to a clang tool, -# such as clang-check. These options will then be passed to the parser. -# Note: The availability of this option depends on whether or not doxygen was -# generated with the -Duse_libclang=ON option for CMake. - -CLANG_DATABASE_PATH = - #--------------------------------------------------------------------------- # Configuration options related to the alphabetical class index #--------------------------------------------------------------------------- @@ -1099,13 +1108,6 @@ CLANG_DATABASE_PATH = ALPHABETICAL_INDEX = NO -# The COLS_IN_ALPHA_INDEX tag can be used to specify the number of columns in -# which the alphabetical index list will be split. -# Minimum value: 1, maximum value: 20, default value: 5. -# This tag requires that the tag ALPHABETICAL_INDEX is set to YES. - -COLS_IN_ALPHA_INDEX = 5 - # In case all classes in a project start with a common prefix, all classes will # be put under the same header in the alphabetical index. The IGNORE_PREFIX tag # can be used to specify a prefix (or a list of prefixes) that should be ignored @@ -1276,10 +1278,11 @@ HTML_INDEX_NUM_ENTRIES = 100 # If the GENERATE_DOCSET tag is set to YES, additional index files will be # generated that can be used as input for Apple's Xcode 3 integrated development -# environment (see: https://developer.apple.com/xcode/), introduced with OSX -# 10.5 (Leopard). To create a documentation set, doxygen will generate a -# Makefile in the HTML output directory. Running make will produce the docset in -# that directory and running make install will install the docset in +# environment (see: +# https://developer.apple.com/xcode/), introduced with OSX 10.5 (Leopard). To +# create a documentation set, doxygen will generate a Makefile in the HTML +# output directory. Running make will produce the docset in that directory and +# running make install will install the docset in # ~/Library/Developer/Shared/Documentation/DocSets so that Xcode will find it at # startup. See https://developer.apple.com/library/archive/featuredarticles/Doxy # genXcode/_index.html for more information. @@ -1321,8 +1324,8 @@ DOCSET_PUBLISHER_NAME = Publisher # If the GENERATE_HTMLHELP tag is set to YES then doxygen generates three # additional HTML index files: index.hhp, index.hhc, and index.hhk. The # index.hhp is a project file that can be read by Microsoft's HTML Help Workshop -# (see: https://www.microsoft.com/en-us/download/details.aspx?id=21138) on -# Windows. +# (see: +# https://www.microsoft.com/en-us/download/details.aspx?id=21138) on Windows. # # The HTML Help Workshop contains a compiler that can convert all HTML output # generated by doxygen into a single compiled HTML file (.chm). Compiled HTML @@ -1352,7 +1355,7 @@ CHM_FILE = HHC_LOCATION = # The GENERATE_CHI flag controls if a separate .chi index file is generated -# (YES) or that it should be included in the master .chm file (NO). +# (YES) or that it should be included in the main .chm file (NO). # The default value is: NO. # This tag requires that the tag GENERATE_HTMLHELP is set to YES. @@ -1397,7 +1400,8 @@ QCH_FILE = # The QHP_NAMESPACE tag specifies the namespace to use when generating Qt Help # Project output. For more information please see Qt Help Project / Namespace -# (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#namespace). +# (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#namespace). # The default value is: org.doxygen.Project. # This tag requires that the tag GENERATE_QHP is set to YES. @@ -1405,8 +1409,8 @@ QHP_NAMESPACE = org.doxygen.Project # The QHP_VIRTUAL_FOLDER tag specifies the namespace to use when generating Qt # Help Project output. For more information please see Qt Help Project / Virtual -# Folders (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#virtual- -# folders). +# Folders (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#virtual-folders). # The default value is: doc. # This tag requires that the tag GENERATE_QHP is set to YES. @@ -1414,16 +1418,16 @@ QHP_VIRTUAL_FOLDER = doc # If the QHP_CUST_FILTER_NAME tag is set, it specifies the name of a custom # filter to add. For more information please see Qt Help Project / Custom -# Filters (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom- -# filters). +# Filters (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom-filters). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_CUST_FILTER_NAME = # The QHP_CUST_FILTER_ATTRS tag specifies the list of the attributes of the # custom filter to add. For more information please see Qt Help Project / Custom -# Filters (see: https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom- -# filters). +# Filters (see: +# https://doc.qt.io/archives/qt-4.8/qthelpproject.html#custom-filters). # This tag requires that the tag GENERATE_QHP is set to YES. QHP_CUST_FILTER_ATTRS = @@ -1435,9 +1439,9 @@ QHP_CUST_FILTER_ATTRS = QHP_SECT_FILTER_ATTRS = -# The QHG_LOCATION tag can be used to specify the location of Qt's -# qhelpgenerator. If non-empty doxygen will try to run qhelpgenerator on the -# generated .qhp file. +# The QHG_LOCATION tag can be used to specify the location (absolute path +# including file name) of Qt's qhelpgenerator. If non-empty doxygen will try to +# run qhelpgenerator on the generated .qhp file. # This tag requires that the tag GENERATE_QHP is set to YES. QHG_LOCATION = @@ -1514,6 +1518,17 @@ TREEVIEW_WIDTH = 250 EXT_LINKS_IN_WINDOW = NO +# If the HTML_FORMULA_FORMAT option is set to svg, doxygen will use the pdf2svg +# tool (see https://github.com/dawbarton/pdf2svg) or inkscape (see +# https://inkscape.org) to generate formulas as SVG images instead of PNGs for +# the HTML output. These images will generally look nicer at scaled resolutions. +# Possible values are: png (the default) and svg (looks nicer but requires the +# pdf2svg or inkscape tool). +# The default value is: png. +# This tag requires that the tag GENERATE_HTML is set to YES. + +HTML_FORMULA_FORMAT = png + # Use this tag to change the font size of LaTeX formulas included as images in # the HTML documentation. When you change the font size after a successful # doxygen run you need to manually remove any form_*.png images from the HTML @@ -1553,7 +1568,7 @@ USE_MATHJAX = NO # When MathJax is enabled you can set the default output format to be used for # the MathJax output. See the MathJax site (see: -# http://docs.mathjax.org/en/latest/output.html) for more details. +# http://docs.mathjax.org/en/v2.7-latest/output.html) for more details. # Possible values are: HTML-CSS (which is slower, but has the best # compatibility), NativeMML (i.e. MathML) and SVG. # The default value is: HTML-CSS. @@ -1569,7 +1584,7 @@ MATHJAX_FORMAT = HTML-CSS # Content Delivery Network so you can quickly see the result without installing # MathJax. However, it is strongly recommended to install a local copy of # MathJax from https://www.mathjax.org before deployment. -# The default value is: https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/. +# The default value is: https://cdn.jsdelivr.net/npm/mathjax@2. # This tag requires that the tag USE_MATHJAX is set to YES. MATHJAX_RELPATH = http://cdn.mathjax.org/mathjax/latest @@ -1583,7 +1598,8 @@ MATHJAX_EXTENSIONS = # The MATHJAX_CODEFILE tag can be used to specify a file with javascript pieces # of code that will be used on startup of the MathJax code. See the MathJax site -# (see: http://docs.mathjax.org/en/latest/output.html) for more details. For an +# (see: +# http://docs.mathjax.org/en/v2.7-latest/output.html) for more details. For an # example see the documentation. # This tag requires that the tag USE_MATHJAX is set to YES. @@ -1630,7 +1646,8 @@ SERVER_BASED_SEARCH = NO # # Doxygen ships with an example indexer (doxyindexer) and search engine # (doxysearch.cgi) which are based on the open source search engine library -# Xapian (see: https://xapian.org/). +# Xapian (see: +# https://xapian.org/). # # See the section "External Indexing and Searching" for details. # The default value is: NO. @@ -1643,8 +1660,9 @@ EXTERNAL_SEARCH = NO # # Doxygen ships with an example indexer (doxyindexer) and search engine # (doxysearch.cgi) which are based on the open source search engine library -# Xapian (see: https://xapian.org/). See the section "External Indexing and -# Searching" for details. +# Xapian (see: +# https://xapian.org/). See the section "External Indexing and Searching" for +# details. # This tag requires that the tag SEARCHENGINE is set to YES. SEARCHENGINE_URL = @@ -1739,7 +1757,7 @@ COMPACT_LATEX = NO # The default value is: a4. # This tag requires that the tag GENERATE_LATEX is set to YES. -PAPER_TYPE = a4wide +PAPER_TYPE = a4 # The EXTRA_PACKAGES tag can be used to specify one or more LaTeX package names # that should be included in the LaTeX output. The package can be specified just @@ -1808,9 +1826,11 @@ LATEX_EXTRA_FILES = PDF_HYPERLINKS = YES -# If the USE_PDFLATEX tag is set to YES, doxygen will use pdflatex to generate -# the PDF file directly from the LaTeX files. Set this option to YES, to get a -# higher quality PDF documentation. +# If the USE_PDFLATEX tag is set to YES, doxygen will use the engine as +# specified with LATEX_CMD_NAME to generate the PDF file directly from the LaTeX +# files. Set this option to YES, to get a higher quality PDF documentation. +# +# See also section LATEX_CMD_NAME for selecting the engine. # The default value is: YES. # This tag requires that the tag GENERATE_LATEX is set to YES. @@ -2242,7 +2262,7 @@ HIDE_UNDOC_RELATIONS = YES # http://www.graphviz.org/), a graph visualization toolkit from AT&T and Lucent # Bell Labs. The other options in this section have no effect if this option is # set to NO -# The default value is: YES. +# The default value is: NO. HAVE_DOT = NO @@ -2321,10 +2341,32 @@ UML_LOOK = NO # but if the number exceeds 15, the total amount of fields shown is limited to # 10. # Minimum value: 0, maximum value: 100, default value: 10. -# This tag requires that the tag HAVE_DOT is set to YES. +# This tag requires that the tag UML_LOOK is set to YES. UML_LIMIT_NUM_FIELDS = 10 +# If the DOT_UML_DETAILS tag is set to NO, doxygen will show attributes and +# methods without types and arguments in the UML graphs. If the DOT_UML_DETAILS +# tag is set to YES, doxygen will add type and arguments for attributes and +# methods in the UML graphs. If the DOT_UML_DETAILS tag is set to NONE, doxygen +# will not generate fields with class member information in the UML graphs. The +# class diagrams will look similar to the default class diagrams but using UML +# notation for the relationships. +# Possible values are: NO, YES and NONE. +# The default value is: NO. +# This tag requires that the tag UML_LOOK is set to YES. + +DOT_UML_DETAILS = NO + +# The DOT_WRAP_THRESHOLD tag can be used to set the maximum number of characters +# to display on a single line. If the actual line length exceeds this threshold +# significantly it will wrapped across multiple lines. Some heuristics are apply +# to avoid ugly line breaks. +# Minimum value: 0, maximum value: 1000, default value: 17. +# This tag requires that the tag HAVE_DOT is set to YES. + +DOT_WRAP_THRESHOLD = 17 + # If the TEMPLATE_RELATIONS tag is set to YES then the inheritance and # collaboration graphs will show the relations between templates and their # instances. @@ -2398,9 +2440,7 @@ DIRECTORY_GRAPH = YES # Note: If you choose svg you need to set HTML_FILE_EXTENSION to xhtml in order # to make the SVG files visible in IE 9+ (other browsers do not have this # requirement). -# Possible values are: png, png:cairo, png:cairo:cairo, png:cairo:gd, png:gd, -# png:gd:gd, jpg, jpg:cairo, jpg:cairo:gd, jpg:gd, jpg:gd:gd, gif, gif:cairo, -# gif:cairo:gd, gif:gd, gif:gd:gd, svg, png:gd, png:gd:gd, png:cairo, +# Possible values are: png, jpg, gif, svg, png:gd, png:gd:gd, png:cairo, # png:cairo:gd, png:cairo:cairo, png:cairo:gdiplus, png:gdiplus and # png:gdiplus:gdiplus. # The default value is: png. @@ -2516,9 +2556,11 @@ DOT_MULTI_TARGETS = NO GENERATE_LEGEND = YES -# If the DOT_CLEANUP tag is set to YES, doxygen will remove the intermediate dot +# If the DOT_CLEANUP tag is set to YES, doxygen will remove the intermediate # files that are used to generate the various graphs. +# +# Note: This setting is not only used for dot files but also for msc and +# plantuml temporary files. # The default value is: YES. -# This tag requires that the tag HAVE_DOT is set to YES. DOT_CLEANUP = YES diff --git a/docs/user_guide.md b/docs/user_guide.md index 2752ac60..ad9a6850 100644 --- a/docs/user_guide.md +++ b/docs/user_guide.md @@ -1,5 +1,9 @@ @mainpage +## Documentation for Previous Versions of NCEPLIBS-g2 + +* [NCEPLIBS-g2 Version 3.4.5](ver-3.4.5/index.html) + # Introduction This document briefly describes the routines available for encoding/decoding diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 312b0859..8001126a 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,5 +1,27 @@ -include("list_of_files.cmake") +# This is the CMake file for the src directory of the NCEPLIBS-g2 project. +# +# Mark Potts, Kyle Gerheiser, Ed Hartnett + +# These are the fortran source files. +set(fortran_src addfield.f addgrid.f addlocal.f cmplxpack.f compack.f +comunpack.f drstemplates.f g2_gbytesc.f g2grids.f gb_info.f gdt2gds.f +getdim.f getfield.F90 getg2i.f getg2ir.f getgb2.f getgb2l.f getgb2p.f +getgb2r.f getgb2rp.f getgb2s.f getidx.f getlocal.f getpoly.f +gettemplates.f gf_free.f gf_getfld.F90 gf_unpack1.f gf_unpack2.f +gf_unpack3.F90 gf_unpack4.f gf_unpack5.f gf_unpack6.f gf_unpack7.f +gribcreate.f gribend.f gribinfo.f ${CMAKE_CURRENT_BINARY_DIR}/gribmod.F90 gridtemplates.f intmath.f +ixgb2.f jpcpack.f jpcunpack.f misspack.f mkieee.f pack_gp.f +params_ecmwf.f params.f pdstemplates.F90 pngpack.f pngunpack.f putgb2.f +rdieee.f realloc.f reduce.f simpack.f simunpack.f skgb.f specpack.f +specunpack.f ) + +# These are the C source files. +set(c_src dec_jpeg2000.c dec_png.c enc_jpeg2000.c enc_png.c mova2i.c ) + +# Create this fortran file, which has the contents of the VERSION file +# substituted in. +configure_file("${CMAKE_CURRENT_SOURCE_DIR}/gribmod.F90.in" "${CMAKE_CURRENT_BINARY_DIR}/gribmod.F90" @ONLY) add_compile_definitions(__64BIT__) if(APPLE) diff --git a/src/addfield.f b/src/addfield.f index 489e983e..19190941 100644 --- a/src/addfield.f +++ b/src/addfield.f @@ -96,6 +96,7 @@ subroutine addfield(cgrib,lcgrib,ipdsnum,ipdstmpl,ipdstmplen, integer,intent(in) :: idrsnum,numcoord,ipdstmplen,idrstmplen integer,intent(in) :: lcgrib,ngrdpts,ibmap real,intent(in) :: coordlist(numcoord) + real(kind = 4) :: coordlist_4(numcoord) real,target,intent(in) :: fld(ngrdpts) integer,intent(out) :: ierr integer,intent(inout) :: idrstmpl(*) @@ -259,7 +260,10 @@ subroutine addfield(cgrib,lcgrib,ipdsnum,ipdstmpl,ipdstmplen, ! after the Product Definition Template, if necessary. ! if ( numcoord .ne. 0 ) then - call mkieee(coordlist,coordieee,numcoord) + do i = 1, numcoord + coordlist_4(i) = coordlist(i) + end do + call mkieee(coordlist_4, coordieee, numcoord) call g2_sbytesc(cgrib,coordieee,iofst,32,0,numcoord) iofst=iofst+(32*numcoord) endif diff --git a/src/dec_jpeg2000.c b/src/dec_jpeg2000.c index 0528ffb3..697ac3aa 100644 --- a/src/dec_jpeg2000.c +++ b/src/dec_jpeg2000.c @@ -1,148 +1,198 @@ -/** - * @file - * @brief This Function decodes a JPEG2000 code stream specified in the - * JPEG2000 Part-1 standard. +/** @file + * @brief Decodes JPEG2000 code stream. * @author Stephen Gilbert @date 2002-12-02 + * + * ### Program History Log + * Date | Programmer | Comments + * -----|------------|--------- + * 2002-12-02 | Gilbert | Initial + * 2022-04-15 | Hartnett | Converted to use jas_ instead of jpc_ functions. */ #include #include #include #include "jasper/jasper.h" -#define JAS_1_700_2 - - -#ifdef __64BIT__ - typedef int g2int; /**< Integer type. */ -#else - typedef long g2int; /**< Long Integer type. */ -#endif - -#if defined CRAY90 - #include - #define SUB_NAME DEC_JPEG2000 -#elif defined LINUXF90 - #define SUB_NAME DEC_JPEG2000 -#elif defined LINUXG95 - #define SUB_NAME dec_jpeg2000__ -#elif defined HP || defined AIX - #define SUB_NAME dec_jpeg2000 -#elif defined SGI || defined LINUX || defined VPP5000 || defined APPLE - #define SUB_NAME dec_jpeg2000_ -#endif +#include "jpeg.h" /** - * This Function decodes a JPEG2000 code stream specified in the JPEG2000 Part-1 standard. - * The JPEG2000 Part-1 standard (i.e., ISO/IEC 15444-1) using JasPer - * Software version 1.500.4 (or 1.700.2) written by the University of British - * Columbia and Image Power Inc, and others. - * JasPer is available at http://www.ece.uvic.ca/~mdadams/jasper/. - * - * @param[in] injpc Input JPEG2000 code stream. - * @param[in] bufsize Length (in bytes) of the input JPEG2000 code stream. - * @param[in] outfld Output matrix of grayscale image values. Only grayscale is expected. - * @return - 0 = Successful decode - * - -3 = Error decode jpeg2000 code stream. - * - -5 = decoded image had multiple color components. + * This Function decodes a JPEG2000 code stream specified in the + * JPEG2000 Part-1 standard (i.e., ISO/IEC 15444-1) using [JasPer + * Software](https://github.com/jasper-software/jasper). + * + * @param injpc Pointer to buffer that holds the input JPEG2000 code + * stream. + * @param bufsize Length (in bytes) of the buffer that holds the input + * JPEG2000 code stream. + * @param outfld Pointer to either int or g2int array, already + * allocated, that gets the unpacked data. + * @param out_is_g2int Non-zero if the output array is of type g2int + * (i.e. 64-bit ints), zero if output is an int array (32-bits). * - * @note Requires JasPer Software version 1.500.4 or 1.700.2 + * @return + * - 0 Successful decode + * - ::G2_JASPER_DECODE Error decode jpeg2000 code stream. + * - ::G2_JASPER_DECODE_COLOR decoded image had multiple color + * components. Only grayscale is expected. + * - ::G2_JASPER_INIT Error inializing Jasper library. * * @author Stephen Gilbert @date 2002-12-02 + * @author Ed Hartnett */ - int SUB_NAME(char *injpc,g2int *bufsize,g2int *outfld) +static int +int_dec_jpeg2000(char *injpc, g2int bufsize, void *outfld, int out_is_g2int) { - int ier=0; - g2int i,j,k,n; - jas_image_t *image=0; - jas_stream_t *jpcstream,*istream; - jas_image_cmpt_t cmpt,*pcmpt; - char *opts=0; + g2int i, j, k; + jas_image_t *image = NULL; + jas_stream_t *jpcstream; + jas_image_cmpt_t *pcmpt; + char *opts = NULL; jas_matrix_t *data; + int fmt; + + /* Initialize Jasper. */ +#ifdef JASPER3 + jas_conf_clear(); + /* static jas_std_allocator_t allocator; */ + /* jas_std_allocator_init(&allocator); */ + /* jas_conf_set_allocator(JAS_CAST(jas_std_allocator_t *, &allocator)); */ + jas_conf_set_max_mem_usage(10000000); + jas_conf_set_multithread(true); + if (jas_init_library()) + return G2_JASPER_INIT; + if (jas_init_thread()) + return G2_JASPER_INIT; +#else + if (jas_init()) + return G2_JASPER_INIT; +#endif /* JASPER3 */ -/* jas_init(); */ + /* Create jas_stream_t containing input JPEG200 codestream in + * memory. */ + jpcstream = jas_stream_memopen(injpc, bufsize); -/* -** Create jas_stream_t containing input JPEG200 codestream in memory. -** -*/ + /* Get jasper ID of JPEG encoder. */ + fmt = jas_image_strtofmt(G2C_JASPER_JPEG_FORMAT_NAME); - jpcstream=jas_stream_memopen(injpc,*bufsize); + /* Decode JPEG200 codestream into jas_image_t structure. */ + if (!(image = jas_image_decode(jpcstream, fmt, opts))) + return G2_JASPER_DECODE; -/* -** Decode JPEG200 codestream into jas_image_t structure. -** -*/ - image=jpc_decode(jpcstream,opts); - if ( image == 0 ) { - printf(" jpc_decode return = %d \n",ier); - return -3; + pcmpt = image->cmpts_[0]; + /* + printf(" SAGOUT DECODE:\n"); + printf(" tlx %d \n", image->tlx_); + printf(" tly %d \n", image->tly_); + printf(" brx %d \n", image->brx_); + printf(" bry %d \n", image->bry_); + printf(" numcmpts %d \n", image->numcmpts_); + printf(" maxcmpts %d \n", image->maxcmpts_); + printf(" colorspace %d \n", image->clrspc_); + printf(" inmem %d \n", image->inmem_); + printf(" COMPONENT:\n"); + printf(" tlx %d \n", pcmpt->tlx_); + printf(" tly %d \n", pcmpt->tly_); + printf(" hstep %d \n", pcmpt->hstep_); + printf(" vstep %d \n", pcmpt->vstep_); + printf(" width %d \n", pcmpt->width_); + printf(" height %d \n", pcmpt->height_); + printf(" prec %d \n", pcmpt->prec_); + printf(" sgnd %d \n", pcmpt->sgnd_); + printf(" cps %d \n", pcmpt->cps_); + printf(" type %d \n", pcmpt->type_); + */ + + /* Expecting jpeg2000 image to be grayscale only. No color components. */ + if (image->numcmpts_ != 1) + return G2_JASPER_DECODE_COLOR; + + /* Create a data matrix of grayscale image values decoded from the + * jpeg2000 codestream. */ + data = jas_matrix_create(jas_image_height(image), jas_image_width(image)); + jas_image_readcmpt(image, 0, 0, 0, jas_image_width(image), + jas_image_height(image), data); + + /* Copy data matrix to output integer array. */ + k = 0; + if (out_is_g2int) + { + for (i = 0; i < pcmpt->height_; i++) + for (j = 0; j < pcmpt->width_; j++) + ((g2int *)outfld)[k++] = data->rows_[i][j]; } - - pcmpt=image->cmpts_[0]; -/* - printf(" SAGOUT DECODE:\n"); - printf(" tlx %d \n",image->tlx_); - printf(" tly %d \n",image->tly_); - printf(" brx %d \n",image->brx_); - printf(" bry %d \n",image->bry_); - printf(" numcmpts %d \n",image->numcmpts_); - printf(" maxcmpts %d \n",image->maxcmpts_); -#ifdef JAS_1_500_4 - printf(" colormodel %d \n",image->colormodel_); -#endif -#ifdef JAS_1_700_2 - printf(" colorspace %d \n",image->clrspc_); -#endif - printf(" inmem %d \n",image->inmem_); - printf(" COMPONENT:\n"); - printf(" tlx %d \n",pcmpt->tlx_); - printf(" tly %d \n",pcmpt->tly_); - printf(" hstep %d \n",pcmpt->hstep_); - printf(" vstep %d \n",pcmpt->vstep_); - printf(" width %d \n",pcmpt->width_); - printf(" height %d \n",pcmpt->height_); - printf(" prec %d \n",pcmpt->prec_); - printf(" sgnd %d \n",pcmpt->sgnd_); - printf(" cps %d \n",pcmpt->cps_); -#ifdef JAS_1_700_2 - printf(" type %d \n",pcmpt->type_); -#endif -*/ - -/* -** Expecting jpeg2000 image to be grayscale only. -** No color components. -** -*/ - if (image->numcmpts_ != 1 ) { - printf("dec_jpeg2000: Found color image. Grayscale expected.\n"); - return (-5); + else + { + for (i = 0; i < pcmpt->height_; i++) + for (j = 0; j < pcmpt->width_; j++) + ((int *)outfld)[k++] = data->rows_[i][j]; } -/* -** Create a data matrix of grayscale image values decoded from -** the jpeg2000 codestream. -** -*/ - data=jas_matrix_create(jas_image_height(image), jas_image_width(image)); - jas_image_readcmpt(image,0,0,0,jas_image_width(image), - jas_image_height(image),data); -/* -** Copy data matrix to output integer array. -** -*/ - k=0; - for (i=0;iheight_;i++) - for (j=0;jwidth_;j++) - outfld[k++]=data->rows_[i][j]; -/* -** Clean up JasPer work structures. -** -*/ + /* Clean up JasPer work structures. */ jas_matrix_destroy(data); - ier=jas_stream_close(jpcstream); + jas_stream_close(jpcstream); jas_image_destroy(image); + /* Finalize jasper. */ +#ifdef JASPER3 + jas_cleanup_thread(); + jas_cleanup_library(); +#else + jas_cleanup(); +#endif /* JASPER3 */ + return 0; +} +/** + * This Function decodes a JPEG2000 code stream specified in the + * JPEG2000 Part-1 standard (i.e., ISO/IEC 15444-1) using [JasPer + * Software](https://github.com/jasper-software/jasper). + * + * @param injpc Pointer to buffer that holds the input JPEG2000 code + * stream. + * @param bufsize Length (in bytes) of the buffer that holds the input + * JPEG2000 code stream. + * @param outfld Pointer to int array, already allocated, that gets + * the unpacked data. + * + * @return + * - ::G2_JASPER_DECODE Error decode jpeg2000 code stream. + * - ::G2_JASPER_DECODE_COLOR decoded image had multiple color + * components. Only grayscale is expected. + * - ::G2_JASPER_INIT Error inializing Jasper library. + * + * @author Ed Hartnett @date 9/7/22 + */ +int +g2c_dec_jpeg2000(char *injpc, size_t bufsize, int *outfld) +{ + return int_dec_jpeg2000(injpc, bufsize, outfld, 0); +} + +/** + * This Function decodes a JPEG2000 code stream specified in the + * JPEG2000 Part-1 standard (i.e., ISO/IEC 15444-1) using [JasPer + * Software](https://github.com/jasper-software/jasper). + * + * @param injpc Pointer to buffer that holds the input JPEG2000 code + * stream. + * @param bufsize Length (in bytes) of the buffer that holds the input + * JPEG2000 code stream. + * @param outfld Pointer to g2int array, already allocated, that gets + * the unpacked data. + * + * @return + * - 0 Successful decode + * - ::G2_JASPER_DECODE Error decode jpeg2000 code stream. + * - ::G2_JASPER_DECODE_COLOR decoded image had multiple color + * components. Only grayscale is expected. + * - ::G2_JASPER_INIT Error inializing Jasper library. + * + * @author Stephen Gilbert, Ed Hartnett + */ +int +dec_jpeg2000_(char *injpc, g2int bufsize, g2int *outfld) +{ + return int_dec_jpeg2000(injpc, bufsize, outfld, 1); } + diff --git a/src/dec_png.c b/src/dec_png.c index 33368f39..da650583 100644 --- a/src/dec_png.c +++ b/src/dec_png.c @@ -40,13 +40,18 @@ typedef struct png_stream png_stream; /**< location to write PNG stream */ void user_read_data(png_structp , png_bytep , png_uint_32 ); -void user_read_data(png_structp png_ptr,png_bytep data, png_uint_32 length) - /** * Custom read function used so that libpng will read a PNG stream * from memory instead of a file on disk. -*/ - + * + * @param png_ptr Pointer to PNG. + * @param data Pointer to data. + * @param length Length. + * + * @author Stephen Gilbert + */ +void +user_read_data(png_structp png_ptr,png_bytep data, png_uint_32 length) { char *ptr; g2int offset; @@ -55,7 +60,6 @@ void user_read_data(png_structp png_ptr,png_bytep data, png_uint_32 length) mem=(png_stream *)png_get_io_ptr(png_ptr); ptr=(void *)mem->stream_ptr; offset=mem->stream_len; -/* printf("SAGrd %ld %ld %x\n",offset,length,ptr); */ memcpy(data,ptr+offset,length); mem->stream_len += length; } @@ -71,8 +75,6 @@ void user_read_data(png_structp png_ptr,png_bytep data, png_uint_32 length) * * @author Stephen Gilbert */ - - int SUB_NAME(unsigned char *pngbuf,g2int *width,g2int *height,char *cout) { int interlace,color,compres,filter,bit_depth; diff --git a/src/drstemplates.f b/src/drstemplates.f index 20b33afb..73532c7e 100644 --- a/src/drstemplates.f +++ b/src/drstemplates.f @@ -1,39 +1,39 @@ -!> @file -!> @brief This Fortran Module contains info on all the available -!> GRIB2 Data Representation Templates used in Section 5 (DRS). -!> @author Stephen Gilbert @date 2001-04-03 -!> - -!> This Fortran Module contains info on all the available -!> GRIB2 Data Representation Templates used in Section 5 (DRS). -!> Each Template has three parts: The number of entries in the template -!> (mapgridlen); A map of the template (mapgrid), which contains the -!> number of octets in which to pack each of the template values; and -!> a logical value (needext) that indicates whether the Template needs -!> to be extended. In some cases the number of entries in a template -!> can vary depending upon values specified in the "static" part of -!> the template. ( See Template 5.1 as an example ) +!> @file +!> @brief This Fortran Module contains info on all the available GRIB2 +!> Data Representation Templates used in Section 5 - the Data +!> Representation Section (DRS). +!> @author Stephen Gilbert @date 2001-04-03 + +!> This Fortran Module contains info on all the available GRIB2 Data +!> Representation Templates used in Section 5 - the Data +!> Representation Section (DRS). (See +!> https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_sect5.shtml.) !> -!> This module also contains two subroutines. Subroutine getdrstemplate -!> returns the octet map for a specified Template number, and -!> subroutine extdrstemplate will calculate the extended octet map -!> of an appropriate template given values for the "static" part of the -!> template. See docblocks below for the arguments and usage of these -!> routines. +!> Each Template has three parts: +!> 1. The number of entries in the template (mapdrslen); +!> 2. A map of the template (mapdrs), which contains the number of +!> octets in which to pack each of the template values; +!> 3. A logical value (needext) that indicates whether the Template +!> needs to be extended. !> -!> @note Array mapgrid contains the number of octets in which the -!> corresponding template values will be stored. A negative value in -!> mapgrid is used to indicate that the corresponding template entry can -!> contain negative values. This information is used later when packing -!> (or unpacking) the template data values. Negative data values in GRIB -!> are stored with the left most bit set to one, and a negative number -!> of octets value in mapgrid indicates that this possibility should -!> be considered. The number of octets used to store the data value -!> in this case would be the absolute value of the negative value in -!> mapgrid. -!> -!> @author Stephen Gilbert @date 2001-04-03 +!> This module also contains two subroutines. Subroutine +!> getdrstemplate() returns the octet map for a specified Template +!> number, and subroutine extdrstemplate() will calculate the extended +!> octet map of an appropriate template given values for the "static" +!> part of the template. !> +!> @note Array mapdrs contains the number of octets in which the +!> corresponding template values will be stored. A negative value in +!> mapdrs is used to indicate that the corresponding template entry +!> can contain negative values. This information is used later when +!> packing (or unpacking) the template data values. Negative data +!> values in GRIB are stored with the left most bit set to one, and a +!> negative number of octets value in mapdrs indicates that this +!> possibility should be considered. The number of octets used to +!> store the data value in this case would be the absolute value of +!> the negative value in mapdrs. +!> +!> @author Stephen Gilbert @date 2001-04-03 module drstemplates integer,parameter :: MAXLEN=200 !< maximum number of octets in mapgrid @@ -112,19 +112,16 @@ module drstemplates contains -!> @brief This function returns the index of specified Data -!> Representation Template 5.NN (NN=number) in array templates. . -!> @author Stephen Gilbert @date 2001-06-28 -!> - -!> @param[in] number NN, indicating the number of the Data Representation -!> Template 5.NN that is being requested. -!> -!> @return Index of DRT 5.NN in array templates, if template exists. -!> = -1, otherwise. -!> -!> @author Stephen Gilbert @date 2001-06-28 -!> + !> This function returns the index of specified Data + !> Representation Template 5.NN (NN=number) in array templates. + !> + !> @param[in] number NN, indicating the number of the Data Representation + !> Template 5.NN that is being requested. + !> + !> @return Index of DRT 5.NN in array templates, if template exists. + !> = -1, otherwise. + !> + !> @author Stephen Gilbert @date 2001-06-28 integer function getdrsindex(number) integer,intent(in) :: number @@ -139,28 +136,25 @@ integer function getdrsindex(number) end function -!> @brief This subroutine returns DRS template information for a . -!> specified Data Representation Template 5.NN. -!> @author Stephen Gilbert @date 2000-05-11 -!> - -!> The number of entries in the template is returned along with a map -!> of the number of octets occupied by each entry. Also, a flag is -!> returned to indicate whether the template would need to be extended. -!> -!> @param[in] number NN, indicating the number of the Data Representation -!> Template 5.NN that is being requested. -!> @param[out] nummap Number of entries in the Template -!> @param[out] map An array containing the number of octets that each -!> template entry occupies when packed up into the DRS. -!> @param[out] needext Logical variable indicating whether the Data Representation -!> Template has to be extended. -!> @param[out] iret Error return code. -!> - 0 = no error -!> - 1 = Undefined Data Representation Template number. -!> -!> @author Stephen Gilbert @date 2000-05-11 -!> + !> This subroutine returns DRS template information for a + !> specified Data Representation Template 5.NN. + !> + !> The number of entries in the template is returned along with a map + !> of the number of octets occupied by each entry. Also, a flag is + !> returned to indicate whether the template would need to be extended. + !> + !> @param[in] number NN, indicating the number of the Data Representation + !> Template 5.NN that is being requested. + !> @param[out] nummap Number of entries in the Template + !> @param[out] map An array containing the number of octets that each + !> template entry occupies when packed up into the DRS. + !> @param[out] needext Logical variable indicating whether the Data Representation + !> Template has to be extended. + !> @param[out] iret Error return code. + !> - 0 = no error + !> - 1 = Undefined Data Representation Template number. + !> + !> @author Stephen Gilbert @date 2000-05-11 subroutine getdrstemplate(number,nummap,map,needext,iret) integer,intent(in) :: number integer,intent(out) :: nummap,map(*),iret @@ -184,25 +178,23 @@ subroutine getdrstemplate(number,nummap,map,needext,iret) end subroutine -!> @brief This subroutine generates the remaining octet map for a -!> given Data Representation Template, if required. -!> @author Stephen Gilbert @date 2000-05-11 -!> - -!> Some Templates can vary depending on data values given in an earlier part -!> of the Template, and it is necessary to know some of the earlier entry -!> values to generate the full octet map of the Template. -!> -!> @param[in] number NN, indicating the number of the Data Representation -!> Template 5.NN that is being requested. -!> @param[in] list The list of values for each entry in the -!> Data Representation Template 5.NN. -!> @param[out] nummap Number of entries in the Template -!> @param[out] map An array containing the number of octets that each -!> template entry occupies when packed up into the GDS. -!> -!> @author Stephen Gilbert @date 2000-05-11 -!> + !> This subroutine generates the remaining octet map for a given Data + !> Representation Template, if required. + !> + !> Some Templates can vary depending on data values given in an + !> earlier part of the Template, and it is necessary to know some of + !> the earlier entry values to generate the full octet map of the + !> Template. + !> + !> @param[in] number NN, indicating the number of the Data + !> Representation Template 5.NN that is being requested. + !> @param[in] list The list of values for each entry in the Data + !> Representation Template 5.NN. + !> @param[out] nummap Number of entries in the Template + !> @param[out] map An array containing the number of octets that each + !> template entry occupies when packed up into the GDS. + !> + !> @author Stephen Gilbert @date 2000-05-11 subroutine extdrstemplate(number,list,nummap,map) integer,intent(in) :: number,list(*) integer,intent(out) :: nummap,map(*) diff --git a/src/enc_jpeg2000.c b/src/enc_jpeg2000.c index 296da9dd..f7772e6d 100644 --- a/src/enc_jpeg2000.c +++ b/src/enc_jpeg2000.c @@ -1,194 +1,195 @@ -/** - * @file - * @brief This Function encodes a grayscale image into a JPEG2000 code stream - * specified in the JPEG2000 Part-1 standard. +/** @file + * @brief Encodes JPEG2000 code stream. * @author Stephen Gilbert @date 2002-12-02 */ #include #include -#include #include "jasper/jasper.h" -#define JAS_1_700_2 /**< Define jasper type. */ +#include "jpeg.h" -#ifdef __64BIT__ - typedef int g2int; /**< Integer type. */ -#else - typedef long g2int; /**< Long Integer type. */ -#endif - -#if defined CRAY90 - #include - #define SUB_NAME ENC_JPEG2000 -#elif defined LINUXF90 - #define SUB_NAME ENC_JPEG2000 -#elif defined LINUXG95 - #define SUB_NAME enc_jpeg2000__ -#elif defined HP || defined AIX - #define SUB_NAME enc_jpeg2000 -#elif defined SGI || defined LINUX || defined VPP5000 || defined APPLE - #define SUB_NAME enc_jpeg2000_ -#endif +#define MAXOPTSSIZE 1024 /**< Maximum size of options. */ /** * This Function encodes a grayscale image into a JPEG2000 code stream - * specified in the JPEG2000 Part-1 standard. It uses JasPer - * Software version 1.500.4 (or 1.700.2 ) written by the - * University of British Columbia, Image Power Inc, and others. - * JasPer is available at http: * www.ece.uvic.ca/~mdadams/jasper/. - * - * PROGRAM HISTORY LOG: - * - 2002-12-02 Stephen Gilbert - * - 2004-07-20 Stephen Gilbert - Added retry argument/option to allow option of - * increasing the maximum number of guard bits to the JPEG2000 algorithm. + * specified in the JPEG2000 Part-1 standard (i.e., ISO/IEC 15444-1) + * using [JasPer Software](https://github.com/jasper-software/jasper). + * + * ### Program History Log + * Date | Programmer | Comments + * -----|------------|--------- + * 2002-12-02 | Gilbert | Initial + * 2004-12-16 | Gilbert | Added retry argument allowing increased guard bits. + * 2022-04-15 | Hartnett | Converted to use jas_ instead of jpc_ functions. * - * @param[in] cin Packed matrix of Grayscale image values to encode. - * @param[in] pwidth Pointer to width of image - * @param[in] pheight Pointer to height of image - * @param[in] pnbits Pointer to depth (in bits) of image. i.e number of bits - * used to hold each data value - * @param[in] ltype Pointer to indicator of lossless or lossy compression - * - = 1, for lossy compression + * @param cin Packed matrix of Grayscale image values to encode. + * @param width width of image. + * @param height height of image. + * @param nbits depth (in bits) of image. i.e number of bits used to + * hold each data value. + * @param ltype indicator of lossless or lossy compression. + * - 1, for lossy compression * - != 1, for lossless compression - * @param[in] ratio Pointer to target compression ratio. (ratio:1) - * Used only when *ltype == 1. - * @param[in] retry - Pointer to option type. - * 1 = try increasing number of guard bits otherwise, no additional options - * @param[in] jpclen - Number of bytes allocated for new JPEG2000 code stream in outjpc. - * @param[in] outjpc - Output encoded JPEG2000 code stream - * @return - * - 0 Length in bytes of encoded JPEG2000 code stream. - * - -3 Error decode jpeg2000 code stream. - * - -5 decoded image had multiple color components. - * Only grayscale is expected. - * @var int MAXOPTSSIZE - * - * @note Requires JasPer Software version 1.500.4 or 1.700.2 + * @param ratio target compression ratio. (ratio:1) Used only when + * ltype == 1. + * @param retry If 1 try increasing number of guard bits. + * @param outjpc Output encoded JPEG2000 code stream. + * @param jpclen Number of bytes allocated for the output JPEG2000 + * code stream in outjpc. + * + * @return + * - > 0 = Length in bytes of encoded JPEG2000 code stream + * - ::G2_JASPER_INIT Error initializing jasper library. + * - ::G2_JASPER_ENCODE Error encode jpeg2000 code stream. + * + * @note Requires JasPer Software version 1.500.4 or 1.700.2 or later. * * @author Stephen Gilbert @date 2002-12-02 + * @author Ed Hartnett */ -int SUB_NAME(unsigned char *cin,g2int *pwidth,g2int *pheight,g2int *pnbits, - g2int *ltype, g2int *ratio, g2int *retry, char *outjpc, - g2int *jpclen) +int +g2c_enc_jpeg2000(unsigned char *cin, int width, int height, int nbits, + int ltype, int ratio, int retry, char *outjpc, + size_t jpclen) { - int ier,rwcnt; - jas_image_t image; - jas_stream_t *jpcstream,*istream; - jas_image_cmpt_t cmpt,*pcmpt; + g2int width8 = width, height8 = height, nbits8 = nbits, ltype8 = ltype; + g2int ratio8 = ratio, retry8 = retry, jpclen8 = jpclen; + + return enc_jpeg2000_(cin, width8, height8, nbits8, ltype8, ratio8, retry8, + outjpc, jpclen8); +} + /** - * \def MAXOPTSSIZE - * Maximum size of the options. -*/ -#define MAXOPTSSIZE 1024 + * This Function encodes a grayscale image into a JPEG2000 code stream + * specified in the JPEG2000 Part-1 standard (i.e., ISO/IEC 15444-1) + * using [JasPer Software](https://github.com/jasper-software/jasper). + * + * ### Program History Log + * Date | Programmer | Comments + * -----|------------|--------- + * 2002-12-02 | Gilbert | Initial + * 2004-12-16 | Gilbert | Added retry argument allowing increased guard bits. + * 2022-04-15 | Hartnett | Converted to use jas_ instead of jpc_ functions. + * + * @param cin Packed matrix of Grayscale image values to encode. + * @param width width of image. + * @param height height of image. + * @param nbits depth (in bits) of image. i.e number of bits used to + * hold each data value. + * @param ltype indicator of lossless or lossy compression. + * - 1, for lossy compression + * - != 1, for lossless compression + * @param ratio target compression ratio. (ratio:1) Used only when + * ltype == 1. + * @param retry If 1 try increasing number of guard bits. + * @param outjpc Output encoded JPEG2000 code stream. + * @param jpclen Number of bytes allocated for the output JPEG2000 + * code stream in outjpc. + * + * @return + * - > 0 = Length in bytes of encoded JPEG2000 code stream + * - ::G2_JASPER_INIT Error initializing jasper library. + * - ::G2_JASPER_ENCODE Error encode jpeg2000 code stream. + * + * @note Requires JasPer Software version 1.500.4 or 1.700.2 or later. + * + * @author Stephen Gilbert @date 2002-12-02 + * @author Ed Hartnett + */ +int +enc_jpeg2000_(unsigned char *cin, g2int width, g2int height, g2int nbits, + g2int ltype, g2int ratio, g2int retry, char *outjpc, + g2int jpclen) +{ + int ier, rwcnt; + jas_image_t image; + jas_stream_t *jpcstream, *istream; + jas_image_cmpt_t cmpt, *pcmpt; char opts[MAXOPTSSIZE]; + int fmt; - g2int width,height,nbits; - width=*pwidth; - height=*pheight; - nbits=*pnbits; -/* - printf(" enc_jpeg2000:width %ld\n",width); - printf(" enc_jpeg2000:height %ld\n",height); - printf(" enc_jpeg2000:nbits %ld\n",nbits); - printf(" enc_jpeg2000:jpclen %ld\n",*jpclen); -*/ -/* jas_init(); */ - -/* -** Set lossy compression options, if requested. -*/ - if ( *ltype != 1 ) { - opts[0]=(char)0; - } - else { - snprintf(opts,MAXOPTSSIZE,"mode=real\nrate=%f",1.0/(float)*ratio); - } - if ( *retry == 1 ) { // option to increase number of guard bits - strcat(opts,"\nnumgbits=4"); - } -/* printf("SAGopts: %s\n",opts); */ - -/* -** Initialize the JasPer image structure describing the grayscale -** image to encode into the JPEG2000 code stream. -*/ - image.tlx_=0; - image.tly_=0; -#ifdef JAS_1_500_4 - image.brx_=(uint_fast32_t)width; - image.bry_=(uint_fast32_t)height; -#endif -#ifdef JAS_1_700_2 - image.brx_=(jas_image_coord_t)width; - image.bry_=(jas_image_coord_t)height; -#endif - image.numcmpts_=1; - image.maxcmpts_=1; -#ifdef JAS_1_500_4 -/* -** grayscale Image -*/ - image.colormodel_=JAS_IMAGE_CM_GRAY; -#endif -#ifdef JAS_1_700_2 -/* -** grayscale Image -*/ - image.clrspc_=JAS_CLRSPC_SGRAY; - image.cmprof_=0; -#endif -/* image.inmem_=1; */ - - cmpt.tlx_=0; - cmpt.tly_=0; - cmpt.hstep_=1; - cmpt.vstep_=1; -#ifdef JAS_1_500_4 - cmpt.width_=(uint_fast32_t)width; - cmpt.height_=(uint_fast32_t)height; -#endif -#ifdef JAS_1_700_2 - cmpt.width_=(jas_image_coord_t)width; - cmpt.height_=(jas_image_coord_t)height; - cmpt.type_=JAS_IMAGE_CT_COLOR(JAS_CLRSPC_CHANIND_GRAY_Y); -#endif - cmpt.prec_=nbits; - cmpt.sgnd_=0; - cmpt.cps_=(nbits+7)/8; - - pcmpt=&cmpt; - image.cmpts_=&pcmpt; - -/* -** Open a JasPer stream containing the input grayscale values -*/ - istream=jas_stream_memopen((char *)cin,height*width*cmpt.cps_); - cmpt.stream_=istream; - -/* -** Open an output stream that will contain the encoded jpeg2000 -** code stream. -*/ - jpcstream=jas_stream_memopen(outjpc,(int)(*jpclen)); - -/* -** Encode image. -*/ - ier=jpc_encode(&image,jpcstream,opts); - if ( ier != 0 ) { - printf(" jpc_encode return = %d \n",ier); - return -3; - } -/* -** Clean up JasPer work structures. -*/ - rwcnt=jpcstream->rwcnt_; - ier=jas_stream_close(istream); - ier=jas_stream_close(jpcstream); -/* -** Return size of jpeg2000 code stream -*/ - return (rwcnt); + /* Set lossy compression options, if requested. */ + if (ltype != 1) + opts[0] = (char)0; + else + snprintf(opts,MAXOPTSSIZE,"mode=real\nrate=%f",1.0/(float)ratio); -} + if (retry == 1) /* option to increase number of guard bits */ + strcat(opts,"\nnumgbits=4"); + + /* Initialize the JasPer image structure describing the grayscale + * image to encode into the JPEG2000 code stream. */ + image.tlx_ = 0; + image.tly_ = 0; + image.brx_ = (jas_image_coord_t)width; + image.bry_ = (jas_image_coord_t)height; + image.numcmpts_ = 1; + image.maxcmpts_ = 1; + image.clrspc_ = JAS_CLRSPC_SGRAY; /* grayscale Image */ + image.cmprof_ = 0; + + cmpt.tlx_ = 0; + cmpt.tly_ = 0; + cmpt.hstep_ = 1; + cmpt.vstep_ = 1; + cmpt.width_ = (jas_image_coord_t)width; + cmpt.height_ = (jas_image_coord_t)height; + cmpt.type_ = JAS_IMAGE_CT_COLOR(JAS_CLRSPC_CHANIND_GRAY_Y); + cmpt.prec_ = nbits; + cmpt.sgnd_ = 0; + cmpt.cps_ = (nbits + 7) / 8; + + pcmpt = &cmpt; + image.cmpts_ = &pcmpt; + + /* Initialize Jasper. */ +#ifdef JASPER3 + jas_conf_clear(); + /* static jas_std_allocator_t allocator; */ + /* jas_std_allocator_init(&allocator); */ + /* jas_conf_set_allocator(JAS_CAST(jas_std_allocator_t *, &allocator)); */ + jas_conf_set_max_mem_usage(10000000); + jas_conf_set_multithread(true); + if (jas_init_library()) + return G2_JASPER_INIT; + if (jas_init_thread()) + return G2_JASPER_INIT; +#else + if (jas_init()) + return G2_JASPER_INIT; +#endif /* JASPER3 */ + /* Open a JasPer stream containing the input grayscale values. */ + istream = jas_stream_memopen((char *)cin, height * width * cmpt.cps_); + cmpt.stream_ = istream; + + /* Open an output stream that will contain the encoded jpeg2000 + * code stream. */ + jpcstream = jas_stream_memopen(outjpc, (int)jpclen); + + /* Get jasper ID of JPEG encoder. */ + fmt = jas_image_strtofmt(G2C_JASPER_JPEG_FORMAT_NAME); + + /* Encode image. */ + if ((ier = jas_image_encode(&image, jpcstream, fmt, opts))) + return G2_JASPER_ENCODE; + + /* Rememeber the length in bytes of the encoded JPEG code + * stream. */ + rwcnt = jpcstream->rwcnt_; + + /* Clean up JasPer work structures. */ + ier = jas_stream_close(istream); + ier = jas_stream_close(jpcstream); + + /* Finalize jasper. */ +#ifdef JASPER3 + jas_cleanup_thread(); + jas_cleanup_library(); +#else + jas_cleanup(); +#endif /* JASPER3 */ + + /* Return size of jpeg2000 code stream. */ + return rwcnt; +} diff --git a/src/getfield.F90 b/src/getfield.F90 new file mode 100644 index 00000000..6b004317 --- /dev/null +++ b/src/getfield.F90 @@ -0,0 +1,747 @@ +!> @file +!> @brief Contains subroutines obtain grid information and the +!> unpacked data (section 3 - 6) for a field from a GRIB2 file. +!> @author Stephen Gilbert @date 2000-05-26 + +!> This subroutine returns the Grid Definition, Product Definition, +!> Bit-map (if applicable), and the unpacked data for a given data +!> field. Since there can be multiple data fields packed into a GRIB2 +!> message, the calling routine indicates which field is being +!> requested with the ifldnum argument. +!> +!> @param[in] cgrib Character array that contains the GRIB2 message. +!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. +!> @param[in] ifldnum Specifies which field in the GRIB2 message to +!> return. +!> @param[out] igds Contains information read from the appropriate +!> GRIB Grid Definition Section 3 for the field being returned. Must +!> be dimensioned >= 5. +!> - igds(1) Source of grid definition (see [Code Table +!> 3.0](https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-0.shtml)). +!> - igds(2) Number of grid points in the defined grid. +!> - igds(3) Number of octets needed for each additional grid points +!> definition. Used to define number of points in each row (or +!> column) for non-regular grids. = 0, if using regular grid. +!> - igds(4) Interpretation of list for optional points definition +!> ([Code Table +!> 3.11](https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-11.shtml)). +!> - igds(5) Grid Definition Template Number ([Code Table +!> 3.1](https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-1.shtml)). +!> @param[out] igdstmpl Contains the data values for the specified +!> Grid Definition Template (NN=igds(5)). Each element of this +!> integer array contains an entry (in the order specified) of Grid +!> Defintion Template 3.NN. A safe dimension for this array can be +!> obtained in advance from maxvals(2), which is returned from +!> subroutine gribinfo(). +!> @param[out] igdslen Number of elements in igdstmpl. i.e. number of +!> entries in Grid Defintion Template 3.NN (NN=igds(5)). +!> @param[out] ideflist (Used if igds(3) .ne. 0) This array contains +!> the number of grid points contained in each row (or column). (part +!> of Section 3) A safe dimension for this array can be obtained in +!> advance from maxvals(3), which is returned from subroutine +!> gribinfo(). +!> @param[out] idefnum (Used if igds(3) .ne. 0) The number of entries +!> in array ideflist - i.e. number of rows (or columns) for which +!> optional grid points are defined. +!> @param[out] ipdsnum Product Definition Template Number (see [Code +!> Table 4.0] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table4-0.shtml)). +!> @param[out] ipdstmpl Contains the data values for the specified +!> Product Definition Template (N=ipdsnum). Each element of this +!> integer array contains an entry (in the order specified) of +!> Product Defintion Template 4.N. A safe dimension for this array +!> can be obtained in advance from maxvals(4), which is returned from +!> subroutine gribinfo(). +!> @param[out] ipdslen Number of elements in ipdstmpl - i.e. number +!> of entries in Product Defintion Template 4.N (N=ipdsnum). +!> @param[out] coordlist Array containg floating point values +!> intended to document the vertical discretisation associated to +!> model data on hybrid coordinate vertical levels (part of Section +!> 4). The dimension of this array can be obtained in advance from +!> maxvals(5), which is returned from subroutine gribinfo(). +!> @param[out] numcoord number of values in array coordlist. +!> @param[out] ndpts Number of data points unpacked and returned. +!> @param[out] idrsnum Data Representation Template Number (see [Code +!> Table 5.0] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table5-0.shtml)). +!> @param[out] idrstmpl Contains the data values for the specified +!> Data Representation Template (N=idrsnum). Each element of this +!> integer array contains an entry (in the order specified) of +!> Product Defintion Template 5.N A safe dimension for this array can +!> be obtained in advance from maxvals(6), which is returned from +!> subroutine gribinfo(). +!> @param[out] idrslen Number of elements in idrstmpl. i.e. number of +!> entries in Data Representation Template specified by idrsnum. +!> @param[out] ibmap Bitmap indicator (see [Code Table +!> 6.0](https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table6-0.shtml)). +!> - 0 bitmap applies and is included in Section 6. +!> - 1-253 Predefined bitmap applies. +!> - 254 Previously defined bitmap applies to this field. +!> - 255 Bit map does not apply to this product. +!> @param[out] bmap Logical*1 array containing decoded bitmap (if +!> ibmap=0). The dimension of this array can be obtained in advance +!> from maxvals(7), which is returned from subroutine gribinfo(). +!> @param[out] fld Array of ndpts unpacked data points. A safe +!> dimension for this array can be obtained in advance from +!> maxvals(7), which is returned from subroutine gribinfo(). +!> @param[out] ierr Error return code. +!> - 0 no error. +!> - 1 Beginning characters "GRIB" not found. +!> - 2 GRIB message is not Edition 2. +!> - 3 The data field request number was not positive. +!> - 4 End string "7777" found, but not where expected. +!> - 6 GRIB message did not contain the requested number of data fields. +!> - 7 End string "7777" not found at end of message. +!> - 9 Data Representation Template 5.NN not yet implemented. +!> - 10 Error unpacking Section 3. +!> - 11 Error unpacking Section 4. +!> - 12 Error unpacking Section 5. +!> - 13 Error unpacking Section 6. +!> - 14 Error unpacking Section 7. +!> +!> @note Note that subroutine gribinfo can be used to first determine +!> how many data fields exist in a given GRIB message. +!> +!> @author Stephen Gilbert @date 2000-05-26 +subroutine getfield(cgrib, lcgrib, ifldnum, igds, igdstmpl, & + igdslen, ideflist, idefnum, ipdsnum, ipdstmpl, ipdslen, & + coordlist, numcoord, ndpts, idrsnum, idrstmpl, idrslen, & + ibmap, bmap, fld, ierr) + + implicit none + + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib, ifldnum + integer, intent(out) :: igds(*), igdstmpl(*), ideflist(*) + integer, intent(out) :: ipdsnum, ipdstmpl(*) + integer, intent(out) :: idrsnum, idrstmpl(*) + integer, intent(out) :: ndpts, ibmap, idefnum, numcoord + integer, intent(out) :: ierr + logical*1, intent(out) :: bmap(*) + real, intent(out) :: fld(*), coordlist(*) + + character(len = 4), parameter :: grib = 'GRIB', c7777 = '7777' + character(len = 4) :: ctemp + integer :: listsec0(2) + integer :: iofst, istart + integer(4) :: ieee + logical :: have3, have4, have5, have6, have7 + + !implicit none additions + integer, intent(out) :: igdslen, ipdslen, idrslen + integer :: numfld, j, lengrib, lensec0, ipos + integer :: lensec, isecnum, jerr, ier, numlocal + + have3 = .false. + have4 = .false. + have5 = .false. + have6 = .false. + have7 = .false. + ierr = 0 + numfld = 0 + + ! Check for valid request number + if (ifldnum .le. 0) then + print *, 'getfield: Request for field number ' & + ,'must be positive.' + ierr = 3 + return + endif + + ! Check for beginning of GRIB message in the first 100 bytes + istart = 0 + do j = 1, 100 + ctemp = cgrib(j) // cgrib(j + 1) // cgrib(j + 2) // cgrib(j + 3) + if (ctemp .eq. grib) then + istart = j + exit + endif + enddo + if (istart .eq. 0) then + print *, 'getfield: Beginning characters GRIB not found.' + ierr = 1 + return + endif + + ! Unpack Section 0 - Indicator Section + iofst = 8 * (istart + 5) + call g2_gbytec(cgrib, listsec0(1), iofst, 8) ! Discipline + iofst = iofst + 8 + call g2_gbytec(cgrib, listsec0(2), iofst, 8) ! GRIB edition number + iofst = iofst + 8 + iofst = iofst + 32 + call g2_gbytec(cgrib, lengrib, iofst, 32) ! Length of GRIB message + iofst = iofst + 32 + lensec0 = 16 + ipos = istart + lensec0 + + ! Currently handles only GRIB Edition 2. + if (listsec0(2) .ne. 2) then + print *, 'getfield: can only decode GRIB edition 2.' + ierr = 2 + return + endif + + ! Loop through the remaining sections keeping track of the length of + ! each. Also keep the latest Grid Definition Section info. Unpack + ! the requested field number. + do + ! Check to see if we are at end of GRIB message + ctemp = cgrib(ipos) // cgrib(ipos + 1) // cgrib(ipos + 2) // & + cgrib(ipos + 3) + if (ctemp .eq. c7777) then + ipos = ipos + 4 + ! If end of GRIB message not where expected, issue error + if (ipos.ne.(istart + lengrib)) then + print *, 'getfield: "7777" found, but not ' & + ,'where expected.' + ierr = 4 + return + endif + exit + endif + ! Get length of Section and Section number + iofst = (ipos - 1) * 8 + call g2_gbytec(cgrib, lensec, iofst, 32) ! Get Length of Section + iofst = iofst + 32 + call g2_gbytec(cgrib, isecnum, iofst, 8) ! Get Section number + iofst = iofst + 8 + + ! If found Section 3, unpack the GDS info using the appropriate + ! template. Save in case this is the latest grid before the + ! requested field. + if (isecnum .eq. 3) then + iofst = iofst - 40 ! reset offset to beginning of section + call unpack3(cgrib, lcgrib, iofst, igds, igdstmpl, & + igdslen, ideflist, idefnum, jerr) + if (jerr .eq. 0) then + have3 = .true. + else + ierr = 10 + return + endif + endif + + ! If found Section 4, check to see if this field is the one + ! requested. + if (isecnum .eq. 4) then + numfld = numfld + 1 + if (numfld .eq. ifldnum) then + iofst = iofst - 40 ! reset offset to beginning of section + call unpack4(cgrib, lcgrib, iofst, ipdsnum, ipdstmpl, & + ipdslen, coordlist, numcoord, jerr) + if (jerr .eq. 0) then + have4 = .true. + else + ierr = 11 + return + endif + endif + endif + + ! If found Section 5, check to see if this field is the one + ! requested. + if ((isecnum .eq. 5) .and. (numfld .eq. ifldnum)) then + iofst = iofst - 40 ! reset offset to beginning of section + call unpack5(cgrib, lcgrib, iofst, ndpts, idrsnum, & + idrstmpl, idrslen, jerr) + if (jerr .eq. 0) then + have5 = .true. + else + ierr = 12 + return + endif + endif + + ! If found Section 6, Unpack bitmap. Save in case this is the + ! latest bitmap before the requested field. + if (isecnum .eq. 6) then + iofst = iofst - 40 ! reset offset to beginning of section + call unpack6(cgrib, lcgrib, iofst, igds(2), ibmap, bmap, & + jerr) + if (jerr .eq. 0) then + have6 = .true. + else + ierr = 13 + return + endif + endif + + ! If found Section 7, check to see if this field is the one + ! requested. + if ((isecnum .eq. 7) .and. (numfld .eq. ifldnum)) then + if (idrsnum .eq. 0) then + call simunpack(cgrib(ipos + 5), lensec - 6, idrstmpl, & + ndpts, fld) + have7 = .true. + elseif (idrsnum .eq. 2 .or. idrsnum .eq. 3) then + call comunpack(cgrib(ipos + 5), lensec - 6, lensec, & + idrsnum,idrstmpl, ndpts, fld, ier) + if (ier .ne. 0) then + ierr = 14 + return + endif + have7 = .true. + elseif (idrsnum .eq. 50) then + call simunpack(cgrib(ipos + 5), lensec - 6, idrstmpl, & + ndpts - 1, fld(2)) + ieee = idrstmpl(5) + call rdieee(ieee, fld(1), 1) + have7 = .true. + elseif (idrsnum .eq. 40 .or. idrsnum .eq. 40000) then + call jpcunpack(cgrib(ipos + 5), lensec - 5, idrstmpl, & + ndpts, fld) + have7 = .true. + elseif (idrsnum .eq. 41 .or. idrsnum .eq. 40010) then + call pngunpack(cgrib(ipos + 5), lensec - 5, idrstmpl, & + ndpts, fld) + have7 = .true. + else + print *, 'getfield: Data Representation Template ', & + idrsnum, ' not yet implemented.' + ierr = 9 + return + endif + endif + + ! Check to see if we read pass the end of the GRIB message and + ! missed the terminator string '7777'. + ipos = ipos + lensec ! Update beginning of section pointer + if (ipos .gt. (istart + lengrib)) then + print *, 'getfield: "7777" not found at end' & + ,' of GRIB message.' + ierr = 7 + return + endif + + if (have3 .and. have4 .and. have5 .and. have6 .and. have7) & + return + + enddo + + ! If exited from above loop, the end of the GRIB message was reached + ! before the requested field was found. + print *, 'getfield: GRIB message contained ', numlocal, & + ' different fields.' + print *, 'getfield: The request was for the ', ifldnum, & + ' field.' + ierr = 6 + +end subroutine getfield + +!> This subroutine unpacks Section 3 (Grid Definition Section) +!> starting at octet 6 of that Section. +!> +!> @param[in] cgrib Character array that contains the GRIB2 message. +!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. +!> @param[inout] iofst Bit offset of the beginning (in) or the end +!> (out) of Section 3. +!> @param[out] igds Contains information read from the appropriate +!> GRIB Grid Definition Section 3 for the field being returned. Must +!> be dimensioned >= 5. + +!> - igds(1) Source of grid definition (see [Code Table - 3.0] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-0.shtml)) +!> - igds(2) Number of grid points in the defined grid. +!> - igds(3) Number of octets needed for each additional grid points +!> definition. Used to define number of points in each row (or +!> column) for non-regular grids. = 0, if using regular grid. +!> - igds(4) Interpretation of list for optional points +!> definition. ([Code Table 3.11] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-11.shtml)). +!> - igds(5) Grid Definition Template Number ([Code Table 3.1] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-1.shtml)). +!> @param[out] igdstmpl Contains the data values for the specified +!> Grid Definition Template (NN=igds(5)). Each element of this +!> integer array contains an entry (in the order specified) of Grid +!> Defintion Template 3.NN. +!> @param[out] mapgridlen Number of elements in igdstmpl - +!> i.e. number of entries in Grid Defintion Template 3.NN +!> (NN=igds(5)). +!> @param[out] ideflist (Used if igds(3) .ne. 0). This array contains +!> the number of grid points contained in each row (or column) (part +!> of Section 3). +!> @param[out] idefnum (Used if igds(3) .ne. 0). The number of +!> entries in array ideflist - i.e. number of rows (or columns) for +!> which optional grid points are defined. +!> @param[out] ierr Error return code. +!> - 0 no error. +!> - 5 "GRIB" message contains an undefined Grid Definition Template. +!> +!> @author Stephen Gilbert @date 2000-05-26 +!> +subroutine unpack3(cgrib, lcgrib, iofst, igds, igdstmpl, & + mapgridlen, ideflist, idefnum, ierr) + + use gridtemplates + implicit none + + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib + integer, intent(inout) :: iofst + integer, intent(out) :: igds(*), igdstmpl(*), ideflist(*) + integer, intent(out) :: ierr, idefnum + + integer, allocatable :: mapgrid(:) + integer :: mapgridlen, ibyttem + logical needext + + !implicit none additions + integer :: lensec, iret, i, nbits, isign, newmapgridlen + + ierr = 0 + + call g2_gbytec(cgrib, lensec, iofst, 32) ! Get Length of Section + iofst = iofst + 32 + iofst = iofst + 8 ! skip section number + + call g2_gbytec(cgrib, igds(1), iofst, 8) ! Get source of Grid def. + iofst = iofst + 8 + call g2_gbytec(cgrib, igds(2), iofst, 32) ! Get number of grid pts. + iofst = iofst + 32 + call g2_gbytec(cgrib, igds(3), iofst, 8) ! Get num octets for opt. list + iofst = iofst + 8 + call g2_gbytec(cgrib, igds(4), iofst, 8) ! Get interpret. for opt. list + iofst = iofst + 8 + call g2_gbytec(cgrib, igds(5), iofst, 16) ! Get Grid Def Template num. + iofst = iofst + 16 + if (igds(1) .eq. 0) then + ! if (igds(1).eq.0.OR.igds(1).eq.255) then ! FOR ECMWF TEST ONLY + allocate(mapgrid(lensec)) + ! Get Grid Definition Template + call getgridtemplate(igds(5), mapgridlen, mapgrid, needext, & + iret) + if (iret .ne. 0) then + ierr = 5 + return + endif + else + ! igdstmpl = -1 + mapgridlen = 0 + needext = .false. + endif + + ! Unpack each value into array igdstmpl from the the appropriate + ! number of octets, which are specified in corresponding entries in + ! array mapgrid. + ibyttem = 0 + do i = 1, mapgridlen + nbits = iabs(mapgrid(i)) * 8 + if (mapgrid(i) .ge. 0) then + call g2_gbytec(cgrib, igdstmpl(i), iofst, nbits) + else + call g2_gbytec(cgrib, isign, iofst, 1) + call g2_gbytec(cgrib, igdstmpl(i), iofst + 1, nbits-1) + if (isign .eq. 1) igdstmpl(i) = -igdstmpl(i) + endif + iofst = iofst + nbits + ibyttem = ibyttem + iabs(mapgrid(i)) + enddo + + ! Check to see if the Grid Definition Template needs to be + ! extended. The number of values in a specific template may vary + ! depending on data specified in the "static" part of the template. + if (needext) then + call extgridtemplate(igds(5), igdstmpl, newmapgridlen, & + mapgrid) + ! Unpack the rest of the Grid Definition Template + do i = mapgridlen + 1, newmapgridlen + nbits = iabs(mapgrid(i)) * 8 + if (mapgrid(i) .ge. 0) then + call g2_gbytec(cgrib, igdstmpl(i), iofst, nbits) + else + call g2_gbytec(cgrib, isign, iofst, 1) + call g2_gbytec(cgrib, igdstmpl(i), iofst + 1, nbits - & + 1) + if (isign .eq. 1) igdstmpl(i) = -igdstmpl(i) + endif + iofst = iofst + nbits + ibyttem = ibyttem + iabs(mapgrid(i)) + enddo + mapgridlen = newmapgridlen + endif + + ! Unpack optional list of numbers defining number of points in each + ! row or column, if included. This is used for non regular grids. + if (igds(3) .ne. 0) then + nbits = igds(3) * 8 + idefnum = (lensec - 14 - ibyttem) / igds(3) + call g2_gbytesc(cgrib, ideflist, iofst, nbits, 0, idefnum) + iofst = iofst + (nbits * idefnum) + else + idefnum = 0 + endif + if (allocated(mapgrid)) deallocate(mapgrid) +end subroutine unpack3 + +!> This subroutine unpacks Section 4 (Product Definition Section) +!> starting at octet 6 of that Section. +!> +!> @param[in] cgrib Character array that contains the GRIB2 message. +!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. +!> @param[inout] iofst Bit offset of the beginning (in) or the end +!> (out) of Section 4. +!> @param[out] ipdsnum Product Definition Template Number (see [Code +!> Table 4.0] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table4-0.shtml)). +!> @param[out] ipdstmpl Contains the data values for the specified +!> Product Definition Template (N=ipdsnum). Each element of this +!> integer array contains an entry (in the order specified) of +!> Product Defintion Template 4.N. +!> @param[out] mappdslen Number of elements in ipdstmpl. i.e. number +!> of entries in Product Defintion Template 4.N (N=ipdsnum). +!> @param[out] coordlist- Array containg floating point values +!> intended to document the vertical discretisation associated to +!> model data on hybrid coordinate vertical levels (part of Section +!> 4). +!> @param[out] numcoord number of values in array coordlist. +!> @param[out] ierr Error return code. +!> - 0 no error. +!> - 5 GRIB message contains an undefined Product Definition Template. +!> +!> @author Stephen Gilbert @date 2000-05-26 +subroutine unpack4(cgrib, lcgrib, iofst, ipdsnum, ipdstmpl, & + mappdslen, coordlist, numcoord, ierr) + + use pdstemplates + implicit none + + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib + integer, intent(inout) :: iofst + real, intent(out) :: coordlist(*) + integer, intent(out) :: ipdsnum, ipdstmpl(*) + integer, intent(out) :: ierr, numcoord + + real(4), allocatable :: coordieee(:) + integer, allocatable :: mappds(:) + integer :: mappdslen + logical needext + + !implicit none additions + integer :: lensec, iret, i, nbits, isign, newmappdslen + + ierr = 0 + + call g2_gbytec(cgrib, lensec, iofst, 32) ! Get Length of Section + iofst = iofst + 32 + iofst = iofst + 8 ! skip section number + allocate(mappds(lensec)) + + call g2_gbytec(cgrib, numcoord, iofst, 16) ! Get num of coordinate values + iofst = iofst + 16 + call g2_gbytec(cgrib, ipdsnum, iofst, 16) ! Get Prod. Def Template num. + iofst = iofst + 16 + ! Get Product Definition Template. + call getpdstemplate(ipdsnum, mappdslen, mappds, needext, iret) + if (iret.ne.0) then + ierr = 5 + return + endif + + ! Unpack each value into array ipdstmpl from the the appropriate + ! number of octets, which are specified in corresponding entries in + ! array mappds. + do i = 1, mappdslen + nbits = iabs(mappds(i))*8 + if (mappds(i).ge.0) then + call g2_gbytec(cgrib, ipdstmpl(i), iofst, nbits) + else + call g2_gbytec(cgrib, isign, iofst, 1) + call g2_gbytec(cgrib, ipdstmpl(i), iofst + 1, nbits-1) + if (isign.eq.1) ipdstmpl(i) = -ipdstmpl(i) + endif + iofst = iofst + nbits + enddo + + ! Check to see if the Product Definition Template needs to be + ! extended. The number of values in a specific template may vary + ! depending on data specified in the "static" part of the template. + if (needext) then + call extpdstemplate(ipdsnum, ipdstmpl, newmappdslen, mappds) + + ! Unpack the rest of the Product Definition Template + do i = mappdslen + 1, newmappdslen + nbits = iabs(mappds(i))*8 + if (mappds(i).ge.0) then + call g2_gbytec(cgrib, ipdstmpl(i), iofst, nbits) + else + call g2_gbytec(cgrib, isign, iofst, 1) + call g2_gbytec(cgrib, ipdstmpl(i), iofst + 1, nbits-1) + if (isign.eq.1) ipdstmpl(i) = -ipdstmpl(i) + endif + iofst = iofst + nbits + enddo + mappdslen = newmappdslen + endif + + ! Get Optional list of vertical coordinate values after the Product + ! Definition Template, if necessary. + if (numcoord .ne. 0) then + allocate (coordieee(numcoord)) + call g2_gbytesc(cgrib, coordieee, iofst, 32, 0, numcoord) + call rdieee(coordieee, coordlist, numcoord) + deallocate (coordieee) + iofst = iofst + (32*numcoord) + endif + if (allocated(mappds)) deallocate(mappds) +end subroutine unpack4 + +!> This subroutine unpacks Section 5 (Data Representation Section) +!> starting at octet 6 of that Section. +!> +!> @param[in] cgrib Character array that contains the GRIB2 message. +!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. +!> @param[inout] iofst Bit offset of the beginning (in) or the +!> end(out) of Section 5. +!> @param[out] ndpts Number of data points unpacked and returned. +!> @param[out] idrsnum Data Representation Template Number (see [Code +!> Table 5.0] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table5-0.shtml)) +!> @param[out] idrstmpl Contains the data values for the specified +!> Data Representation Template (N = idrsnum). Each element of this +!> integer array contains an entry (in the order specified) of Data +!> Representation Template 5.N. +!> @param[out] mapdrslen Number of elements in idrstmpl. i.e. number +!> of entries in Data Representation Template 5.N (N = idrsnum). +!> @param[out] ierr Error return code. +!> - 0 no error. +!> - 7 GRIB message contains an undefined Data Representation Template. +!> +!> @author Stephen Gilbert @date 2000-05-26 +subroutine unpack5(cgrib, lcgrib, iofst, ndpts, idrsnum, & + idrstmpl, mapdrslen, ierr) + + use drstemplates + implicit none + + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib + integer, intent(inout) :: iofst + integer, intent(out) :: ndpts, idrsnum, idrstmpl(*) + integer, intent(out) :: ierr + + ! integer, allocatable :: mapdrs(:) + integer, allocatable :: mapdrs(:) + integer :: mapdrslen + logical needext + + !implicit none additions + integer :: lensec, i, nbits, isign, newmapdrslen, iret + + ierr = 0 + + call g2_gbytec(cgrib, lensec, iofst, 32) ! Get Length of Section + iofst = iofst + 32 + iofst = iofst + 8 ! skip section number + allocate(mapdrs(lensec)) + + call g2_gbytec(cgrib, ndpts, iofst, 32) ! Get num of data points + iofst = iofst + 32 + call g2_gbytec(cgrib, idrsnum, iofst, 16) ! Get Data Rep Template Num. + iofst = iofst + 16 + ! Gen Data Representation Template + call getdrstemplate(idrsnum, mapdrslen, mapdrs, needext, iret) + if (iret.ne.0) then + ierr = 7 + return + endif + + ! Unpack each value into array ipdstmpl from the the appropriate + ! number of octets, which are specified in corresponding entries in + ! array mappds. + do i = 1, mapdrslen + nbits = iabs(mapdrs(i))*8 + if (mapdrs(i).ge.0) then + call g2_gbytec(cgrib, idrstmpl(i), iofst, nbits) + else + call g2_gbytec(cgrib, isign, iofst, 1) + call g2_gbytec(cgrib, idrstmpl(i), iofst + 1, nbits-1) + if (isign.eq.1) idrstmpl(i) = -idrstmpl(i) + endif + iofst = iofst + nbits + enddo + + ! Check to see if the Data Representation Template needs to be + ! extended. The number of values in a specific template may vary + ! depending on data specified in the "static" part of the template. + if (needext) then + call extdrstemplate(idrsnum, idrstmpl, newmapdrslen, mapdrs) + ! Unpack the rest of the Data Representation Template + do i = mapdrslen + 1, newmapdrslen + nbits = iabs(mapdrs(i))*8 + if (mapdrs(i).ge.0) then + call g2_gbytec(cgrib, idrstmpl(i), iofst, nbits) + else + call g2_gbytec(cgrib, isign, iofst, 1) + call g2_gbytec(cgrib, idrstmpl(i), iofst + 1, nbits - 1) + if (isign.eq.1) idrstmpl(i) = -idrstmpl(i) + endif + iofst = iofst + nbits + enddo + mapdrslen = newmapdrslen + endif + if (allocated(mapdrs)) deallocate(mapdrs) +end subroutine unpack5 + +!> This subroutine unpacks Section 6 (Bit-Map Section) starting at +!> octet 6 of that Section. +!> +!> @param[in] cgrib Character array that contains the GRIB2 message. +!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. +!> @param[inout] iofst Bit offset of the beginning (in) or the end +!> (out) of Section 6. +!> @param[in] ngpts Number of grid points specified in the bit-map. +!> @param[out] ibmap Bitmap indicator (see [Code Table 6.0] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table6-0.shtml)). +!> - 0 bitmap applies and is included in Section 6. +!> - 1-253 Predefined bitmap applies. +!> - 254 Previously defined bitmap applies to this field. +!> - 255 Bit map does not apply to this product. +!> @param[out] bmap Logical*1 array containing decoded bitmap (if +!> ibmap = 0). +!> @param[out] ierr Error return code. +!> - 0 no error. +!> - 4 Unrecognized pre-defined bit-map. +!> +!> @author Stephen Gilbert @date 2000-05-26 +subroutine unpack6(cgrib, lcgrib, iofst, ngpts, ibmap, bmap, ierr) + implicit none + + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib, ngpts + integer, intent(inout) :: iofst + integer, intent(out) :: ibmap + integer, intent(out) :: ierr + logical*1, intent(out) :: bmap(ngpts) + + integer :: intbmap(ngpts) + + !implicit none additions + integer :: j + + ierr = 0 + + iofst = iofst + 32 ! skip Length of Section + iofst = iofst + 8 ! skip section number + + call g2_gbytec(cgrib, ibmap, iofst, 8) ! Get bit-map indicator + iofst = iofst + 8 + + if (ibmap.eq.0) then ! Unpack bitmap + call g2_gbytesc(cgrib, intbmap, iofst, 1, 0, ngpts) + iofst = iofst + ngpts + do j = 1, ngpts + bmap(j) = .true. + if (intbmap(j).eq.0) bmap(j) = .false. + enddo + elseif (ibmap.eq.254) then ! Use previous bitmap + return + elseif (ibmap.eq.255) then ! No bitmap in message + bmap(1:ngpts) = .true. + else + print *, 'unpack6: Predefined bitmap ', ibmap, & + ' not recognized.' + ierr = 4 + endif +end subroutine unpack6 diff --git a/src/getfield.f b/src/getfield.f deleted file mode 100644 index 4129f119..00000000 --- a/src/getfield.f +++ /dev/null @@ -1,720 +0,0 @@ -!> @file -!> @brief Contains subroutines obtain grid information and the unpacked data -!> (section 3 - 6) for a field from a GRIB2 file. -!> @author Stephen Gilbert @date 2000-05-26 -!> - -!> This subroutine returns the Grid Definition, Product Definition, -!> Bit-map (if applicable), and the unpacked data for a given data -!> field. Since there can be multiple data fields packed into a GRIB2 -!> message, the calling routine indicates which field is being requested -!> with the ifldnum argument. -!> -!> @param[in] cgrib Character array that contains the GRIB2 message -!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. -!> @param[in] ifldnum Specifies which field in the GRIB2 message to return. -!> @param[out] igds Contains information read from the appropriate GRIB Grid -!> Definition Section 3 for the field being returned. -!> Must be dimensioned >= 5. -!> - igds(1) Source of grid definition (see Code Table 3.0) -!> - igds(2) Number of grid points in the defined grid. -!> - igds(3) Number of octets needed for each additional grid points definition. -!> Used to define number of points in each row (or column) for -!> non-regular grids. = 0, if using regular grid. -!> - igds(4) Interpretation of list for optional points definition (Code Table 3.11). -!> - igds(5) Grid Definition Template Number (Code Table 3.1). -!> @param[out] igdstmpl Contains the data values for the specified Grid Definition -!> Template (NN=igds(5)). Each element of this integer array contains an entry (in -!> the order specified) of Grid Defintion Template 3.NN. A safe dimension for this -!> array can be obtained in advance from maxvals(2), which is returned -!> from subroutine gribinfo. -!> @param[out] igdslen Number of elements in igdstmpl. i.e. number of entries -!> in Grid Defintion Template 3.NN (NN=igds(5)). -!> @param[out] ideflist (Used if igds(3) .ne. 0) This array contains the number -!> of grid points contained in each row (or column). (part of Section 3) -!> A safe dimension for this array can be obtained in advance -!> from maxvals(3), which is returned from subroutine gribinfo. -!> @param[out] idefnum (Used if igds(3) .ne. 0) The number of entries in array ideflist. -!> i.e. number of rows (or columns) for which optional grid points are defined. -!> @param[out] ipdsnum Product Definition Template Number (see Code Table 4.0). -!> @param[out] ipdstmpl Contains the data values for the specified Product Definition -!> Template (N=ipdsnum). Each element of this integer array contains an entry -!> (in the order specified) of Product Defintion Template 4.N. A safe -!> dimension for this array can be obtained in advance from maxvals(4), -!> which is returned from subroutine gribinfo. -!> @param[out] ipdslen Number of elements in ipdstmpl. i.e. number of entries -!> in Product Defintion Template 4.N (N=ipdsnum). -!> @param[out] coordlist Array containg floating point values intended to document -!> the vertical discretisation associated to model data on hybrid coordinate vertical levels. -!> (part of Section 4) The dimension of this array can be obtained in advance -!> from maxvals(5), which is returned from subroutine gribinfo. -!> @param[out] numcoord number of values in array coordlist. -!> @param[out] ndpts Number of data points unpacked and returned. -!> @param[out] idrsnum Data Representation Template Number (see Code Table 5.0). -!> @param[out] idrstmpl Contains the data values for the specified Data Representation -!> Template (N=idrsnum). Each element of this integer array contains -!> an entry (in the order specified) of Product Defintion Template 5.N -!> A safe dimension for this array can be obtained in advance -!> from maxvals(6), which is returned from subroutine gribinfo. -!> @param[out] idrslen Number of elements in idrstmpl. i.e. number of entries -!> in Data Representation Template 5.N (N=idrsnum). -!> @param[out] ibmap Bitmap indicator (see Code Table 6.0) -!> - 0 bitmap applies and is included in Section 6. -!> - 1-253 Predefined bitmap applies. -!> - 254 Previously defined bitmap applies to this field. -!> - 255 Bit map does not apply to this product. -!> @param[out] bmap Logical*1 array containing decoded bitmap. (if ibmap=0) -!> The dimension of this array can be obtained in advance from maxvals(7), -!> which is returned from subroutine gribinfo. -!> @param[out] fld Array of ndpts unpacked data points. A safe dimension -!> for this array can be obtained in advance from maxvals(7), -!> which is returned from subroutine gribinfo. -!> @param[out] ierr Error return code. -!> - 0 no error. -!> - 1 Beginning characters "GRIB" not found. -!> - 2 GRIB message is not Edition 2. -!> - 3 The data field request number was not positive. -!> - 4 End string "7777" found, but not where expected. -!> - 6 GRIB message did not contain the requested number of data fields. -!> - 7 End string "7777" not found at end of message. -!> - 9 Data Representation Template 5.NN not yet implemented. -!> - 10 Error unpacking Section 3. -!> - 11 Error unpacking Section 4. -!> - 12 Error unpacking Section 5. -!> - 13 Error unpacking Section 6. -!> - 14 Error unpacking Section 7. -!> -!> @note Note that subroutine gribinfo can be used to first determine -!> how many data fields exist in a given GRIB message. -!> -!> @author Stephen Gilbert @date 2000-05-26 -!> - - subroutine getfield(cgrib,lcgrib,ifldnum,igds,igdstmpl,igdslen, - & ideflist,idefnum,ipdsnum,ipdstmpl,ipdslen, - & coordlist,numcoord,ndpts,idrsnum,idrstmpl, - & idrslen,ibmap,bmap,fld,ierr) - - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib,ifldnum - integer,intent(out) :: igds(*),igdstmpl(*),ideflist(*) - integer,intent(out) :: ipdsnum,ipdstmpl(*) - integer,intent(out) :: idrsnum,idrstmpl(*) - integer,intent(out) :: ndpts,ibmap,idefnum,numcoord - integer,intent(out) :: ierr - logical*1,intent(out) :: bmap(*) - real,intent(out) :: fld(*),coordlist(*) - - character(len=4),parameter :: grib='GRIB',c7777='7777' - character(len=4) :: ctemp - integer:: listsec0(2) - integer iofst,ibeg,istart - integer(4) :: ieee - logical have3,have4,have5,have6,have7 - - have3=.false. - have4=.false. - have5=.false. - have6=.false. - have7=.false. - ierr=0 - numfld=0 -! -! Check for valid request number -! - if (ifldnum.le.0) then - print *,'getfield: Request for field number must be positive.' - ierr=3 - return - endif -! -! Check for beginning of GRIB message in the first 100 bytes -! - istart=0 - do j=1,100 - ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3) - if (ctemp.eq.grib ) then - istart=j - exit - endif - enddo - if (istart.eq.0) then - print *,'getfield: Beginning characters GRIB not found.' - ierr=1 - return - endif -! -! Unpack Section 0 - Indicator Section -! - iofst=8*(istart+5) - call g2_gbytec(cgrib,listsec0(1),iofst,8) ! Discipline - iofst=iofst+8 - call g2_gbytec(cgrib,listsec0(2),iofst,8) ! GRIB edition number - iofst=iofst+8 - iofst=iofst+32 - call g2_gbytec(cgrib,lengrib,iofst,32) ! Length of GRIB message - iofst=iofst+32 - lensec0=16 - ipos=istart+lensec0 -! -! Currently handles only GRIB Edition 2. -! - if (listsec0(2).ne.2) then - print *,'getfield: can only decode GRIB edition 2.' - ierr=2 - return - endif -! -! Loop through the remaining sections keeping track of the -! length of each. Also keep the latest Grid Definition Section info. -! Unpack the requested field number. -! - do - ! Check to see if we are at end of GRIB message - ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3) - if (ctemp.eq.c7777 ) then - ipos=ipos+4 - ! If end of GRIB message not where expected, issue error - if (ipos.ne.(istart+lengrib)) then - print *,'getfield: "7777" found, but not where expected.' - ierr=4 - return - endif - exit - endif - ! Get length of Section and Section number - iofst=(ipos-1)*8 - call g2_gbytec(cgrib,lensec,iofst,32) ! Get Length of Section - iofst=iofst+32 - call g2_gbytec(cgrib,isecnum,iofst,8) ! Get Section number - iofst=iofst+8 - !print *,' lensec= ',lensec,' secnum= ',isecnum - ! - ! If found Section 3, unpack the GDS info using the - ! appropriate template. Save in case this is the latest - ! grid before the requested field. - ! - if (isecnum.eq.3) then - iofst=iofst-40 ! reset offset to beginning of section - call unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,igdslen, - & ideflist,idefnum,jerr) - if (jerr.eq.0) then - have3=.true. - else - ierr=10 - return - endif - endif - ! - ! If found Section 4, check to see if this field is the - ! one requested. - ! - if (isecnum.eq.4) then - numfld=numfld+1 - if (numfld.eq.ifldnum) then - iofst=iofst-40 ! reset offset to beginning of section - call unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,ipdslen, - & coordlist,numcoord,jerr) - if (jerr.eq.0) then - have4=.true. - else - ierr=11 - return - endif - endif - endif - ! - ! If found Section 5, check to see if this field is the - ! one requested. - ! - if ((isecnum.eq.5).and.(numfld.eq.ifldnum)) then - iofst=iofst-40 ! reset offset to beginning of section - call unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl, - & idrslen,jerr) - if (jerr.eq.0) then - have5=.true. - else - ierr=12 - return - endif - endif - ! - ! If found Section 6, Unpack bitmap. - ! Save in case this is the latest - ! bitmap before the requested field. - ! - if (isecnum.eq.6) then - iofst=iofst-40 ! reset offset to beginning of section - call unpack6(cgrib,lcgrib,iofst,igds(2),ibmap,bmap,jerr) - if (jerr.eq.0) then - have6=.true. - else - ierr=13 - return - endif - endif - ! - ! If found Section 7, check to see if this field is the - ! one requested. - ! - if ((isecnum.eq.7).and.(numfld.eq.ifldnum)) then - if (idrsnum.eq.0) then - call simunpack(cgrib(ipos+5),lensec-6,idrstmpl,ndpts,fld) - have7=.true. - elseif (idrsnum.eq.2.or.idrsnum.eq.3) then - call comunpack(cgrib(ipos+5),lensec-6,lensec,idrsnum, - & idrstmpl,ndpts,fld,ier) - if ( ier .ne. 0 ) then - ierr=14 - return - endif - have7=.true. - elseif (idrsnum.eq.50) then - call simunpack(cgrib(ipos+5),lensec-6,idrstmpl,ndpts-1, - & fld(2)) - ieee=idrstmpl(5) - call rdieee(ieee,fld(1),1) - have7=.true. - elseif (idrsnum.eq.40 .OR. idrsnum.eq.40000) then - call jpcunpack(cgrib(ipos+5),lensec-5,idrstmpl,ndpts,fld) - have7=.true. - elseif (idrsnum.eq.41 .OR. idrsnum.eq.40010) then - call pngunpack(cgrib(ipos+5),lensec-5,idrstmpl,ndpts,fld) - have7=.true. - else - print *,'getfield: Data Representation Template ',idrsnum, - & ' not yet implemented.' - ierr=9 - return - endif - endif - ! - ! Check to see if we read pass the end of the GRIB - ! message and missed the terminator string '7777'. - ! - ipos=ipos+lensec ! Update beginning of section pointer - if (ipos.gt.(istart+lengrib)) then - print *,'getfield: "7777" not found at end of GRIB message.' - ierr=7 - return - endif - - if (have3.and.have4.and.have5.and.have6.and.have7) return - - enddo - -! -! If exited from above loop, the end of the GRIB message was reached -! before the requested field was found. -! - print *,'getfield: GRIB message contained ',numlocal, - & ' different fields.' - print *,'getfield: The request was for the ',ifldnum, - & ' field.' - ierr=6 - - return - end - -!> This subroutine unpacks Section 3 (Grid Definition Section) -!> starting at octet 6 of that Section. -!> -!> @param[in] cgrib Character array that contains the GRIB2 message. -!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. -!> @param[inout] iofst Bit offset of the beginning (in) or the end (out) of Section 3. -!> @param[out] igds Contains information read from the appropriate GRIB Grid -!> Definition Section 3 for the field being returned. Must be dimensioned >= 5. -!> - igds(1) Source of grid definition (see Code Table 3.0) -!> - igds(2) Number of grid points in the defined grid. -!> - igds(3) Number of octets needed for each additional grid points definition. -!> Used to define number of points in each row (or column) for non-regular -!> grids. = 0, if using regular grid. -!> - igds(4) Interpretation of list for optional points definition. (Code Table 3.11) -!> - igds(5) Grid Definition Template Number (Code Table 3.1) -!> @param[out] igdstmpl Contains the data values for the specified Grid Definition -!> Template (NN=igds(5)). Each element of this integer array contains an entry -!> (in the order specified) of Grid Defintion Template 3.NN. -!> @param[out] mapgridlen Number of elements in igdstmpl. i.e. number of entries -!> in Grid Defintion Template 3.NN (NN=igds(5)). -!> @param[out] ideflist (Used if igds(3) .ne. 0) This array contains the -!> number of grid points contained in each row (or column). (part of Section 3). -!> @param[out] idefnum (Used if igds(3) .ne. 0) The number of entries in array -!> ideflist. i.e. number of rows (or columns) for which optional grid points are defined. -!> @param[out] ierr Error return code. -!> - 0 no error. -!> - 5 "GRIB" message contains an undefined Grid Definition Template. -!> -!> @note Uses Fortran 90 module gridtemplates. -!> -!> @author Stephen Gilbert @date 2000-05-26 -!> - subroutine unpack3(cgrib,lcgrib,iofst,igds,igdstmpl, - & mapgridlen,ideflist,idefnum,ierr) - - use gridtemplates - - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib - integer,intent(inout) :: iofst - integer,intent(out) :: igds(*),igdstmpl(*),ideflist(*) - integer,intent(out) :: ierr,idefnum - - integer,allocatable :: mapgrid(:) - integer :: mapgridlen,ibyttem - logical needext - - ierr=0 - - call g2_gbytec(cgrib,lensec,iofst,32) ! Get Length of Section - iofst=iofst+32 - iofst=iofst+8 ! skip section number - - call g2_gbytec(cgrib,igds(1),iofst,8) ! Get source of Grid def. - iofst=iofst+8 - call g2_gbytec(cgrib,igds(2),iofst,32) ! Get number of grid pts. - iofst=iofst+32 - call g2_gbytec(cgrib,igds(3),iofst,8) ! Get num octets for opt. list - iofst=iofst+8 - call g2_gbytec(cgrib,igds(4),iofst,8) ! Get interpret. for opt. list - iofst=iofst+8 - call g2_gbytec(cgrib,igds(5),iofst,16) ! Get Grid Def Template num. - iofst=iofst+16 - if (igds(1).eq.0) then -! if (igds(1).eq.0.OR.igds(1).eq.255) then ! FOR ECMWF TEST ONLY - allocate(mapgrid(lensec)) - ! Get Grid Definition Template - call getgridtemplate(igds(5),mapgridlen,mapgrid,needext, - & iret) - if (iret.ne.0) then - ierr=5 - return - endif - else -! igdstmpl=-1 - mapgridlen=0 - needext=.false. - endif - ! - ! Unpack each value into array igdstmpl from the - ! the appropriate number of octets, which are specified in - ! corresponding entries in array mapgrid. - ! - ibyttem=0 - do i=1,mapgridlen - nbits=iabs(mapgrid(i))*8 - if ( mapgrid(i).ge.0 ) then - call g2_gbytec(cgrib,igdstmpl(i),iofst,nbits) - else - call g2_gbytec(cgrib,isign,iofst,1) - call g2_gbytec(cgrib,igdstmpl(i),iofst+1,nbits-1) - if (isign.eq.1) igdstmpl(i)=-igdstmpl(i) - endif - iofst=iofst+nbits - ibyttem=ibyttem+iabs(mapgrid(i)) - enddo - ! - ! Check to see if the Grid Definition Template needs to be - ! extended. - ! The number of values in a specific template may vary - ! depending on data specified in the "static" part of the - ! template. - ! - if ( needext ) then - call extgridtemplate(igds(5),igdstmpl,newmapgridlen,mapgrid) - ! Unpack the rest of the Grid Definition Template - do i=mapgridlen+1,newmapgridlen - nbits=iabs(mapgrid(i))*8 - if ( mapgrid(i).ge.0 ) then - call g2_gbytec(cgrib,igdstmpl(i),iofst,nbits) - else - call g2_gbytec(cgrib,isign,iofst,1) - call g2_gbytec(cgrib,igdstmpl(i),iofst+1,nbits-1) - if (isign.eq.1) igdstmpl(i)=-igdstmpl(i) - endif - iofst=iofst+nbits - ibyttem=ibyttem+iabs(mapgrid(i)) - enddo - mapgridlen=newmapgridlen - endif - ! - ! Unpack optional list of numbers defining number of points - ! in each row or column, if included. This is used for non regular - ! grids. - ! - if ( igds(3).ne.0 ) then - nbits=igds(3)*8 - idefnum=(lensec-14-ibyttem)/igds(3) - call g2_gbytesc(cgrib,ideflist,iofst,nbits,0,idefnum) - iofst=iofst+(nbits*idefnum) - else - idefnum=0 - endif - if( allocated(mapgrid) ) deallocate(mapgrid) - return ! End of Section 3 processing - end - -!> This subroutine unpacks Section 4 (Product Definition Section) -!> starting at octet 6 of that Section. -!> -!> @param[in] cgrib Character array that contains the GRIB2 message -!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. -!> @param[inout] iofst Bit offset of the beginning (in) or the end (out) of Section 4. -!> @param[out] ipdsnum Product Definition Template Number (see Code Table 4.0). -!> @param[out] ipdstmpl Contains the data values for the specified Product Definition -!> Template (N=ipdsnum). Each element of this integer array contains an entry -!> (in the order specified) of Product Defintion Template 4.N. -!> @param[out] mappdslen Number of elements in ipdstmpl. i.e. number of entries -!> in Product Defintion Template 4.N (N=ipdsnum). -!> @param[out] coordlist- Array containg floating point values intended to document -!> the vertical discretisation associated to model data on hybrid coordinate -!> vertical levels. (part of Section 4). -!> @param[out] numcoord number of values in array coordlist. -!> @param[out] ierr Error return code. -!> - 0 no error. -!> - 5 GRIB message contains an undefined Product Definition Template. -!> -!> @note Uses Fortran 90 module pdstemplates. -!> -!> @author Stephen Gilbert @date 2000-05-26 -!> - subroutine unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,mappdslen, - & coordlist,numcoord,ierr) - - use pdstemplates - - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib - integer,intent(inout) :: iofst - real,intent(out) :: coordlist(*) - integer,intent(out) :: ipdsnum,ipdstmpl(*) - integer,intent(out) :: ierr,numcoord - - real(4),allocatable :: coordieee(:) - integer,allocatable :: mappds(:) - integer :: mappdslen - logical needext - - ierr=0 - - call g2_gbytec(cgrib,lensec,iofst,32) ! Get Length of Section - iofst=iofst+32 - iofst=iofst+8 ! skip section number - allocate(mappds(lensec)) - - call g2_gbytec(cgrib,numcoord,iofst,16) ! Get num of coordinate values - iofst=iofst+16 - call g2_gbytec(cgrib,ipdsnum,iofst,16) ! Get Prod. Def Template num. - iofst=iofst+16 - ! Get Product Definition Template - call getpdstemplate(ipdsnum,mappdslen,mappds,needext,iret) - if (iret.ne.0) then - ierr=5 - return - endif - ! - ! Unpack each value into array ipdstmpl from the - ! the appropriate number of octets, which are specified in - ! corresponding entries in array mappds. - ! - do i=1,mappdslen - nbits=iabs(mappds(i))*8 - if ( mappds(i).ge.0 ) then - call g2_gbytec(cgrib,ipdstmpl(i),iofst,nbits) - else - call g2_gbytec(cgrib,isign,iofst,1) - call g2_gbytec(cgrib,ipdstmpl(i),iofst+1,nbits-1) - if (isign.eq.1) ipdstmpl(i)=-ipdstmpl(i) - endif - iofst=iofst+nbits - enddo - ! - ! Check to see if the Product Definition Template needs to be - ! extended. - ! The number of values in a specific template may vary - ! depending on data specified in the "static" part of the - ! template. - ! - if ( needext ) then - call extpdstemplate(ipdsnum,ipdstmpl,newmappdslen,mappds) - ! Unpack the rest of the Product Definition Template - do i=mappdslen+1,newmappdslen - nbits=iabs(mappds(i))*8 - if ( mappds(i).ge.0 ) then - call g2_gbytec(cgrib,ipdstmpl(i),iofst,nbits) - else - call g2_gbytec(cgrib,isign,iofst,1) - call g2_gbytec(cgrib,ipdstmpl(i),iofst+1,nbits-1) - if (isign.eq.1) ipdstmpl(i)=-ipdstmpl(i) - endif - iofst=iofst+nbits - enddo - mappdslen=newmappdslen - endif - ! - ! Get Optional list of vertical coordinate values - ! after the Product Definition Template, if necessary. - ! - if ( numcoord .ne. 0 ) then - allocate (coordieee(numcoord)) - call g2_gbytesc(cgrib,coordieee,iofst,32,0,numcoord) - call rdieee(coordieee,coordlist,numcoord) - deallocate (coordieee) - iofst=iofst+(32*numcoord) - endif - if( allocated(mappds) ) deallocate(mappds) - return ! End of Section 4 processing - end - -!> This subroutine unpacks Section 5 (Data Representation Section) -!> starting at octet 6 of that Section. -!> -!> @param[in] cgrib Character array that contains the GRIB2 message -!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. -!> @param[inout] iofst Bit offset of the beginning (in) or the end(out) of Section 5. -!> @param[out] ndpts Number of data points unpacked and returned. -!> @param[out] idrsnum Data Representation Template Number (see Code Table 5.0) -!> @param[out] idrstmpl Contains the data values for the specified Data Representation -!> Template (N=idrsnum). Each element of this integer array contains an entry -!> (in the order specified) of Data Representation Template 5.N. -!> @param[out] mapdrslen Number of elements in idrstmpl. i.e. number of entries -!> in Data Representation Template 5.N (N=idrsnum). -!> @param[out] ierr Error return code. -!> - 0 no error. -!> - 7 GRIB message contains an undefined Data Representation Template. -!> -!> @author Stephen Gilbert @date 2000-05-26 -!> - - subroutine unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl, - & mapdrslen,ierr) - - use drstemplates - - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib - integer,intent(inout) :: iofst - integer,intent(out) :: ndpts,idrsnum,idrstmpl(*) - integer,intent(out) :: ierr - -! integer,allocatable :: mapdrs(:) - integer,allocatable :: mapdrs(:) - integer :: mapdrslen - logical needext - - ierr=0 - - call g2_gbytec(cgrib,lensec,iofst,32) ! Get Length of Section - iofst=iofst+32 - iofst=iofst+8 ! skip section number - allocate(mapdrs(lensec)) - - call g2_gbytec(cgrib,ndpts,iofst,32) ! Get num of data points - iofst=iofst+32 - call g2_gbytec(cgrib,idrsnum,iofst,16) ! Get Data Rep Template Num. - iofst=iofst+16 - ! Gen Data Representation Template - call getdrstemplate(idrsnum,mapdrslen,mapdrs,needext,iret) - if (iret.ne.0) then - ierr=7 - return - endif - ! - ! Unpack each value into array ipdstmpl from the - ! the appropriate number of octets, which are specified in - ! corresponding entries in array mappds. - ! - do i=1,mapdrslen - nbits=iabs(mapdrs(i))*8 - if ( mapdrs(i).ge.0 ) then - call g2_gbytec(cgrib,idrstmpl(i),iofst,nbits) - else - call g2_gbytec(cgrib,isign,iofst,1) - call g2_gbytec(cgrib,idrstmpl(i),iofst+1,nbits-1) - if (isign.eq.1) idrstmpl(i)=-idrstmpl(i) - endif - iofst=iofst+nbits - enddo - ! - ! Check to see if the Data Representation Template needs to be - ! extended. - ! The number of values in a specific template may vary - ! depending on data specified in the "static" part of the - ! template. - ! - if ( needext ) then - call extdrstemplate(idrsnum,idrstmpl,newmapdrslen,mapdrs) - ! Unpack the rest of the Data Representation Template - do i=mapdrslen+1,newmapdrslen - nbits=iabs(mapdrs(i))*8 - if ( mapdrs(i).ge.0 ) then - call g2_gbytec(cgrib,idrstmpl(i),iofst,nbits) - else - call g2_gbytec(cgrib,isign,iofst,1) - call g2_gbytec(cgrib,idrstmpl(i),iofst+1,nbits-1) - if (isign.eq.1) idrstmpl(i)=-idrstmpl(i) - endif - iofst=iofst+nbits - enddo - mapdrslen=newmapdrslen - endif - if( allocated(mapdrs) ) deallocate(mapdrs) - return ! End of Section 5 processing - end - -!> This subroutine unpacks Section 6 (Bit-Map Section) -!> starting at octet 6 of that Section. -!> -!> @param[in] cgrib Character array that contains the GRIB2 message -!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. -!> @param[inout] iofst Bit offset of the beginning (in) or the end (out) of Section 6. -!> @param[in] ngpts Number of grid points specified in the bit-map -!> @param[out] ibmap Bitmap indicator (see Code Table 6.0). -!> - 0 bitmap applies and is included in Section 6. -!> - 1-253 Predefined bitmap applies. -!> - 254 Previously defined bitmap applies to this field. -!> - 255 Bit map does not apply to this product. -!> @param[out] bmap Logical*1 array containing decoded bitmap (if ibmap=0). -!> @param[out] ierr Error return code. -!> - 0 no error. -!> - 4 Unrecognized pre-defined bit-map. -!> -!> @author Stephen Gilbert @date 2000-05-26 -!> - subroutine unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,bmap,ierr) - - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib,ngpts - integer,intent(inout) :: iofst - integer,intent(out) :: ibmap - integer,intent(out) :: ierr - logical*1,intent(out) :: bmap(ngpts) - - integer :: intbmap(ngpts) - - ierr=0 - - iofst=iofst+32 ! skip Length of Section - iofst=iofst+8 ! skip section number - - call g2_gbytec(cgrib,ibmap,iofst,8) ! Get bit-map indicator - iofst=iofst+8 - - if (ibmap.eq.0) then ! Unpack bitmap - call g2_gbytesc(cgrib,intbmap,iofst,1,0,ngpts) - iofst=iofst+ngpts - do j=1,ngpts - bmap(j)=.true. - if (intbmap(j).eq.0) bmap(j)=.false. - enddo - elseif (ibmap.eq.254) then ! Use previous bitmap - return - elseif (ibmap.eq.255) then ! No bitmap in message - bmap(1:ngpts)=.true. - else - print *,'unpack6: Predefined bitmap ',ibmap,' not recognized.' - ierr=4 - endif - - return ! End of Section 6 processing - end - diff --git a/src/gf_free.f b/src/gf_free.f index a9a6e17a..f34e2854 100644 --- a/src/gf_free.f +++ b/src/gf_free.f @@ -1,140 +1,20 @@ -!> @file -!> @brief This subroutine frees up memory in derived type gribfield. -!> @author Stephen Gilbert @date 2000-05-26 -!> +!> @file +!> @brief This subroutine frees up memory in derived type grib_mod::gribfield. +!> @author Stephen Gilbert @date 2000-05-26 -!> This subroutine frees up memory that was used to store -!> array values in derived type gribfield. +!> This subroutine frees up memory that was used to store +!> array values in derived type grib_mod::gribfield. !> -!> Program History log: -!> - 2000-05-26 Stephen Gilbert Modified from getg1s to work with grib2 -!> - 2012-12-11 Boi Vuong initialize an undefine pointers -!> - 2015-10-29 Boi Vuong Deallocate pointers in derived type gribfield -!> @param[in] gfld derived type gribfield (defined in module grib_mod) -!> @param[out] gfld derived type gribfield (defined in module grib_mod) -!> (NOTE: See Remarks Section) -!> - gfld\%version GRIB edition number (currently 2) -!> - gfld\%discipline Message Discipline (see Code Table 0.0) -!> - gfld\%idsect Contains the entries in the Identification Section -!> (Section 1) This element is actually a pointer to an array -!> that holds the data. -!> - gfld\%idsect(1) Identification of originating Centre -!> (see Common Code Table C-1) 7 US National Weather Service -!> - gfld\%idsect(2) Identification of originating Sub-centre -!> - gfld\%idsect(3) GRIB Master Tables Version Number -!> (see Code Table 1.0) 0 Experimental; 1 Initial operational version number -!> - gfld\%idsect(4) GRIB Local Tables Version Number (see Code Table 1.1) -!> - 0 Local tables not used -!> - 0 1-254 Number of local tables version used -!> - gfld\%idsect(5) Significance of Reference Time (Code Table 1.2) -!> - 0 Analysis -!> - 1 Start of forecast -!> - 2 Verifying time of forecast -!> - 3 Observation time. -!> - gfld\%idsect(6) Year (4 digits) -!> - gfld\%idsect(7) Month -!> - gfld\%idsect(8) Day -!> - gfld\%idsect(9) Hour -!> - gfld\%idsect(10) Minute -!> - gfld\%idsect(11) Second -!> - gfld\%idsect(12) Production status of processed data (see Code -!> Table 1.3) -!> - 0 Operational products -!> - 1 Operational test products -!> - 2 Research products -!> - 3 Re-analysis products -!> - gfld\%idsect(13) Type of processed data (see Code Table 1.4) -!> - 0 Analysis products -!> - 1 Forecast products -!> - 2 Analysis and forecast products -!> - 3 Control forecast products -!> - 4 Perturbed forecast products -!> - 5 Control and perturbed forecast products -!> - 6 Processed satellite observations -!> - 7 Processed radar observations -!> - gfld\%idsectlen Number of elements in gfld\%idsect -!> - gfld\%local Pointer to character array containing contents -!> of Local Section 2, if included -!> - gfld\%locallen length of array gfld\%local -!> - gfld\%ifldnum field number within GRIB message -!> - gfld\%griddef Source of grid definition (see Code Table 3.0) -!> - 0 Specified in Code table 3.1 -!> - 1 Predetermined grid Defined by originating centre -!> - gfld\%ngrdpts Number of grid points in the defined grid. -!> Note that the number of actual data values returned from getgb2 -!> (in gfld\%ndpts) may be less than this value if a logical bitmap -!> is in use with grid points that are being masked out. -!> - gfld\%numoct_opt Number of octets needed for each additional grid -!> points definition. Used to define number of points in each row (or -!> column) for non-regular grids. = 0, if using regular grid. -!> - gfld\%interp_opt Interpretation of list for optional points -!> definition.(Code Table 3.11) -!> - gfld\%igdtnum Grid Definition Template Number (Code Table 3.1) -!> - gfld\%igdtmpl Contains the data values for the specified Grid -!> Definition Template (NN=gfld\%igdtnum). Each element of this -!> integer array contains an entry (in the order specified) of Grid -!> Defintion Template 3.NN This element is actually a pointer to an -!> array that holds the data. -!> - gfld\%igdtlen Number of elements in gfld\%igdtmpl. i.e. number -!> of entries in Grid Defintion Template 3.NN (NN=gfld\%igdtnum). -!> - gfld\%list_opt (Used if gfld\%numoct_opt .ne. 0) This array -!> contains the number of grid points contained in each row (or -!> column). (part of Section 3) This element is actually a pointer -!> to an array that holds the data. This pointer is nullified -!> if gfld\%numoct_opt=0. -!> - gfld\%num_opt (Used if gfld\%numoct_opt .ne. 0) The number of -!> entries in array ideflist. i.e. number of rows (or columns) for which -!> optional grid points are defined. This value is set to zero, -!> if gfld\%numoct_opt=0. -!> - gfdl\%ipdtnum Product Definition Template Number (Code Table 4.0) -!> - gfld\%ipdtmpl Contains the data values for the specified Product -!> Definition Template (N=gfdl\%ipdtnum). Each element of this integer -!> array contains an entry (in the order specified) of Product Defintion -!> Template 4.N. This element is actually a pointer to an array -!> that holds the data. -!> - gfld\%ipdtlen Number of elements in gfld\%ipdtmpl. i.e. number of -!> entries in Product Defintion Template 4.N (N=gfdl\%ipdtnum). -!> - gfld\%coord_list Real array containing floating point values -!> intended to document the vertical discretisation associated to -!> model data on hybrid coordinate vertical levels.(part of Section 4) -!> This element is actually a pointer to an array -!> that holds the data. -!> - gfld\%num_coord number of values in array gfld\%coord_list. -!> - gfld\%ndpts Number of data points unpacked and returned. -!> Note that this number may be different from the value of -!> - gfld\%ngrdpts if a logical bitmap is in use with grid points -!> that are being masked out. -!> - gfld\%idrtnum Data Representation Template Number (Code Table 5.0) -!> - gfld\%idrtmpl Contains the data values for the specified Data -!> Representation Template (N=gfld\%idrtnum). Each element of this -!> integer array contains an entry (in the order specified) of -!> Product Defintion Template 5.N. This element is actually a -!> pointer to an array that holds the data. -!> - gfld\%idrtlen Number of elements in gfld\%idrtmpl. i.e. number -!> of entries in Data Representation Template 5.N (N=gfld\%idrtnum). -!> - gfld\%unpacked logical value indicating whether the bitmap and -!> data values were unpacked. If false, gfld\%bmap and gfld\%fld -!> pointers are nullified. -!> - gfld\%expanded Logical value indicating whether the data field -!> was expanded to the grid in the case where a bit-map is present. -!> If true, the data points in gfld\%fld match the grid points and -!> zeros were inserted at grid points where data was bit-mapped out. -!> If false, the data values in gfld\%fld were not expanded to the -!> grid and are just a consecutive array of data points corresponding -!> to each value of "1" in gfld\%bmap. -!> - gfld\%ibmap Bitmap indicator (see Code Table 6.0) -!> - 0 bitmap applies and is included in Section 6. -!> - 1-253 Predefined bitmap applies -!> - 254 Previously defined bitmap applies to this field -!> - 255 Bit map does not apply to this product. -!> - gfld\%bmap Logical*1 array containing decoded bitmap, if ibmap=0 -!> or ibap=254. Otherwise nullified. This element is actually a -!> pointer to an array that holds the data. -!> - gfld\%fld Array of gfld\%ndpts unpacked data points. This element -!> is actually a pointer to an array that holds the data. -!> @author Stephen Gilbert @date 2000-05-26 +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2000-05-26 | Stephen Gilbert | Modified from getg1s to work with grib2 +!> 2012-12-11 | Boi Vuong | initialize an undefine pointers +!> 2015-10-29 | Boi Vuong | Deallocate pointers in derived type gribfield !> - +!> @param gfld derived type grib_mod::gribfield. +!> +!> @author Stephen Gilbert @date 2000-05-26 subroutine gf_free(gfld) use grib_mod diff --git a/src/gf_getfld.F90 b/src/gf_getfld.F90 new file mode 100644 index 00000000..28f6853b --- /dev/null +++ b/src/gf_getfld.F90 @@ -0,0 +1,441 @@ +!> @file +!> @brief Contains subroutines returns the Grid Definition, and +!> Product Definition for a given data field. +!> @author Stephen Gilbert @date 2000-05-26 + +!> This subroutine returns the Grid Definition, Product Definition, +!> Bit-map (if applicable), and the unpacked data for a given data +!> field. All of the information returned is stored in a derived type +!> variable, gfld. Gfld is of type gribfield, which is defined in +!> module grib_mod, so users of this routine will need to include the +!> line "USE GRIB_MOD" in their calling routine. +!> +!> Since there can be multiple data fields packed into a GRIB2 +!> message, the calling routine indicates which field is being +!> requested with the ifldnum argument. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2000-05-26 | Stephen Gilbert | Initial. +!> 2002-01-24 | Stephen Gilbert | Pass back derived type gribfield variable through argument list. +!> 2004-05-20 | Stephen Gilbert | Check if previous a bit-map is specified, but none was found. +!> 2015-10-29 | Boi Vuong | Initial all pointers in derive type gribfield. +!> +!> @param[in] cgrib Character array that contains the GRIB2 message. +!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. +!> @param[in] ifldnum Specifies which field in the GRIB2 message to +!> return. +!> @param[in] unpack Logical value indicating whether to unpack +!> bitmap/data. .true. = unpack bitmap and data values; .false. = do +!> not unpack bitmap and data values. +!> @param[in] expand Boolean value indicating whether the data points +!> should be expanded to the correspond grid, if a bit-map is +!> present. +!> - 1 if possible, expand data field to grid, inserting zero +!> values at gridpoints that are bitmapped out. +!> - 0 do not expand data field, leaving it an array of consecutive +!> data points for each "1" in the bitmap. This argument is ignored +!> if unpack == 0 OR if the returned field does not contain a +!> bit-map. +!> @param[out] gfld derived type @ref grib_mod::gribfield. +!> @param[out] ierr Error return code. +!> - 0 no error. +!> - 1 Beginning characters "GRIB" not found. +!> - 2 GRIB message is not Edition 2. +!> - 3 The data field request number was not positive. +!> - 4 End string "7777" found, but not where expected. +!> - 5 End string "7777" not found at end of message. +!> - 6 GRIB message did not contain the requested number of data fields. +!> - 7 End string "7777" not found at end of message. +!> - 9 Data Representation Template 5.NN not yet implemented. +!> - 10 Error unpacking Section 3. +!> - 11 Error unpacking Section 4. +!> - 12 Error unpacking Section 5. +!> - 13 Error unpacking Section 6. +!> - 14 Error unpacking Section 7. +!> - 17 Previous bitmap specified, but none exists. +!> +!> @note Note that derived type @ref grib_mod::gribfield contains +!> pointers to many arrays of data. The memory for these arrays is +!> allocated when the values in the arrays are set, to help minimize +!> problems with array overloading. Because of this users should free +!> this memory, when it is no longer needed, by a call to subroutine +!> gf_free(). Subroutine gb_info() can be used to first determine how +!> many data fields exist in a given GRIB message. +!> +!> It may not always be possible to expand a bit-mapped data +!> field. If a pre-defined bit-map is used and not included in the +!> GRIB2 message itself, this routine would not have the necessary +!> information to expand the data. In this case, gfld\%expanded would +!> be set to 0 (false), regardless of the value of input argument +!> expand. +!> +!> @author Stephen Gilbert @date 2000-05-26 +subroutine gf_getfld(cgrib, lcgrib, ifldnum, unpack, expand, gfld, ierr) + + use grib_mod + implicit none + + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib, ifldnum + logical, intent(in) :: unpack, expand + type(gribfield), intent(out) :: gfld + integer, intent(out) :: ierr + + character(len = 4), parameter :: grib = 'GRIB', c7777 = '7777' + character(len = 4) :: ctemp + real, pointer, dimension(:) :: newfld + integer:: listsec0(2), igds(5) + integer iofst, istart + logical*1, pointer, dimension(:) :: bmpsave + logical have3, have4, have5, have6, have7 + + !implicit none additions + integer :: numfld, j, lengrib, ipos, lensec0, lensec + integer :: isecnum, jerr, n, numlocal + + interface + subroutine gf_unpack1(cgrib, lcgrib, iofst, ids, idslen, ierr) + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib + integer, intent(inout) :: iofst + integer, pointer, dimension(:) :: ids + integer, intent(out) :: ierr, idslen + end subroutine gf_unpack1 + subroutine gf_unpack2(cgrib, lcgrib, iofst, lencsec2, csec2, ierr) + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib + integer, intent(inout) :: iofst + integer, intent(out) :: lencsec2 + integer, intent(out) :: ierr + character(len = 1), pointer, dimension(:) :: csec2 + end subroutine gf_unpack2 + subroutine gf_unpack3(cgrib, lcgrib, iofst, igds, igdstmpl, & + mapgridlen, ideflist, idefnum, ierr) + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib + integer, intent(inout) :: iofst + integer, pointer, dimension(:) :: igdstmpl, ideflist + integer, intent(out) :: igds(5) + integer, intent(out) :: mapgridlen + integer, intent(out) :: ierr, idefnum + end subroutine gf_unpack3 + subroutine gf_unpack4(cgrib, lcgrib, iofst, ipdsnum, ipdstmpl, & + mappdslen, coordlist, numcoord, ierr) + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib + integer, intent(inout) :: iofst + real, pointer, dimension(:) :: coordlist + integer, pointer, dimension(:) :: ipdstmpl + integer, intent(out) :: ipdsnum + integer, intent(out) :: mappdslen + integer, intent(out) :: ierr, numcoord + end subroutine gf_unpack4 + subroutine gf_unpack5(cgrib, lcgrib, iofst, ndpts, idrsnum, & + idrstmpl, mapdrslen, ierr) + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib + integer, intent(inout) :: iofst + integer, intent(out) :: ndpts, idrsnum + integer, pointer, dimension(:) :: idrstmpl + integer, intent(out) :: mapdrslen + integer, intent(out) :: ierr + end subroutine gf_unpack5 + subroutine gf_unpack6(cgrib, lcgrib, iofst, ngpts, ibmap, bmap, & + ierr) + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib, ngpts + integer, intent(inout) :: iofst + integer, intent(out) :: ibmap + integer, intent(out) :: ierr + logical*1, pointer, dimension(:) :: bmap + end subroutine gf_unpack6 + subroutine gf_unpack7(cgrib, lcgrib, iofst, igdsnum, igdstmpl, & + idrsnum, idrstmpl, ndpts, fld, ierr) + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib, ndpts, idrsnum, igdsnum + integer, intent(inout) :: iofst + integer, pointer, dimension(:) :: idrstmpl, igdstmpl + integer, intent(out) :: ierr + real, pointer, dimension(:) :: fld + end subroutine gf_unpack7 + end interface + + have3 = .false. + have4 = .false. + have5 = .false. + have6 = .false. + have7 = .false. + ierr = 0 + numfld = 0 + gfld%locallen = 0 + nullify(gfld%list_opt, gfld%igdtmpl, gfld%ipdtmpl) + nullify(gfld%coord_list, gfld%idrtmpl, gfld%bmap, gfld%fld) + + ! Check for valid request number + if (ifldnum .le. 0) then + print *, 'gf_getfld: Request for field number ' & + ,'must be positive.' + ierr = 3 + return + endif + + ! Check for beginning of GRIB message in the first 100 bytes + istart = 0 + do j = 1, 100 + ctemp = cgrib(j) // cgrib(j + 1) // cgrib(j + 2) // cgrib(j + 3) + if (ctemp .eq. grib) then + istart = j + exit + endif + enddo + if (istart .eq. 0) then + print *, 'gf_getfld: Beginning characters GRIB not found.' + ierr = 1 + return + endif + + ! Unpack Section 0 - Indicator Section + iofst = 8 * (istart + 5) + call g2_gbytec(cgrib, listsec0(1), iofst, 8) ! Discipline + iofst = iofst + 8 + call g2_gbytec(cgrib, listsec0(2), iofst, 8) ! GRIB edition number + iofst = iofst + 8 + iofst = iofst + 32 + call g2_gbytec(cgrib, lengrib, iofst, 32) ! Length of GRIB message + iofst = iofst + 32 + lensec0 = 16 + ipos = istart + lensec0 + + ! Currently handles only GRIB Edition 2. + if (listsec0(2) .ne. 2) then + print *, 'gf_getfld: can only decode GRIB edition 2.' + ierr = 2 + return + endif + + ! Loop through the remaining sections keeping track of the length of + ! each. Also keep the latest Grid Definition Section info. Unpack + ! the requested field number. + do + ! Check to see if we are at end of GRIB message + ctemp = cgrib(ipos) // cgrib(ipos + 1) // cgrib(ipos + 2) // & + cgrib(ipos + 3) + if (ctemp .eq. c7777) then + ipos = ipos + 4 + ! If end of GRIB message not where expected, issue error + if (ipos.ne.(istart + lengrib)) then + print *, 'gf_getfld: "7777" found, but not ' & + ,'where expected.' + ierr = 4 + return + endif + exit + endif + + ! Get length of Section and Section number + iofst = (ipos - 1) * 8 + call g2_gbytec(cgrib, lensec, iofst, 32) ! Get Length of Section + iofst = iofst + 32 + call g2_gbytec(cgrib, isecnum, iofst, 8) ! Get Section number + iofst = iofst + 8 + + ! Check to see if section number is valid + if ((isecnum .lt. 1) .or. (isecnum .gt. 7)) then + print *, 'gf_getfld: Unrecognized Section Encountered = ', & + isecnum + ierr = 8 + return + endif + + ! If found Section 1, decode elements in Identification Section. + if (isecnum .eq. 1) then + iofst = iofst - 40 ! reset offset to beginning of section + call gf_unpack1(cgrib, lcgrib, iofst, gfld%idsect, & + gfld%idsectlen, jerr) + if (jerr .ne. 0) then + ierr = 15 + return + endif + endif + + ! If found Section 2, Grab local section. Save in case this is + ! the latest one before the requested field. + if (isecnum .eq. 2) then + iofst = iofst - 40 ! reset offset to beginning of section + if (associated(gfld%local)) deallocate(gfld%local) + call gf_unpack2(cgrib, lcgrib, iofst, gfld%locallen, & + gfld%local, jerr) + if (jerr .ne. 0) then + call gf_free(gfld) + ierr = 16 + return + endif + endif + + ! If found Section 3, unpack the GDS info using the appropriate + ! template. Save in case this is the latest grid before the + ! requested field. + if (isecnum .eq. 3) then + iofst = iofst - 40 ! reset offset to beginning of section + if (associated(gfld%igdtmpl)) deallocate(gfld%igdtmpl) + if (associated(gfld%list_opt)) deallocate(gfld%list_opt) + call gf_unpack3(cgrib, lcgrib, iofst, igds, gfld%igdtmpl, & + gfld%igdtlen, gfld%list_opt, gfld%num_opt, jerr) + if (jerr .ne. 0) then + call gf_free(gfld) + ierr = 10 + return + endif + have3 = .true. + gfld%griddef = igds(1) + gfld%ngrdpts = igds(2) + gfld%numoct_opt = igds(3) + gfld%interp_opt = igds(4) + gfld%igdtnum = igds(5) + endif + + ! If found Section 4, check to see if this field is the one + ! requested. + if (isecnum .eq. 4) then + numfld = numfld + 1 + if (numfld .eq. ifldnum) then + gfld%discipline = listsec0(1) + gfld%version = listsec0(2) + gfld%ifldnum = ifldnum + gfld%unpacked = unpack + gfld%expanded = .false. + iofst = iofst-40 ! reset offset to beginning of section + call gf_unpack4(cgrib, lcgrib, iofst, gfld%ipdtnum, & + gfld%ipdtmpl, gfld%ipdtlen, gfld%coord_list, & + gfld%num_coord, jerr) + if (jerr .ne. 0) then + call gf_free(gfld) + ierr = 11 + return + endif + have4 = .true. + endif + endif + + ! If found Section 5, check to see if this field is the one + ! requested. + if ((isecnum .eq. 5).and.(numfld .eq. ifldnum)) then + iofst = iofst-40 ! reset offset to beginning of section + call gf_unpack5(cgrib, lcgrib, iofst, gfld%ndpts, & + gfld%idrtnum, gfld%idrtmpl, gfld%idrtlen, jerr) + if (jerr .ne. 0) then + call gf_free(gfld) + ierr = 12 + return + endif + have5 = .true. + endif + + ! If found Section 6, Unpack bitmap. Save in case this is the + ! latest bitmap before the requested field. + if (isecnum .eq. 6) then + if (unpack) then ! unpack bitmap + iofst = iofst - 40 ! reset offset to beginning of section + bmpsave => gfld%bmap ! save pointer to previous bitmap + call gf_unpack6(cgrib, lcgrib, iofst, gfld%ngrdpts, & + gfld%ibmap, gfld%bmap, jerr) + if (jerr .ne. 0) then + call gf_free(gfld) + ierr = 13 + return + endif + have6 = .true. + if (gfld%ibmap .eq. 254) then ! use previously specified bitmap + if (associated(bmpsave)) then + gfld%bmap => bmpsave + else + print *, 'gf_getfld: Previous bit-map ' & + ,'specified, but none exists, ' + call gf_free(gfld) + ierr = 17 + return + endif + else ! get rid of it + if (associated(bmpsave)) deallocate(bmpsave) + endif + else ! do not unpack bitmap + call g2_gbytec(cgrib, gfld%ibmap, iofst, 8) ! Get BitMap Indicator + have6 = .true. + endif + endif + + ! If found Section 7, check to see if this field is the one + ! requested. + if ((isecnum .eq. 7) .and. (numfld .eq. ifldnum) .and. unpack) & + then + iofst = iofst - 40 ! reset offset to beginning of section + call gf_unpack7(cgrib, lcgrib, iofst, gfld%igdtnum, & + gfld%igdtmpl, gfld%idrtnum, & + gfld%idrtmpl, gfld%ndpts, & + gfld%fld, jerr) + if (jerr .ne. 0) then + call gf_free(gfld) + print *, 'gf_getfld: return from gf_unpack7 = ', jerr + ierr = 14 + return + endif + have7 = .true. + + ! If bitmap is used with this field, expand data field + ! to grid, if possible. + if (gfld%ibmap .ne. 255 .AND. associated(gfld%bmap)) then + if (expand) then + allocate(newfld(gfld%ngrdpts)) + n = 1 + do j = 1, gfld%ngrdpts + if (gfld%bmap(j)) then + newfld(j) = gfld%fld(n) + n = n + 1 + else + newfld(j) = 0.0 + endif + enddo + deallocate(gfld%fld); + gfld%fld=>newfld; + gfld%expanded = .true. + else + gfld%expanded = .false. + endif + else + gfld%expanded = .true. + endif + endif + + ! Check to see if we read pass the end of the GRIB message and + ! missed the terminator string '7777'. + ipos = ipos + lensec ! Update beginning of section pointer + if (ipos .gt. (istart + lengrib)) then + print *, 'gf_getfld: "7777" not found at end ' & + ,'of GRIB message.' + call gf_free(gfld) + ierr = 7 + return + endif + ! + ! If unpacking requested, return when all sections have been + ! processed. + if (unpack .and. have3 .and. have4 .and. have5 .and. have6 & + .and. have7) return + + ! If unpacking is not requested, return when sections 3 through + ! 6 have been processed. + if ((.not. unpack) .and. have3 .and. have4 .and. have5 .and. & + have6) return + enddo + + ! If exited from above loop, the end of the GRIB message was reached + ! before the requested field was found. + print *, 'gf_getfld: GRIB message contained ', numlocal, & + ' different fields.' + print *, 'gf_getfld: The request was for the ', ifldnum, & + ' field.' + ierr = 6 + call gf_free(gfld) +end subroutine gf_getfld diff --git a/src/gf_getfld.f b/src/gf_getfld.f deleted file mode 100644 index e5c53e4e..00000000 --- a/src/gf_getfld.f +++ /dev/null @@ -1,570 +0,0 @@ -!> @file -!> @brief Contains subroutines returns the Grid Definition, -!> and Product Definition for a given data field. -!> @author Stephen Gilbert @date 2000-05-26 -!> - -!> This subroutine returns the Grid Definition, Product Definition, -!> Bit-map (if applicable), and the unpacked data for a given data -!> field. All of the information returned is stored in a derived -!> type variable, gfld. Gfld is of type gribfield, which is defined -!> in module grib_mod, so users of this routine will need to include -!> the line "USE GRIB_MOD" in their calling routine. Each component of the -!> gribfield type is described in the OUTPUT ARGUMENT LIST section below. -!> Since there can be multiple data fields packed into a GRIB2 -!> message, the calling routine indicates which field is being requested -!> with the ifldnum argument. -!> -!> PROGRAM HISTORY LOG: -!> - 2000-05-26 Stephen Gilbert -!> - 2002-01-24 Stephen Gilbert Changed to pass back derived type gribfield -!> variable through argument list, instead of having many different arguments. -!> - 2004-05-20 Stephen Gilbert Added check to see if previous a bit-map is -!> specified, but none was found. -!> - 2015-10-29 Boi Vuong Initial all pointers in derive type gribfield. -!> -!> @param[in] cgrib Character array that contains the GRIB2 message. -!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. -!> @param[in] ifldnum Specifies which field in the GRIB2 message to return. -!> @param[in] unpack Logical value indicating whether to unpack -!> bitmap/data. .true. = unpack bitmap and data values; .false. = do -!> not unpack bitmap and data values. -!> @param[in] expand Boolean value indicating whether the data points -!> should be expanded to the correspond grid, if a bit-map is present. -!> - 1 = if possible, expand data field to grid, inserting zero values -!> at gridpoints that are bitmapped out. -!> - 0 do not expand data field, leaving it an array of consecutive -!> data points for each "1" in the bitmap. This argument is ignored -!> if unpack == 0 OR if the returned field does not contain a bit-map. -!> @param[out] gfld derived type gribfield (defined in module grib_mod) -!> (NOTE: See Remarks Section) -!> - gfld\%version GRIB edition number (currently 2) -!> - gfld\%discipline Message Discipline (see Code Table 0.0) -!> - gfld\%idsect Contains the entries in the Identification Section -!> (Section 1) This element is actually a pointer to an array -!> that holds the data. -!> - gfld\%idsect(1) Identification of originating Centre -!> (see Common Code Table C-1) 7 US National Weather Service -!> - gfld\%idsect(2) Identification of originating Sub-centre -!> - gfld\%idsect(3) GRIB Master Tables Version Number -!> (see Code Table 1.0) 0 Experimental; 1 Initial operational version number -!> - gfld\%idsect(4) GRIB Local Tables Version Number (see Code Table 1.1) -!> - 0 Local tables not used -!> - 0 1-254 Number of local tables version used -!> - gfld\%idsect(5) Significance of Reference Time (Code Table 1.2) -!> - 0 Analysis -!> - 1 Start of forecast -!> - 2 Verifying time of forecast -!> - 3 Observation time. -!> - gfld\%idsect(6) Year (4 digits) -!> - gfld\%idsect(7) Month -!> - gfld\%idsect(8) Day -!> - gfld\%idsect(9) Hour -!> - gfld\%idsect(10) Minute -!> - gfld\%idsect(11) Second -!> - gfld\%idsect(12) Production status of processed data (see Code -!> Table 1.3) -!> - 0 Operational products -!> - 1 Operational test products -!> - 2 Research products -!> - 3 Re-analysis products -!> - gfld\%idsect(13) Type of processed data (see Code Table 1.4) -!> - 0 Analysis products -!> - 1 Forecast products -!> - 2 Analysis and forecast products -!> - 3 Control forecast products -!> - 4 Perturbed forecast products -!> - 5 Control and perturbed forecast products -!> - 6 Processed satellite observations -!> - 7 Processed radar observations -!> - gfld\%idsectlen Number of elements in gfld\%idsect -!> - gfld\%local Pointer to character array containing contents -!> of Local Section 2, if included -!> - gfld\%locallen length of array gfld\%local -!> - gfld\%ifldnum field number within GRIB message -!> - gfld\%griddef Source of grid definition (see Code Table 3.0) -!> - 0 Specified in Code table 3.1 -!> - 1 Predetermined grid Defined by originating centre -!> - gfld\%ngrdpts Number of grid points in the defined grid. -!> Note that the number of actual data values returned from getgb2 -!> (in gfld\%ndpts) may be less than this value if a logical bitmap -!> is in use with grid points that are being masked out. -!> - gfld\%numoct_opt Number of octets needed for each additional grid -!> points definition. Used to define number of points in each row (or -!> column) for non-regular grids. = 0, if using regular grid. -!> - gfld\%interp_opt Interpretation of list for optional points -!> definition.(Code Table 3.11) -!> - gfld\%igdtnum Grid Definition Template Number (Code Table 3.1) -!> - gfld\%igdtmpl Contains the data values for the specified Grid -!> Definition Template (NN=gfld\%igdtnum). Each element of this -!> integer array contains an entry (in the order specified) of Grid -!> Defintion Template 3.NN This element is actually a pointer to an -!> array that holds the data. -!> - gfld\%igdtlen Number of elements in gfld\%igdtmpl. i.e. number -!> of entries in Grid Defintion Template 3.NN (NN=gfld\%igdtnum). -!> - gfld\%list_opt (Used if gfld\%numoct_opt .ne. 0) This array -!> contains the number of grid points contained in each row (or -!> column). (part of Section 3) This element is actually a pointer -!> to an array that holds the data. This pointer is nullified -!> if gfld\%numoct_opt=0. -!> - gfld\%num_opt (Used if gfld\%numoct_opt .ne. 0) The number of -!> entries in array ideflist. i.e. number of rows (or columns) for which -!> optional grid points are defined. This value is set to zero, -!> if gfld\%numoct_opt=0. -!> - gfdl\%ipdtnum Product Definition Template Number (Code Table 4.0) -!> - gfld\%ipdtmpl Contains the data values for the specified Product -!> Definition Template (N=gfdl\%ipdtnum). Each element of this integer -!> array contains an entry (in the order specified) of Product Defintion -!> Template 4.N. This element is actually a pointer to an array -!> that holds the data. -!> - gfld\%ipdtlen Number of elements in gfld\%ipdtmpl. i.e.number of -!> entries in Product Defintion Template 4.N (N=gfdl\%ipdtnum). -!> - gfld\%coord_list Real array containing floating point values -!> intended to document the vertical discretisation associated to -!> model data on hybrid coordinate vertical levels.(part of Section 4) -!> This element is actually a pointer to an array -!> that holds the data. -!> - gfld\%num_coord number of values in array gfld\%coord_list. -!> - gfld\%ndpts Number of data points unpacked and returned. -!> Note that this number may be different from the value of -!> - gfld\%ngrdpts if a logical bitmap is in use with grid points -!> that are being masked out. -!> - gfld\%idrtnum Data Representation Template Number (Code Table 5.0) -!> - gfld\%idrtmpl Contains the data values for the specified Data -!> Representation Template (N=gfld\%idrtnum). Each element of this -!> integer array contains an entry (in the order specified) of -!> Product Defintion Template 5.N. This element is actually a -!> pointer to an array that holds the data. -!> - gfld\%idrtlen Number of elements in gfld\%idrtmpl. i.e. number -!> of entries in Data Representation Template 5.N (N=gfld\%idrtnum). -!> - gfld\%unpacked logical value indicating whether the bitmap and -!> data values were unpacked. If false, gfld\%bmap and gfld\%fld -!> pointers are nullified. -!> - gfld\%expanded Logical value indicating whether the data field -!> was expanded to the grid in the case where a bit-map is present. -!> If true, the data points in gfld\%fld match the grid points and -!> zeros were inserted at grid points where data was bit-mapped out. -!> If false, the data values in gfld\%fld were not expanded to the -!> grid and are just a consecutive array of data points corresponding -!> to each value of "1" in gfld\%bmap. -!> - gfld\%ibmap Bitmap indicator (see Code Table 6.0) -!> - 0 bitmap applies and is included in Section 6. -!> - 1-253 Predefined bitmap applies -!> - 254 Previously defined bitmap applies to this field -!> - 255 Bit map does not apply to this product. -!> - gfld\%bmap Logical*1 array containing decoded bitmap, if ibmap=0 -!> or ibap=254. Otherwise nullified. This element is actually a -!> pointer to an array that holds the data. -!> - gfld\%fld Array of gfld\%ndpts unpacked data points. This element -!> is actually a pointer to an array that holds the data. -!> @param[out] ierr Error return code. -!> - 0 no error. -!> - 1 Beginning characters "GRIB" not found. -!> - 2 GRIB message is not Edition 2. -!> - 3 The data field request number was not positive. -!> - 4 End string "7777" found, but not where expected. -!> - 5 End string "7777" not found at end of message. -!> - 6 GRIB message did not contain the requested number of data fields. -!> - 7 End string "7777" not found at end of message. -!> - 9 Data Representation Template 5.NN not yet implemented. -!> - 10 Error unpacking Section 3. -!> - 11 Error unpacking Section 4. -!> - 12 Error unpacking Section 5. -!> - 13 Error unpacking Section 6. -!> - 14 Error unpacking Section 7. -!> - 17 Previous bitmap specified, but none exists. -!> -!> @note Note that derived type gribfield contains pointers to many -!> arrays of data. The memory for these arrays is allocated when the -!> values in the arrays are set, to help minimize problems with array -!> overloading. Because of this users are encouraged to free up this memory, -!> when it is no longer needed, by an explicit call to subroutine gf_free. -!> Subroutine gb_info can be used to first determine how many data fields -!> exist in a given GRIB message.It may not always be possible to expand -!> a bit-mapped data field. If a pre-defined bit-map is used and not -!> included in the GRIB2 message itself, this routine would not have the -!> necessary information to expand the data. In this case, gfld\%expanded -!> would be set to 0 (false), regardless of the value of input argument expand. -!> -!> @author Stephen Gilbert @date 2000-05-26 -!> - - subroutine gf_getfld(cgrib,lcgrib,ifldnum,unpack,expand,gfld,ierr) - - use grib_mod - - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib,ifldnum - logical,intent(in) :: unpack,expand - type(gribfield),intent(out) :: gfld - integer,intent(out) :: ierr -! integer,intent(out) :: igds(*),igdstmpl(*),ideflist(*) -! integer,intent(out) :: ipdsnum,ipdstmpl(*) -! integer,intent(out) :: idrsnum,idrstmpl(*) -! integer,intent(out) :: ndpts,ibmap,idefnum,numcoord -! logical*1,intent(out) :: bmap(*) -! real,intent(out) :: fld(*),coordlist(*) - - character(len=4),parameter :: grib='GRIB',c7777='7777' - character(len=4) :: ctemp - real,pointer,dimension(:) :: newfld - integer:: listsec0(2),igds(5) - integer iofst,ibeg,istart - integer(4) :: ieee - logical*1,pointer,dimension(:) :: bmpsave - logical have3,have4,have5,have6,have7 - - interface - subroutine gf_unpack1(cgrib,lcgrib,iofst,ids,idslen,ierr) - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib - integer,intent(inout) :: iofst - integer,pointer,dimension(:) :: ids - integer,intent(out) :: ierr,idslen - end subroutine gf_unpack1 - subroutine gf_unpack2(cgrib,lcgrib,iofst,lencsec2,csec2,ierr) - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib - integer,intent(inout) :: iofst - integer,intent(out) :: lencsec2 - integer,intent(out) :: ierr - character(len=1),pointer,dimension(:) :: csec2 - end subroutine gf_unpack2 - subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl, - & mapgridlen,ideflist,idefnum,ierr) - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib - integer,intent(inout) :: iofst - integer,pointer,dimension(:) :: igdstmpl,ideflist - integer,intent(out) :: igds(5) - integer,intent(out) :: ierr,idefnum - end subroutine gf_unpack3 - subroutine gf_unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl, - & mappdslen,coordlist,numcoord,ierr) - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib - integer,intent(inout) :: iofst - real,pointer,dimension(:) :: coordlist - integer,pointer,dimension(:) :: ipdstmpl - integer,intent(out) :: ipdsnum - integer,intent(out) :: ierr,numcoord - end subroutine gf_unpack4 - subroutine gf_unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum, - & idrstmpl,mapdrslen,ierr) - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib - integer,intent(inout) :: iofst - integer,intent(out) :: ndpts,idrsnum - integer,pointer,dimension(:) :: idrstmpl - integer,intent(out) :: ierr - end subroutine gf_unpack5 - subroutine gf_unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,bmap,ierr) - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib,ngpts - integer,intent(inout) :: iofst - integer,intent(out) :: ibmap - integer,intent(out) :: ierr - logical*1,pointer,dimension(:) :: bmap - end subroutine gf_unpack6 - subroutine gf_unpack7(cgrib,lcgrib,iofst,igdsnum,igdstmpl, - & idrsnum,idrstmpl,ndpts,fld,ierr) - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib,ndpts,idrsnum,igdsnum - integer,intent(inout) :: iofst - integer,pointer,dimension(:) :: idrstmpl,igdstmpl - integer,intent(out) :: ierr - real,pointer,dimension(:) :: fld - end subroutine gf_unpack7 - end interface - - have3=.false. - have4=.false. - have5=.false. - have6=.false. - have7=.false. - ierr=0 - numfld=0 - gfld%locallen=0 - nullify(gfld%list_opt,gfld%igdtmpl,gfld%ipdtmpl) - nullify(gfld%coord_list,gfld%idrtmpl,gfld%bmap,gfld%fld) -! -! Check for valid request number -! - if (ifldnum.le.0) then - print *,'gf_getfld: Request for field number must be positive.' - ierr=3 - return - endif -! -! Check for beginning of GRIB message in the first 100 bytes -! - istart=0 - do j=1,100 - ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3) - if (ctemp.eq.grib ) then - istart=j - exit - endif - enddo - if (istart.eq.0) then - print *,'gf_getfld: Beginning characters GRIB not found.' - ierr=1 - return - endif -! -! Unpack Section 0 - Indicator Section -! - iofst=8*(istart+5) - call g2_gbytec(cgrib,listsec0(1),iofst,8) ! Discipline - iofst=iofst+8 - call g2_gbytec(cgrib,listsec0(2),iofst,8) ! GRIB edition number - iofst=iofst+8 - iofst=iofst+32 - call g2_gbytec(cgrib,lengrib,iofst,32) ! Length of GRIB message - iofst=iofst+32 - lensec0=16 - ipos=istart+lensec0 -! -! Currently handles only GRIB Edition 2. -! - if (listsec0(2).ne.2) then - print *,'gf_getfld: can only decode GRIB edition 2.' - ierr=2 - return - endif -! -! Loop through the remaining sections keeping track of the -! length of each. Also keep the latest Grid Definition Section info. -! Unpack the requested field number. -! - do - ! Check to see if we are at end of GRIB message - ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3) - if (ctemp.eq.c7777 ) then - ipos=ipos+4 - ! If end of GRIB message not where expected, issue error - if (ipos.ne.(istart+lengrib)) then - print *,'gf_getfld: "7777" found, but not where expected.' - ierr=4 - return - endif - exit - endif - ! Get length of Section and Section number - iofst=(ipos-1)*8 - call g2_gbytec(cgrib,lensec,iofst,32) ! Get Length of Section - iofst=iofst+32 - call g2_gbytec(cgrib,isecnum,iofst,8) ! Get Section number - iofst=iofst+8 - !print *,' lensec= ',lensec,' secnum= ',isecnum - ! - ! Check to see if section number is valid - ! - if ( (isecnum.lt.1).OR.(isecnum.gt.7) ) then - print *,'gf_getfld: Unrecognized Section Encountered=',isecnum - ierr=8 - return - endif - ! - ! If found Section 1, decode elements in Identification Section - ! - if (isecnum.eq.1) then - iofst=iofst-40 ! reset offset to beginning of section - call gf_unpack1(cgrib,lcgrib,iofst,gfld%idsect, - & gfld%idsectlen,jerr) - if (jerr.ne.0) then - ierr=15 - return - endif - endif - ! - ! If found Section 2, Grab local section - ! Save in case this is the latest one before the requested field. - ! - if (isecnum.eq.2) then - iofst=iofst-40 ! reset offset to beginning of section - if (associated(gfld%local)) deallocate(gfld%local) - call gf_unpack2(cgrib,lcgrib,iofst,gfld%locallen, - & gfld%local,jerr) - if (jerr.ne.0) then - ierr=16 - return - endif - endif - ! - ! If found Section 3, unpack the GDS info using the - ! appropriate template. Save in case this is the latest - ! grid before the requested field. - ! - if (isecnum.eq.3) then - iofst=iofst-40 ! reset offset to beginning of section - if (associated(gfld%igdtmpl)) deallocate(gfld%igdtmpl) - if (associated(gfld%list_opt)) deallocate(gfld%list_opt) - call gf_unpack3(cgrib,lcgrib,iofst,igds,gfld%igdtmpl, - & gfld%igdtlen,gfld%list_opt,gfld%num_opt,jerr) - if (jerr.eq.0) then - have3=.true. - gfld%griddef=igds(1) - gfld%ngrdpts=igds(2) - gfld%numoct_opt=igds(3) - gfld%interp_opt=igds(4) - gfld%igdtnum=igds(5) - else - ierr=10 - return - endif - endif - ! - ! If found Section 4, check to see if this field is the - ! one requested. - ! - if (isecnum.eq.4) then - numfld=numfld+1 - if (numfld.eq.ifldnum) then - gfld%discipline=listsec0(1) - gfld%version=listsec0(2) - gfld%ifldnum=ifldnum - gfld%unpacked=unpack - gfld%expanded=.false. - iofst=iofst-40 ! reset offset to beginning of section - call gf_unpack4(cgrib,lcgrib,iofst,gfld%ipdtnum, - & gfld%ipdtmpl,gfld%ipdtlen,gfld%coord_list, - & gfld%num_coord,jerr) - if (jerr.eq.0) then - have4=.true. - else - ierr=11 - return - endif - endif - endif - ! - ! If found Section 5, check to see if this field is the - ! one requested. - ! - if ((isecnum.eq.5).and.(numfld.eq.ifldnum)) then - iofst=iofst-40 ! reset offset to beginning of section - call gf_unpack5(cgrib,lcgrib,iofst,gfld%ndpts,gfld%idrtnum, - & gfld%idrtmpl,gfld%idrtlen,jerr) - if (jerr.eq.0) then - have5=.true. - else - ierr=12 - return - endif - endif - ! - ! If found Section 6, Unpack bitmap. - ! Save in case this is the latest - ! bitmap before the requested field. - ! - if (isecnum.eq.6) then - if (unpack) then ! unpack bitmap - iofst=iofst-40 ! reset offset to beginning of section - bmpsave=>gfld%bmap ! save pointer to previous bitmap - call gf_unpack6(cgrib,lcgrib,iofst,gfld%ngrdpts,gfld%ibmap, - & gfld%bmap,jerr) - if (jerr.eq.0) then - have6=.true. - if (gfld%ibmap .eq. 254) then ! use previously specified bitmap - if ( associated(bmpsave) ) then - gfld%bmap=>bmpsave - else - print *,'gf_getfld: Previous bit-map specified,', - & ' but none exists,' - ierr=17 - return - endif - else ! get rid of it - if ( associated(bmpsave) ) deallocate(bmpsave) - endif - else - ierr=13 - return - endif - else ! do not unpack bitmap - call g2_gbytec(cgrib,gfld%ibmap,iofst,8) ! Get BitMap Indicator - have6=.true. - endif - endif - ! - ! If found Section 7, check to see if this field is the - ! one requested. - ! - if ((isecnum.eq.7).and.(numfld.eq.ifldnum).and.unpack) then - iofst=iofst-40 ! reset offset to beginning of section - call gf_unpack7(cgrib,lcgrib,iofst,gfld%igdtnum, - & gfld%igdtmpl,gfld%idrtnum, - & gfld%idrtmpl,gfld%ndpts, - & gfld%fld,jerr) - if (jerr.eq.0) then - have7=.true. - ! If bitmap is used with this field, expand data field - ! to grid, if possible. - if ( gfld%ibmap .ne. 255 .AND. associated(gfld%bmap) ) then - if ( expand ) then - allocate(newfld(gfld%ngrdpts)) - !newfld(1:gfld%ngrdpts)=0.0 - !newfld=unpack(gfld%fld,gfld%bmap,newfld) - n=1 - do j=1,gfld%ngrdpts - if ( gfld%bmap(j) ) then - newfld(j)=gfld%fld(n) - n=n+1 - else - newfld(j)=0.0 - endif - enddo - deallocate(gfld%fld); - gfld%fld=>newfld; - gfld%expanded=.true. - else - gfld%expanded=.false. - endif - else - gfld%expanded=.true. - endif - else - print *,'gf_getfld: return from gf_unpack7 = ',jerr - ierr=14 - return - endif - endif - ! - ! Check to see if we read pass the end of the GRIB - ! message and missed the terminator string '7777'. - ! - ipos=ipos+lensec ! Update beginning of section pointer - if (ipos.gt.(istart+lengrib)) then - print *,'gf_getfld: "7777" not found at end of GRIB message.' - ierr=7 - return - endif - ! - ! If unpacking requested, return when all sections have been - ! processed - ! - if (unpack.and.have3.and.have4.and.have5.and.have6.and.have7) - & return - ! - ! If unpacking is not requested, return when sections - ! 3 through 6 have been processed - ! - if ((.NOT.unpack).and.have3.and.have4.and.have5.and.have6) - & return - - enddo - -! -! If exited from above loop, the end of the GRIB message was reached -! before the requested field was found. -! - print *,'gf_getfld: GRIB message contained ',numlocal, - & ' different fields.' - print *,'gf_getfld: The request was for the ',ifldnum, - & ' field.' - ierr=6 - - return - end - diff --git a/src/gf_unpack3.F90 b/src/gf_unpack3.F90 new file mode 100644 index 00000000..8dbefaae --- /dev/null +++ b/src/gf_unpack3.F90 @@ -0,0 +1,177 @@ +!> @file +!> @brief This subroutine unpacks Section 3 ([Grid Definition Section] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_sect3.shtml)) +!> of a GRIB2 message. +!> @author Stephen Gilbert @date 2000-05-26 + +!> This subroutine unpacks Section 3 ([Grid Definition Section] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_sect3.shtml)) +!> of a GRIB2 message, starting at octet 6 of that Section. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2000-05-26 | Stephen Gilbert | Initial development. +!> 2002-01-24 | Stephen Gilbert | Dynamically allocate arrays and pass pointers. +!> +!> @param[in] cgrib Character array that contains the GRIB2 message. +!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. +!> @param[inout] iofst Bit offset of the beginning/end(returned) of +!> Section 3. +!> @param[out] igds Contains information read from the appropriate +!> GRIB Grid Definition Section 3 for the field being returned. Must +!> be dimensioned >= 5. +!> - igds(1) Source of grid definition (see [Code Table 3.0] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-0.shtml)). +!> - igds(2) Number of grid points in the defined grid. +!> - igds(3) Number of octets needed for each additional grid points +!> definition. Used to define number of points in each row (or +!> column) for non-regular grids. = 0, if using regular grid. +!> - igds(4) Interpretation of list for optional points definition ([Code Table 3.11] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-11.shtml)). +!> - igds(5) Grid Definition Template Number ([Code Table 3.1] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-1.shtml)). +!> @param[out] igdstmpl Contains the data values for the specified +!> Grid Definition Template (NN=igds(5)). Each element of this +!> integer array contains an entry (in the order specified) of Grid +!> Defintion Template 3.NN. A safe dimension for this array can be +!> obtained in advance from maxvals(2), which is returned from +!> subroutine gribinfo(). +!> @param[out] mapgridlen Number of elements in igdstmpl. i.e. number +!> of entries in Grid Defintion Template 3.NN (NN=igds(5)). +!> @param[out] ideflist (Used if igds(3) .ne. 0) This array contains +!> the number of grid points contained in each row (or column). (part +!> of Section 3) A safe dimension for this array can be obtained in +!> advance from maxvals(3), which is returned from subroutine +!> gribinfo(). +!> @param[out] idefnum (Used if igds(3) .ne. 0) The number of entries +!> in array ideflist. i.e. number of rows (or columns) for which +!> optional grid points are defined. +!> @param[out] ierr Error return code. +!> - 0 no error. +!> - 5 "GRIB" message contains an undefined Grid Definition Template. +!> - 6 memory allocation error. +!> +!> @author Stephen Gilbert @date 2000-05-26 +subroutine gf_unpack3(cgrib, lcgrib, iofst, igds, igdstmpl, & + mapgridlen, ideflist, idefnum, ierr) + + use gridtemplates + use re_alloc ! needed for subroutine realloc + implicit none + + character(len = 1), intent(in) :: cgrib(lcgrib) + integer, intent(in) :: lcgrib + integer, intent(inout) :: iofst + integer, pointer, dimension(:) :: igdstmpl, ideflist + integer, intent(out) :: igds(5) + integer, intent(out) :: ierr, idefnum + + integer, allocatable :: mapgrid(:) + integer, intent(out) :: mapgridlen + integer :: ibyttem + logical needext + integer :: lensec, istat, i, nbits, isign, newmapgridlen, iret + + ierr = 0 + nullify(igdstmpl, ideflist) + + call g2_gbytec(cgrib, lensec, iofst, 32) ! Get Length of Section + iofst = iofst + 32 + iofst = iofst + 8 ! skip section number + + call g2_gbytec(cgrib, igds(1), iofst, 8) ! Get source of Grid def. + iofst = iofst + 8 + call g2_gbytec(cgrib, igds(2), iofst, 32) ! Get number of grid pts. + iofst = iofst + 32 + call g2_gbytec(cgrib, igds(3), iofst, 8) ! Get num octets for opt. list + iofst = iofst + 8 + call g2_gbytec(cgrib, igds(4), iofst, 8) ! Get interpret. for opt. list + iofst = iofst + 8 + call g2_gbytec(cgrib, igds(5), iofst, 16) ! Get Grid Def Template num. + iofst = iofst + 16 + + if (igds(1) .eq. 0 .OR. igds(1) .eq. 255) then ! FOR ECMWF TEST ONLY + allocate(mapgrid(lensec)) + + ! Get Grid Definition Template + call getgridtemplate(igds(5), mapgridlen, mapgrid, needext, iret) + if (iret .ne. 0) then + ierr = 5 + if (allocated(mapgrid)) deallocate(mapgrid) + return + endif + else + mapgridlen = 0 + needext = .false. + endif + + ! Unpack each value into array igdstmpl from the the appropriate + ! number of octets, which are specified in corresponding entries in + ! array mapgrid. + istat = 0 + if (mapgridlen .gt. 0) allocate(igdstmpl(mapgridlen), stat = istat) + if (istat .ne. 0) then + ierr = 6 + nullify(igdstmpl) + if (allocated(mapgrid)) deallocate(mapgrid) + return + endif + ibyttem = 0 + do i = 1, mapgridlen + nbits = iabs(mapgrid(i)) * 8 + if (mapgrid(i) .ge. 0) then + call g2_gbytec(cgrib, igdstmpl(i), iofst, nbits) + else + call g2_gbytec(cgrib, isign, iofst, 1) + call g2_gbytec(cgrib, igdstmpl(i), iofst + 1, nbits - 1) + if (isign .eq. 1) igdstmpl(i) = -igdstmpl(i) + endif + iofst = iofst + nbits + ibyttem = ibyttem + iabs(mapgrid(i)) + enddo + + ! Check to see if the Grid Definition Template needs to be extended. + ! The number of values in a specific template may vary depending on + ! data specified in the "static" part of the template. + if (needext) then + call extgridtemplate(igds(5), igdstmpl, newmapgridlen, & + mapgrid) + + ! Unpack the rest of the Grid Definition Template. + call realloc(igdstmpl, mapgridlen, newmapgridlen, istat) + do i = mapgridlen + 1, newmapgridlen + nbits = iabs(mapgrid(i)) * 8 + if (mapgrid(i) .ge. 0) then + call g2_gbytec(cgrib, igdstmpl(i), iofst, nbits) + else + call g2_gbytec(cgrib, isign, iofst, 1) + call g2_gbytec(cgrib, igdstmpl(i), iofst + 1, nbits - 1) + if (isign.eq.1) igdstmpl(i) = -igdstmpl(i) + endif + iofst = iofst + nbits + ibyttem = ibyttem + iabs(mapgrid(i)) + enddo + mapgridlen = newmapgridlen + endif + if (allocated(mapgrid)) deallocate(mapgrid) + + ! Unpack optional list of numbers defining number of points in each + ! row or column, if included. This is used for non regular grids. + if (igds(3) .ne. 0) then + nbits = igds(3) * 8 + idefnum = (lensec - 14 - ibyttem) / igds(3) + istat = 0 + if (idefnum .gt. 0) allocate(ideflist(idefnum), stat = istat) + if (istat .ne. 0) then + ierr = 6 + nullify(ideflist) + return + endif + call g2_gbytesc(cgrib, ideflist, iofst, nbits, 0, idefnum) + iofst = iofst + (nbits * idefnum) + else + idefnum = 0 + nullify(ideflist) + endif +end subroutine gf_unpack3 diff --git a/src/gf_unpack3.f b/src/gf_unpack3.f deleted file mode 100644 index 1e226c2d..00000000 --- a/src/gf_unpack3.f +++ /dev/null @@ -1,177 +0,0 @@ -!> @file -!> @brief This subroutine unpacks Section 3 (Grid Definition -!> Section). -!> @author Stephen Gilbert @date 2000-05-26 -!> - -!> This subroutine unpacks Section 3 (Grid Definition Section) -!> starting at octet 6 of that Section. -!> -!> PROGRAM HISTORY LOG: -!> - 2000-05-26 Stephen Gilbert Initial development. -!> - 2002-01-24 Stephen Gilbert Changed to dynamically allocate -!> arrays and to pass pointers to those arrays through the argument -!> list. -!> -!> @param[in] cgrib Character array that contains the GRIB2 message. -!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. -!> @param[inout] iofst Bit offset of the beginning/end(returned) of Section 3. -!> @param[out] igds Contains information read from the appropriate GRIB Grid -!> Definition Section 3 for the field being returned. -!> Must be dimensioned >= 5. -!> - igds(1) Source of grid definition (see Code Table 3.0). -!> - igds(2) Number of grid points in the defined grid. -!> - igds(3) Number of octets needed for each additional grid points definition. -!> Used to define number of points in each row (or column) for -!> non-regular grids. = 0, if using regular grid. -!> - igds(4) Interpretation of list for optional points definition (Code Table 3.11). -!> - igds(5) Grid Definition Template Number (Code Table 3.1). -!> @param[out] igdstmpl Contains the data values for the specified Grid Definition -!> Template (NN=igds(5)). Each element of this integer array contains an entry (in -!> the order specified) of Grid Defintion Template 3.NN. A safe dimension for this -!> array can be obtained in advance from maxvals(2), which is returned -!> from subroutine gribinfo. -!> @param[out] mapgridlen Number of elements in igdstmpl. i.e. number of entries -!> in Grid Defintion Template 3.NN (NN=igds(5)). -!> @param[out] ideflist (Used if igds(3) .ne. 0) This array contains the number -!> of grid points contained in each row (or column). (part of Section 3) -!> A safe dimension for this array can be obtained in advance -!> from maxvals(3), which is returned from subroutine gribinfo. -!> @param[out] idefnum (Used if igds(3) .ne. 0) The number of entries in array ideflist. -!> i.e. number of rows (or columns) for which optional grid points are defined. -!> @param[out] ierr Error return code. -!> - 0 no error. -!> - 5 "GRIB" message contains an undefined Grid Definition Template. -!> - 6 memory allocation error. -!> -!> @note Uses Fortran 90 module gridtemplates and module re_alloc. -!> -!> @author Stephen Gilbert @date 2000-05-26 -!> - - subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl, - & mapgridlen,ideflist,idefnum,ierr) - - use gridtemplates - use re_alloc ! needed for subroutine realloc - - character(len=1),intent(in) :: cgrib(lcgrib) - integer,intent(in) :: lcgrib - integer,intent(inout) :: iofst - integer,pointer,dimension(:) :: igdstmpl,ideflist - integer,intent(out) :: igds(5) - integer,intent(out) :: ierr,idefnum - - integer,allocatable :: mapgrid(:) - integer :: mapgridlen,ibyttem - logical needext - - ierr=0 - nullify(igdstmpl,ideflist) - - call g2_gbytec(cgrib,lensec,iofst,32) ! Get Length of Section - iofst=iofst+32 - iofst=iofst+8 ! skip section number - - call g2_gbytec(cgrib,igds(1),iofst,8) ! Get source of Grid def. - iofst=iofst+8 - call g2_gbytec(cgrib,igds(2),iofst,32) ! Get number of grid pts. - iofst=iofst+32 - call g2_gbytec(cgrib,igds(3),iofst,8) ! Get num octets for opt. list - iofst=iofst+8 - call g2_gbytec(cgrib,igds(4),iofst,8) ! Get interpret. for opt. list - iofst=iofst+8 - call g2_gbytec(cgrib,igds(5),iofst,16) ! Get Grid Def Template num. - iofst=iofst+16 -! if (igds(1).eq.0) then - if (igds(1).eq.0.OR.igds(1).eq.255) then ! FOR ECMWF TEST ONLY - allocate(mapgrid(lensec)) - ! Get Grid Definition Template - call getgridtemplate(igds(5),mapgridlen,mapgrid,needext, - & iret) - if (iret.ne.0) then - ierr=5 - if( allocated(mapgrid) ) deallocate(mapgrid) - return - endif - else -! igdstmpl=-1 - mapgridlen=0 - needext=.false. - endif - ! - ! Unpack each value into array igdstmpl from the - ! the appropriate number of octets, which are specified in - ! corresponding entries in array mapgrid. - ! - istat=0 - if (mapgridlen.gt.0) allocate(igdstmpl(mapgridlen),stat=istat) - if (istat.ne.0) then - ierr=6 - nullify(igdstmpl) - if( allocated(mapgrid) ) deallocate(mapgrid) - return - endif - ibyttem=0 - do i=1,mapgridlen - nbits=iabs(mapgrid(i))*8 - if ( mapgrid(i).ge.0 ) then - call g2_gbytec(cgrib,igdstmpl(i),iofst,nbits) - else - call g2_gbytec(cgrib,isign,iofst,1) - call g2_gbytec(cgrib,igdstmpl(i),iofst+1,nbits-1) - if (isign.eq.1) igdstmpl(i)=-igdstmpl(i) - endif - iofst=iofst+nbits - ibyttem=ibyttem+iabs(mapgrid(i)) - enddo - ! - ! Check to see if the Grid Definition Template needs to be - ! extended. - ! The number of values in a specific template may vary - ! depending on data specified in the "static" part of the - ! template. - ! - if ( needext ) then - call extgridtemplate(igds(5),igdstmpl,newmapgridlen,mapgrid) - ! Unpack the rest of the Grid Definition Template - call realloc(igdstmpl,mapgridlen,newmapgridlen,istat) - do i=mapgridlen+1,newmapgridlen - nbits=iabs(mapgrid(i))*8 - if ( mapgrid(i).ge.0 ) then - call g2_gbytec(cgrib,igdstmpl(i),iofst,nbits) - else - call g2_gbytec(cgrib,isign,iofst,1) - call g2_gbytec(cgrib,igdstmpl(i),iofst+1,nbits-1) - if (isign.eq.1) igdstmpl(i)=-igdstmpl(i) - endif - iofst=iofst+nbits - ibyttem=ibyttem+iabs(mapgrid(i)) - enddo - mapgridlen=newmapgridlen - endif - if( allocated(mapgrid) ) deallocate(mapgrid) - ! - ! Unpack optional list of numbers defining number of points - ! in each row or column, if included. This is used for non regular - ! grids. - ! - if ( igds(3).ne.0 ) then - nbits=igds(3)*8 - idefnum=(lensec-14-ibyttem)/igds(3) - istat=0 - if (idefnum.gt.0) allocate(ideflist(idefnum),stat=istat) - if (istat.ne.0) then - ierr=6 - nullify(ideflist) - return - endif - call g2_gbytesc(cgrib,ideflist,iofst,nbits,0,idefnum) - iofst=iofst+(nbits*idefnum) - else - idefnum=0 - nullify(ideflist) - endif - - return ! End of Section 3 processing - end diff --git a/src/gf_unpack7.f b/src/gf_unpack7.f index fb246d51..2086cf1b 100644 --- a/src/gf_unpack7.f +++ b/src/gf_unpack7.f @@ -1,44 +1,49 @@ -!> @file -!> @brief Contains subroutines unpacks Section 7 (Data Section). -!> @author Stephen Gilbert @date 2002-01-24 -!> +!> @file +!> @brief Contains subroutines unpacks Section 7 ([Data Section] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_sect7.shtml)) +!> of a GRIB2 message. +!> @author Stephen Gilbert @date 2002-01-24 -!> This subroutine unpacks Section 7 (Data Section). -!> -!> PROGRAM HISTORY LOG: -!> - 2000-05-26 Stephen Gilbert Initial development. -!> - 2002-12-17 Stephen Gilbert Added support for new templates using. -!> PNG and JPEG2000 algorithms/templates. -!> - 2002-12-29 Stephen Gilbert Added check on comunpack return code. +!> This subroutine unpacks Section 7 ([Data Section] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_sect7.shtml)) +!> of a GRIB2 message. !> -!> @param[in] cgrib Character array that contains the GRIB2 message. -!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. -!> @param[inout] iofst Bit offset of the beginning/end(returned) of Section 7. -!> @param[in] igdsnum Grid Definition Template Number (Code Table 3.0) -!> (Only required to unpack DRT 5.51). -!> @param[in] igdstmpl Pointer to an integer array containing the data values -!> for the specified Grid Definition. Template (N=igdsnum). Each element of this -!> integer array contains an entry (in the order specified) of Grid Definition -!> Template 3.N (Only required to unpack DRT 5.51). -!> @param[in] ndpts Number of data points unpacked and returned. -!> @param[in] idrsnum Data Representation Template Number (Code Table 5.0). -!> @param[in] idrstmpl Pointer to an integer array containing the data values for -!> the specified Data Representation Template (N=idrsnum). Each element of this -!> integer array contains an entry (in the order specified) of Product Defintion -!> Template 5.N A safe dimension for this array can be obtained in advance -!> from maxvals(6), which is returned from subroutine gribinfo. -!> @param[in] ndpts Number of data points unpacked and returned. -!> @param[out] fld Pointer to a real array containing the unpacked data field. -!> @param[out] ierr Error return code. -!> - 0 no error. -!> - 4 Unrecognized Data Representation Template. -!> - 5 One of GDT 3.50 through 3.53 required to unpack DRT 5.51. -!> - 6 memory allocation error. -!> - 7 corrupt section 7. +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2000-05-26 | Stephen Gilbert | Initial development. +!> 2002-12-17 | Stephen Gilbert | New templates using PNG and JPEG2000 algorithms/templates. +!> 2002-12-29 | Stephen Gilbert | Added check on comunpack return code. !> -!> @author Stephen Gilbert @date 2002-01-24 +!> @param[in] cgrib Character array that contains the GRIB2 message. +!> @param[in] lcgrib Length (in bytes) of GRIB message array cgrib. +!> @param[inout] iofst Bit offset of the beginning/end(returned) of +!> Section 7. +!> @param[in] igdsnum Grid Definition Template Number (Code Table +!> 3.0) (Only required to unpack DRT 5.51). +!> @param[in] igdstmpl Pointer to an integer array containing the +!> data values for the specified Grid Definition. Template +!> (N=igdsnum). Each element of this integer array contains an entry +!> (in the order specified) of Grid Definition Template 3.N (Only +!> required to unpack DRT 5.51). +!> @param[in] idrsnum Data Representation Template Number ([Code Table +!> 5.0] +!> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table5-0.shtml)). +!> @param[in] idrstmpl Pointer to an integer array containing the data +!> values for the Data Representation Template specified by idrsnum. A +!> safe dimension for this array can be obtained in advance from +!> maxvals(6), which is returned from subroutine gribinfo. +!> @param[in] ndpts Number of data points unpacked and returned. +!> @param[out] fld Pointer to a real array containing the unpacked +!> data field. +!> @param[out] ierr Error return code. +!> - 0 no error. +!> - 4 Unrecognized Data Representation Template. +!> - 5 One of GDT 3.50 through 3.53 required to unpack DRT 5.51. +!> - 6 memory allocation error. +!> - 7 corrupt section 7. !> - +!> @author Stephen Gilbert @date 2002-01-24 subroutine gf_unpack7(cgrib,lcgrib,iofst,igdsnum,igdstmpl, & idrsnum,idrstmpl,ndpts,fld,ierr) diff --git a/src/gribmod.F90.in b/src/gribmod.F90.in new file mode 100644 index 00000000..4aafbf53 --- /dev/null +++ b/src/gribmod.F90.in @@ -0,0 +1,213 @@ +!> @file +!> @brief This Fortran module contains the declaration of derived +!> type gribfield. +!> @author Stephen Gilbert @date 2002-01-23 + +!> This Fortran module contains the declaration of derived type +!> gribfield. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2002-01-23 | Stephen Gilbert | Initial. +!> 2007-04-24 | Boi Vuong | Added GDT 3.204 Curvilinear Orthogonal Grids +!> 2008-05-29 | Boi Vuong | Added GDT 3.32768 Rotate Lat/Lon E-grid +!> 2009-02-17 | Boi Vuong | Allow negative scale factors and limits for Templates 4.5 and 4.9 +!> 2009-12-14 | Boi Vuong | Fixed bug in getidx.f, increase length of seek(512), Added Templates (Satellite Product) 4.31, (ICAO WAFS) 4.15 +!> 2013-05-07 | Boi Vuong | Initialized all pointers to null() +!> 2013-08-29 | Boi Vuong | Changed version number 2.5.0 +!> 2015-11-01 | Boi Vuong | Changed version number 2.6.0 +!> 2017-18-01 | Boi Vuong | Changed version number 3.1.0 +!> +!> @author Stephen Gilbert @date 2002-01-23 +module grib_mod + + character(len = 12) :: G2_VERSION = "g2lib-@pVersion@" !< Library version. + + type gribfield + integer :: version !< GRIB edition number (currently 2). + + !> Message Discipline (see [Code Table 0.0] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table0-0.shtml)). + integer :: discipline + + !> Contains the entries in the Identification Section (Section + !> 1). + !> - idsect(1) Identification of originating Centre + !> (see Common Code Table C-1) 7 US National Weather Service. ([Table 0] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/on388/table0.html)). + !> - idsect(2) Identification of originating Sub-centre ([Table C] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/on388/tablec.html)). + !> - idsect(3) GRIB Master Tables Version Number. ([Table 1.0] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table1-0.shtml)) + !> 0 Experimental; 1 Initial operational version number + !> - idsect(4) GRIB Local Tables Version Number ([Table 1.1] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table1-1.shtml)). + !> - 0 Local tables not used + !> - 0 1-254 Number of local tables version used + !> - idsect(5) Significance of Reference Time ([Table 1.2] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table1-1.shtml)). + !> - 0 Analysis + !> - 1 Start of forecast + !> - 2 Verifying time of forecast + !> - 3 Observation time + !> - idsect(6) Year (4 digits) + !> - idsect(7) Month + !> - idsect(8) Day + !> - idsect(9) Hour + !> - idsect(10) Minute + !> - idsect(11) Second + !> - idsect(12) Production status of processed data (see [Table 1.3] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table1-3.shtml)) + !> - 0 Operational products + !> - 1 Operational test products + !> - 2 Research products + !> - 3 Re-analysis products + !> - idsect(13) Type of processed data ([Table 1.4] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table1-4.shtml)) + !> - 0 Analysis products + !> - 1 Forecast products + !> - 2 Analysis and forecast products + !> - 3 Control forecast products + !> - 4 Perturbed forecast products + !> - 5 Control and perturbed forecast products + !> - 6 Processed satellite observations + !> - 7 Processed radar observations + integer, pointer, dimension(:) :: idsect => null() + + !> Number of elements in idsect (always 13). + integer :: idsectlen + + !> Pointer to character array containing contents of Local + !> Section 2, if included. + character(len = 1), pointer, dimension(:) :: local => null() + + !> Length of array local. + integer :: locallen + + !> Field number within GRIB message. + integer :: ifldnum + + !> Source of grid definition (see [Code Table 3.0] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-0.shtml)) + !> - 0 Specified in field igdtnum (as defined in [Code table 3.1] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-1.shtml). + !> - 1 Predetermined grid Defined by originating centre. + integer :: griddef + + !> Number of grid points in the defined grid. Note that the + !> number of actual data values returned from getgb2() (in ndpts) + !> may be less than this value if a logical bitmap is in use with + !> grid points that are being masked out. + integer :: ngrdpts + + !> Number of octets needed for each additional grid points + !> definition. Used to define number of points in each row (or + !> column) for non-regular grids. Equal to 0, if using regular + !> grid. + integer :: numoct_opt + + !> Interpretation of list of numbers at end of section 3 - the + !> Grid Definiton Section. (See [Code Table 3.11] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-11.shtml)). + integer :: interp_opt + + !> (Used if numoct_opt .ne. 0.) The number of entries in array + !> ideflist. i.e. number of rows (or columns) for which optional + !> grid points are defined. This value is set to zero, if + !> umoct_opt = 0. + integer :: num_opt + + !> (Used if numoct_opt .ne. 0.) This array contains the number of + !> grid points contained in each row (or column) (part of Section + !> 3), This element is actually a pointer to an array that holds + !> the data. This pointer is null if numoct_opt equals 0. + integer, pointer, dimension(:) :: list_opt => null() + + !> Grid Definition Template Number ([Code Table 3.1] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table3-1.shtml)). + integer :: igdtnum + + !> Number of elements in the Grid Defintion Template specified by + !> igdtnum. + integer :: igdtlen + + !> Contains the data values for the Grid Definition Template + !> specified by igdtnum. This element is actually a pointer to an + !> array that holds the data. + integer, pointer, dimension(:) :: igdtmpl => null() + + !> Product Definition Template Number ([Code Table 4.0] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table4-0.shtml)). + integer :: ipdtnum + + !> Number of elements in the Product Defintion Template specified + !> by ipdtnum. + integer :: ipdtlen + + !> Contains the data values for the Product Definition Template + !> specified by ipdtnum. This element is actually a pointer to an + !> array that holds the data. + integer, pointer, dimension(:) :: ipdtmpl => null() + + !> Number of values in array coord_list. This is part of Section + !> 3 - the Grid Definition Section. + integer :: num_coord + + !> Real array containing floating point values intended to + !> document the vertical discretisation associated to model data + !> on hybrid coordinate vertical levels (part of Section 3 - the + !> Grid Definition Section). This element is actually a pointer + !> to an array that holds the data. + real, pointer, dimension(:) :: coord_list => null() + + !> Number of data points unpacked and returned. Note that this + !> number may be different from the value of ngrdpts if a logical + !> bitmap is in use with grid points that are being masked out. + integer :: ndpts + + !> Data Representation Template Number ([Code Table 5.0] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table5-0.shtml)). + integer :: idrtnum + + !> Number of elements in the Data Representation Template array + !> specified by idrtnum. + integer :: idrtlen + + !> Contains the data values for the Data Representation Template + !> specified by idrtnum. This element is actually a pointer to an + !> array that holds the data. + integer, pointer, dimension(:) :: idrtmpl => null() + + !> Logical value indicating whether the bitmap and data values + !> were unpacked. If false, bmap and fld pointers are null. + logical :: unpacked + + !> Logical value indicating whether the data field was expanded + !> to the grid in the case where a bit-map is present. If true, + !> the data points in fld match the grid points and zeros were + !> inserted at grid points where data was bit-mapped out. If + !> false, the data values in fld were not expanded to the grid + !> and are just a consecutive array of data points corresponding + !> to each value of "1" in bmap. + logical :: expanded + + !> Bitmap indicator (see [Code Table 6.0] + !> (https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_table6-0.shtml)). + !> - 0 bitmap applies and is included in Section 6. + !> - 1-253 Predefined bitmap applies. + !> - 254 Previously defined bitmap applies to this field. + !> - 255 Bit map does not apply to this product. + integer :: ibmap + + !> Logical*1 array containing decoded bitmap, if ibmap equals 0 + !> or 254 - otherwise null. This element is actually a pointer to + !> an array that holds the data. + logical*1, pointer, dimension(:) :: bmap => null() + + !> Array of ndpts unpacked data points. This element is actually + !> a pointer to an array that holds the data. + real, pointer, dimension(:) :: fld => null() + end type gribfield + +end module grib_mod diff --git a/src/gribmod.f b/src/gribmod.f deleted file mode 100644 index 6b98fc84..00000000 --- a/src/gribmod.f +++ /dev/null @@ -1,180 +0,0 @@ -!> @file -!> @brief This Fortran Module contains the declaration of derived -!> type gribfield. -!> @author Stephen Gilbert @date 2002-01-23 -!> - -!> PROGRAM HISTORY LOG: -!> - 2002-01-23 Stephen Gilbert -!> - 2007-04-24 Boi Vuong Added GDT 3.204 Curvilinear Orthogonal Grids -!> - 2008-05-29 Boi Vuong Added GDT 3.32768 Rotate Lat/Lon E-grid -!> - 2009-02-17 Boi Vuong Allow negative scale factors and limits for -!> Templates 4.5 and 4.9 -!> - 2009-12-14 Boi Vuong -!> - Fixed bug in routine getidx.f -!> - Modified to increase length of seek(512) -!> - Added Templates (Satellite Product) 4.31 -!> - Added Templates (ICAO WAFS) 4.15 -!> - 2013-05-07 Boi Vuong Initialized all pointers to null() -!> - 2013-08-29 Boi Vuong Changed version number 2.5.0 -!> - 2015-11-01 Boi Vuong Changed version number 2.6.0 -!> - 2017-18-01 Boi Vuong Changed version number 3.1.0 -!> -!> This Fortran Module contains the declaration of derived type -!> gribfield. If variable gfld is declared of type gribfield, -!> (i.e.TYPE(GRIBFIELD) :: GFLD), it would have the following -!> componenets: -!> - gfld\%version GRIB edition number (currently 2) -!> - gfld\%discipline Message Discipline (see Code Table 0.0) -!> - gfld\%idsect Contains the entries in the Identification Section -!> (Section 1) This element is actually a pointer to an array -!> that holds the data. -!> - gfld\%idsect(1) Identification of originating Centre -!> (see Common Code Table C-1) 7 US National Weather Service -!> - gfld\%idsect(2) Identification of originating Sub-centre -!> - gfld\%idsect(3) GRIB Master Tables Version Number -!> (see Code Table 1.0) 0 Experimental; 1 Initial operational version number -!> - gfld\%idsect(4) GRIB Local Tables Version Number (Code Table 1.1) -!> - 0 Local tables not used -!> - 0 1-254 Number of local tables version used -!> - gfld\%idsect(5) Significance of Reference Time (Code Table 1.2) -!> - 0 Analysis -!> - 1 Start of forecast -!> - 2 Verifying time of forecast -!> - 3 Observation time. -!> - gfld\%idsect(6) Year (4 digits) -!> - gfld\%idsect(7) Month -!> - gfld\%idsect(8) Day -!> - gfld\%idsect(9) Hour -!> - gfld\%idsect(10) Minute -!> - gfld\%idsect(11) Second -!> - gfld\%idsect(12) Production status of processed data (see Code -!> Table 1.3) -!> - 0 Operational products -!> - 1 Operational test products -!> - 2 Research products -!> - 3 Re-analysis products -!> - gfld\%idsect(13) Type of processed data (see Code Table 1.4) -!> - 0 Analysis products -!> - 1 Forecast products -!> - 2 Analysis and forecast products -!> - 3 Control forecast products -!> - 4 Perturbed forecast products -!> - 5 Control and perturbed forecast products -!> - 6 Processed satellite observations -!> - 7 Processed radar observations -!> - gfld\%idsectlen Number of elements in gfld\%idsect -!> - gfld\%local Pointer to character array containing contents -!> of Local Section 2, if included -!> - gfld\%locallen length of array gfld\%local -!> - gfld\%ifldnum field number within GRIB message -!> - gfld\%griddef Source of grid definition (see Code Table 3.0) -!> - 0 Specified in Code table 3.1 -!> - 1 Predetermined grid Defined by originating centre -!> - gfld\%ngrdpts Number of grid points in the defined grid. -!> Note that the number of actual data values returned from getgb2 -!> (in gfld\%ndpts) may be less than this value if a logical bitmap -!> is in use with grid points that are being masked out. -!> - gfld\%numoct_opt Number of octets needed for each additional grid -!> points definition. Used to define number of points in each row (or -!> column) for non-regular grids. = 0, if using regular grid. -!> - gfld\%interp_opt Interpretation of list for optional points -!> definition.(Code Table 3.11) -!> - gfld\%igdtnum Grid Definition Template Number (Code Table 3.1) -!> - gfld\%igdtmpl Contains the data values for the specified Grid -!> Definition Template (NN=gfld\%igdtnum). Each element of this -!> integer array contains an entry (in the order specified) of Grid -!> Defintion Template 3.NN This element is actually a pointer to an -!> array that holds the data. -!> - gfld\%igdtlen Number of elements in gfld\%igdtmpl. i.e. number -!> of entries in Grid Defintion Template 3.NN (NN=gfld\%igdtnum). -!> - gfld\%list_opt (Used if gfld\%numoct_opt .ne. 0) This array -!> contains the number of grid points contained in each row (or -!> column). (part of Section 3) This element is actually a pointer -!> to an array that holds the data. This pointer is nullified -!> if gfld\%numoct_opt=0. -!> - gfld\%num_opt (Used if gfld\%numoct_opt .ne. 0) The number of -!> entries in array ideflist. i.e. number of rows (or columns) for which -!> optional grid points are defined. This value is set to zero, -!> if gfld\%numoct_opt=0. -!> - gfdl\%ipdtnum Product Definition Template Number (Code Table 4.0) -!> - gfld\%ipdtmpl Contains the data values for the specified Product -!> Definition Template (N=gfdl\%ipdtnum). Each element of this integer -!> array contains an entry (in the order specified) of Product Defintion -!> Template 4.N. This element is actually a pointer to an array -!> that holds the data. -!> - gfld\%ipdtlen Number of elements in gfld\%ipdtmpl. i.e. number of -!> entries in Product Defintion Template 4.N (N=gfdl\%ipdtnum). -!> - gfld\%coord_list Real array containing floating point values -!> intended to document the vertical discretisation associated to -!> model data on hybrid coordinate vertical levels.(part of Section 4) -!> This element is actually a pointer to an array -!> that holds the data. -!> - gfld\%num_coord number of values in array gfld\%coord_list. -!> - gfld\%ndpts Number of data points unpacked and returned. -!> Note that this number may be different from the value of -!> - gfld\%ngrdpts if a logical bitmap is in use with grid points -!> that are being masked out. -!> - gfld\%idrtnum Data Representation Template Number (Code Table 5.0) -!> - gfld\%idrtmpl Contains the data values for the specified Data -!> Representation Template (N=gfld\%idrtnum). Each element of this -!> integer array contains an entry (in the order specified) of -!> Product Defintion Template 5.N. This element is actually a -!> pointer to an array that holds the data. -!> - gfld\%idrtlen Number of elements in gfld\%idrtmpl. i.e. number -!> of entries in Data Representation Template 5.N (N=gfld\%idrtnum). -!> - gfld\%unpacked logical value indicating whether the bitmap and -!> data values were unpacked. If false, gfld\%bmap and gfld\%fld -!> pointers are nullified. -!> - gfld\%expanded Logical value indicating whether the data field -!> was expanded to the grid in the case where a bit-map is present. -!> If true, the data points in gfld\%fld match the grid points and -!> zeros were inserted at grid points where data was bit-mapped out. -!> If false, the data values in gfld\%fld were not expanded to the -!> grid and are just a consecutive array of data points corresponding -!> to each value of "1" in gfld\%bmap. -!> - gfld\%ibmap Bitmap indicator (see Code Table 6.0) -!> - 0 bitmap applies and is included in Section 6. -!> - 1-253 Predefined bitmap applies -!> - 254 Previously defined bitmap applies to this field -!> - 255 Bit map does not apply to this product. -!> - gfld\%bmap Logical*1 array containing decoded bitmap, if ibmap=0 -!> or ibap=254. Otherwise nullified. This element is actually a -!> pointer to an array that holds the data. -!> - gfld\%fld Array of gfld\%ndpts unpacked data points. This element -!> is actually a pointer to an array that holds the data. -!> -!> @author Stephen Gilbert @date 2002-01-23 -!> - - - module grib_mod - - character(len=12) :: G2_VERSION="g2lib-3.1.0" - - type gribfield - integer :: version,discipline - integer,pointer,dimension(:) :: idsect => null () - integer :: idsectlen - character(len=1),pointer,dimension(:) :: local => null () - integer :: locallen - integer :: ifldnum - integer :: griddef,ngrdpts - integer :: numoct_opt,interp_opt,num_opt - integer,pointer,dimension(:) :: list_opt => null () - integer :: igdtnum,igdtlen - integer,pointer,dimension(:) :: igdtmpl => null () - integer :: ipdtnum,ipdtlen - integer,pointer,dimension(:) :: ipdtmpl => null () - integer :: num_coord - real,pointer,dimension(:) :: coord_list => null () - integer :: ndpts,idrtnum,idrtlen - integer,pointer,dimension(:) :: idrtmpl => null () - logical :: unpacked - logical :: expanded - integer :: ibmap - logical*1,pointer,dimension(:) :: bmap => null () - real,pointer,dimension(:) :: fld => null () - end type gribfield - - end module diff --git a/src/jpeg.h b/src/jpeg.h new file mode 100644 index 00000000..f957dea8 --- /dev/null +++ b/src/jpeg.h @@ -0,0 +1,29 @@ +/** + * @file + * @brief Header for JPEG C code. + * + * @author Ed Hartnett @date 12/23/22 + */ + +/** Long integer type. */ +typedef int64_t g2int; + +/** Unsigned long integer type. This typedef is provided for backward + * compatibility and is not used by the library any more. */ +typedef uint64_t g2intu; + +/** Float type. This typedef is provided for backward compatibility + * and is not used by the library any more. Use float in new code. */ +typedef float g2float; + +#define G2_JASPER_INIT -2 /**< In enc_jpeg2000()/dec_jpeg2000() error initializing jasper library. */ +#define G2_JASPER_ENCODE -3 /**< In enc_jpeg2000() error encoding image with jasper. */ +#define G2_JASPER_DECODE -3 /**< In dec_jpeg2000() error decoding image with jasper. */ +#define G2_JASPER_DECODE_COLOR -5 /**< In dec_jpeg2000() decoded image had multiple color components. */ + +/** Name of JPEG codec in Jasper. */ +#define G2C_JASPER_JPEG_FORMAT_NAME "jpc" + +int enc_jpeg2000_(unsigned char *cin, g2int width, g2int height, g2int nbits, + g2int ltype, g2int ratio, g2int retry, char *outjpc, + g2int jpclen); diff --git a/src/list_of_files.cmake b/src/list_of_files.cmake deleted file mode 100644 index 69757766..00000000 --- a/src/list_of_files.cmake +++ /dev/null @@ -1,70 +0,0 @@ -set(fortran_src - addfield.f - addgrid.f - addlocal.f - cmplxpack.f - compack.f - comunpack.f - drstemplates.f - g2_gbytesc.f - g2grids.f - gb_info.f - gdt2gds.f - getdim.f - getfield.f - getg2i.f - getg2ir.f - getgb2.f - getgb2l.f - getgb2p.f - getgb2r.f - getgb2rp.f - getgb2s.f - getidx.f - getlocal.f - getpoly.f - gettemplates.f - gf_free.f - gf_getfld.f - gf_unpack1.f - gf_unpack2.f - gf_unpack3.f - gf_unpack4.f - gf_unpack5.f - gf_unpack6.f - gf_unpack7.f - gribcreate.f - gribend.f - gribinfo.f - gribmod.f - gridtemplates.f - intmath.f - ixgb2.f - jpcpack.f - jpcunpack.f - misspack.f - mkieee.f - pack_gp.f - params_ecmwf.f - params.f - pdstemplates.f - pngpack.f - pngunpack.f - putgb2.f - rdieee.f - realloc.f - reduce.f - simpack.f - simunpack.f - skgb.f - specpack.f - specunpack.f - ) - -set(c_src - dec_jpeg2000.c - dec_png.c - enc_jpeg2000.c - enc_png.c - mova2i.c - ) diff --git a/src/pdstemplates.F90 b/src/pdstemplates.F90 new file mode 100644 index 00000000..fcf94f96 --- /dev/null +++ b/src/pdstemplates.F90 @@ -0,0 +1,700 @@ +!> @file +!> @brief Information on all GRIB2 Product Definition Templates used +!> in [Section 4 - the Product Definition Section +!> (PDS)](https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_sect4.shtml) +!> @author Stephen Gilbert @date 2000-05-11 + +!> @brief Information on all GRIB2 Product Definition Templates used +!> in [Section 4 - the Product Definition Section +!> (PDS)](https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_sect4.shtml) +!> +!> Each Template has three parts: +!> 1. The number of entries in the template (mapppdslen); +!> 2. A map of the template (mappds), which contains the number of +!> octets in which to pack each of the template values; +!> 3. a logical value (needext) that indicates whether the Template +!> needs to be extended. In some cases the number of entries in a +!> template can vary depending upon values specified in the static +!> part of the template. (Template 4.3 as an example). +!> +!> This module also contains two subroutines. +!> - getpdstemplate() returns the octet map for a specified +!> Template number. +!> - extpdstemplate() will calculate the extended octet map of an +!> appropriate template given values for the static part of the +!> template. +!> +!> ### Program History Log +!> Date | Programmer | Comments +!> -----|------------|--------- +!> 2000-05-11 Stephen Gilbert | +!> 2001-12-04 Stephen Gilbert | Added Templates 4.12, 4.12, 4.14, 4.1000, 4.1001, 4.1002, 4.1100 and 4.1101 +!> 2009-05-21 Boi Vuong | Allow negative scale factors and limits for Templates 4.5 and 4.9 +!> 2009-12-14 Boi Vuong | Added Templates (Satellite Product) 4.31 Added Templates (ICAO WAFS) 4.15 +!> 2010-08-03 Boi Vuong | Added Templates 4.40,4.41,4.42,.4.43 +!> 2010-12-08 Boi Vuong | Corrected Product Definition Template 4.42 and 4.43 +!> 2012-02-07 Boi Vuong | Added Templates 4.44,4.45,4.46,4.47,4.48,4.50,4.51,4.91,4.32 and 4.52 +!> 2013-07-29 Boi Vuong | Corrected 4.91 and added Templates 4.33,4.34,4.53,4.54 +!> +!> @note Array mapgrid contains the number of octets in which the +!> corresponding template values will be stored. A negative value in +!> mapgrid is used to indicate that the corresponding template entry +!> can contain negative values. This information is used later when +!> packing (or unpacking) the template data values. Negative data +!> values in GRIB are stored with the left most bit set to one, and +!> a negative number of octets value in mapgrid indicates that this +!> possibility should be considered. The number of octets used to +!> store the data value in this case would be the absolute value of +!> the negative value in mapgrid. +!> +!> @author Stephen Gilbert @date 2000-05-11 +module pdstemplates + + integer, parameter :: MAXLEN = 200 !< MAXLEN max length of entries + integer, parameter :: MAXTEMP = 43 !< MAXTEMP maximum number of templates + + !> This is the defined type for a Product Definition Section (PDS) + !> template. + type pdstemplate + integer :: template_num !< Template number. + integer :: mappdslen !< The number of entries in the template. + integer, dimension(MAXLEN) :: mappds !< Number of octets in which to pack each value. + logical :: needext !< Does template need to be extended? + end type pdstemplate + + type(pdstemplate), dimension(MAXTEMP) :: templates !< template in type of pdstemplate + + data templates(1)%template_num /0/ ! Fcst at Level/Layer + data templates(1)%mappdslen /15/ + data templates(1)%needext /.false./ + data (templates(1)%mappds(j), j = 1, 15) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4/ + + data templates(2)%template_num /1/ ! Ens fcst at level/layer + data templates(2)%mappdslen /18/ + data templates(2)%needext /.false./ + data (templates(2)%mappds(j), j = 1, 18) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1/ + + data templates(3)%template_num /2/ ! Derived Ens fcst at level/layer + data templates(3)%mappdslen /17/ + data templates(3)%needext /.false./ + data (templates(3)%mappds(j), j = 1, 17) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1/ + + data templates(4)%template_num /3/ ! Ens cluster fcst rect. area + data templates(4)%mappdslen /31/ + data templates(4)%needext /.true./ + data (templates(4)%mappds(j), j = 1, 31) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 1, 1, 1, 1, -4, -4, 4, 4, & + 1, -1, 4, -1, 4/ + + data templates(5)%template_num /4/ ! Ens cluster fcst circ. area + data templates(5)%mappdslen /30/ + data templates(5)%needext /.true./ + data (templates(5)%mappds(j), j = 1, 30) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 1, 1, 1, 1, -4, 4, 4, & + 1, -1, 4, -1, 4/ + + data templates(6)%template_num /5/ ! Prob fcst at level/layer + data templates(6)%mappdslen /22/ + data templates(6)%needext /.false./ + data (templates(6)%mappds(j), j = 1, 22) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, -1, -4, -1, -4/ + + data templates(7)%template_num /6/ ! Percentile fcst at level/layer + data templates(7)%mappdslen /16/ + data templates(7)%needext /.false./ + data (templates(7)%mappds(j), j = 1, 16) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1/ + + data templates(8)%template_num /7/ ! Error at level/layer + data templates(8)%mappdslen /15/ + data templates(8)%needext /.false./ + data (templates(8)%mappds(j), j = 1, 15) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4/ + + data templates(9)%template_num /8/ ! Ave or Accum at level/layer + data templates(9)%mappdslen /29/ + data templates(9)%needext /.true./ + data (templates(9)%mappds(j), j = 1, 29) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 2, 1, 1, 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4/ + + data templates(10)%template_num /9/ ! Prob over time interval + data templates(10)%mappdslen /36/ + data templates(10)%needext /.true./ + data (templates(10)%mappds(j), j = 1, 36) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, -1, -4, -1, -4, 2, 1, 1, 1, & + 1, 1, 1, 4, 1, 1, 1, 4, 1, 4/ + + data templates(11)%template_num /10/ ! Percentile over time interval + data templates(11)%mappdslen /30/ + data templates(11)%needext /.true./ + data (templates(11)%mappds(j), j = 1, 30) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 2, 1, 1, 1, 1, 1, 1, 4, & + 1, 1, 1, 4, 1, 4/ + + data templates(12)%template_num /11/ ! Ens member over time interval + data templates(12)%mappdslen /32/ + data templates(12)%needext /.true./ + data (templates(12)%mappds(j), j = 1, 32) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, & + 4, 1, 1, 1, 4, 1, 4/ + + data templates(13)%template_num /12/ ! Derived Ens fcst over time int + data templates(13)%mappdslen /31/ + data templates(13)%needext /.true./ + data (templates(13)%mappds(j), j = 1, 31) & + /1, 1, 1, 1, 1, 2, 1, 1, 4, 1, -1, -4, 1, -1, -4, 1, 1, & + 2, 1, 1, 1, 1, 1, 1, -4, 1, 1, 1, 4, 1, 4/ + + data templates(14)%template_num /13/ ! Ens cluster fcst rect. area + data templates(14)%mappdslen /45/ + data templates(14)%needext /.true./ + data (templates(14)%mappds(j), j = 1, 45) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 1, 1, 1, 1, -4, -4, 4, 4, & + 1, -1, 4, -1, 4, 2, 1, 1, 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4/ + + data templates(15)%template_num /14/ ! Ens cluster fcst circ. area + data templates(15)%mappdslen /44/ + data templates(15)%needext /.true./ + data (templates(15)%mappds(j), j = 1, 44) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 1, 1, 1, 1, -4, 4, 4, & + 1, -1, 4, -1, 4, 2, 1, 1, 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4/ + + data templates(16)%template_num /20/ ! Radar Product + data templates(16)%mappdslen /19/ + data templates(16)%needext /.false./ + data (templates(16)%mappds(j), j = 1, 19) & + /1, 1, 1, 1, 1, -4, 4, 2, -4, 2, 1, 1, 1, 1, 1, 2, 1, 3, 2/ + + data templates(17)%template_num /30/ ! Satellite Product + data templates(17)%mappdslen /5/ + data templates(17)%needext /.true./ + data (templates(17)%mappds(j), j = 1, 5) & + /1, 1, 1, 1, 1/ + + data templates(18)%template_num /254/ ! CCITTIA5 Character String + data templates(18)%mappdslen /3/ + data templates(18)%needext /.false./ + data (templates(18)%mappds(j), j = 1, 3) & + /1, 1, 4/ + + data templates(19)%template_num /1000/ ! Cross section + data templates(19)%mappdslen /9/ + data templates(19)%needext /.false./ + data (templates(19)%mappds(j), j = 1, 9) & + /1, 1, 1, 1, 1, 2, 1, 1, -4/ + + data templates(20)%template_num /1001/ ! Cross section over time + data templates(20)%mappdslen /16/ + data templates(20)%needext /.false./ + data (templates(20)%mappds(j), j = 1, 16) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 4, 1, 1, 1, 4, 1, 4/ + + data templates(21)%template_num /1002/ ! Cross section processed time + data templates(21)%mappdslen /15/ + data templates(21)%needext /.false./ + data (templates(21)%mappds(j), j = 1, 15) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, 1, 1, 4, 4, 2/ + + data templates(22)%template_num /1100/ ! Hovmoller grid + data templates(22)%mappdslen /15/ + data templates(22)%needext /.false./ + data (templates(22)%mappds(j), j = 1, 15) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4/ + + data templates(23)%template_num /1101/ ! Hovmoller with stat proc + data templates(23)%mappdslen /22/ + data templates(23)%needext /.false./ + data (templates(23)%mappds(j), j = 1, 22) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 4, 1, 1, 1, 4, 1, 4/ + + data templates(24)%template_num /31/ ! Satellite Product + data templates(24)%mappdslen /5/ + data templates(24)%needext /.true./ + data (templates(24)%mappds(j), j = 1, 5) & + /1, 1, 1, 1, 1/ + + data templates(25)%template_num /15/ ! Ave or Accum at level/layer + data templates(25)%mappdslen /18/ ! For ICAO WAFS products + data templates(25)%needext /.false./ + data (templates(25)%mappds(j), j = 1, 18) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1/ + + data templates(26)%template_num /40/ ! Analysis or Forecast at a horizontal or in a + data templates(26)%mappdslen /16/ ! horizontal layer at a point in time for + data templates(26)%needext /.false./ ! atmospheric chemical constituents + data (templates(26)%mappds(j), j = 1, 16) & + /1, 1, 2, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4/ + + data templates(27)%template_num /41/ ! Individual ensemble forecast, control and + data templates(27)%mappdslen /19/ ! perturbed, at horizontal level or + data templates(27)%needext /.false./ ! in a horizontal layer at a point in time for + data (templates(27)%mappds(j), j = 1, 19) & ! atmospheric chemical constituents + /1, 1, 2, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1/ + + data templates(28)%template_num /42/ ! Average, Accumulation, and/or extreme values or other + data templates(28)%mappdslen /30/ ! statistically-processed values at horizontal level or + data templates(28)%needext /.true./ ! in a horizontal layer in contnunuous or non-continuous time + data (templates(28)%mappds(j), j = 1, 30) & ! interval for atmospheric chemical constituents + /1, 1, 2, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 2, 1, 1, 1, 1, 1, 1, 4, & + 1, 1, 1, 4, 1, 4/ + + data templates(29)%template_num /43/ ! Individual ensemble forecast, control and + data templates(29)%mappdslen /33/ ! perturbed, at horizontal level or in a horizontal + data templates(29)%needext /.true./ ! layer at a point in a continuous or non-continuous time + data (templates(29)%mappds(j), j = 1, 33) & ! interval for atmospheric chemical constituents + /1, 1, 2, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 4, & + 1, 1, 1, 4, 1, 4/ + + data templates(30)%template_num /44/ ! Analysis or Forecast at a horizontal or in a + data templates(30)%mappdslen /21/ ! horizontal layer at a point in time for + data templates(30)%needext /.false./ ! Aerosol + data (templates(30)%mappds(j), j = 1, 21) & + /1, 1, 2, 1, -1, -4, -1, -4, 1, 1, 1, 2, 1, 1, -2, 1, -1, -4, 1, -1, -4/ + + data templates(31)%template_num /45/ ! Individual ensemble forecast, control and + data templates(31)%mappdslen /24/ ! perturbed, at horizontal level or in a horizontal + data templates(31)%needext /.false./ ! layer at a point in time for Aerosol + data (templates(31)%mappds(j), j = 1, 24) & + /1, 1, 2, 1, -1, -4, -1, -4, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1/ + + data templates(32)%template_num /46/ ! Ave or Accum or Extreme value at level/layer + data templates(32)%mappdslen /35/ ! in a continuous or non-continuous time interval + data templates(32)%needext /.true./ ! for Aerosol + data (templates(32)%mappds(j), j = 1, 35) & + /1, 1, 2, 1, -1, -4, -1, -4, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 2, 1, 1, 1, 1, & + 1, 1, 4, 1, 1, 1, 4, 1, 4/ + + data templates(33)%template_num /47/ ! Individual ensemble forecast, control and + data templates(33)%mappdslen /38/ ! perturbed, at horizontal level or in a horizontal + data templates(33)%needext /.true./ ! in a continuous or non-continuous time interval + data (templates(33)%mappds(j), j = 1, 38) & ! for Aerosol + /1, 1, 1, 2, 1, -1, -4, -1, -4, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 2, 1, & + 1, 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4/ + + data templates(34)%template_num /51/ ! Categorical forecasts at a horizontal level or + data templates(34)%mappdslen /16/ ! in a horizontal layer at a point in time + data templates(34)%needext /.true./ + data (templates(34)%mappds(j), j = 1, 16) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1/ + ! + ! PDT 4.91 + ! + data templates(35)%template_num /91/ ! Categorical forecasts at a horizontal level or + data templates(35)%mappdslen /36/ ! in a horizontal layer in a continuous or + data templates(35)%needext /.true./ ! non-continuous time interval + data (templates(35)%mappds(j), j = 1, 36) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, -1, -4, -1, -4, & + 2, 1, 1, 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4/ + + data templates(36)%template_num /32/ ! Analysis or forecast at a horizontal level or + data templates(36)%mappdslen /10/ ! in a horizontal layer at a point in time for + data templates(36)%needext /.true./ ! for simulate (synthetic) Satellite data + data (templates(36)%mappds(j), j = 1, 10) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1/ + ! + ! PDT 4.48 + ! + data templates(37)%template_num /48/ ! Analysis or forecast at a horizontal level or + data templates(37)%mappdslen /26/ ! in a horizontal layer at a point in time for + data templates(37)%needext /.false./ ! Optical Properties of Aerosol + data (templates(37)%mappds(j), j = 1, 26) & + /1, 1, 2, 1, -1, -4, -1, -4, 1, -1, -4, -1, -4, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, & + 1, -1, -4/ + ! + ! PDT 4.50 VALIDATION + ! + data templates(38)%template_num /50/ ! Analysis or Forecast of a multi component + data templates(38)%mappdslen /21/ ! parameter or matrix element at a point in time + data templates(38)%needext /.false./ ! + data (templates(38)%mappds(j), j = 1, 21) & + /1, 1, 1, 1, 1, 2, 1, 1, 4, 1, -1, -4, 1, -1, -4, 1, 1, 4, 4, 4, 4/ + ! + ! PDT 4.52 VALIDATION + ! + data templates(39)%template_num /52/ ! Analysis or forecast of Wave parameters + data templates(39)%mappdslen /15/ ! at the Sea surface at a point in time + data templates(39)%needext /.false./ ! + data (templates(39)%mappds(j), j = 1, 15) & + /1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 4, 1, -1, -4/ + ! + ! PDT 4.33 (07/29/2013) + ! + data templates(40)%template_num /33/ ! Individual ensemble forecast, control, perturbed, + data templates(40)%mappdslen /18/ ! at a horizontal level or in a horizontal layer + data templates(40)%needext /.true./ ! at a point in time for simulate (synthetic) Satellite data + data (templates(40)%mappds(j), j = 1, 18) & + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, 2, 2, 2, -1, -4, 1, 1, 1/ + ! + ! PDT 4.34 (07/29/2013) + ! + data templates(41)%template_num /34/ ! Individual ensemble forecast, control, perturbed, + data templates(41)%mappdslen /32/ ! at a horizontal level or in a horizontal layer, + data templates(41)%needext /.true./ ! in a continuous or non-continuous interval + data (templates(41)%mappds(j), j = 1, 32) & ! for simulate (synthetic) Satellite data + /1, 1, 1, 1, 1, 2, 1, 1, -4, 1, 2, 2, 2, -1, -4, 1, 1, 1, 2, 1, 1, 1, & + 1, 1, 1, 4, 1, 1, 1, 4, 1, 4/ + ! + ! PDT 4.53 (07/30/2013) + ! + data templates(42)%template_num /53/ ! Partitioned parameters at + data templates(42)%mappdslen /19/ ! horizontal level or horizontal layer + data templates(42)%needext /.true./ ! at a point in time + data (templates(42)%mappds(j), j = 1, 19) & + /1, 1, 1, 1, 4, 2, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4/ + ! + ! PDT 4.54 (07/30/2013) + ! + data templates(43)%template_num /54/ ! Individual ensemble forecast, controli and perturbed, + data templates(43)%mappdslen /22/ ! at a horizontal level or in a horizontal layer + data templates(43)%needext /.true./ ! at a point in time for partitioned parameters + data (templates(43)%mappds(j), j = 1, 22) & + /1, 1, 1, 1, 4, 2, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1/ + +contains + + !> This function returns the index of specified Product + !> Definition Template in array templates. + !> + !> @param[in] number the Product Definition Template number. + !> @return + !> - Index of PDT in array templates, if template exists. + !> - -1, otherwise. + !> + !> @author Stephen Gilbert @date 2001-06-28 + integer function getpdsindex(number) + implicit none + + integer, intent(in) :: number + integer :: j + + getpdsindex = -1 + + do j = 1, MAXTEMP + if (number .eq. templates(j)%template_num) then + getpdsindex = j + return + endif + enddo + + end function getpdsindex + + !> This subroutine returns PDS template information for a specified + !> Product Definition Template. The number of entries in the + !> template is returned along with a map of the number of octets + !> occupied by each entry. Also, a flag is returned to indicate + !> whether the template would need to be extended. + !> + !> ### Program History Log + !> Date | Programmer | Comments + !> -----|------------|--------- + !> 2000-05-11 | Stephen Gilbert | Initial + !> 2010-08-03 | Boi Vuong | Added Templates 4.40, 4.41, 4.42, .4.43 + !> 2010-12-08 | Boi Vuong | Corrected Product Definition Template 4.42 and 4.43 + !> 2013-07-29 | Boi Vuong | Added Templates 4.48, 4.50, 4.33, 4.34, 4.53, 4.54 + !> + !> @param[in] number the Product Definition Template number that is + !> being requested. + !> @param[out] nummap Number of entries in the Template. + !> @param[out] map An array containing the number of octets that each + !> template entry occupies when packed up into the PDS. + !> @param[out] needext Logical variable indicating whether the + !> Product Defintion Template has to be extended. + !> @param[out] iret Error return code. + !> - 0 no error. + !> - 1 Undefine Product Template number. + !> + !> @author Stephen Gilbert @date 2000-05-11 + subroutine getpdstemplate(number, nummap, map, needext, iret) + implicit none + + integer, intent(in) :: number + integer, intent(out) :: nummap, map(*), iret + logical, intent(out) :: needext + integer :: index + + iret = 0 + + index = getpdsindex(number) + + if (index.ne.-1) then + nummap = templates(index)%mappdslen + needext = templates(index)%needext + map(1:nummap) = templates(index)%mappds(1:nummap) + else + nummap = 0 + needext = .false. + print *, 'getpdstemplate: PDS Template ', number, & + ' not defined.' + iret = 1 + endif + + end subroutine getpdstemplate + + !> This subroutine generates the remaining octet map for a given + !> Product Definition Template, if required. Some Templates can + !> vary depending on data values given in an earlier part of the + !> Template, and it is necessary to know some of the earlier entry + !> values to generate the full octet map of the Template. + !> + !> ### Program History Log + !> Date | Programmer | Comments + !> -----|------------|--------- + !> 2000-05-11 | Stephen Gilbert | Initial + !> 2010-08-03 | Boi Vuong | Added Templates 4.40, 4.41, 4.42, .4.43 + !> 2010-12-08 | Boi Vuong | Corrected Product Definition Template 4.42 and 4.43 + !> 2013-07-29 | Boi Vuong | Added Templates 4.48, 4.50, 4.33, 4.34, 4.53, 4.54 + !> + !> @param[in] number the Product Definition Template number. + !> @param[in] list An array containing the number of octets that match + !> the Product Definition Template. + !> @param[out] nummap Number of entries in the Template. + !> @param[out] map An array containing the number of octets that each + !> template entry occupies when packed up into the PDS. + !> + !> @author Stephen Gilbert @date 2000-05-11 + subroutine extpdstemplate(number, list, nummap, map) + implicit none + + integer, intent(in) :: number, list(*) + integer, intent(out) :: nummap, map(*) + integer :: i, index, k, n, j + + index = getpdsindex(number) + if (index .eq. -1) return + + if (.not. templates(index)%needext) return + nummap = templates(index)%mappdslen + map(1:nummap) = templates(index)%mappds(1:nummap) + + if (number .eq. 3) then + N = list(27) + do i = 1, N + map(nummap + i) = 1 + enddo + nummap = nummap + N + elseif (number .eq. 4) then + N = list(26) + do i = 1, N + map(nummap + i) = 1 + enddo + nummap = nummap + N + elseif (number .eq. 8) then + if (list(22).gt.1) then + do j = 2, list(22) + do k = 1, 6 + map(nummap + k) = map(23 + k) + enddo + nummap = nummap + 6 + enddo + endif + elseif (number .eq. 9) then + if (list(29).gt.1) then + do j = 2, list(29) + do k = 1, 6 + map(nummap + k) = map(30 + k) + enddo + nummap = nummap + 6 + enddo + endif + elseif (number .eq. 10) then + if (list(23).gt.1) then + do j = 2, list(23) + do k = 1, 6 + map(nummap + k) = map(24 + k) + enddo + nummap = nummap + 6 + enddo + endif + elseif (number .eq. 11) then + if (list(25).gt.1) then + do j = 2, list(25) + do k = 1, 6 + map(nummap + k) = map(26 + k) + enddo + nummap = nummap + 6 + enddo + endif + elseif (number .eq. 12) then + if (list(24).gt.1) then + do j = 2, list(24) + do k = 1, 6 + map(nummap + k) = map(25 + k) + enddo + nummap = nummap + 6 + enddo + endif + elseif (number .eq. 13) then + if (list(38).gt.1) then + do j = 2, list(38) + do k = 1, 6 + map(nummap + k) = map(39 + k) + enddo + nummap = nummap + 6 + enddo + endif + N = list(27) + do i = 1, N + map(nummap + i) = 1 + enddo + nummap = nummap + N + elseif (number .eq. 14) then + if (list(37).gt.1) then + do j = 2, list(37) + do k = 1, 6 + map(nummap + k) = map(38 + k) + enddo + nummap = nummap + 6 + enddo + endif + N = list(26) + do i = 1, N + map(nummap + i) = 1 + enddo + nummap = nummap + N + elseif (number .eq. 30) then + do j = 1, list(5) + map(nummap + 1) = 2 + map(nummap + 2) = 2 + map(nummap + 3) = 1 + map(nummap + 4) = 1 + map(nummap + 5) = 4 + nummap = nummap + 5 + enddo + elseif (number .eq. 31) then + do j = 1, list(5) + map(nummap + 1) = 2 + map(nummap + 2) = 2 + map(nummap + 3) = 2 + map(nummap + 4) = 1 + map(nummap + 5) = 4 + nummap = nummap + 5 + enddo + elseif (number .eq. 32) then + do j = 1, list(10) + map(nummap + 1) = 2 + map(nummap + 2) = 2 + map(nummap + 3) = 2 + map(nummap + 4) = -1 + map(nummap + 5) = -4 + nummap = nummap + 5 + enddo + elseif (number .eq. 33) then + N = list(10) + do i = 1, N + map(nummap + i) = 1 + enddo + nummap = nummap + N + elseif (number .eq. 34) then + if (list(25).gt.1) then + do j = 2, list(25) + do k = 1, 6 + map(nummap + k) = map(26 + k) + enddo + nummap = nummap + 6 + enddo + endif + N = list(10) + do i = 1, N + map(nummap + i) = 1 + enddo + nummap = nummap + N + elseif (number .eq. 42) then + if (list(23).gt.1) then + do j = 2, list(23) + do k = 1, 6 + map(nummap + k) = map(24 + k) + enddo + nummap = nummap + 6 + enddo + endif + elseif (number .eq. 43) then + if (list(26).gt.1) then + do j = 2, list(26) + do k = 1, 6 + map(nummap + k) = map(27 + k) + enddo + nummap = nummap + 6 + enddo + endif + elseif (number .eq. 46) then + if (list(28).gt.1) then + do j = 2, list(28) + do k = 1, 6 + map(nummap + k) = map(29 + k) + enddo + nummap = nummap + 6 + enddo + endif + elseif (number .eq. 47) then + if (list(31).gt.1) then + do j = 2, list(31) + do k = 1, 6 + map(nummap + k) = map(32 + k) + enddo + nummap = nummap + 6 + enddo + endif + elseif (number .eq. 51) then + do j = 1, list(16) + map(nummap + 1) = 1 + map(nummap + 2) = 1 + map(nummap + 3) = -1 + map(nummap + 4) = -4 + map(nummap + 5) = -1 + map(nummap + 6) = -4 + nummap = nummap + 6 + enddo + elseif (number .eq. 53) then + N = list(4) + do i = 1, N + map(nummap + i) = 1 + enddo + nummap = nummap + N + elseif (number .eq. 54) then + N = list(4) + do i = 1, N + map(nummap + i) = 1 + enddo + nummap = nummap + N + elseif (number .eq. 91) then + if (list(29).gt.1 ) then + do j = 2, list(29) + do k = 1, 6 + map(nummap + k) = map(30 + k) + enddo + nummap = nummap + 6 + enddo + endif + N = list(16) + do i = 1, N + map(nummap + i) = 1 + enddo + nummap = nummap + N + endif + end subroutine extpdstemplate + + !> This function returns the initial length (number of entries) in + !> the static part of specified Product Definition Template. + !> + !> @param[in] number the Product Definition Template number. + !> @return + !> - Number of entries in the static part of PDT. + !> - 0, if requested template is not found. + !> + !> @author Stephen Gilbert @date 2004-05-11 + integer function getpdtlen(number) + implicit none + + integer, intent(in) :: number + integer :: index + + getpdtlen = 0 + index = getpdsindex(number) + if (index .ne. -1) then + getpdtlen=templates(index)%mappdslen + endif + end function getpdtlen +end module pdstemplates diff --git a/src/pdstemplates.f b/src/pdstemplates.f deleted file mode 100644 index 3e373deb..00000000 --- a/src/pdstemplates.f +++ /dev/null @@ -1,703 +0,0 @@ -!> @file -!> @brief This Fortran Module contains info on all the available -!> GRIB2 Product Definition Templates used in Section 4 (PDS). -!> @author Stephen Gilbert @date 2000-05-11 -!> - -!> This Fortran Module contains info on all the available GRIB2 -!> Product Definition Templates used in Section 4 (PDS). Each -!> Template has three parts: The number of entries in the template -!> (mapgridlen); A map of the template (mapgrid), which contains the -!> number of octets in which to pack each of the template values; -!> and a logical value (needext) that indicates whether the Template -!> needs to be extended. In some cases the number of entries in a -!> template can vary depending upon values specified in the "static" -!> part of the template. (Template 4.3 as an example) -!> -!> This module also contains two subroutines. getpdstemplate() -!> returns the octet map for a specified Template number, and -!> extpdstemplate() will calculate the extended octet map of an -!> appropriate template given values for the "static" part of the -!> template. See docblocks below for the arguments and usage of these -!> routines. -!> -!> PROGRAM HISTORY LOG: -!> - 2000-05-11 Stephen Gilbert -!> - 2001-12-04 Stephen Gilbert Added Templates 4.12, 4.12, 4.14, -!> 4.1000, 4.1001, 4.1002, 4.1100 and 4.1101 -!> - 2009-05-21 Boi Vuong Allow negative scale factors and limits for -!> Templates 4.5 and 4.9 -!> - 2009-12-14 Boi Vuong Added Templates (Satellite Product) 4.31 -!> Added Templates (ICAO WAFS) 4.15 -!> - 2010-08-03 Boi Vuong Added Templates 4.40,4.41,4.42,.4.43 -!> - 2010-12-08 Boi Vuong Corrected Product Definition Template 4.42 -!> and 4.43 -!> - 2012-02-07 Boi Vuong Added Templates -!> 4.44,4.45,4.46,4.47,4.48,4.50,4.51,4.91,4.32 and 4.52 -!> - 2013-07-29 Boi Vuong Corrected 4.91 and added Templates -!> 4.33,4.34,4.53,4.54 -!> -!> @note Array mapgrid contains the number of octets in which the -!> corresponding template values will be stored. A negative value in -!> mapgrid is used to indicate that the corresponding template entry -!> can contain negative values. This information is used later when -!> packing (or unpacking) the template data values. Negative data -!> values in GRIB are stored with the left most bit set to one, and -!> a negative number of octets value in mapgrid() indicates that this -!> possibility should be considered. The number of octets used to -!> store the data value in this case would be the absolute value of -!> the negative value in mapgrid(). -!> -!> @author Stephen Gilbert @date 2000-05-11 -!> - - module pdstemplates - - integer,parameter :: MAXLEN=200 !< MAXLEN max length of entries - integer,parameter :: MAXTEMP=43 !< MAXTEMP maximum number of templates - - type pdstemplate - integer :: template_num - integer :: mappdslen - integer,dimension(MAXLEN) :: mappds - logical :: needext - end type pdstemplate - - type(pdstemplate),dimension(MAXTEMP) :: templates !< template in type of pdstemplate - - data templates(1)%template_num /0/ ! Fcst at Level/Layer - data templates(1)%mappdslen /15/ - data templates(1)%needext /.false./ - data (templates(1)%mappds(j),j=1,15) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/ - - data templates(2)%template_num /1/ ! Ens fcst at level/layer - data templates(2)%mappdslen /18/ - data templates(2)%needext /.false./ - data (templates(2)%mappds(j),j=1,18) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1/ - - data templates(3)%template_num /2/ ! Derived Ens fcst at level/layer - data templates(3)%mappdslen /17/ - data templates(3)%needext /.false./ - data (templates(3)%mappds(j),j=1,17) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1/ - - data templates(4)%template_num /3/ ! Ens cluster fcst rect. area - data templates(4)%mappdslen /31/ - data templates(4)%needext /.true./ - data (templates(4)%mappds(j),j=1,31) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,-4,4,4, - & 1,-1,4,-1,4/ - - data templates(5)%template_num /4/ ! Ens cluster fcst circ. area - data templates(5)%mappdslen /30/ - data templates(5)%needext /.true./ - data (templates(5)%mappds(j),j=1,30) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,4,4, - & 1,-1,4,-1,4/ - - data templates(6)%template_num /5/ ! Prob fcst at level/layer - data templates(6)%mappdslen /22/ - data templates(6)%needext /.false./ - data (templates(6)%mappds(j),j=1,22) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,-1,-4,-1,-4/ - - data templates(7)%template_num /6/ ! Percentile fcst at level/layer - data templates(7)%mappdslen /16/ - data templates(7)%needext /.false./ - data (templates(7)%mappds(j),j=1,16) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1/ - - data templates(8)%template_num /7/ ! Error at level/layer - data templates(8)%mappdslen /15/ - data templates(8)%needext /.false./ - data (templates(8)%mappds(j),j=1,15) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/ - - data templates(9)%template_num /8/ ! Ave or Accum at level/layer - data templates(9)%mappdslen /29/ - data templates(9)%needext /.true./ - data (templates(9)%mappds(j),j=1,29) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,2,1,1,1,1,1,1,4,1,1,1,4,1,4/ - - data templates(10)%template_num /9/ ! Prob over time interval - data templates(10)%mappdslen /36/ - data templates(10)%needext /.true./ - data (templates(10)%mappds(j),j=1,36) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,-1,-4,-1,-4,2,1,1,1, - & 1,1,1,4,1,1,1,4,1,4/ - - data templates(11)%template_num /10/ ! Percentile over time interval - data templates(11)%mappdslen /30/ - data templates(11)%needext /.true./ - data (templates(11)%mappds(j),j=1,30) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,2,1,1,1,1,1,1,4, - & 1,1,1,4,1,4/ - - data templates(12)%template_num /11/ ! Ens member over time interval - data templates(12)%mappdslen /32/ - data templates(12)%needext /.true./ - data (templates(12)%mappds(j),j=1,32) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,2,1,1,1,1,1,1, - & 4,1,1,1,4,1,4/ - - data templates(13)%template_num /12/ ! Derived Ens fcst over time int - data templates(13)%mappdslen /31/ - data templates(13)%needext /.true./ - data (templates(13)%mappds(j),j=1,31) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1, - & 2,1,1,1,1,1,1,4,1,1,1,4,1,4/ - - data templates(14)%template_num /13/ ! Ens cluster fcst rect. area - data templates(14)%mappdslen /45/ - data templates(14)%needext /.true./ - data (templates(14)%mappds(j),j=1,45) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,-4,4,4, - & 1,-1,4,-1,4,2,1,1,1,1,1,1,4,1,1,1,4,1,4/ - - data templates(15)%template_num /14/ ! Ens cluster fcst circ. area - data templates(15)%mappdslen /44/ - data templates(15)%needext /.true./ - data (templates(15)%mappds(j),j=1,44) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,4,4, - & 1,-1,4,-1,4,2,1,1,1,1,1,1,4,1,1,1,4,1,4/ - - data templates(16)%template_num /20/ ! Radar Product - data templates(16)%mappdslen /19/ - data templates(16)%needext /.false./ - data (templates(16)%mappds(j),j=1,19) - & /1,1,1,1,1,-4,4,2,4,2,1,1,1,1,1,2,1,3,2/ - - data templates(17)%template_num /30/ ! Satellite Product - data templates(17)%mappdslen /5/ - data templates(17)%needext /.true./ - data (templates(17)%mappds(j),j=1,5) - & /1,1,1,1,1/ - - data templates(18)%template_num /254/ ! CCITTIA5 Character String - data templates(18)%mappdslen /3/ - data templates(18)%needext /.false./ - data (templates(18)%mappds(j),j=1,3) - & /1,1,4/ - - data templates(19)%template_num /1000/ ! Cross section - data templates(19)%mappdslen /9/ - data templates(19)%needext /.false./ - data (templates(19)%mappds(j),j=1,9) - & /1,1,1,1,1,2,1,1,4/ - - data templates(20)%template_num /1001/ ! Cross section over time - data templates(20)%mappdslen /16/ - data templates(20)%needext /.false./ - data (templates(20)%mappds(j),j=1,16) - & /1,1,1,1,1,2,1,1,4,4,1,1,1,4,1,4/ - - data templates(21)%template_num /1002/ ! Cross section processed time - data templates(21)%mappdslen /15/ - data templates(21)%needext /.false./ - data (templates(21)%mappds(j),j=1,15) - & /1,1,1,1,1,2,1,1,4,1,1,1,4,4,2/ - - data templates(22)%template_num /1100/ ! Hovmoller grid - data templates(22)%mappdslen /15/ - data templates(22)%needext /.false./ - data (templates(22)%mappds(j),j=1,15) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/ - - data templates(23)%template_num /1101/ ! Hovmoller with stat proc - data templates(23)%mappdslen /22/ - data templates(23)%needext /.false./ - data (templates(23)%mappds(j),j=1,22) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,4,1,1,1,4,1,4/ - - data templates(24)%template_num /31/ ! Satellite Product - data templates(24)%mappdslen /5/ - data templates(24)%needext /.true./ - data (templates(24)%mappds(j),j=1,5) - & /1,1,1,1,1/ - - data templates(25)%template_num /15/ ! Ave or Accum at level/layer - data templates(25)%mappdslen /18/ ! For ICAO WAFS products - data templates(25)%needext /.false./ - data (templates(25)%mappds(j),j=1,18) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1/ - - data templates(26)%template_num /40/ ! Analysis or Forecast at a horizontal or in a - data templates(26)%mappdslen /16/ ! horizontal layer at a point in time for - data templates(26)%needext /.false./ ! atmospheric chemical constituents - data (templates(26)%mappds(j),j=1,16) - & /1,1,2,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/ - - data templates(27)%template_num /41/ ! Individual ensemble forecast, control and - data templates(27)%mappdslen /19/ ! perturbed, at horizontal level or - data templates(27)%needext /.false./ ! in a horizontal layer at a point in time for - data (templates(27)%mappds(j),j=1,19) ! atmospheric chemical constituents - & /1,1,2,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1/ - - data templates(28)%template_num /42/ ! Average, Accumulation, and/or extreme values or other - data templates(28)%mappdslen /30/ ! statistically-processed values at horizontal level or - data templates(28)%needext /.true./ ! in a horizontal layer in contnunuous or non-continuous time - data (templates(28)%mappds(j),j=1,30) ! interval for atmospheric chemical constituents - & /1,1,2,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,2,1,1,1,1,1,1,4, - & 1,1,1,4,1,4/ - - data templates(29)%template_num /43/ ! Individual ensemble forecast, control and - data templates(29)%mappdslen /33/ ! perturbed, at horizontal level or in a horizontal - data templates(29)%needext /.true./ ! layer at a point in a continuous or non-continuous time - data (templates(29)%mappds(j),j=1,33) ! interval for atmospheric chemical constituents - & /1,1,2,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,2,1,1,1,1,1,1,4, - & 1,1,1,4,1,4/ - - data templates(30)%template_num /44/ ! Analysis or Forecast at a horizontal or in a - data templates(30)%mappdslen /21/ ! horizontal layer at a point in time for - data templates(30)%needext /.false./ ! Aerosol - data (templates(30)%mappds(j),j=1,21) - & /1,1,2,1,-1,-4,-1,-4,1,1,1,2,1,1,2,1,-1,-4,1,-1,-4/ - - data templates(31)%template_num /45/ ! Individual ensemble forecast, control and - data templates(31)%mappdslen /24/ ! perturbed, at horizontal level or in a horizontal - data templates(31)%needext /.false./ ! layer at a point in time for Aerosol - data (templates(31)%mappds(j),j=1,24) - & /1,1,2,1,-1,-4,-1,-4,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1/ - - data templates(32)%template_num /46/ ! Ave or Accum or Extreme value at level/layer - data templates(32)%mappdslen /35/ ! in a continuous or non-continuous time interval - data templates(32)%needext /.true./ ! for Aerosol - data (templates(32)%mappds(j),j=1,35) - & /1,1,2,1,-1,-4,-1,-4,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,2,1,1,1,1, - & 1,1,4,1,1,1,4,1,4/ - - data templates(33)%template_num /47/ ! Individual ensemble forecast, control and - data templates(33)%mappdslen /38/ ! perturbed, at horizontal level or in a horizontal - data templates(33)%needext /.true./ ! in a continuous or non-continuous time interval - data (templates(33)%mappds(j),j=1,38) ! for Aerosol - & /1,1,1,2,1,-1,-4,-1,-4,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,2,1, - & 1,1,1,1,1,4,1,1,1,4,1,4/ - - data templates(34)%template_num /51/ ! Categorical forecasts at a horizontal level or - data templates(34)%mappdslen /16/ ! in a horizontal layer at a point in time - data templates(34)%needext /.true./ - data (templates(34)%mappds(j),j=1,16) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1/ -! -! PDT 4.91 -! - data templates(35)%template_num /91/ ! Categorical forecasts at a horizontal level or - data templates(35)%mappdslen /36/ ! in a horizontal layer in a continuous or - data templates(35)%needext /.true./ ! non-continuous time interval - data (templates(35)%mappds(j),j=1,36) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,-1,-4,-1,-4, - & 2,1,1,1,1,1,1,4,1,1,1,4,1,4/ - - data templates(36)%template_num /32/ ! Analysis or forecast at a horizontal level or - data templates(36)%mappdslen /10/ ! in a horizontal layer at a point in time for - data templates(36)%needext /.true./ ! for simulate (synthetic) Satellite data - data (templates(36)%mappds(j),j=1,10) - & /1,1,1,1,1,2,1,1,4,1/ -! -! PDT 4.48 -! - data templates(37)%template_num /48/ ! Analysis or forecast at a horizontal level or - data templates(37)%mappdslen /26/ ! in a horizontal layer at a point in time for - data templates(37)%needext /.false./ ! Optical Properties of Aerosol - data (templates(37)%mappds(j),j=1,26) - & /1,1,2,1,-1,-4,-1,-4,1,-1,-4,-1,-4,1,1,1,2,1,1,4,1,-1,-4, - & 1,-1,-4/ -! -! PDT 4.50 VALIDATION -! - data templates(38)%template_num /50/ ! Analysis or Forecast of a multi component - data templates(38)%mappdslen /21/ ! parameter or matrix element at a point in time - data templates(38)%needext /.false./ ! - data (templates(38)%mappds(j),j=1,21) - & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,4,4,4,4/ -! -! PDT 4.52 VALIDATION -! - data templates(39)%template_num /52/ ! Analysis or forecast of Wave parameters - data templates(39)%mappdslen /15/ ! at the Sea surface at a point in time - data templates(39)%needext /.false./ ! - data (templates(39)%mappds(j),j=1,15) - & /1,1,1,1,1,1,1,1,2,1,1,4,1,-1,-4/ -! -! PDT 4.33 (07/29/2013) -! - data templates(40)%template_num /33/ ! Individual ensemble forecast, control, perturbed, - data templates(40)%mappdslen /18/ ! at a horizontal level or in a horizontal layer - data templates(40)%needext /.true./ ! at a point in time for simulate (synthetic) Satellite data - data (templates(40)%mappds(j),j=1,18) - & /1,1,1,1,1,2,1,1,4,1,2,2,2,-1,-4,1,1,1/ -! -! PDT 4.34 (07/29/2013) -! - data templates(41)%template_num /34/ ! Individual ensemble forecast, control, perturbed, - data templates(41)%mappdslen /32/ ! at a horizontal level or in a horizontal layer, - data templates(41)%needext /.true./ ! in a continuous or non-continuous interval - data (templates(41)%mappds(j),j=1,32) ! for simulate (synthetic) Satellite data - & /1,1,1,1,1,2,1,1,4,1,2,2,2,-1,-4,1,1,1,2,1,1,1, - & 1,1,1,4,1,1,1,4,1,4/ -! -! PDT 4.53 (07/30/2013) -! - data templates(42)%template_num /53/ ! Partitioned parameters at - data templates(42)%mappdslen /19/ ! horizontal level or horizontal layer - data templates(42)%needext /.true./ ! at a point in time - data (templates(42)%mappds(j),j=1,19) - & /1,1,1,1,4,2,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/ -! -! PDT 4.54 (07/30/2013) -! - data templates(43)%template_num /54/ ! Individual ensemble forecast, controli and perturbed, - data templates(43)%mappdslen /22/ ! at a horizontal level or in a horizontal layer - data templates(43)%needext /.true./ ! at a point in time for partitioned parameters - data (templates(43)%mappds(j),j=1,22) - & /1,1,1,1,4,2,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1/ - - contains - -!> This function returns the index of specified Product -!> Definition Template 4.NN (NN=number) in array templates. -!> @param[in] number NN, indicating the number of the Product -!> Definition Template 4.NN that is being requested. -!> @return -!> - Index of PDT 4.NN in array templates, if template exists. -!> - -1, otherwise. -!> -!> @author Stephen Gilbert @date 2001-06-28 -!> - - integer function getpdsindex(number) - - integer,intent(in) :: number - - getpdsindex=-1 - - do j=1,MAXTEMP - if (number.eq.templates(j)%template_num) then - getpdsindex=j - return - endif - enddo - - end function - -!> This subroutine returns PDS template information for a specified -!> Product Definition Template 4.NN. The number of entries in the -!> template is returned along with a map of the number of octets -!> occupied by each entry. Also, a flag is returned to indicate -!> whether the template would need to be extended. -!> -!> PROGRAM HISTORY LOG: -!> - 2000-05-11 Stephen Gilbert -!> - 2010-08-03 Boi Vuong Added Templates 4.40,4.41,4.42,.4.43 -!> - 2010-12-08 Boi Vuong Corrected Product Definition Template 4.42 and 4.43 -!> - 2013-07-29 Boi Vuong Added Templates 4.48,4.50,4.33,4.34,4.53,4.54 -!> -!> @param[in] number NN, indicating the number of the Product -!> Definition Template 4.NN that is being requested. -!> @param[out] nummap Number of entries in the Template. -!> @param[out] map An array containing the number of octets that each -!> template entry occupies when packed up into the PDS. -!> @param[out] needext Logical variable indicating whether the -!> Product Defintion Template has to be extended. -!> @param[out] iret Error return code. -!> - 0 no error. -!> - 1 Undefine Product Template number. -!> -!> @author Stephen Gilbert @date 2000-05-11 -!> - - subroutine getpdstemplate(number,nummap,map,needext,iret) - - integer,intent(in) :: number - integer,intent(out) :: nummap,map(*),iret - logical,intent(out) :: needext - - iret=0 - - index=getpdsindex(number) - - if (index.ne.-1) then - nummap=templates(index)%mappdslen - needext=templates(index)%needext - map(1:nummap)=templates(index)%mappds(1:nummap) - else - nummap=0 - needext=.false. - print *,'getpdstemplate: PDS Template ',number, - & ' not defined.' - iret=1 - endif - - end subroutine - -!> This subroutine generates the remaining octet map for a given -!> Product Definition Template, if required. Some Templates can -!> vary depending on data values given in an earlier part of the -!> Template, and it is necessary to know some of the earlier entry -!> values to generate the full octet map of the Template. -!> -!> PROGRAM HISTORY LOG: -!> - 2000-05-11 Stephen Gilbert -!> - 2010-08-03 Boi Vuong Added Templates 4.40,4.41,4.42,.4.43 -!> - 2010-12-08 Boi Vuong Corrected Product Definition Template 4.42 and 4.43 -!> - 2013-07-29 Boi Vuong Added Templates 4.48,4.50,4.33,4.34,4.53,4.54 -!> -!> @param[in] number NN, indicating the number of the Product -!> Definition Template 4.NN that is being requested. -!> @param[in] list An array containing the number of octets that each -!> the Product Definition Template 4.NN. -!> @param[out] nummap Number of entries in the Template. -!> @param[out] map An array containing the number of octets that each -!> template entry occupies when packed up into the PDS. -!> -!> @author Stephen Gilbert @date 2000-05-11 -!> - - subroutine extpdstemplate(number,list,nummap,map) - - integer,intent(in) :: number,list(*) - integer,intent(out) :: nummap,map(*) - - index=getpdsindex(number) - if (index.eq.-1) return - - if ( .not. templates(index)%needext ) return - nummap=templates(index)%mappdslen - map(1:nummap)=templates(index)%mappds(1:nummap) - - if ( number.eq.3 ) then - N=list(27) - do i=1,N - map(nummap+i)=1 - enddo - nummap=nummap+N - elseif ( number.eq.4 ) then - N=list(26) - do i=1,N - map(nummap+i)=1 - enddo - nummap=nummap+N - elseif ( number.eq.8 ) then - if ( list(22).gt.1 ) then - do j=2,list(22) - do k=1,6 - map(nummap+k)=map(23+k) - enddo - nummap=nummap+6 - enddo - endif - elseif ( number.eq.9 ) then - if ( list(29).gt.1 ) then - do j=2,list(29) - do k=1,6 - map(nummap+k)=map(30+k) - enddo - nummap=nummap+6 - enddo - endif - elseif ( number.eq.10 ) then - if ( list(23).gt.1 ) then - do j=2,list(23) - do k=1,6 - map(nummap+k)=map(24+k) - enddo - nummap=nummap+6 - enddo - endif - elseif ( number.eq.11 ) then - if ( list(25).gt.1 ) then - do j=2,list(25) - do k=1,6 - map(nummap+k)=map(26+k) - enddo - nummap=nummap+6 - enddo - endif - elseif ( number.eq.12 ) then - if ( list(24).gt.1 ) then - do j=2,list(24) - do k=1,6 - map(nummap+k)=map(25+k) - enddo - nummap=nummap+6 - enddo - endif - elseif ( number.eq.13 ) then - if ( list(38).gt.1 ) then - do j=2,list(38) - do k=1,6 - map(nummap+k)=map(39+k) - enddo - nummap=nummap+6 - enddo - endif - N=list(27) - do i=1,N - map(nummap+i)=1 - enddo - nummap=nummap+N - elseif ( number.eq.14 ) then - if ( list(37).gt.1 ) then - do j=2,list(37) - do k=1,6 - map(nummap+k)=map(38+k) - enddo - nummap=nummap+6 - enddo - endif - N=list(26) - do i=1,N - map(nummap+i)=1 - enddo - nummap=nummap+N - elseif ( number.eq.30 ) then - do j=1,list(5) - map(nummap+1)=2 - map(nummap+2)=2 - map(nummap+3)=1 - map(nummap+4)=1 - map(nummap+5)=4 - nummap=nummap+5 - enddo - elseif ( number.eq.31 ) then - do j=1,list(5) - map(nummap+1)=2 - map(nummap+2)=2 - map(nummap+3)=2 - map(nummap+4)=1 - map(nummap+5)=4 - nummap=nummap+5 - enddo - elseif ( number.eq.32 ) then - do j=1,list(10) - map(nummap+1)=2 - map(nummap+2)=2 - map(nummap+3)=2 - map(nummap+4)=-1 - map(nummap+5)=-4 - nummap=nummap+5 - enddo - elseif ( number.eq.33 ) then - N=list(10) - do i=1,N - map(nummap+i)=1 - enddo - nummap=nummap+N - elseif ( number.eq.34 ) then - if ( list(25).gt.1 ) then - do j=2,list(25) - do k=1,6 - map(nummap+k)=map(26+k) - enddo - nummap=nummap+6 - enddo - endif - N=list(10) - do i=1,N - map(nummap+i)=1 - enddo - nummap=nummap+N - elseif ( number.eq.42 ) then - if ( list(23).gt.1 ) then - do j=2,list(23) - do k=1,6 - map(nummap+k)=map(24+k) - enddo - nummap=nummap+6 - enddo - endif - elseif ( number.eq.43 ) then - if ( list(26).gt.1 ) then - do j=2,list(26) - do k=1,6 - map(nummap+k)=map(27+k) - enddo - nummap=nummap+6 - enddo - endif - elseif ( number.eq.46 ) then - if ( list(28).gt.1 ) then - do j=2,list(28) - do k=1,6 - map(nummap+k)=map(29+k) - enddo - nummap=nummap+6 - enddo - endif - elseif ( number.eq.47 ) then - if ( list(31).gt.1 ) then - do j=2,list(31) - do k=1,6 - map(nummap+k)=map(32+k) - enddo - nummap=nummap+6 - enddo - endif - elseif ( number.eq.51 ) then - do j=1,list(16) - map(nummap+1)=1 - map(nummap+2)=1 - map(nummap+3)=-1 - map(nummap+4)=-4 - map(nummap+5)=-1 - map(nummap+6)=-4 - nummap=nummap+6 - enddo - elseif ( number.eq.53 ) then - N=list(4) - do i=1,N - map(nummap+i)=1 - enddo - nummap=nummap+N - elseif ( number.eq.54 ) then - N=list(4) - do i=1,N - map(nummap+i)=1 - enddo - nummap=nummap+N - elseif ( number.eq.91 ) then - if ( list(29).gt.1 ) then - do j=2,list(29) - do k=1,6 - map(nummap+k)=map(30+k) - enddo - nummap=nummap+6 - enddo - endif - N=list(16) - do i=1,N - map(nummap+i)=1 - enddo - nummap=nummap+N - endif - - end subroutine - -!> This function returns the initial length (number of entries) in -!> the "static" part of specified Product Definition Template 4.number. -!> @param[in] number NN, indicating the number of the Product -!> Definition Template 4.NN that is being requested. -!> @return -!> - Number of entries in the "static" part of PDT 4.number.. -!> - 0, if requested template is not found. -!> -!> @author Stephen Gilbert @date 2004-05-11 -!> - - integer function getpdtlen(number) - - integer,intent(in) :: number - - getpdtlen=0 - - index=getpdsindex(number) - - if (index.ne.-1) then - getpdtlen=templates(index)%mappdslen - endif - - end function - - end module diff --git a/tests/CMakeLists.txt b/tests/CMakeLists.txt index 2ee4bc36..a7c7afe0 100644 --- a/tests/CMakeLists.txt +++ b/tests/CMakeLists.txt @@ -1,4 +1,55 @@ +# This is the CMake file for the test directory in the NCEPLIBS-g2 +# project. +# +# Ed Hartnett -add_executable(test_g2 test_g2.f90) -target_link_libraries(test_g2 g2_d) -add_test(test_g2 test_g2) +# This function builds, links, and runs a test program. +function(create_test name kind) + add_executable(${name}_${kind} ${name}.F90) + target_link_libraries(${name}_${kind} PRIVATE g2_${kind} PNG::PNG) + set_target_properties(${name}_${kind} PROPERTIES COMPILE_FLAGS "${fortran_${kind}_flags}") + set_target_properties(${name}_${kind} PROPERTIES Fortran_MODULE_DIRECTORY + ${CMAKE_CURRENT_BINARY_DIR}/include_${kind}) + add_test(NAME ${name}_${kind} COMMAND ${name}_${kind}) + target_compile_definitions(${name}_${kind} PUBLIC -DKIND_${kind}) +endfunction() + +# Copy the VERSION file, it's needed in a test. +FILE(COPY ${CMAKE_SOURCE_DIR}/VERSION DESTINATION ${CMAKE_CURRENT_BINARY_DIR}) + +# Build a _4 and _d version of each test and link them to the _4 and +# _d builds of the library, for 4-byte real, and 8-byte real. +foreach(kind ${kinds}) + create_test(test_g2_encode ${kind}) + create_test(test_g2_decode ${kind}) + create_test(test_gridtemplates ${kind}) + create_test(test_drstemplates ${kind}) + create_test(test_params ${kind}) + create_test(test_params_ecmwf ${kind}) + create_test(test_pdstemplates ${kind}) + create_test(test_pdstemplates_2 ${kind}) +# create_test(test_getgb2 ${kind}) + create_test(test_getdim ${kind}) + create_test(test_getpoly ${kind}) + create_test(test_intmath ${kind}) +# create_test(test_g2grids ${kind}) + create_test(test_mkieee ${kind}) +# create_test(test_getlocal ${kind}) +# create_test(test_getg2i ${kind}) + create_test(test_realloc ${kind}) +# create_test(test_gdt2gds ${kind}) + create_test(test_simpack ${kind}) + create_test(test_gbytec ${kind}) +# create_test(test_gribcreate ${kind}) + create_test(test_getfield ${kind}) + create_test(test_pngpack ${kind}) +# create_test(test_jpcpack ${kind}) +endforeach() + +# add_executable(test_g2 test_g2.f90) +# target_link_libraries(test_g2 g2_d) +# add_test(test_g2 test_g2) + +# add_executable(test_params test_params.F90) +# target_link_libraries(test_params g2_d) +# add_test(test_params test_params) diff --git a/tests/test_drstemplates.F90 b/tests/test_drstemplates.F90 new file mode 100644 index 00000000..70e94094 --- /dev/null +++ b/tests/test_drstemplates.F90 @@ -0,0 +1,37 @@ +! This program tests the drstemplates module of the NCEPLIBS-g2 +! project. +! +! Ed Hartnett 10/1/21 +program test_drstemplates + use drstemplates + implicit none + + integer :: index, nummap, iret + logical :: needext + integer, parameter :: max_map = 5 + integer :: map(max_map) + integer :: list(1) + integer :: map1(max_map) + + print *, 'Testing the drstemplates module.' + + print *, 'Testing getdrsindex...' + index = getdrsindex(0) + if (index .ne. 1) stop 2 + index = getdrsindex(41) + if (index .ne. 9) stop 3 + + print *, 'Testing getdrstemplate...' + call getdrstemplate(0, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 5 .or. needext) stop 4 + if (map(1) .ne. 4 .or. map(2) .ne. -2 .or. map(3) .ne. -2 .or. & + map(4) .ne. 1 .or. map(5) .ne. 1) stop 5 + + + ! Currenrly no drstemplates have needext=.true. + print *, 'Testing extdrstemplate...' + call extdrstemplate(0, list, nummap, map1) + + print *, 'SUCCESS!' + +end program test_drstemplates diff --git a/tests/test_g2_decode.F90 b/tests/test_g2_decode.F90 new file mode 100644 index 00000000..cdcab809 --- /dev/null +++ b/tests/test_g2_decode.F90 @@ -0,0 +1,154 @@ +!> This test is a test for the NCEPLIBS-g2 library. +!> It fully decode all grib2 message. Code referenced to the g2c test by Dusan. +!> Extra functions and code for fortran are added. Data was designed for +!> a typical grib2 file in fortran, with zero values to the variables. +!> +!> Hang Lei 2021-11-21 +!> + + program tst_decode + use grib_mod + use g2grids + use params + use gridtemplates + + + integer :: fgrib_len, iret, i, Nan + character, dimension(269) :: fgrib + real, dimension(225) :: fld_ok + integer :: G2_ERROR, numfields, numlocal, maxlocal + integer, dimension(3) :: listsec0, listsec0_ok + integer, dimension(13) :: listsec1, listsec1_ok + type(gribfield) :: gfld + integer :: k1, k2, k3, k4, k5, k6, k7, k8, k9, k10 + integer :: n1, n2, n3 + + print *,"Testing decoding full grib2 message.\n" + + ! To initialize large parameters in typical grib2 file. + k1=6371200 ! Radius of the earth + k2=1073 ! Nx for lambert 5km + k3=689 ! Ny for lambert 5km + k4=2019199 ! La1 - latitude of first grid point + k5=2384459 ! Lo1 - longitude of first grid point + k6=25000000 ! Latitude where grid spacing is defined + k7=265000000 ! Orientation longitude + k8=2539703 ! X & Y direction grid length + k9=-90000000 ! Latitude of pole + k10=739297 ! Number of grid Nx*Ny + Nan=9999 ! Missing value + fgrib_len=269 ! Grib message length + + ! Large numbers in message initials + n1=229 + n2=254 + n3=255 + + ! The grib message for a typical grib2 file in fortran. + fgrib(:)=(/ & + ! section 0 + & "G", "R", "I", "B", achar(0), achar(0), & + & achar(0), achar(2), achar(0), achar(0), achar(0), achar(0), & + & achar(0), achar(0), achar(1), achar(13), & + ! section 1 + & achar(0), achar(0), achar(0), achar(21), achar(1), achar(0), & + & achar(8), achar(0), achar(0), achar(1), achar(0), achar(1), & + & achar(7), achar(n1), achar(11), achar(15), achar(10), & + & achar(10), achar(10), achar(0), achar(1), & + ! section 2 + & achar(0), achar(0), achar(0), achar(11), achar(2), & + & achar(1), "H", "K", "T", "A", "R", & + ! section 3 + & achar(0), achar(0), achar(0), achar(81), achar(3), achar(0), & + & achar(0), achar(0), achar(0), achar(k10), achar(0), achar(0), & + & achar(0), achar(30), achar(1), achar(0), achar(k1), achar(k1), & + & achar(k1), achar(k1), achar(0), achar(0), achar(0), achar(0), & + & achar(0), achar(0), achar(0), achar(0), achar(0), achar(0), & + & achar(k2), achar(k2), achar(k2), achar(k2), achar(k3), & + & achar(k3), achar(k3), achar(k3), achar(k4), achar(k4), & + & achar(k4), achar(k4),achar(k5),achar(k5), achar(k5), & + & achar(k5), achar(0), achar(k6), achar(k6), achar(k6), & + & achar(k6), achar(k7), achar(k7), achar(k7), achar(k7), & + & achar(k8), achar(k8), achar(k8), achar(k8), achar(k8), & + & achar(k8), achar(k8), achar(k8), achar(0), achar(80), & + & achar(k6), achar(k6), achar(k6), achar(k6), achar(k6), & + & achar(k6), achar(k6), achar(k6), achar(k9), achar(k9), & + & achar(k9), achar(k9), achar(0), achar(0), achar(0), achar(0), & + ! section 4 + & achar(0), achar(0), achar(0), achar(71), achar(4), achar(0), & + & achar(0), achar(0), achar(9), achar(1), achar(8), achar(2), & + & achar(0), achar(0), achar(0), achar(0), achar(0), achar(0), & + & achar(0), achar(3), achar(6), achar(9), achar(1), achar(0), & + & achar(0), achar(0), achar(0), achar(0), achar(0), achar(0), & + & achar(0), achar(0), achar(0), achar(0), achar(0), achar(0), & + & achar(1), achar(0), achar(0), achar(0), achar(0), achar(0), & + & achar(3), achar(0), achar(0), achar(0), achar(n2), achar(7), & + & achar(n1), achar(11), achar(15), achar(12), achar(20), & + & achar(10), achar(1), achar(0), achar(0), achar(0), achar(0), & + & achar(1), achar(0), achar(1), achar(0), achar(0), achar(0), & + & achar(12), achar(1), achar(0), achar(0), achar(0), achar(0), & + ! section 5 + & achar(0), achar(0), achar(0), achar(47), achar(5), achar(0), & + & achar(0), achar(0), achar(k10), achar(0), achar(2), achar(0), & + & achar(0), achar(0), achar(0), achar(0), achar(0), achar(0), & + & achar(1), achar(8), achar(1), achar(1), achar(1), achar(Nan), & + & achar(Nan), achar(Nan), achar(Nan), achar(0), achar(0), & + & achar(0), achar(0), achar(0), achar(0), achar(0), achar(0), & + & achar(0), achar(0), achar(0), achar(0), achar(0), achar(0), & + & achar(0), achar(0), achar(0), achar(0), achar(0), achar(0), & + ! section 6 + & achar(0), achar(0), achar(0), achar(6), achar(6), achar(n3), & + ! section 7 + & achar(0), achar(0), achar(0), achar(12), achar(7), achar(1), & + & achar(0), achar(0), achar(0), achar(0), achar(0), achar(0), & + ! section 8 + & "7", "7", "7", "7" /) + + ! Test g2_gbytesc.f90 to get grib header info. + call g2_gbytec(fgrib,i,32,8) + if (i .ne. 0) stop 101 + call G2_GBYTESC(fgrib,i,56,8,0,1) + if (i .ne. 2) stop 102 ! check grib version. + + ! Test gb_info.f90 to get full grib2 messages. + + G2_ERROR = 2 + listsec0_ok(:) = (/ 0, 2, 269 /) + listsec1_ok(:) = (/ 8, 0, 1, 0, 1, 2021, 11, 15, 10, 10, 10, 0, 1 /) + fld_ok(:) = 0 ! zero data field. + + call gb_info(fgrib, fgrib_len, listsec0, listsec1, & + & numfields, numlocal, maxlocal, iret) + + if (iret .ne. 0) stop 103 + + do i =1,3 + if (listsec0(i) .ne. listsec0_ok(i)) stop 104 + end do + + do i =1,13 + if (listsec1(i) .ne. listsec1_ok(i)) stop 105 + end do + + if (numfields .ne. 1) stop 106 + if (numlocal .ne. 1) stop 107 + + ! Test gf_getfld.f90 to get data from grib2 message. + + call gf_getfld(fgrib, fgrib_len, 1, 1, 1, gfld, iret) + + if (iret .ne. 0) stop 108 + + if (gfld%version .ne. 2) stop 109 + + if (gfld%ndpts .ne. 225) stop 110 + + do i =1,(gfld%ndpts) + if (gfld%fld(i) .ne. fld_ok(i)) stop 111 + end do + ! Release gfld + call gf_free(gfld) + + print *,"SUCCESS!\n" + + end program tst_decode diff --git a/tests/test_g2_encode.F90 b/tests/test_g2_encode.F90 new file mode 100644 index 00000000..a7c3bdb6 --- /dev/null +++ b/tests/test_g2_encode.F90 @@ -0,0 +1,300 @@ +! This is a test for the NCEPLIBS-g2 library. +! +! In this test we try out the g2_encode() subroutine. +! +! Ed Hartnett 9/29/21 + +! This subroutine prints in a pretty way the contents of a gribfield +! type. +! +! Ed Hartnett 10/5/21 +subroutine print_gribfield(gfld) + use grib_mod + use gridtemplates + implicit none + + type(gribfield), intent(in) :: gfld + integer :: i + + print *, 'Section 0: Indicator Section' + print *, 'discipline: ', gfld%discipline + print *, 'version: ', gfld%version + print *, '' + + print *, 'Section 1: Identification Section' + print *, 'idsectlen: ', gfld%idsectlen + do i = 1, gfld%idsectlen + print *, 'idsect(', i, '): ', gfld%idsect(i) + enddo + print *, '' + + print *, 'Section 2: Local Use Section' + print *, ' locallen: ', gfld%locallen + print *, '' + + print *, 'Section 3: Grid Definition Section' + print *, 'griddef: ', gfld%griddef + print *, 'igdtnum: ', gfld%igdtnum, ' igdtlen: ', gfld%igdtlen + print *, 'ngrdpts: ', gfld%ngrdpts + print *, 'numoct_opt: ', gfld%numoct_opt + print *, 'interp_opt: ', gfld%interp_opt + print *, 'num_opt: ', gfld%num_opt + do i = 1, gfld%igdtlen + print *, 'igdtmpl(', i, '): ', gfld%igdtmpl(i) + enddo + print *, 'num_coord: ', gfld%num_coord + do i = 1, gfld%num_coord + print *, 'coord_list(', i, '): ', gfld%coord_list(i) + enddo + print *, '' + + print *, 'Section 4: Product Definition Section' + print *, 'ipdtnum: ', gfld%ipdtnum + print *, 'ipdtlen: ', gfld%ipdtlen + do i = 1, gfld%ipdtlen + print *, 'ipdtmpl(', i, '): ', gfld%ipdtmpl(i) + enddo + print *, '' + + print *, 'Section 5: Data Representation Section' + print *, 'idrtnum: ', gfld%idrtnum + print *, 'idrtlen: ', gfld%idrtlen + do i = 1, gfld%idrtlen + print *, 'idrtmpl(', i, '): ', gfld%idrtmpl(i) + enddo + print *, '' + + print *, 'Section 6: Bit Map Section' + print *, ' ibmap: ', gfld%ibmap + print *, '' + + print *, 'Section 7: Data Section' + print *, 'ndpts: ', gfld%ndpts + print *, 'ifldnum: ', gfld%ifldnum + print *, 'expanded: ', gfld%expanded + print *, 'unpacked: ', gfld%unpacked + print *, '' + +end subroutine print_gribfield + +! This is the main test program. +! +! Ed Hartnett 9/29/21 +program test_g2_encode + use grib_mod + implicit none + + ! For gribcreate(). + integer, parameter :: MAX_MSG_LEN = 256 + character (len = MAX_MSG_LEN) :: msg + integer :: listsec0(2) + integer :: listsec1(13) + integer :: msg_len + + ! For addgrid(). + integer :: igds(5) + integer, parameter :: my_grid_tmpl_maplen = 19 + integer, dimension(my_grid_tmpl_maplen) :: igdstmpl + integer :: ideflist(5) + integer :: idefnum + + ! For addfield(). + integer :: ipdsnum + integer, parameter :: my_pds_tmpl_maplen = 35 ! 29 plus 6 extra + integer :: ipdstmpl(my_pds_tmpl_maplen) + integer, parameter :: numcoord = 3 + integer :: idrsnum + integer, parameter :: my_drs_tmpl_maplen = 5 + integer :: idrstmpl(my_drs_tmpl_maplen) + integer, parameter :: ngrdpts = 4 + real :: coordlist(numcoord) + real :: fld(10) + integer :: ibmap + logical*1 :: bmap(ngrdpts) + + ! For rereading the message. + integer :: listsec0_in(3) + integer :: listsec1_in(13) + integer :: numfields, numlocal, maxlocal + type(gribfield) :: gfld + + integer :: ierr + integer :: i + + print *, 'Testing g2 library encoding/decoding.' + + print *, 'Testing g2 library encoding...' +! listsec0(1) Discipline-GRIB Master Table Number (Code Table 0.0) +! listsec0(2) GRIB Edition Number (currently 2) + listsec0 = (/ 0, 2 /) + +! listsec1(1) Id of orginating centre (Common Code Table C-1) +! listsec1(2) Id of orginating sub-centre (local table) +! listsec1(3) GRIB Master Tables Version Number (Code Table 1.0) +! listsec1(4) GRIB Local Tables Version Number (Code Table 1.1) +! listsec1(5) Significance of Reference Time (Code Table 1.2) +! listsec1(6) Reference Time - Year (4 digits) +! listsec1(7) Reference Time - Month +! listsec1(8) Reference Time - Day +! listsec1(9) Reference Time - Hour +! listsec1(10) Reference Time - Minute +! listsec1(11) Reference Time - Second +! listsec1(12) Production status of data (Code Table 1.3) +! listsec1(13) Type of processed data (Code Table 1.4) + listsec1 = (/ 0, 0, 0, 0, 0, 2021, 1, 31, 12, 59, 59, 0, 0 /) + + ! Create the GRIB2 message. + call gribcreate(msg, MAX_MSG_LEN, listsec0, listsec1, ierr) + if (ierr .ne. 0) stop 2 + + ! igds(1) Source of grid definition (see Code Table 3.0) + ! igds(2) Number of grid points in the defined grid. + ! igds(3) Number of octets needed for each additional grid points + ! definition. Used to define number of points in each row (or column) + ! for non-regular grids. = 0, if using regular grid. + ! igds(4) Interpretation of list for optional points definition. (Code Table 3.11) + ! igds(5) Grid Definition Template Number (Code Table 3.1) + igds = (/ 0, 4, 0, 0, 0 /) + + ! Contains the data values for the specified Grid Definition + ! Template (NN=igds(5)). Each element of this integer array + ! contains an entry (in the order specified) of Grid Defintion + ! Template 3.NN. + igdstmpl = (/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /) + + ! What's this? + idefnum = 0 + + ! Add a grid to the GRIB2 message. + call addgrid(msg, MAX_MSG_LEN, igds, igdstmpl, my_grid_tmpl_maplen, ideflist, idefnum, ierr) + if (ierr .ne. 0) then + print *, 'ierr = ', ierr + stop 2 + endif + + ! Product Definition Template Number (see Code Table 4.0). + ipdsnum = 8 + + ! Contains the data values for the specified Product Definition + ! Template (N=ipdsnum). Each element of this integer array contains + ! an entry (in the order specified) of Product Defintion Template + ! 4.N. + ipdstmpl = (/ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, & + 1, 1, 1, 1, 1, 1/) + + ! Array containg floating point values intended to document the + ! vertical discretisation associated to model data on hybrid + ! coordinate vertical levels. (part of Section 4) The dimension of + ! this array can be obtained in advance from maxvals(5), which is + ! returned from subroutine gribinfo. + coordlist(1) = 1.0 + coordlist(2) = 2.0 + coordlist(3) = 3.0 + + ! idrsnum - Data Representation Template Number (see Code Table 5.0) + idrsnum = 0 + + ! idrstmpl Contains the data values for the specified Data + ! Representation Template (N=idrsnum). Each element of this integer + ! array contains an entry (in the order specified) of Data + ! Representation Template 5.N. Note that some values in this + ! template (eg. reference values, number of bits, etc...) may be + ! changed by the data packing algorithms. Use this to specify + ! scaling factors and order of spatial differencing, if desired. + idrstmpl = (/ 0, 0, 0, 0, 0 /) + + ! fld Array of data points to pack. + + ! ngrdpts Number of data points in grid. i.e. size of fld and bmap. + + ! ibmap Bitmap indicator (see Code Table 6.0). + ibmap = 253 + + ! bmap Logical*1 array containing bitmap to be added. (if ibmap=0 or + ! ibmap=254) + + ! Add a field to the GRIB2 message. + call addfield(msg, MAX_MSG_LEN, ipdsnum, ipdstmpl, my_pds_tmpl_maplen, & + coordlist, numcoord, idrsnum, idrstmpl, my_drs_tmpl_maplen, fld, & + ngrdpts, ibmap, bmap, ierr) + if (ierr .ne. 0) stop 3 + + ! Finilize the GRIB2 message. + call gribend(msg, MAX_MSG_LEN, msg_len, ierr) + if (ierr .ne. 0) stop 4 + print *, 'msg_len = ', msg_len + ! I don't understand why the msg_len is 216 on GNU and 217 on Intel... + ! if (msg_len .ne. 216) stop 5 + + print *, 'Testing g2 library decoding...' + + ! Check the message for correctness. + call gb_info(msg, msg_len, listsec0_in, listsec1_in, & + numfields, numlocal, maxlocal, ierr) + if (ierr .ne. 0) stop 10 + ! I don't understand why listsec0_in(1) is 216 instead of 0... + ! print *, listsec0(1), listsec0_in(1) + if (listsec0(2) .ne. listsec0_in(2)) stop 11 + do i = 1, 13 + if (listsec1(i) .ne. listsec1_in(i)) stop 12 + enddo + if (numfields .ne. 1 .or. numlocal .ne. 0 .or. maxlocal .ne. 0) stop 10 + + call gf_getfld(msg, msg_len, 1, .true., 0, gfld, ierr) + if (ierr .ne. 0) stop 20 + + ! Print results. + call print_gribfield(gfld) + + ! Section 0 - Indicator. + if (gfld%discipline .ne. listsec0(1)) stop 100 + if (gfld%version .ne. 2) stop 101 + + ! Section 1 - Identification. + if (gfld%idrtlen .ne. my_drs_tmpl_maplen) stop 110 + do i = 1, 13 + if (gfld%idsect(i) .ne. listsec1(i)) stop 111 + enddo + + ! Section 2 - Local Use. + if (gfld%locallen .ne. 0) stop 120 + + ! Section 3 - Grid Definition. + if (gfld%griddef .ne. igds(1)) stop 130 + do i = 1, my_grid_tmpl_maplen + if (igdstmpl(i) .ne. gfld%igdtmpl(i)) stop 131 + end do + if (gfld%ngrdpts .ne. ngrdpts) stop 132 + if (gfld%numoct_opt .ne. 0) stop 133 + if (gfld%interp_opt .ne. 0) stop 134 + if (gfld%num_opt .ne. 0) stop 135 + if (gfld%num_coord .ne. numcoord) stop 136 + do i = 1, gfld%num_coord + print *, i, coordlist(i), gfld%coord_list(i) + if (coordlist(i) .ne. gfld%coord_list(i)) stop 137 + end do + + ! Section 4 - Product Definition. + if (gfld%ipdtnum .ne. ipdsnum) stop 140 + if (gfld%ipdtlen .ne. 29) stop 141 + do i = 1, 29 + if (ipdstmpl(i) .ne. gfld%ipdtmpl(i)) stop 142 + end do + + ! Section 5 - Data Representation. + if (gfld%idrtnum .ne. idrsnum) stop 140 + if (gfld%idrtlen .ne. 5) stop 141 + do i = 1, 5 + if (idrstmpl(i) .ne. gfld%idrtmpl(i)) stop 142 + end do + + ! Section 6 - Bit Map. + if (gfld%ibmap .ne. ibmap) stop 160 + + ! Section 7 - Data. + if (gfld%ndpts .ne. 4 .or. .not. gfld%unpacked) stop 170 + if (gfld%ifldnum .ne. 1 .or. .not. gfld%expanded) stop 171 + + print *, 'SUCESSS!' +end program test_g2_encode diff --git a/tests/test_gbytec.F90 b/tests/test_gbytec.F90 new file mode 100644 index 00000000..cfb49fb0 --- /dev/null +++ b/tests/test_gbytec.F90 @@ -0,0 +1,181 @@ +! This is a test program for the NCEPLIBS-g2 project. +! +! This program tests the g2_gbytesc.F90 code. +! +! Ed Hartnett, Nov. 12, 2021 +program test_gbytec + implicit none + + character*1 :: out(1) + character*1 :: out4(4) + character*1 :: out5(5) + character*1 :: out8(8) + character*1 :: out10(10) + integer, parameter :: n = 1 + integer :: in(n) + real :: r_in(n) + integer, parameter :: n2 = 2 + integer :: in2(n2) + real :: r_in2(n2) + integer, parameter :: n5 = 5 + integer :: in5(n5) + integer :: iskip = 0 + integer :: nbits = 8 + integer :: nskip = 0 + integer :: i + integer :: num + + print *, 'Testing g2_gbytesc.f subroutines.' + + print *, 'Testing g2_sbytec()...' + in(1) = 3 + out(1) = char(0) + call g2_sbytec(out, in, iskip, nbits) + if (ichar(out(1)) .ne. in(1)) stop 10 + + print *, 'Testing g2_sbytesc()...' + in(1) = 3 + out(1) = char(0) + call g2_sbytesc(out, in, iskip, nbits, nskip, n) + if (ichar(out(1)) .ne. in(1)) stop 20 + + ! This will pack the numbers 1 and 2 into the first two chars of the + ! buffer. The rest of the output buffer will remain zeros. + print *, 'Testing g2_sbytesc() packing 2 values...' + in2(1) = 1 + in2(2) = 2 + do i = 1, 8 + out8(i) = char(0) + end do + nbits = 8 + call g2_sbytesc(out8, in2, iskip, nbits, nskip, n2) + do i = 1, 8 + if (i .le. 2) then + if (ichar(out8(i)) .ne. in2(i)) stop 30; + else + if (ichar(out8(i)) .ne. 0) stop 31; + endif + end do + + ! Now pack 5 values into the 5 character array out5. + print *, 'Testing g2_sbytesc() packing 5 values...' + in5(1) = 1 + in5(2) = 2 + in5(3) = 3 + in5(4) = 4 + in5(5) = 5 + nbits = 8 + nskip = 0 + do i = 1, 5 + out5(i) = char(0) + end do + call g2_sbytesc(out5, in5, iskip, nbits, nskip, n5) + do i = 1, 5 + if (ichar(out5(i)) .ne. in5(i)) stop 40; + end do + + ! Now pack 5 values into the 10 character array out10. Skip every + ! other byte in the output. + print *, 'Testing g2_sbytesc() packing 5 values, skipping every other byte...' + nbits = 8 + nskip = 0 + do i = 1, 10 + out10(i) = char(0) + end do + call g2_sbytesc(out10, in5, iskip, nbits, 8, 5) + do i = 1, 10 + ! print '(z2.2)', out10(i) + if (mod(i, 2) .gt. 0) then + if (ichar(out10(i)) .ne. in5(int(i/2) + 1)) stop 51; + else + if (ichar(out10(i)) .ne. 0) stop 50; + endif + end do + + print *, 'Testing g2_sbytec() with iskip of 1...' + in(1) = 1 + out(1) = char(0) + call g2_sbytec(out, in, 1, 6) + ! print '(z2.2)', out(1) + if (ichar(out(1)) .ne. 2) stop 20 + + print *, 'Testing g2_sbytesc() with a small array...' + iskip = 0 + nbits = 32 + nskip = 0 + num = 1 + in(1) = 1 + call g2_sbytesc(out4, in, iskip, nbits, nskip, num) + if (ichar(out4(1)) .ne. 0 .and. ichar(out4(2)) .ne. 0 .and. ichar(out4(3)) .ne. 0 .and. ichar(out4(4)) .ne. 1) stop 50 + !print '(z2.2)', out4(1) + + ! For this test to pass the -fallow-argument-mismatch flag must be + ! used, because I am passing in a real array instead of an int array + ! for the in parameter. This is how g2_sbytesc() is called in + ! addfield.F90. + print *, 'Testing g2_sbytesc() with a real array (size 1) instead of an int array...' + iskip = 0 + nbits = 32 + nskip = 0 + num = 1 + r_in(1) = 1 + call g2_sbytesc(out4, r_in, iskip, nbits, nskip, num) + ! Note that the 32-bit IEEE representation of 1.0 is 3f800000. The + ! decimal for 3f is 63, the decimal for 80 is 128. + if (ichar(out4(1)) .ne. 63 .and. ichar(out4(2)) .ne. 128 .and. ichar(out4(3)) .ne. 0 .and. ichar(out4(4)) .ne. 0) stop 50 + ! print '(z2.2)', out4(1) + ! print '(z2.2)', out4(2) + ! print '(z2.2)', out4(3) + ! print '(z2.2)', out4(4) + + ! This test is the same as above, but does not require the -fallow-argument-mismatch flag. + print *, 'Testing g2_sbytesc() with a real array (size 1) instead of an int array, using transfer() intrinsic...' + iskip = 0 + nbits = 32 + nskip = 0 + num = 1 + r_in(1) = 1 + in = transfer(r_in, in) + call g2_sbytesc(out4, in, iskip, nbits, nskip, num) + ! Note that the 32-bit IEEE representation of 1.0 is 3f800000. The + ! decimal for 3f is 63, the decimal for 80 is 128. + if (ichar(out4(1)) .ne. 63 .and. ichar(out4(2)) .ne. 128 .and. ichar(out4(3)) .ne. 0 .and. ichar(out4(4)) .ne. 0) stop 50 + ! print '(z2.2)', out4(1) + + ! For this test to pass the -fallow-argument-mismatch flag must be + ! used, because I am passing in a real array instead of an int array + ! for the in parameter. This is how g2_sbytesc() is called in + ! addfield.F90. + print *, 'Testing g2_sbytesc() with a real array instead of an int array...' + iskip = 0 + nbits = 32 + nskip = 0 + num = 2 + r_in2(1) = 1 + r_in2(2) = 1 + call g2_sbytesc(out8, r_in2, iskip, nbits, nskip, num) + ! Note that the 32-bit IEEE representation of 1.0 is 3f800000. The + ! decimal for 3f is 63, the decimal for 80 is 128. + if (ichar(out8(1)) .ne. 63 .and. ichar(out8(2)) .ne. 128 .and. ichar(out8(3)) .ne. 0 .and. ichar(out8(4)) .ne. 0) stop 50 + if (ichar(out8(5)) .ne. 63 .and. ichar(out8(6)) .ne. 128 .and. ichar(out8(7)) .ne. 0 .and. ichar(out8(8)) .ne. 0) stop 50 + ! print '(z2.2)', out8(1) + + ! This test is the same as above, but does not require the -fallow-argument-mismatch flag. + print *, 'Testing g2_sbytesc() with a real array instead of an int array, using transfer() intrinsic...' + iskip = 0 + nbits = 32 + nskip = 0 + num = 2 + r_in2(1) = 1 + r_in2(2) = 1 + in = transfer(r_in2, in2) + call g2_sbytesc(out8, in2, iskip, nbits, nskip, num) + ! Note that the 32-bit IEEE representation of 1.0 is 3f800000. The + ! decimal for 3f is 63, the decimal for 80 is 128. + if (ichar(out4(1)) .ne. 63 .and. ichar(out4(2)) .ne. 128 .and. ichar(out4(3)) .ne. 0 .and. ichar(out4(4)) .ne. 0) stop 50 + if (ichar(out8(5)) .ne. 63 .and. ichar(out8(6)) .ne. 128 .and. ichar(out8(7)) .ne. 0 .and. ichar(out8(8)) .ne. 0) stop 50 + ! print '(z2.2)', out4(1) + + print *, 'SUCCESS!' + +end program test_gbytec diff --git a/tests/test_getdim.F90 b/tests/test_getdim.F90 new file mode 100644 index 00000000..5b2862e6 --- /dev/null +++ b/tests/test_getdim.F90 @@ -0,0 +1,25 @@ +!Test for the getdim source file +!Brian Curtis 2021-12-08 +program test_getdim + implicit none + + integer, parameter :: lcsec3 = 72 + character(len=1) :: csec3(lcsec3) + integer :: width, height, iscan + + csec3 = (/ achar(0), achar(0), achar(0), achar(72), & + achar(3), achar(0), achar(0), achar(0), achar(0), achar(4), achar(0), achar(0), achar(0), achar(0), achar(0), & + achar(1), achar(0), achar(0), achar(0), achar(2), achar(3), achar(0), achar(0), achar(0), achar(4), achar(5), & + achar(0), achar(0), achar(0), achar(6), achar(0), achar(0), achar(0), achar(7), achar(0), achar(0), achar(0), & + achar(8), achar(0), achar(0), achar(0), achar(9), achar(0), achar(0), achar(0), achar(10), achar(0), achar(0), & + achar(0), achar(11), achar(0), achar(0), achar(0), achar(12), achar(13), achar(0), achar(0), achar(0), achar(14), & + achar(0), achar(0), achar(0), achar(15), achar(0), achar(0), achar(0), achar(16), achar(0), achar(0), achar(0), & + achar(17), achar(18) /) + + call getdim(csec3, lcsec3, width, height, iscan) + + if (width .ne. 7) stop 10 + if (height .ne. 8) stop 20 + if (iscan .ne. 18) stop 30 + +end program test_getdim diff --git a/tests/test_getfield.F90 b/tests/test_getfield.F90 new file mode 100644 index 00000000..a8ec34a3 --- /dev/null +++ b/tests/test_getfield.F90 @@ -0,0 +1,422 @@ +! This program tests the getfield() subroutine of the NCEPLIBS-g2 +! project. Link this to the _4 build of the library. +! +! Ed Hartnett 11/16/21 +program test_getfield + use grib_mod + implicit none + + ! Storage for the grib2 message we are reading. + integer, parameter :: lcgrib = 191 + + ! This is a copy of the GRIB2 message generated in + ! test_gribcreate.f90. + character :: cgrib(lcgrib) = (/ char( 71), char( 82),& + & char( 73), char( 66), char( 0), char( 0), char( 0),& + & char( 2), char( 0), char( 0), char( 0), char( 0),& + & char( 0), char( 0), char( 0), char(191), char( 0),& + & char( 0), char( 0), char( 21), char( 1), char( 0),& + & char( 7), char( 0), char( 4), char( 2), char( 24),& + & char( 0), char( 7), char(229), char( 11), char( 13),& + & char( 15), char( 59), char( 59), char( 1), char( 0),& + & char( 0), char( 0), char( 0), char( 8), char( 2),& + & char( 1), char( 2), char( 3), char( 0), char( 0),& + & char( 0), char( 72), char( 3), char( 0), char( 0),& + & char( 0), char( 0), char( 4), char( 0), char( 0),& + & char( 0), char( 0), char( 0), char( 1), char( 0),& + & char( 0), char( 0), char( 1), char( 1), char( 0),& + & char( 0), char( 0), char( 1), char( 1), char( 0),& + & char( 0), char( 0), char( 1), char( 0), char( 0),& + & char( 0), char( 2), char( 0), char( 0), char( 0),& + & char( 2), char( 0), char( 0), char( 0), char( 0),& + & char( 0), char( 0), char( 0), char( 0), char( 0),& + & char( 0), char( 0), char( 45), char( 0), char( 0),& + & char( 0), char( 91), char( 0), char( 0), char( 0),& + & char( 0), char( 55), char( 0), char( 0), char( 0),& + & char(101), char( 0), char( 0), char( 0), char( 5),& + & char( 0), char( 0), char( 0), char( 5), char( 0),& + & char( 0), char( 0), char( 0), char( 34), char( 4),& + & char( 0), char( 0), char( 0), char( 0), char( 0),& + & char( 0), char( 0), char( 0), char( 0), char( 0),& + & char( 12), char( 59), char( 0), char( 0), char( 0),& + & char( 0), char( 0), char( 1), char( 1), char( 0),& + & char( 0), char( 0), char( 1), char( 2), char( 1),& + & char( 0), char( 0), char( 0), char( 1), char( 0),& + & char( 0), char( 0), char( 21), char( 5), char( 0),& + & char( 0), char( 0), char( 4), char( 0), char( 0),& + & char( 65), char( 48), char( 0), char( 0), char( 0),& + & char( 1), char( 0), char( 1), char( 8), char( 0),& + & char( 0), char( 0), char( 0), char( 6), char( 6),& + & char(255), char( 0), char( 0), char( 0), char( 9),& + & char( 7), char( 0), char( 1), char( 1), char( 2),& + & char( 55), char( 55), char( 55), char( 55) /) + + ! Section 0. + integer :: listsec0(3) + + ! Section 1. + integer :: listsec1(13) + integer :: x_listsec1(13) = (/ 7, 4, 2, 24, 0, 2021, 11, 13, 15, 59, 59, 1, 0 /) + + ! Section 2. + integer, parameter :: lcsec2 = 3 + character :: csec2(lcsec2) = (/ char(1), char(2), char(3) /) + integer :: numlocal + + ! Section 3. + integer, parameter :: expected_len_sec3 = 72 + integer :: idefnum + integer :: ndpts + ! See https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_sect3.shtml + integer :: igds(5) + integer :: x_igds(5) = (/ 0, 4, 0, 0, 0/) + ! See https://www.nco.ncep.noaa.gov/pmb/docs/grib2/grib2_doc/grib2_temp3-0.shtml + integer :: igdstmpl(19) + integer :: x_igdstmpl(19) = (/ 0, 1, 1, 1, 1, 1, 1, 2, 2, 0, 0, 45, 91, 0, 55, 101, 5, 5, 0 /) + integer :: ideflist(1) + + ! Sections 4-7. + integer :: ipdsnum + integer :: numcoord = 0 + integer :: ipdstmpl(15) + integer :: x_ipdstmpl(15) = (/ 0, 0, 0, 0, 0, 12, 59, 0, 0, 1, 1, 1, 2, 1, 1 /) + integer :: coordlist(1) + integer :: idrsnum = 0 + integer :: idrstmpl(5) +! integer :: x_idrstmpl(5) = (/ 1093664768, 1, 1, 8, 0 /) + integer :: ibmap = 255 + logical :: bmap(4) + real :: fld(4) + real :: x_fld(4) = (/ 1.1, 1.2, 1.3, 1.4 /) + real, parameter :: EPSILON = .2 + integer :: numfields, maxvals(7) + integer :: x_maxvals(7) = (/ 3, 58, 1, 25, 1, 10, 4 /) + + ! For reading values. + integer :: idrslen, igdslen, ipdslen + type(gribfield) :: gfld + + ! For changing values for tests. + character :: old_val + character :: old_val_arr(4) + + integer :: i, ierr + + print *, '*** Testing gribcreate().' + + print *, '*** Testing getfield(). Expect and ignore error messages.' + + ! Request an invalid field - won't work. + call getfield(cgrib, lcgrib, 0, igds, igdstmpl, igdslen,& + & ideflist, idefnum, ipdsnum, ipdstmpl, ipdslen, coordlist,& + & numcoord, ndpts, idrsnum, idrstmpl, idrslen, ibmap, bmap,& + & fld, ierr) + if (ierr .ne. 3) stop 10 + + ! Change first char of message and try to get a field - won't work. + old_val = cgrib(1) + cgrib(1) = char(0) + call getfield(cgrib, lcgrib, 1, igds, igdstmpl, igdslen,& + & ideflist, idefnum, ipdsnum, ipdstmpl, ipdslen, coordlist,& + & numcoord, ndpts, idrsnum, idrstmpl, idrslen, ibmap, bmap,& + & fld, ierr) + if (ierr .ne. 1) stop 20 + cgrib(1) = old_val + + ! Change grib version number and try to get a field - won't work. + old_val = cgrib(8) + cgrib(8) = char(0) + call getfield(cgrib, lcgrib, 1, igds, igdstmpl, igdslen,& + & ideflist, idefnum, ipdsnum, ipdstmpl, ipdslen, coordlist,& + & numcoord, ndpts, idrsnum, idrstmpl, idrslen, ibmap, bmap,& + & fld, ierr) + if (ierr .ne. 2) stop 30 + cgrib(8) = old_val + + ! Request a field that's not present. + call getfield(cgrib, lcgrib, 2, igds, igdstmpl, igdslen,& + & ideflist, idefnum, ipdsnum, ipdstmpl, ipdslen, coordlist,& + & numcoord, ndpts, idrsnum, idrstmpl, idrslen, ibmap, bmap,& + & fld, ierr) + if (ierr .ne. 6) stop 40 + + ! Put an early end in the message and call getfield - will not work. + old_val_arr(1) = cgrib(17) + old_val_arr(2) = cgrib(18) + old_val_arr(3) = cgrib(19) + old_val_arr(4) = cgrib(20) + cgrib(17) = char(55) + cgrib(18) = char(55) + cgrib(19) = char(55) + cgrib(20) = char(55) + call getfield(cgrib, lcgrib, 1, igds, igdstmpl, igdslen,& + & ideflist, idefnum, ipdsnum, ipdstmpl, ipdslen, coordlist,& + & numcoord, ndpts, idrsnum, idrstmpl, idrslen, ibmap, bmap,& + & fld, ierr) + if (ierr .ne. 4) stop 45 + cgrib(17) = old_val_arr(1) + cgrib(18) = old_val_arr(2) + cgrib(19) = old_val_arr(3) + cgrib(20) = old_val_arr(4) + + ! Mess up section 3 and try to get a field - won't work. + old_val = cgrib(58) + cgrib(58) = char(99) + call getfield(cgrib, lcgrib, 1, igds, igdstmpl, igdslen,& + & ideflist, idefnum, ipdsnum, ipdstmpl, ipdslen, coordlist,& + & numcoord, ndpts, idrsnum, idrstmpl, idrslen, ibmap, bmap,& + & fld, ierr) + if (ierr .ne. 10) stop 46 + cgrib(58) = old_val + + ! Mess up section 4 and try to get a field - won't work. + old_val = cgrib(125) + cgrib(125) = char(99) + call getfield(cgrib, lcgrib, 1, igds, igdstmpl, igdslen,& + & ideflist, idefnum, ipdsnum, ipdstmpl, ipdslen, coordlist,& + & numcoord, ndpts, idrsnum, idrstmpl, idrslen, ibmap, bmap,& + & fld, ierr) + if (ierr .ne. 11) stop 47 + cgrib(125) = old_val + + ! Mess up section 5 and try to get a field - won't work. + old_val = cgrib(161) + cgrib(161) = char(99) + call getfield(cgrib, lcgrib, 1, igds, igdstmpl, igdslen,& + & ideflist, idefnum, ipdsnum, ipdstmpl, ipdslen, coordlist,& + & numcoord, ndpts, idrsnum, idrstmpl, idrslen, ibmap, bmap,& + & fld, ierr) + if (ierr .ne. 12) stop 48 + cgrib(161) = old_val + + ! Mess up section 6 and try to get a field - won't work. + old_val = cgrib(178) + cgrib(178) = char(99) + call getfield(cgrib, lcgrib, 1, igds, igdstmpl, igdslen,& + & ideflist, idefnum, ipdsnum, ipdstmpl, ipdslen, coordlist,& + & numcoord, ndpts, idrsnum, idrstmpl, idrslen, ibmap, bmap,& + & fld, ierr) + if (ierr .ne. 13) stop 49 + cgrib(178) = old_val + + ! Mess up end of message and call getfield - will not work. + old_val = cgrib(16) + cgrib(16) = char(0) + call getfield(cgrib, lcgrib, 1, igds, igdstmpl, igdslen,& + & ideflist, idefnum, ipdsnum, ipdstmpl, ipdslen, coordlist,& + & numcoord, ndpts, idrsnum, idrstmpl, idrslen, ibmap, bmap,& + & fld, ierr) + if (ierr .ne. 7) stop 45 + cgrib(16) = old_val + + ! Get the field. + call getfield(cgrib, lcgrib, 1, igds, igdstmpl, igdslen,& + & ideflist, idefnum, ipdsnum, ipdstmpl, ipdslen, coordlist,& + & numcoord, ndpts, idrsnum, idrstmpl, idrslen, ibmap, bmap,& + & fld, ierr) + if (ierr .ne. 0) stop 50 + + ! Check results. + if (igdslen .ne. 19) stop 200 + do i = 1, 5 + if (igds(i) .ne. x_igds(i)) stop 205 + end do + do i = 1, 19 + if (igdstmpl(i) .ne. x_igdstmpl(i)) stop 210 + end do + if (idefnum .ne. 0) stop 220 + if (ipdsnum .ne. 0) stop 230 + if (ipdslen .ne. 15) stop 240 + do i = 1, 15 + if (ipdstmpl(i) .ne. x_ipdstmpl(i)) stop 250 + end do + if (numcoord .ne. 0) stop 260 + if (ndpts .ne. 4) stop 270 + if (idrsnum .ne. 0) stop 280 + if (idrslen .ne. 5) stop 290 + if (ibmap .ne. 255) stop 300 + do i = 1, 4 + ! print *, fld(i), abs(fld(i) - x_fld(i)) + if (abs(fld(i) - x_fld(i)) .ge. EPSILON) stop 310 + end do + + print *, 'OK!' + print *, '*** Testing gf_getfld(). Expect and ignore error messages.' + + ! Try to read with bad field number - won't work. + call gf_getfld(cgrib, lcgrib, -1, .true., .true., gfld, ierr) + if (ierr .ne. 3) stop 500 + + ! Mess up first char and try to read - won't work. + old_val = cgrib(1) + cgrib(1) = char(0) + call gf_getfld(cgrib, lcgrib, 1, .true., .true., gfld, ierr) + if (ierr .ne. 1) stop 510 + cgrib(1) = old_val + + ! Change grib version number and try to get a field - won't work. + old_val = cgrib(8) + cgrib(8) = char(0) + call gf_getfld(cgrib, lcgrib, 1, .true., .true., gfld, ierr) + if (ierr .ne. 2) stop 520 + cgrib(8) = old_val + + ! Put an early end in the message and call getfield - will not work. + old_val_arr(1) = cgrib(17) + old_val_arr(2) = cgrib(18) + old_val_arr(3) = cgrib(19) + old_val_arr(4) = cgrib(20) + cgrib(17) = char(55) + cgrib(18) = char(55) + cgrib(19) = char(55) + cgrib(20) = char(55) + call gf_getfld(cgrib, lcgrib, 1, .true., .true., gfld, ierr) + if (ierr .ne. 4) stop 545 + cgrib(17) = old_val_arr(1) + cgrib(18) = old_val_arr(2) + cgrib(19) = old_val_arr(3) + cgrib(20) = old_val_arr(4) + + ! Mess up section 3 and try to get a field - won't work. + old_val = cgrib(58) + cgrib(58) = char(99) + call gf_getfld(cgrib, lcgrib, 1, .true., .true., gfld, ierr) + if (ierr .ne. 10) stop 547 + cgrib(58) = old_val + + ! Mess up section 4 and try to get a field - won't work. + old_val = cgrib(125) + cgrib(125) = char(99) + call gf_getfld(cgrib, lcgrib, 1, .true., .true., gfld, ierr) + if (ierr .ne. 11) stop 548 + cgrib(125) = old_val + + ! Mess up section 5 and try to get a field - won't work. + old_val = cgrib(161) + cgrib(161) = char(99) + call gf_getfld(cgrib, lcgrib, 1, .true., .true., gfld, ierr) + if (ierr .ne. 12) stop 549 + cgrib(161) = old_val + + ! ! Mess up section 6 and try to get a field - won't work. + ! old_val = cgrib(178) + ! cgrib(178) = char(99) + ! call gf_getfld(cgrib, lcgrib, 1, .true., .true., gfld, ierr) + ! if (ierr .ne. 13) stop 550 + ! cgrib(178) = old_val + + ! Mess up end of message and call getfield - will not work. + old_val = cgrib(16) + cgrib(16) = char(0) + call gf_getfld(cgrib, lcgrib, 1, .true., .true., gfld, ierr) + if (ierr .ne. 7) stop 551 + cgrib(16) = old_val + + ! Mess up section number and call getfield - will not work. + old_val = cgrib(21) + cgrib(21) = char(0) + call gf_getfld(cgrib, lcgrib, 1, .true., .true., gfld, ierr) + if (ierr .ne. 8) stop 552 + cgrib(21) = old_val + + ! Now read the same field with gf_getfld(). + call gf_getfld(cgrib, lcgrib, 1, .true., .true., gfld, ierr) + if (ierr .ne. 0) stop 600 + + ! Check results. + if (gfld%idsectlen .ne. 13) stop 800 + do i = 1, 13 + if (gfld%idsect(i) .ne. x_listsec1(i)) stop 810 + end do + if (gfld%locallen .ne. 3) stop 800 + do i = 1, 3 + if (gfld%local(i) .ne. csec2(i)) stop 810 + end do + if (gfld%igdtnum .ne. 0) stop 802 + if (gfld%igdtlen .ne. 19) stop 801 + do i = 1, 19 + if (gfld%igdtmpl(i) .ne. x_igdstmpl(i)) stop 810 + end do + if (idefnum .ne. 0) stop 820 + if (gfld%ipdtnum .ne. 0) stop 830 + if (gfld%ipdtlen .ne. 15) stop 840 + do i = 1, 15 + if (gfld%ipdtmpl(i) .ne. x_ipdstmpl(i)) stop 850 + end do + if (gfld%num_coord .ne. 0) stop 860 + if (gfld%ndpts .ne. 4) stop 870 + if (gfld%idrtnum .ne. 0) stop 880 + if (gfld%idrtlen .ne. 5) stop 890 + if (gfld%ibmap .ne. 255) stop 900 + do i = 1, 4 + ! print *, fld(i), abs(fld(i) - x_fld(i)) + if (abs(gfld%fld(i) - x_fld(i)) .ge. EPSILON) stop 910 + end do + + ! Free resources. + call gf_free(gfld) + + print *, 'OK!' + print *, '*** Testing gribinfo(). Expect and ignore error messages.' + + ! Mess up first char and try to read - won't work. + old_val = cgrib(1) + cgrib(1) = char(0) + call gribinfo(cgrib, lcgrib, listsec0, listsec1, numlocal, & + numfields, maxvals, ierr) + if (ierr .ne. 1) stop 510 + cgrib(1) = old_val + + ! Change grib version number and try to get a field - won't work. + old_val = cgrib(8) + cgrib(8) = char(0) + call gribinfo(cgrib, lcgrib, listsec0, listsec1, numlocal, & + numfields, maxvals, ierr) + if (ierr .ne. 2) stop 520 + cgrib(8) = old_val + + ! Put an early end in the message and call getfield - will not work. + old_val_arr(1) = cgrib(38) + old_val_arr(2) = cgrib(39) + old_val_arr(3) = cgrib(40) + old_val_arr(4) = cgrib(41) + cgrib(38) = char(55) + cgrib(39) = char(55) + cgrib(40) = char(55) + cgrib(41) = char(55) + call gribinfo(cgrib, lcgrib, listsec0, listsec1, numlocal, & + numfields, maxvals, ierr) + if (ierr .ne. 4) stop 521 + cgrib(38) = old_val_arr(1) + cgrib(39) = old_val_arr(2) + cgrib(40) = old_val_arr(3) + cgrib(41) = old_val_arr(4) + + ! Mess up section length end of message and call getfield - will not work. + old_val = cgrib(40) + cgrib(40) = char(99) + call gribinfo(cgrib, lcgrib, listsec0, listsec1, numlocal, & + numfields, maxvals, ierr) + if (ierr .ne. 5) stop 522 + cgrib(40) = old_val + + ! Call gribinfo(). + call gribinfo(cgrib, lcgrib, listsec0, listsec1, numlocal, & + numfields, maxvals, ierr) + if (ierr .ne. 0) stop 915 + + ! Check results. + if (listsec0(1) .ne. 0 .or. listsec0(2) .ne. 2) stop 920 + if (listsec0(3) .ne. lcgrib) stop 921 + do i = 1, 13 + if (listsec1(i) .ne. x_listsec1(i)) stop 922 + end do + if (numlocal .ne. 1) stop 923 + if (numfields .ne. 1) stop 924 + do i = 1, 7 + if (maxvals(i) .ne. x_maxvals(i)) stop 925 + end do + + print *, 'SUCCESS!' + +end program test_getfield diff --git a/tests/test_getpoly.F90 b/tests/test_getpoly.F90 new file mode 100644 index 00000000..03ef8e81 --- /dev/null +++ b/tests/test_getpoly.F90 @@ -0,0 +1,37 @@ +! test getpoly.F90 +! Author Brian Curtis 2021/12/21 + +program test_getpoly + implicit none + + integer, parameter :: lcsec3 = 72 + character(len=1) :: csec3(lcsec3) + integer :: jj, kk, mm + + csec3 = (/ achar(0), achar(0), achar(0), achar(72), & + achar(3), achar(0), achar(0), achar(0), achar(0), achar(4), achar(0), achar(0), achar(0), achar(0), achar(0), & + achar(1), achar(0), achar(0), achar(0), achar(2), achar(3), achar(0), achar(0), achar(0), achar(4), achar(5), & + achar(0), achar(0), achar(0), achar(6), achar(0), achar(0), achar(0), achar(7), achar(0), achar(0), achar(0), & + achar(8), achar(0), achar(0), achar(0), achar(9), achar(0), achar(0), achar(0), achar(10), achar(0), achar(0), & + achar(0), achar(11), achar(0), achar(0), achar(0), achar(12), achar(13), achar(0), achar(0), achar(0), achar(14), & + achar(0), achar(0), achar(0), achar(15), achar(0), achar(0), achar(0), achar(16), achar(0), achar(0), achar(0), & + achar(17), achar(18) /) + + call getpoly(csec3, lcsec3, jj, kk, mm) + + ! Grid template number not 50:53, values should all be 0 + if (jj .ne. 0) stop 10 + if (kk .ne. 0) stop 20 + if (mm .ne. 0) stop 30 + + ! Lets get into the igds(5) 50:53 section of code + csec3(13) = achar(0) + csec3(14) = achar(51) + + call getpoly(csec3, lcsec3, jj, kk, mm) + if (jj .ne. 65536) stop 40 + if (kk .ne. 131840) stop 50 + if (mm .ne. 1029) stop 60 + +end program test_getpoly + diff --git a/tests/test_gridtemplates.F90 b/tests/test_gridtemplates.F90 new file mode 100644 index 00000000..bd2554c1 --- /dev/null +++ b/tests/test_gridtemplates.F90 @@ -0,0 +1,58 @@ +! This program tests the gridtemplates module of the NCEPLIBS-g2 +! project. +! +! Ed Hartnett 9/30/21 +program test_gridtemplates + use gridtemplates + implicit none + + integer :: index, t + integer, dimension(MAXTEMP):: template_num = (/ 0, 1, 2, 3, 10, 20, & + 30, 40, 41, 42, 43, 50, 51, 52, 53, 90, 100, 110, 120, 1000, & + 1100, 1200, 31, 204, 32768, 32769, 4, 5, 12, 101, 140/) + integer :: nummap + integer, parameter :: lat_lon_mapgridlen = 19 + integer :: map(20) + integer :: list_4(lat_lon_mapgridlen) + logical :: needext + integer :: gdtlen + integer :: iret + + print *, 'Testing the gridtemplates module.' + + print *, 'Testing getgridindex...' + do t = 1, MAXTEMP + index = getgridindex(template_num(t)) + if (index .ne. t) stop 2 + enddo + + print *, 'Testing getgridtemplate...' + call getgridtemplate(0, nummap, map, needext, iret) + if (nummap .ne. lat_lon_mapgridlen .or. needext) stop 3 + + print *, 'Testing getgridtemplate 4, which needs extension...' + ! An extra 6 values are added to the map. + call getgridtemplate(4, nummap, map, needext, iret) + if (nummap .ne. 13 .or. .not. needext) stop 4 + list_4(8) = 2 + list_4(9) = 2 + call extgridtemplate(4, list_4, nummap, map) + if (nummap .ne. 17) stop 5 + if (map(14) .ne. 4 .or. map(15) .ne. 4 .or. map(16) .ne. -4 .or. map(17) .ne. -4) stop 6 + + print *, 'Testing getgridtemplate 5, which needs extension...' + call getgridtemplate(5, nummap, map, needext, iret) + if (nummap .ne. 16 .or. .not. needext) stop 40 + list_4(8) = 2 + list_4(9) = 2 + call extgridtemplate(5, list_4, nummap, map) + if (nummap .ne. 20) stop 50 + if (map(17) .ne. 4 .or. map(18) .ne. 4 .or. map(19) .ne. -4 .or. map(20) .ne. -4) stop 60 + + print *, 'Testing getgdtlen...' + gdtlen = getgdtlen(0) + if (gdtlen .ne. lat_lon_mapgridlen) stop 400 + + print *, 'SUCCESS!' + +end program test_gridtemplates diff --git a/tests/test_intmath.F90 b/tests/test_intmath.F90 new file mode 100644 index 00000000..04ef599a --- /dev/null +++ b/tests/test_intmath.F90 @@ -0,0 +1,39 @@ +! This is a test program for NCEPLIBS-g2. It tests the intmath module. +! +! Ed Hartnett, 12/22/21 +program test_intmath + use intmath + implicit none + real(kind = 16), parameter :: alog2 = log(2.0_16) + integer(kind = 8) :: ival8 = 10, iret8 + integer(kind = 4) :: ival4 = 10, iret4 + integer(kind = 2) :: ival2 = 10_2, iret2 + integer(kind = 1) :: ival1 = 10_1, iret1 + + print *, 'Testing intmath...' + + print *, 'Testing i1log2()...' + iret8 = i1log2(ival8) + if (iret8 .ne. 4) stop 2 + iret4 = i1log2(ival4) + if (iret4 .ne. 4) stop 2 + iret2 = i1log2(ival2) + if (iret2 .ne. 4) stop 2 + iret1 = i1log2(ival1) + if (iret1 .ne. 4) stop 2 + print *, 'ok' + + print *, 'Testing ilog2()...' + iret8 = ilog2(ival8) + if (iret8 .ne. 4) stop 2 + iret4 = ilog2(ival4) + if (iret4 .ne. 4) stop 2 + iret2 = ilog2(ival2) + if (iret2 .ne. 4) stop 2 + iret1 = ilog2(ival1) + if (iret1 .ne. 4) stop 2 + print *, 'ok' + + print *, 'SUCCESS!' +end program test_intmath + diff --git a/tests/test_mkieee.F90 b/tests/test_mkieee.F90 new file mode 100644 index 00000000..8a4c6b57 --- /dev/null +++ b/tests/test_mkieee.F90 @@ -0,0 +1,36 @@ +! Test the mkieee and rdieee functions in NCEPLIBS-g2 +! +! These functions only make sense when KIND == 4. +! +! Brian Curtis 2022/02/01 +! Ed Hartnett + +program test_mkieee + implicit none + +#if KIND == 4 + integer, parameter :: num = 4 + real :: rieee(num) + real :: a(num) = (/ 4.3000000, 5.6000000, 1.6700000, 2.3300000 /) + real :: b(num) + integer :: i + + print *, 'Testing mkieee and rdieee ...' + + call mkieee(a, rieee, num) + + do i = 1, num + if (abs(a(i) - rieee(i)) .gt. .00001) stop 10 + end do + + call rdieee(rieee, b, num) + + do i = 1, num + print *, i, a(i), b(i) + if (abs(a(i) - b(i)) .gt. .00001) stop 20 + end do +#endif + + print *, '... Success!' + +end program test_mkieee diff --git a/tests/test_params.F90 b/tests/test_params.F90 new file mode 100644 index 00000000..1583c993 --- /dev/null +++ b/tests/test_params.F90 @@ -0,0 +1,3591 @@ +! This program tests the params module of the NCEPLIBS-g2 +! project. +! +! Ed Hartnett 10/1/21 +program test_params + use params + implicit none + + integer :: g2disc, g2cat, g2num, g1val, g1ver + character(len=8) :: abbrev + integer :: LU = 10; + integer :: g1_table_version, g1_val, g2_discipline, g2_category, g2_param_num + character(len = 8) :: g2_abbrev + integer :: ios, i + + print *, 'Testing the params module.' + + print *, 'Testing param_g1_to_g2...' + call param_g1_to_g2(1, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 0) stop 2 + call param_g1_to_g2(47, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 0) stop 3 + + print *, 'Testing param_get_abbrev...' + abbrev = param_get_abbrev(0, 3, 1) + if (abbrev .ne. 'PRMSL') stop 4 + abbrev = param_get_abbrev(0, 3, 8) + if (abbrev .ne. 'PRESA') stop 4 + + print *, 'Testing param_g2_to_g1...' + call param_g2_to_g1(0, 3, 1, g1val, g1ver) + if (g1val .ne. 2 .or. g1ver .ne. 2) stop 6 + call param_g2_to_g1(0, 2, 0, g1val, g1ver) + if (g1val .ne. 31 .or. g1ver .ne. 2) stop 7 + + ! Check all abb + abbrev = param_get_abbrev(0, 3, 1) + if (abbrev .ne. 'PRMSL') stop 4 + abbrev = param_get_abbrev(0, 3, 0) + if (abbrev .ne. 'PRES') stop 5 + abbrev = param_get_abbrev(0, 3, 1) + if (abbrev .ne. 'PRMSL') stop 5 + abbrev = param_get_abbrev(0, 3, 2) + if (abbrev .ne. 'PTEND') stop 5 + abbrev = param_get_abbrev(0, 2, 14) + if (abbrev .ne. 'PVORT') stop 5 + abbrev = param_get_abbrev(0, 3, 3) + if (abbrev .ne. 'ICAHT') stop 5 + abbrev = param_get_abbrev(0, 3, 4) + if (abbrev .ne. 'GP') stop 5 + abbrev = param_get_abbrev(0, 3, 5) + if (abbrev .ne. 'HGT') stop 5 + abbrev = param_get_abbrev(0, 3, 6) + if (abbrev .ne. 'DIST') stop 5 + abbrev = param_get_abbrev(0, 3, 7) + if (abbrev .ne. 'HSTDV') stop 5 + abbrev = param_get_abbrev(0, 14, 0) + if (abbrev .ne. 'TOZNE') stop 5 + abbrev = param_get_abbrev(0, 0, 0) + if (abbrev .ne. 'TMP') stop 5 + abbrev = param_get_abbrev(0, 0, 1) + if (abbrev .ne. 'VTMP') stop 5 + abbrev = param_get_abbrev(0, 0, 2) + if (abbrev .ne. 'POT') stop 5 + abbrev = param_get_abbrev(0, 0, 3) + if (abbrev .ne. 'EPOT') stop 5 + abbrev = param_get_abbrev(0, 0, 4) + if (abbrev .ne. 'TMAX') stop 5 + abbrev = param_get_abbrev(0, 0, 5) + if (abbrev .ne. 'TMIN') stop 5 + abbrev = param_get_abbrev(0, 0, 6) + if (abbrev .ne. 'DPT') stop 5 + abbrev = param_get_abbrev(0, 0, 7) + if (abbrev .ne. 'DEPR') stop 5 + abbrev = param_get_abbrev(0, 0, 8) + if (abbrev .ne. 'LAPR') stop 5 + abbrev = param_get_abbrev(0, 19, 0) + if (abbrev .ne. 'VIS') stop 5 + abbrev = param_get_abbrev(0, 15, 6) + if (abbrev .ne. 'RDSP1') stop 5 + abbrev = param_get_abbrev(0, 15, 7) + if (abbrev .ne. 'RDSP2') stop 5 + abbrev = param_get_abbrev(0, 15, 8) + if (abbrev .ne. 'RDSP3') stop 5 + abbrev = param_get_abbrev(0, 7, 0) + if (abbrev .ne. 'PLI') stop 5 + abbrev = param_get_abbrev(0, 0, 9) + if (abbrev .ne. 'TMPA') stop 5 + abbrev = param_get_abbrev(0, 3, 8) + if (abbrev .ne. 'PRESA') stop 5 + abbrev = param_get_abbrev(0, 3, 9) + if (abbrev .ne. 'GPA') stop 5 + abbrev = param_get_abbrev(10, 0, 0) + if (abbrev .ne. 'WVSP1') stop 5 + abbrev = param_get_abbrev(10, 0, 1) + if (abbrev .ne. 'WVSP2') stop 5 + abbrev = param_get_abbrev(10, 0, 2) + if (abbrev .ne. 'WVSP3') stop 5 + abbrev = param_get_abbrev(0, 2, 0) + if (abbrev .ne. 'WDIR') stop 5 + abbrev = param_get_abbrev(0, 2, 1) + if (abbrev .ne. 'WIND') stop 5 + abbrev = param_get_abbrev(0, 2, 2) + if (abbrev .ne. 'UGRD') stop 5 + abbrev = param_get_abbrev(0, 2, 3) + if (abbrev .ne. 'VGRD') stop 5 + abbrev = param_get_abbrev(0, 2, 4) + if (abbrev .ne. 'STRM') stop 5 + abbrev = param_get_abbrev(0, 2, 5) + if (abbrev .ne. 'VPOT') stop 5 + abbrev = param_get_abbrev(0, 2, 6) + if (abbrev .ne. 'MNTSF') stop 5 + abbrev = param_get_abbrev(0, 2, 7) + if (abbrev .ne. 'SGCVV') stop 5 + abbrev = param_get_abbrev(0, 2, 8) + if (abbrev .ne. 'VVEL') stop 5 + abbrev = param_get_abbrev(0, 2, 9) + if (abbrev .ne. 'DZDT') stop 5 + abbrev = param_get_abbrev(0, 2, 10) + if (abbrev .ne. 'ABSV') stop 5 + abbrev = param_get_abbrev(0, 2, 11) + if (abbrev .ne. 'ABSD') stop 5 + abbrev = param_get_abbrev(0, 2, 12) + if (abbrev .ne. 'RELV') stop 5 + abbrev = param_get_abbrev(0, 2, 13) + if (abbrev .ne. 'RELD') stop 5 + abbrev = param_get_abbrev(0, 2, 15) + if (abbrev .ne. 'VUCSH') stop 5 + abbrev = param_get_abbrev(0, 2, 16) + if (abbrev .ne. 'VVCSH') stop 5 + abbrev = param_get_abbrev(10, 1, 0) + if (abbrev .ne. 'DIRC') stop 5 + abbrev = param_get_abbrev(10, 1, 1) + if (abbrev .ne. 'SPC') stop 5 + abbrev = param_get_abbrev(10, 1, 2) + if (abbrev .ne. 'UOGRD') stop 5 + abbrev = param_get_abbrev(10, 1, 3) + if (abbrev .ne. 'VOGRD') stop 5 + abbrev = param_get_abbrev(0, 1, 0) + if (abbrev .ne. 'SPFH') stop 5 + abbrev = param_get_abbrev(0, 1, 1) + if (abbrev .ne. 'RH') stop 5 + abbrev = param_get_abbrev(0, 1, 2) + if (abbrev .ne. 'MIXR') stop 5 + abbrev = param_get_abbrev(0, 1, 3) + if (abbrev .ne. 'PWAT') stop 5 + abbrev = param_get_abbrev(0, 1, 4) + if (abbrev .ne. 'VAPP') stop 5 + abbrev = param_get_abbrev(0, 1, 5) + if (abbrev .ne. 'SATD') stop 5 + abbrev = param_get_abbrev(0, 1, 6) + if (abbrev .ne. 'EVP') stop 5 + abbrev = param_get_abbrev(0, 6, 0) + if (abbrev .ne. 'CICE') stop 5 + abbrev = param_get_abbrev(0, 1, 7) + if (abbrev .ne. 'PRATE') stop 5 + abbrev = param_get_abbrev(0, 19, 2) + if (abbrev .ne. 'TSTM') stop 5 + abbrev = param_get_abbrev(0, 1, 8) + if (abbrev .ne. 'APCP') stop 5 + abbrev = param_get_abbrev(0, 1, 9) + if (abbrev .ne. 'NCPCP') stop 5 + abbrev = param_get_abbrev(0, 1, 10) + if (abbrev .ne. 'ACPCP') stop 5 + abbrev = param_get_abbrev(0, 1, 12) + if (abbrev .ne. 'SRWEQ') stop 5 + abbrev = param_get_abbrev(0, 1, 13) + if (abbrev .ne. 'WEASD') stop 5 + abbrev = param_get_abbrev(0, 1, 11) + if (abbrev .ne. 'SNOD') stop 5 + abbrev = param_get_abbrev(0, 19, 3) + if (abbrev .ne. 'MIXHT') stop 5 + abbrev = param_get_abbrev(10, 4, 2) + if (abbrev .ne. 'TTHDP') stop 5 + abbrev = param_get_abbrev(10, 4, 0) + if (abbrev .ne. 'MTHD') stop 5 + abbrev = param_get_abbrev(10, 4, 1) + if (abbrev .ne. 'MTHA') stop 5 + abbrev = param_get_abbrev(0, 6, 1) + if (abbrev .ne. 'TCDC') stop 5 + abbrev = param_get_abbrev(0, 6, 2) + if (abbrev .ne. 'CDCON') stop 5 + abbrev = param_get_abbrev(0, 6, 3) + if (abbrev .ne. 'LCDC') stop 5 + abbrev = param_get_abbrev(0, 6, 4) + if (abbrev .ne. 'MCDC') stop 5 + abbrev = param_get_abbrev(0, 6, 5) + if (abbrev .ne. 'HCDC') stop 5 + abbrev = param_get_abbrev(0, 6, 6) + if (abbrev .ne. 'CWAT') stop 5 + abbrev = param_get_abbrev(0, 7, 1) + if (abbrev .ne. 'BLI') stop 5 + abbrev = param_get_abbrev(0, 1, 14) + if (abbrev .ne. 'SNOC') stop 5 + abbrev = param_get_abbrev(0, 1, 15) + if (abbrev .ne. 'SNOL') stop 5 + abbrev = param_get_abbrev(10, 3, 0) + if (abbrev .ne. 'WTMP') stop 5 + abbrev = param_get_abbrev(2, 0, 0) + if (abbrev .ne. 'LAND') stop 5 + abbrev = param_get_abbrev(10, 3, 1) + if (abbrev .ne. 'DSLM') stop 5 + abbrev = param_get_abbrev(2, 0, 1) + if (abbrev .ne. 'SFCR') stop 5 + abbrev = param_get_abbrev(0, 19, 1) + if (abbrev .ne. 'ALBDO') stop 5 + abbrev = param_get_abbrev(2, 0, 2) + if (abbrev .ne. 'TSOIL') stop 5 + abbrev = param_get_abbrev(2, 0, 3) + if (abbrev .ne. 'SOILM') stop 5 + abbrev = param_get_abbrev(2, 0, 4) + if (abbrev .ne. 'VEG') stop 5 + abbrev = param_get_abbrev(10, 4, 3) + if (abbrev .ne. 'SALTY') stop 5 + abbrev = param_get_abbrev(0, 3, 10) + if (abbrev .ne. 'DEN') stop 5 + abbrev = param_get_abbrev(2, 0, 5) + if (abbrev .ne. 'WATR') stop 5 + abbrev = param_get_abbrev(10, 2, 0) + if (abbrev .ne. 'ICEC') stop 5 + abbrev = param_get_abbrev(10, 2, 1) + if (abbrev .ne. 'ICETK') stop 5 + abbrev = param_get_abbrev(10, 2, 2) + if (abbrev .ne. 'DICED') stop 5 + abbrev = param_get_abbrev(10, 2, 3) + if (abbrev .ne. 'SICED') stop 5 + abbrev = param_get_abbrev(10, 2, 4) + if (abbrev .ne. 'UICE') stop 5 + abbrev = param_get_abbrev(10, 2, 5) + if (abbrev .ne. 'VICE') stop 5 + abbrev = param_get_abbrev(10, 2, 6) + if (abbrev .ne. 'ICEG') stop 5 + abbrev = param_get_abbrev(10, 2, 7) + if (abbrev .ne. 'ICED') stop 5 + abbrev = param_get_abbrev(0, 1, 16) + if (abbrev .ne. 'SNOM') stop 5 + abbrev = param_get_abbrev(10, 0, 3) + if (abbrev .ne. 'HTSGW') stop 5 + abbrev = param_get_abbrev(10, 0, 4) + if (abbrev .ne. 'WVDIR') stop 5 + abbrev = param_get_abbrev(10, 0, 5) + if (abbrev .ne. 'WVHGT') stop 5 + abbrev = param_get_abbrev(10, 0, 6) + if (abbrev .ne. 'WVPER') stop 5 + abbrev = param_get_abbrev(10, 0, 7) + if (abbrev .ne. 'SWDIR') stop 5 + abbrev = param_get_abbrev(10, 0, 8) + if (abbrev .ne. 'SWELL') stop 5 + abbrev = param_get_abbrev(10, 0, 9) + if (abbrev .ne. 'SWPER') stop 5 + abbrev = param_get_abbrev(10, 0, 10) + if (abbrev .ne. 'DIRPW') stop 5 + abbrev = param_get_abbrev(10, 0, 11) + if (abbrev .ne. 'PERPW') stop 5 + abbrev = param_get_abbrev(10, 0, 12) + if (abbrev .ne. 'DIRSW') stop 5 + abbrev = param_get_abbrev(10, 0, 13) + if (abbrev .ne. 'PERSW') stop 5 + abbrev = param_get_abbrev(0, 4, 0) + if (abbrev .ne. 'NSWRS') stop 5 + abbrev = param_get_abbrev(0, 5, 0) + if (abbrev .ne. 'NLWRS') stop 5 + abbrev = param_get_abbrev(0, 4, 1) + if (abbrev .ne. 'NSWRT') stop 5 + abbrev = param_get_abbrev(0, 5, 1) + if (abbrev .ne. 'NLWRT') stop 5 + abbrev = param_get_abbrev(0, 5, 2) + if (abbrev .ne. 'LWAVR') stop 5 + abbrev = param_get_abbrev(0, 4, 2) + if (abbrev .ne. 'SWAVR') stop 5 + abbrev = param_get_abbrev(0, 4, 3) + if (abbrev .ne. 'GRAD') stop 5 + abbrev = param_get_abbrev(0, 4, 4) + if (abbrev .ne. 'BRTMP') stop 5 + abbrev = param_get_abbrev(0, 4, 5) + if (abbrev .ne. 'LWRAD') stop 5 + abbrev = param_get_abbrev(0, 4, 6) + if (abbrev .ne. 'SWRAD') stop 5 + abbrev = param_get_abbrev(0, 0, 10) + if (abbrev .ne. 'LHTFL') stop 5 + abbrev = param_get_abbrev(0, 0, 11) + if (abbrev .ne. 'SHTFL') stop 5 + abbrev = param_get_abbrev(0, 2, 20) + if (abbrev .ne. 'BLYDP') stop 5 + abbrev = param_get_abbrev(0, 2, 17) + if (abbrev .ne. 'UFLX') stop 5 + abbrev = param_get_abbrev(0, 2, 18) + if (abbrev .ne. 'VFLX') stop 5 + abbrev = param_get_abbrev(0, 2, 19) + if (abbrev .ne. 'WMIXE') stop 5 + abbrev = param_get_abbrev(255, 255, 255) + if (abbrev .ne. 'IMGD') stop 5 + abbrev = param_get_abbrev(0, 0, 192) + if (abbrev .ne. 'SNOHF') stop 5 + abbrev = param_get_abbrev(0, 1, 22) + if (abbrev .ne. 'CLWMR') stop 5 + abbrev = param_get_abbrev(0, 1, 192) + if (abbrev .ne. 'CRAIN') stop 5 + abbrev = param_get_abbrev(0, 1, 193) + if (abbrev .ne. 'CFRZR') stop 5 + abbrev = param_get_abbrev(0, 1, 194) + if (abbrev .ne. 'CICEP') stop 5 + abbrev = param_get_abbrev(0, 1, 195) + if (abbrev .ne. 'CSNOW') stop 5 + abbrev = param_get_abbrev(0, 1, 196) + if (abbrev .ne. 'CPRAT') stop 5 + abbrev = param_get_abbrev(0, 1, 197) + if (abbrev .ne. 'MCONV') stop 5 + abbrev = param_get_abbrev(1, 1, 193) + if (abbrev .ne. 'CPOFP') stop 5 + abbrev = param_get_abbrev(0, 1, 199) + if (abbrev .ne. 'PEVAP') stop 5 + abbrev = param_get_abbrev(0, 2, 192) + if (abbrev .ne. 'VWSH') stop 5 + abbrev = param_get_abbrev(0, 2, 193) + if (abbrev .ne. 'MFLX') stop 5 + abbrev = param_get_abbrev(0, 2, 194) + if (abbrev .ne. 'USTM') stop 5 + abbrev = param_get_abbrev(0, 2, 195) + if (abbrev .ne. 'VSTM') stop 5 + abbrev = param_get_abbrev(0, 2, 196) + if (abbrev .ne. 'CD') stop 5 + abbrev = param_get_abbrev(0, 2, 197) + if (abbrev .ne. 'FRICV') stop 5 + abbrev = param_get_abbrev(0, 3, 192) + if (abbrev .ne. 'MSLET') stop 5 + abbrev = param_get_abbrev(0, 4, 192) + if (abbrev .ne. 'DSWRF') stop 5 + abbrev = param_get_abbrev(0, 4, 193) + if (abbrev .ne. 'USWRF') stop 5 + abbrev = param_get_abbrev(0, 5, 192) + if (abbrev .ne. 'DLWRF') stop 5 + abbrev = param_get_abbrev(0, 5, 193) + if (abbrev .ne. 'ULWRF') stop 5 + abbrev = param_get_abbrev(0, 6, 192) + if (abbrev .ne. 'CDLYR') stop 5 + abbrev = param_get_abbrev(0, 7, 193) + if (abbrev .ne. '4LFTX') stop 5 + abbrev = param_get_abbrev(0, 7, 6) + if (abbrev .ne. 'CAPE') stop 5 + abbrev = param_get_abbrev(0, 7, 7) + if (abbrev .ne. 'CIN') stop 5 + abbrev = param_get_abbrev(0, 7, 8) + if (abbrev .ne. 'HLCY') stop 5 + abbrev = param_get_abbrev(0, 7, 192) + if (abbrev .ne. 'LFTX') stop 5 + abbrev = param_get_abbrev(0, 19, 11) + if (abbrev .ne. 'TKE') stop 5 + abbrev = param_get_abbrev(0, 191, 192) + if (abbrev .ne. 'NLAT') stop 5 + abbrev = param_get_abbrev(0, 191, 193) + if (abbrev .ne. 'ELON') stop 5 + abbrev = param_get_abbrev(1, 0, 192) + if (abbrev .ne. 'BGRUN') stop 5 + abbrev = param_get_abbrev(1, 0, 193) + if (abbrev .ne. 'SSRUN') stop 5 + abbrev = param_get_abbrev(2, 0, 192) + if (abbrev .ne. 'SOILW') stop 5 + abbrev = param_get_abbrev(2, 0, 193) + if (abbrev .ne. 'GFLUX') stop 5 + abbrev = param_get_abbrev(2, 0, 194) + if (abbrev .ne. 'MSTAV') stop 5 + abbrev = param_get_abbrev(2, 0, 195) + if (abbrev .ne. 'SFEXC') stop 5 + abbrev = param_get_abbrev(2, 0, 196) + if (abbrev .ne. 'CNWAT') stop 5 + abbrev = param_get_abbrev(2, 0, 197) + if (abbrev .ne. 'BMIXL') stop 5 + abbrev = param_get_abbrev(0, 14, 192) + if (abbrev .ne. 'O3MR') stop 5 + abbrev = param_get_abbrev(0, 3, 193) + if (abbrev .ne. '5WAVH') stop 5 + abbrev = param_get_abbrev(0, 1, 200) + if (abbrev .ne. 'PEVPR') stop 5 + abbrev = param_get_abbrev(0, 6, 193) + if (abbrev .ne. 'CWORK') stop 5 + abbrev = param_get_abbrev(0, 3, 194) + if (abbrev .ne. 'U-GWD') stop 5 + abbrev = param_get_abbrev(0, 3, 195) + if (abbrev .ne. 'V-GWD') stop 5 + abbrev = param_get_abbrev(0, 3, 196) + if (abbrev .ne. 'HPBL') stop 5 + abbrev = param_get_abbrev(0, 3, 197) + if (abbrev .ne. '5WAVA') stop 5 + abbrev = param_get_abbrev(2, 3, 192) + if (abbrev .ne. 'SOILL') stop 5 + abbrev = param_get_abbrev(2, 3, 193) + if (abbrev .ne. 'RLYRS') stop 5 + abbrev = param_get_abbrev(2, 0, 201) + if (abbrev .ne. 'WILT') stop 5 + abbrev = param_get_abbrev(2, 3, 194) + if (abbrev .ne. 'SLTYP') stop 5 + abbrev = param_get_abbrev(2, 3, 0) + if (abbrev .ne. 'SOTYP') stop 5 + abbrev = param_get_abbrev(2, 0, 198) + if (abbrev .ne. 'VGTYP') stop 5 + abbrev = param_get_abbrev(2, 3, 195) + if (abbrev .ne. 'SMREF') stop 5 + abbrev = param_get_abbrev(2, 3, 196) + if (abbrev .ne. 'SMDRY') stop 5 + abbrev = param_get_abbrev(0, 1, 201) + if (abbrev .ne. 'SNOWC') stop 5 + abbrev = param_get_abbrev(2, 3, 197) + if (abbrev .ne. 'POROS') stop 5 + abbrev = param_get_abbrev(0, 1, 202) + if (abbrev .ne. 'FRAIN') stop 5 + abbrev = param_get_abbrev(0, 6, 199) + if (abbrev .ne. 'FICE') stop 5 + abbrev = param_get_abbrev(0, 1, 203) + if (abbrev .ne. 'RIME') stop 5 + abbrev = param_get_abbrev(0, 6, 194) + if (abbrev .ne. 'CUEFI') stop 5 + abbrev = param_get_abbrev(0, 6, 195) + if (abbrev .ne. 'TCOND') stop 5 + abbrev = param_get_abbrev(0, 6, 196) + if (abbrev .ne. 'TCOLW') stop 5 + abbrev = param_get_abbrev(0, 6, 197) + if (abbrev .ne. 'TCOLI') stop 5 + abbrev = param_get_abbrev(0, 1, 204) + if (abbrev .ne. 'TCOLR') stop 5 + abbrev = param_get_abbrev(0, 1, 205) + if (abbrev .ne. 'TCOLS') stop 5 + abbrev = param_get_abbrev(0, 6, 198) + if (abbrev .ne. 'TCOLC') stop 5 + abbrev = param_get_abbrev(0, 19, 192) + if (abbrev .ne. 'MXSALB') stop 5 + abbrev = param_get_abbrev(0, 19, 193) + if (abbrev .ne. 'SNFALB') stop 5 + abbrev = param_get_abbrev(0, 1, 24) + if (abbrev .ne. 'RWMR') stop 5 + abbrev = param_get_abbrev(0, 1, 25) + if (abbrev .ne. 'SNMR') stop 5 + abbrev = param_get_abbrev(2, 0, 199) + if (abbrev .ne. 'CCOND') stop 5 + abbrev = param_get_abbrev(2, 0, 200) + if (abbrev .ne. 'RSMIN') stop 5 + abbrev = param_get_abbrev(2, 0, 202) + if (abbrev .ne. 'RCS') stop 5 + abbrev = param_get_abbrev(2, 0, 203) + if (abbrev .ne. 'RCT') stop 5 + abbrev = param_get_abbrev(2, 0, 204) + if (abbrev .ne. 'RCQ') stop 5 + abbrev = param_get_abbrev(2, 0, 205) + if (abbrev .ne. 'RCSOL') stop 5 + abbrev = param_get_abbrev(0, 7, 194) + if (abbrev .ne. 'RI') stop 5 + abbrev = param_get_abbrev(3, 1, 192) + if (abbrev .ne. 'USCT') stop 5 + abbrev = param_get_abbrev(3, 1, 193) + if (abbrev .ne. 'VSCT') stop 5 + abbrev = param_get_abbrev(0, 191, 194) + if (abbrev .ne. 'TSEC') stop 5 + abbrev = param_get_abbrev(0, 14, 193) + if (abbrev .ne. 'OZCON') stop 5 + abbrev = param_get_abbrev(0, 14, 194) + if (abbrev .ne. 'OZCAT') stop 5 + abbrev = param_get_abbrev(1, 1, 2) + if (abbrev .ne. 'POP') stop 5 + abbrev = param_get_abbrev(1, 1, 192) + if (abbrev .ne. 'CPOZP') stop 5 + abbrev = param_get_abbrev(0, 2, 22) + if (abbrev .ne. 'GUST') stop 5 + abbrev = param_get_abbrev(0, 2, 0) + if (abbrev .ne. 'WDIR') stop 5 + abbrev = param_get_abbrev(0, 2, 1) + if (abbrev .ne. 'WIND') stop 5 + abbrev = param_get_abbrev(0, 2, 2) + if (abbrev .ne. 'UGRD') stop 5 + abbrev = param_get_abbrev(0, 2, 3) + if (abbrev .ne. 'VGRD') stop 5 + abbrev = param_get_abbrev(10, 0, 3) + if (abbrev .ne. 'HTSGW') stop 5 + abbrev = param_get_abbrev(10, 0, 4) + if (abbrev .ne. 'WVDIR') stop 5 + abbrev = param_get_abbrev(10, 0, 6) + if (abbrev .ne. 'WVPER') stop 5 + abbrev = param_get_abbrev(10, 0, 10) + if (abbrev .ne. 'DIRPW') stop 5 + abbrev = param_get_abbrev(10, 0, 11) + if (abbrev .ne. 'PERPW') stop 5 + abbrev = param_get_abbrev(10, 0, 12) + if (abbrev .ne. 'DIRSW') stop 5 + abbrev = param_get_abbrev(10, 0, 13) + if (abbrev .ne. 'PERSW') stop 5 + abbrev = param_get_abbrev(0, 13, 192) + if (abbrev .ne. 'PMTC') stop 5 + abbrev = param_get_abbrev(0, 13, 193) + if (abbrev .ne. 'PMTF') stop 5 + abbrev = param_get_abbrev(0, 0, 0) + if (abbrev .ne. 'TMP') stop 5 + abbrev = param_get_abbrev(0, 3, 198) + if (abbrev .ne. 'MSLMA') stop 5 + abbrev = param_get_abbrev(0, 13, 194) + if (abbrev .ne. 'LPMTF') stop 5 + abbrev = param_get_abbrev(0, 13, 195) + if (abbrev .ne. 'LIPMF') stop 5 + abbrev = param_get_abbrev(0, 1, 23) + if (abbrev .ne. 'ICMR') stop 5 + abbrev = param_get_abbrev(0, 1, 32) + if (abbrev .ne. 'GRMR') stop 5 + abbrev = param_get_abbrev(0, 1, 206) + if (abbrev .ne. 'TIPD') stop 5 + abbrev = param_get_abbrev(0, 17, 192) + if (abbrev .ne. 'LTNG') stop 5 + abbrev = param_get_abbrev(2, 0, 206) + if (abbrev .ne. 'RDRIP') stop 5 + abbrev = param_get_abbrev(0, 0, 15) + if (abbrev .ne. 'VPTMP') stop 5 + abbrev = param_get_abbrev(0, 1, 207) + if (abbrev .ne. 'NCIP') stop 5 + abbrev = param_get_abbrev(0, 1, 208) + if (abbrev .ne. 'SNOT') stop 5 +! abbrev = param_get_abbrev(0, 3, 1) +! if (abbrev .ne. 'MSLSA') stop 5 + abbrev = param_get_abbrev(0, 3, 199) + if (abbrev .ne. 'TSLSA') stop 5 + abbrev = param_get_abbrev(0, 3, 200) + if (abbrev .ne. 'PLPL') stop 5 + abbrev = param_get_abbrev(0, 4, 194) + if (abbrev .ne. 'DUVB') stop 5 + abbrev = param_get_abbrev(0, 4, 195) + if (abbrev .ne. 'CDUVB') stop 5 + abbrev = param_get_abbrev(2, 0, 207) + if (abbrev .ne. 'ICWAT') stop 5 + abbrev = param_get_abbrev(0, 19, 204) + if (abbrev .ne. 'MIXLY') stop 5 + abbrev = param_get_abbrev(0, 0, 193) + if (abbrev .ne. 'TTRAD') stop 5 + abbrev = param_get_abbrev(0, 16, 195) + if (abbrev .ne. 'REFD') stop 5 + abbrev = param_get_abbrev(0, 16, 196) + if (abbrev .ne. 'REFC') stop 5 + abbrev = param_get_abbrev(0, 4, 196) + if (abbrev .ne. 'CSDSF') stop 5 + abbrev = param_get_abbrev(0, 1, 209) + if (abbrev .ne. 'TCLSW') stop 5 + abbrev = param_get_abbrev(0, 1, 210) + if (abbrev .ne. 'TCOLM') stop 5 + abbrev = param_get_abbrev(0, 3, 201) + if (abbrev .ne. 'LPSX') stop 5 + abbrev = param_get_abbrev(0, 3, 202) + if (abbrev .ne. 'LPSY') stop 5 + abbrev = param_get_abbrev(0, 3, 203) + if (abbrev .ne. 'HGTX') stop 5 + abbrev = param_get_abbrev(0, 3, 204) + if (abbrev .ne. 'HGTY') stop 5 + abbrev = param_get_abbrev(0, 0, 194) + if (abbrev .ne. 'REV') stop 5 + abbrev = param_get_abbrev(10, 2, 0) + if (abbrev .ne. 'ICEC') stop 5 + abbrev = param_get_abbrev(10, 1, 2) + if (abbrev .ne. 'UOGRD') stop 5 + abbrev = param_get_abbrev(10, 1, 3) + if (abbrev .ne. 'VOGRD') stop 5 + abbrev = param_get_abbrev(10, 3, 0) + if (abbrev .ne. 'WTMP') stop 5 + abbrev = param_get_abbrev(10, 3, 1) + if (abbrev .ne. 'DSLM') stop 5 + abbrev = param_get_abbrev(10, 4, 3) + if (abbrev .ne. 'SALTY') stop 5 + abbrev = param_get_abbrev(10, 1, 2) + if (abbrev .ne. 'UOGRD') stop 5 + abbrev = param_get_abbrev(10, 1, 3) + if (abbrev .ne. 'VOGRD') stop 5 + abbrev = param_get_abbrev(10, 3, 0) + if (abbrev .ne. 'WTMP') stop 5 + abbrev = param_get_abbrev(10, 4, 3) + if (abbrev .ne. 'SALTY') stop 5 + abbrev = param_get_abbrev(0, 2, 9) + if (abbrev .ne. 'DZDT') stop 5 + abbrev = param_get_abbrev(0, 19, 3) + if (abbrev .ne. 'MIXHT') stop 5 + abbrev = param_get_abbrev(0, 3, 1) + if (abbrev .ne. 'PRMSL') stop 5 + abbrev = param_get_abbrev(0, 3, 5) + if (abbrev .ne. 'HGT') stop 5 + abbrev = param_get_abbrev(10, 3, 194) + if (abbrev .ne. 'ELEV') stop 5 + abbrev = param_get_abbrev(0, 1, 198) + if (abbrev .ne. 'MINRH') stop 5 + abbrev = param_get_abbrev(0, 1, 27) + if (abbrev .ne. 'MAXRH') stop 5 + abbrev = param_get_abbrev(0, 1, 29) + if (abbrev .ne. 'ASNOW') stop 5 + abbrev = param_get_abbrev(0, 16, 192) + if (abbrev .ne. 'REFZR') stop 5 + abbrev = param_get_abbrev(0, 16, 193) + if (abbrev .ne. 'REFZI') stop 5 + abbrev = param_get_abbrev(0, 16, 194) + if (abbrev .ne. 'REFZC') stop 5 + abbrev = param_get_abbrev(0, 2, 198) + if (abbrev .ne. 'LAUV') stop 5 + abbrev = param_get_abbrev(0, 2, 199) + if (abbrev .ne. 'LOUV') stop 5 + abbrev = param_get_abbrev(0, 2, 200) + if (abbrev .ne. 'LAVV') stop 5 + abbrev = param_get_abbrev(0, 2, 201) + if (abbrev .ne. 'LOVV') stop 5 + abbrev = param_get_abbrev(0, 2, 202) + if (abbrev .ne. 'LAPP') stop 5 + abbrev = param_get_abbrev(0, 2, 203) + if (abbrev .ne. 'LOPP') stop 5 + abbrev = param_get_abbrev(10, 3, 195) + if (abbrev .ne. 'SSHG') stop 5 + abbrev = param_get_abbrev(0, 2, 2) + if (abbrev .ne. 'UGRD') stop 5 + abbrev = param_get_abbrev(0, 2, 3) + if (abbrev .ne. 'VGRD') stop 5 + abbrev = param_get_abbrev(0, 3, 1) + if (abbrev .ne. 'PRMSL') stop 5 + abbrev = param_get_abbrev(0, 3, 5) + if (abbrev .ne. 'HGT') stop 5 + abbrev = param_get_abbrev(10, 4, 192) + if (abbrev .ne. 'WTMPC') stop 5 + abbrev = param_get_abbrev(10, 4, 193) + if (abbrev .ne. 'SALIN') stop 5 + abbrev = param_get_abbrev(10, 3, 196) + if (abbrev .ne. 'P2OMLT') stop 5 + abbrev = param_get_abbrev(10, 1, 192) + if (abbrev .ne. 'OMLU') stop 5 + abbrev = param_get_abbrev(10, 1, 193) + if (abbrev .ne. 'OMLV') stop 5 + abbrev = param_get_abbrev(10, 1, 194) + if (abbrev .ne. 'UBARO') stop 5 + abbrev = param_get_abbrev(10, 1, 195) + if (abbrev .ne. 'VBARO') stop 5 + abbrev = param_get_abbrev(0, 19, 205) + if (abbrev .ne. 'FLGHT') stop 5 + abbrev = param_get_abbrev(0, 19, 206) + if (abbrev .ne. 'CICEL') stop 5 + abbrev = param_get_abbrev(0, 19, 207) + if (abbrev .ne. 'CIVIS') stop 5 + abbrev = param_get_abbrev(0, 19, 208) + if (abbrev .ne. 'CIFLT') stop 5 + abbrev = param_get_abbrev(0, 19, 209) + if (abbrev .ne. 'LAVNI') stop 5 + abbrev = param_get_abbrev(0, 19, 210) + if (abbrev .ne. 'HAVNI') stop 5 + abbrev = param_get_abbrev(0, 19, 211) + if (abbrev .ne. 'SBSALB') stop 5 + abbrev = param_get_abbrev(0, 19, 212) + if (abbrev .ne. 'SWSALB') stop 5 + abbrev = param_get_abbrev(0, 19, 213) + if (abbrev .ne. 'NBSALB') stop 5 + abbrev = param_get_abbrev(0, 19, 214) + if (abbrev .ne. 'NWSALB') stop 5 + abbrev = param_get_abbrev(10, 0, 192) + if (abbrev .ne. 'WSTP') stop 5 + abbrev = param_get_abbrev(0, 1, 211) + if (abbrev .ne. 'EMNP') stop 5 + abbrev = param_get_abbrev(0, 3, 205) + if (abbrev .ne. 'LAYTH') stop 5 + abbrev = param_get_abbrev(0, 6, 13) + if (abbrev .ne. 'CEIL') stop 5 + abbrev = param_get_abbrev(0, 19, 12) + if (abbrev .ne. 'PBLREG') stop 5 + abbrev = param_get_abbrev(2, 0, 228) + if (abbrev .ne. 'ACOND') stop 5 + abbrev = param_get_abbrev(0, 1, 212) + if (abbrev .ne. 'SBSNO') stop 5 + abbrev = param_get_abbrev(2, 3, 198) + if (abbrev .ne. 'EVBS') stop 5 + abbrev = param_get_abbrev(2, 0, 229) + if (abbrev .ne. 'EVCW') stop 5 + abbrev = param_get_abbrev(2, 0, 230) + if (abbrev .ne. 'TRANS') stop 5 + abbrev = param_get_abbrev(0, 2, 204) + if (abbrev .ne. 'VEDH') stop 5 + abbrev = param_get_abbrev(0, 0, 195) + if (abbrev .ne. 'LRGHR') stop 5 + abbrev = param_get_abbrev(0, 0, 196) + if (abbrev .ne. 'CNVHR') stop 5 + abbrev = param_get_abbrev(0, 19, 20) + if (abbrev .ne. 'ICIP') stop 5 + abbrev = param_get_abbrev(0, 19, 20) + if (abbrev .ne. 'ICIP') stop 5 + abbrev = param_get_abbrev(0, 19, 21) + if (abbrev .ne. 'CTP') stop 5 + abbrev = param_get_abbrev(0, 19, 21) + if (abbrev .ne. 'CTP') stop 5 + abbrev = param_get_abbrev(0, 19, 22) + if (abbrev .ne. 'CAT') stop 5 + abbrev = param_get_abbrev(0, 19, 22) + if (abbrev .ne. 'CAT') stop 5 + abbrev = param_get_abbrev(0, 6, 25) + if (abbrev .ne. 'CBHE') stop 5 + abbrev = param_get_abbrev(255, 255, 255) + if (abbrev .ne. 'IMGD') stop 5 + abbrev = param_get_abbrev(255, 255, 255) + if (abbrev .ne. 'IMGD') stop 5 + abbrev = param_get_abbrev(255, 255, 255) + if (abbrev .ne. 'IMGD') stop 5 + abbrev = param_get_abbrev(255, 255, 255) + if (abbrev .ne. 'IMGD') stop 5 + abbrev = param_get_abbrev(0, 3, 3) + if (abbrev .ne. 'ICAHT') stop 5 + abbrev = param_get_abbrev(0, 3, 3) + if (abbrev .ne. 'ICAHT') stop 5 + abbrev = param_get_abbrev(255, 255, 255) + if (abbrev .ne. 'IMGD') stop 5 + abbrev = param_get_abbrev(255, 255, 255) + if (abbrev .ne. 'IMGD') stop 5 + abbrev = param_get_abbrev(0, 6, 6) + if (abbrev .ne. 'CWAT') stop 5 + abbrev = param_get_abbrev(10, 0, 7) + if (abbrev .ne. 'SWDIR') stop 5 + abbrev = param_get_abbrev(10, 0, 8) + if (abbrev .ne. 'SWELL') stop 5 + abbrev = param_get_abbrev(10, 0, 9) + if (abbrev .ne. 'SWPER') stop 5 + abbrev = param_get_abbrev(10, 0, 5) + if (abbrev .ne. 'WVHGT') stop 5 + abbrev = param_get_abbrev(3, 192, 0) + if (abbrev .ne. 'SBT122') stop 5 + abbrev = param_get_abbrev(3, 192, 1) + if (abbrev .ne. 'SBT123') stop 5 + abbrev = param_get_abbrev(3, 192, 2) + if (abbrev .ne. 'SBT124') stop 5 + abbrev = param_get_abbrev(3, 192, 3) + if (abbrev .ne. 'SBT126') stop 5 + abbrev = param_get_abbrev(3, 192, 4) + if (abbrev .ne. 'SBC123') stop 5 + abbrev = param_get_abbrev(3, 192, 5) + if (abbrev .ne. 'SBC124') stop 5 + abbrev = param_get_abbrev(10, 3, 192) + if (abbrev .ne. 'SURGE') stop 5 + abbrev = param_get_abbrev(10, 3, 193) + if (abbrev .ne. 'ETSRG') stop 5 + abbrev = param_get_abbrev(0, 2, 14) + if (abbrev .ne. 'PVORT') stop 5 + abbrev = param_get_abbrev(0, 192, 1) + if (abbrev .ne. 'COVMZ') stop 5 + abbrev = param_get_abbrev(0, 192, 2) + if (abbrev .ne. 'COVTZ') stop 5 + abbrev = param_get_abbrev(0, 192, 3) + if (abbrev .ne. 'COVTM') stop 5 + abbrev = param_get_abbrev(0, 0, 197) + if (abbrev .ne. 'THFLX') stop 5 + abbrev = param_get_abbrev(0, 2, 2) + if (abbrev .ne. 'UGRD') stop 5 + abbrev = param_get_abbrev(0, 2, 3) + if (abbrev .ne. 'VGRD') stop 5 + abbrev = param_get_abbrev(0, 2, 9) + if (abbrev .ne. 'DZDT') stop 5 + abbrev = param_get_abbrev(0, 2, 17) + if (abbrev .ne. 'UFLX') stop 5 + abbrev = param_get_abbrev(0, 2, 18) + if (abbrev .ne. 'VFLX') stop 5 + abbrev = param_get_abbrev(0, 3, 6) + if (abbrev .ne. 'DIST') stop 5 + abbrev = param_get_abbrev(0, 0, 2) + if (abbrev .ne. 'POT') stop 5 + abbrev = param_get_abbrev(10, 4, 3) + if (abbrev .ne. 'SALTY') stop 5 + abbrev = param_get_abbrev(10, 1, 2) + if (abbrev .ne. 'UOGRD') stop 5 + abbrev = param_get_abbrev(10, 1, 3) + if (abbrev .ne. 'VOGRD') stop 5 + abbrev = param_get_abbrev(0, 0, 198) + if (abbrev .ne. 'TTDIA') stop 5 + abbrev = param_get_abbrev(0, 0, 199) + if (abbrev .ne. 'TTPHY') stop 5 + abbrev = param_get_abbrev(2, 3, 199) + if (abbrev .ne. 'LSPA') stop 5 + abbrev = param_get_abbrev(0, 4, 197) + if (abbrev .ne. 'SWHR') stop 5 + abbrev = param_get_abbrev(0, 5, 194) + if (abbrev .ne. 'LWHR') stop 5 + abbrev = param_get_abbrev(0, 4, 198) + if (abbrev .ne. 'CSUSF') stop 5 + abbrev = param_get_abbrev(0, 5, 195) + if (abbrev .ne. 'CSULF') stop 5 + abbrev = param_get_abbrev(0, 5, 196) + if (abbrev .ne. 'CSDLF') stop 5 + abbrev = param_get_abbrev(0, 4, 199) + if (abbrev .ne. 'CFNSF') stop 5 + abbrev = param_get_abbrev(0, 5, 197) + if (abbrev .ne. 'CFNLF') stop 5 + abbrev = param_get_abbrev(0, 4, 200) + if (abbrev .ne. 'VBDSF') stop 5 + abbrev = param_get_abbrev(0, 4, 201) + if (abbrev .ne. 'VDDSF') stop 5 + abbrev = param_get_abbrev(0, 4, 202) + if (abbrev .ne. 'NBDSF') stop 5 + abbrev = param_get_abbrev(0, 4, 203) + if (abbrev .ne. 'NDDSF') stop 5 + abbrev = param_get_abbrev(0, 7, 196) + if (abbrev .ne. 'UVI') stop 5 + abbrev = param_get_abbrev(0, 0, 200) + if (abbrev .ne. 'TSD1D') stop 5 + abbrev = param_get_abbrev(0, 3, 206) + if (abbrev .ne. 'NLGSP') stop 5 + abbrev = param_get_abbrev(0, 0, 201) + if (abbrev .ne. 'SHAHR') stop 5 + abbrev = param_get_abbrev(0, 0, 202) + if (abbrev .ne. 'VDFHR') stop 5 + abbrev = param_get_abbrev(0, 1, 213) + if (abbrev .ne. 'CNVMR') stop 5 + abbrev = param_get_abbrev(0, 1, 214) + if (abbrev .ne. 'SHAMR') stop 5 + abbrev = param_get_abbrev(0, 1, 215) + if (abbrev .ne. 'VDFMR') stop 5 + abbrev = param_get_abbrev(0, 2, 208) + if (abbrev .ne. 'VDFUA') stop 5 + abbrev = param_get_abbrev(0, 2, 209) + if (abbrev .ne. 'VDFVA') stop 5 + abbrev = param_get_abbrev(0, 7, 195) + if (abbrev .ne. 'CWDI') stop 5 + abbrev = param_get_abbrev(0, 4, 204) + if (abbrev .ne. 'DTRF') stop 5 + abbrev = param_get_abbrev(0, 4, 205) + if (abbrev .ne. 'UTRF') stop 5 + abbrev = param_get_abbrev(0, 6, 200) + if (abbrev .ne. 'MFLUX') stop 5 + abbrev = param_get_abbrev(0, 7, 195) + if (abbrev .ne. 'CWDI') stop 5 + abbrev = param_get_abbrev(0, 19, 232) + if (abbrev .ne. 'VAFTD') stop 5 + abbrev = param_get_abbrev(0, 1, 201) + if (abbrev .ne. 'SNOWC') stop 5 + abbrev = param_get_abbrev(0, 1, 11) + if (abbrev .ne. 'SNOD') stop 5 + abbrev = param_get_abbrev(0, 7, 2) + if (abbrev .ne. 'KX') stop 5 + abbrev = param_get_abbrev(0, 7, 5) + if (abbrev .ne. 'SX') stop 5 + abbrev = param_get_abbrev(10, 4, 194) + if (abbrev .ne. 'BKENG') stop 5 + abbrev = param_get_abbrev(10, 4, 195) + if (abbrev .ne. 'DBSS') stop 5 + abbrev = param_get_abbrev(10, 3, 197) + if (abbrev .ne. 'AOHFLX') stop 5 + abbrev = param_get_abbrev(10, 3, 198) + if (abbrev .ne. 'ASHFL') stop 5 + abbrev = param_get_abbrev(10, 3, 199) + if (abbrev .ne. 'SSTT') stop 5 + abbrev = param_get_abbrev(10, 3, 200) + if (abbrev .ne. 'SSST') stop 5 + abbrev = param_get_abbrev(10, 3, 201) + if (abbrev .ne. 'KENG') stop 5 + abbrev = param_get_abbrev(10, 4, 196) + if (abbrev .ne. 'INTFD') stop 5 + abbrev = param_get_abbrev(10, 3, 202) + if (abbrev .ne. 'SLTFL') stop 5 + abbrev = param_get_abbrev(10, 4, 197) + if (abbrev .ne. 'OHC') stop 5 + abbrev = param_get_abbrev(0, 1, 216) + if (abbrev .ne. 'CONP') stop 5 + abbrev = param_get_abbrev(0, 191, 195) + if (abbrev .ne. 'MLYNO') stop 5 + abbrev = param_get_abbrev(0, 1, 65) + if (abbrev .ne. 'RPRATE') stop 5 + abbrev = param_get_abbrev(0, 1, 66) + if (abbrev .ne. 'SPRATE') stop 5 + abbrev = param_get_abbrev(0, 1, 67) + if (abbrev .ne. 'FPRATE') stop 5 + abbrev = param_get_abbrev(0, 1, 68) + if (abbrev .ne. 'IPRATE') stop 5 + abbrev = param_get_abbrev(0, 7, 197) + if (abbrev .ne. 'UPHL') stop 5 + abbrev = param_get_abbrev(2, 0, 4) + if (abbrev .ne. 'VEG') stop 5 + abbrev = param_get_abbrev(1, 1, 195) + if (abbrev .ne. 'CWR') stop 5 + abbrev = param_get_abbrev(0, 192, 4) + if (abbrev .ne. 'COVTW') stop 5 + abbrev = param_get_abbrev(0, 192, 5) + if (abbrev .ne. 'COVZZ') stop 5 + abbrev = param_get_abbrev(0, 192, 6) + if (abbrev .ne. 'COVMM') stop 5 + abbrev = param_get_abbrev(0, 192, 7) + if (abbrev .ne. 'COVQZ') stop 5 + abbrev = param_get_abbrev(0, 192, 8) + if (abbrev .ne. 'COVQM') stop 5 + abbrev = param_get_abbrev(0, 192, 9) + if (abbrev .ne. 'COVTVV') stop 5 + abbrev = param_get_abbrev(0, 192, 10) + if (abbrev .ne. 'COVQVV') stop 5 + abbrev = param_get_abbrev(0, 192, 11) + if (abbrev .ne. 'COVPSPS') stop 5 + abbrev = param_get_abbrev(0, 192, 12) + if (abbrev .ne. 'COVQQ') stop 5 + abbrev = param_get_abbrev(0, 192, 13) + if (abbrev .ne. 'COVVVVV') stop 5 + abbrev = param_get_abbrev(0, 192, 14) + if (abbrev .ne. 'COVTT') stop 5 + abbrev = param_get_abbrev(0, 0, 203) + if (abbrev .ne. 'THZ0') stop 5 + abbrev = param_get_abbrev(0, 1, 218) + if (abbrev .ne. 'QZ0') stop 5 + abbrev = param_get_abbrev(0, 1, 219) + if (abbrev .ne. 'QMAX') stop 5 + abbrev = param_get_abbrev(0, 1, 220) + if (abbrev .ne. 'QMIN') stop 5 + abbrev = param_get_abbrev(0, 2, 210) + if (abbrev .ne. 'GWDU') stop 5 + abbrev = param_get_abbrev(0, 2, 211) + if (abbrev .ne. 'GWDV') stop 5 + abbrev = param_get_abbrev(0, 2, 212) + if (abbrev .ne. 'CNVU') stop 5 + abbrev = param_get_abbrev(0, 2, 213) + if (abbrev .ne. 'CNVV') stop 5 + abbrev = param_get_abbrev(0, 2, 214) + if (abbrev .ne. 'WTEND') stop 5 + abbrev = param_get_abbrev(0, 2, 215) + if (abbrev .ne. 'OMGALF') stop 5 + abbrev = param_get_abbrev(0, 2, 216) + if (abbrev .ne. 'CNGWDU') stop 5 + abbrev = param_get_abbrev(0, 2, 217) + if (abbrev .ne. 'CNGWDV') stop 5 + abbrev = param_get_abbrev(0, 3, 207) + if (abbrev .ne. 'CNVUMF') stop 5 + abbrev = param_get_abbrev(0, 3, 208) + if (abbrev .ne. 'CNVDMF') stop 5 + abbrev = param_get_abbrev(0, 3, 209) + if (abbrev .ne. 'CNVDEMF') stop 5 + abbrev = param_get_abbrev(0, 1, 217) + if (abbrev .ne. 'LRGMR') stop 5 + abbrev = param_get_abbrev(0, 14, 195) + if (abbrev .ne. 'VDFOZ') stop 5 + abbrev = param_get_abbrev(0, 14, 196) + if (abbrev .ne. 'POZ') stop 5 + abbrev = param_get_abbrev(0, 14, 197) + if (abbrev .ne. 'TOZ') stop 5 + abbrev = param_get_abbrev(0, 14, 198) + if (abbrev .ne. 'POZT') stop 5 + abbrev = param_get_abbrev(0, 14, 199) + if (abbrev .ne. 'POZO') stop 5 + abbrev = param_get_abbrev(2, 0, 208) + if (abbrev .ne. 'AKHS') stop 5 + abbrev = param_get_abbrev(2, 0, 209) + if (abbrev .ne. 'AKMS') stop 5 + abbrev = param_get_abbrev(0, 19, 218) + if (abbrev .ne. 'EPSR') stop 5 + abbrev = param_get_abbrev(0, 0, 192) + if (abbrev .ne. 'SNOHF') stop 5 + abbrev = param_get_abbrev(0, 0, 204) + if (abbrev .ne. 'TCHP') stop 5 + abbrev = param_get_abbrev(0, 19, 219) + if (abbrev .ne. 'TPFI') stop 5 + abbrev = param_get_abbrev(0, 7, 198) + if (abbrev .ne. 'LAI') stop 5 + abbrev = param_get_abbrev(0, 3, 210) + if (abbrev .ne. 'LMH') stop 5 + abbrev = param_get_abbrev(0, 2, 218) + if (abbrev .ne. 'LMV') stop 5 + abbrev = param_get_abbrev(0, 3, 0) + if (abbrev .ne. 'PRES') stop 5 + ! abbrev = param_get_abbrev(0, 3, 1) + ! if (abbrev .ne. 'PRMSL') stop 5 + abbrev = param_get_abbrev(0, 3, 2) + if (abbrev .ne. 'PTEND') stop 5 + abbrev = param_get_abbrev(0, 2, 14) + if (abbrev .ne. 'PVORT') stop 5 + abbrev = param_get_abbrev(0, 3, 3) + if (abbrev .ne. 'ICAHT') stop 5 + abbrev = param_get_abbrev(0, 3, 4) + if (abbrev .ne. 'GP') stop 5 + abbrev = param_get_abbrev(0, 3, 5) + if (abbrev .ne. 'HGT') stop 5 + abbrev = param_get_abbrev(0, 3, 6) + if (abbrev .ne. 'DIST') stop 5 + abbrev = param_get_abbrev(0, 3, 7) + if (abbrev .ne. 'HSTDV') stop 5 + abbrev = param_get_abbrev(0, 14, 0) + if (abbrev .ne. 'TOZNE') stop 5 + abbrev = param_get_abbrev(0, 0, 0) + if (abbrev .ne. 'TMP') stop 5 + abbrev = param_get_abbrev(0, 0, 1) + if (abbrev .ne. 'VTMP') stop 5 + abbrev = param_get_abbrev(0, 0, 2) + if (abbrev .ne. 'POT') stop 5 + abbrev = param_get_abbrev(0, 0, 3) + if (abbrev .ne. 'EPOT') stop 5 + abbrev = param_get_abbrev(0, 0, 4) + if (abbrev .ne. 'TMAX') stop 5 + abbrev = param_get_abbrev(0, 0, 5) + if (abbrev .ne. 'TMIN') stop 5 + abbrev = param_get_abbrev(0, 0, 6) + if (abbrev .ne. 'DPT') stop 5 + abbrev = param_get_abbrev(0, 0, 7) + if (abbrev .ne. 'DEPR') stop 5 + abbrev = param_get_abbrev(0, 0, 8) + if (abbrev .ne. 'LAPR') stop 5 + abbrev = param_get_abbrev(0, 19, 0) + if (abbrev .ne. 'VIS') stop 5 + abbrev = param_get_abbrev(0, 15, 6) + if (abbrev .ne. 'RDSP1') stop 5 + abbrev = param_get_abbrev(0, 15, 7) + if (abbrev .ne. 'RDSP2') stop 5 + abbrev = param_get_abbrev(0, 15, 8) + if (abbrev .ne. 'RDSP3') stop 5 + abbrev = param_get_abbrev(0, 7, 0) + if (abbrev .ne. 'PLI') stop 5 + abbrev = param_get_abbrev(0, 0, 9) + if (abbrev .ne. 'TMPA') stop 5 + abbrev = param_get_abbrev(0, 3, 8) + if (abbrev .ne. 'PRESA') stop 5 + abbrev = param_get_abbrev(0, 3, 9) + if (abbrev .ne. 'GPA') stop 5 + abbrev = param_get_abbrev(10, 0, 0) + if (abbrev .ne. 'WVSP1') stop 5 + abbrev = param_get_abbrev(10, 0, 1) + if (abbrev .ne. 'WVSP2') stop 5 + abbrev = param_get_abbrev(10, 0, 2) + if (abbrev .ne. 'WVSP3') stop 5 + abbrev = param_get_abbrev(0, 2, 0) + if (abbrev .ne. 'WDIR') stop 5 + abbrev = param_get_abbrev(0, 2, 1) + if (abbrev .ne. 'WIND') stop 5 + abbrev = param_get_abbrev(0, 2, 2) + if (abbrev .ne. 'UGRD') stop 5 + abbrev = param_get_abbrev(0, 2, 3) + if (abbrev .ne. 'VGRD') stop 5 + abbrev = param_get_abbrev(0, 2, 4) + if (abbrev .ne. 'STRM') stop 5 + abbrev = param_get_abbrev(0, 2, 5) + if (abbrev .ne. 'VPOT') stop 5 + abbrev = param_get_abbrev(0, 2, 6) + if (abbrev .ne. 'MNTSF') stop 5 + abbrev = param_get_abbrev(0, 2, 7) + if (abbrev .ne. 'SGCVV') stop 5 + abbrev = param_get_abbrev(0, 2, 8) + if (abbrev .ne. 'VVEL') stop 5 + abbrev = param_get_abbrev(0, 2, 9) + if (abbrev .ne. 'DZDT') stop 5 + abbrev = param_get_abbrev(0, 2, 10) + if (abbrev .ne. 'ABSV') stop 5 + abbrev = param_get_abbrev(0, 2, 11) + if (abbrev .ne. 'ABSD') stop 5 + abbrev = param_get_abbrev(0, 2, 12) + if (abbrev .ne. 'RELV') stop 5 + abbrev = param_get_abbrev(0, 2, 13) + if (abbrev .ne. 'RELD') stop 5 + abbrev = param_get_abbrev(0, 2, 15) + if (abbrev .ne. 'VUCSH') stop 5 + abbrev = param_get_abbrev(0, 2, 16) + if (abbrev .ne. 'VVCSH') stop 5 + abbrev = param_get_abbrev(10, 1, 0) + if (abbrev .ne. 'DIRC') stop 5 + abbrev = param_get_abbrev(10, 1, 1) + if (abbrev .ne. 'SPC') stop 5 + abbrev = param_get_abbrev(10, 1, 2) + if (abbrev .ne. 'UOGRD') stop 5 + abbrev = param_get_abbrev(10, 1, 3) + if (abbrev .ne. 'VOGRD') stop 5 + abbrev = param_get_abbrev(0, 1, 0) + if (abbrev .ne. 'SPFH') stop 5 + abbrev = param_get_abbrev(0, 1, 1) + if (abbrev .ne. 'RH') stop 5 + abbrev = param_get_abbrev(0, 1, 2) + if (abbrev .ne. 'MIXR') stop 5 + abbrev = param_get_abbrev(0, 1, 3) + if (abbrev .ne. 'PWAT') stop 5 + abbrev = param_get_abbrev(0, 1, 4) + if (abbrev .ne. 'VAPP') stop 5 + abbrev = param_get_abbrev(0, 1, 5) + if (abbrev .ne. 'SATD') stop 5 + abbrev = param_get_abbrev(0, 1, 6) + if (abbrev .ne. 'EVP') stop 5 + abbrev = param_get_abbrev(0, 6, 0) + if (abbrev .ne. 'CICE') stop 5 + abbrev = param_get_abbrev(0, 1, 7) + if (abbrev .ne. 'PRATE') stop 5 + abbrev = param_get_abbrev(0, 19, 2) + if (abbrev .ne. 'TSTM') stop 5 + abbrev = param_get_abbrev(0, 1, 8) + if (abbrev .ne. 'APCP') stop 5 + abbrev = param_get_abbrev(0, 1, 9) + if (abbrev .ne. 'NCPCP') stop 5 + abbrev = param_get_abbrev(0, 1, 10) + if (abbrev .ne. 'ACPCP') stop 5 + abbrev = param_get_abbrev(0, 1, 12) + if (abbrev .ne. 'SRWEQ') stop 5 + abbrev = param_get_abbrev(0, 1, 13) + if (abbrev .ne. 'WEASD') stop 5 + abbrev = param_get_abbrev(0, 1, 11) + if (abbrev .ne. 'SNOD') stop 5 + abbrev = param_get_abbrev(0, 19, 3) + if (abbrev .ne. 'MIXHT') stop 5 + abbrev = param_get_abbrev(10, 4, 2) + if (abbrev .ne. 'TTHDP') stop 5 + abbrev = param_get_abbrev(10, 4, 0) + if (abbrev .ne. 'MTHD') stop 5 + abbrev = param_get_abbrev(10, 4, 1) + if (abbrev .ne. 'MTHA') stop 5 + abbrev = param_get_abbrev(0, 6, 1) + if (abbrev .ne. 'TCDC') stop 5 + abbrev = param_get_abbrev(0, 6, 2) + if (abbrev .ne. 'CDCON') stop 5 + abbrev = param_get_abbrev(0, 6, 3) + if (abbrev .ne. 'LCDC') stop 5 + abbrev = param_get_abbrev(0, 6, 4) + if (abbrev .ne. 'MCDC') stop 5 + abbrev = param_get_abbrev(0, 6, 5) + if (abbrev .ne. 'HCDC') stop 5 + abbrev = param_get_abbrev(0, 6, 6) + if (abbrev .ne. 'CWAT') stop 5 + abbrev = param_get_abbrev(0, 7, 1) + if (abbrev .ne. 'BLI') stop 5 + abbrev = param_get_abbrev(0, 1, 14) + if (abbrev .ne. 'SNOC') stop 5 + abbrev = param_get_abbrev(0, 1, 15) + if (abbrev .ne. 'SNOL') stop 5 + abbrev = param_get_abbrev(10, 3, 0) + if (abbrev .ne. 'WTMP') stop 5 + abbrev = param_get_abbrev(2, 0, 0) + if (abbrev .ne. 'LAND') stop 5 + abbrev = param_get_abbrev(10, 3, 1) + if (abbrev .ne. 'DSLM') stop 5 + abbrev = param_get_abbrev(2, 0, 1) + if (abbrev .ne. 'SFCR') stop 5 + abbrev = param_get_abbrev(0, 19, 1) + if (abbrev .ne. 'ALBDO') stop 5 + abbrev = param_get_abbrev(2, 0, 2) + if (abbrev .ne. 'TSOIL') stop 5 + abbrev = param_get_abbrev(2, 0, 3) + if (abbrev .ne. 'SOILM') stop 5 + abbrev = param_get_abbrev(2, 0, 4) + if (abbrev .ne. 'VEG') stop 5 + abbrev = param_get_abbrev(10, 4, 3) + if (abbrev .ne. 'SALTY') stop 5 + abbrev = param_get_abbrev(0, 3, 10) + if (abbrev .ne. 'DEN') stop 5 + abbrev = param_get_abbrev(2, 0, 5) + if (abbrev .ne. 'WATR') stop 5 + abbrev = param_get_abbrev(10, 2, 0) + if (abbrev .ne. 'ICEC') stop 5 + abbrev = param_get_abbrev(10, 2, 1) + if (abbrev .ne. 'ICETK') stop 5 + abbrev = param_get_abbrev(10, 2, 2) + if (abbrev .ne. 'DICED') stop 5 + abbrev = param_get_abbrev(10, 2, 3) + if (abbrev .ne. 'SICED') stop 5 + abbrev = param_get_abbrev(10, 2, 4) + if (abbrev .ne. 'UICE') stop 5 + abbrev = param_get_abbrev(10, 2, 5) + if (abbrev .ne. 'VICE') stop 5 + abbrev = param_get_abbrev(10, 2, 6) + if (abbrev .ne. 'ICEG') stop 5 + abbrev = param_get_abbrev(10, 2, 7) + if (abbrev .ne. 'ICED') stop 5 + abbrev = param_get_abbrev(0, 1, 16) + if (abbrev .ne. 'SNOM') stop 5 + abbrev = param_get_abbrev(10, 0, 3) + if (abbrev .ne. 'HTSGW') stop 5 + abbrev = param_get_abbrev(10, 0, 4) + if (abbrev .ne. 'WVDIR') stop 5 + abbrev = param_get_abbrev(10, 0, 5) + if (abbrev .ne. 'WVHGT') stop 5 + abbrev = param_get_abbrev(10, 0, 6) + if (abbrev .ne. 'WVPER') stop 5 + abbrev = param_get_abbrev(10, 0, 7) + if (abbrev .ne. 'SWDIR') stop 5 + abbrev = param_get_abbrev(10, 0, 8) + if (abbrev .ne. 'SWELL') stop 5 + abbrev = param_get_abbrev(10, 0, 9) + if (abbrev .ne. 'SWPER') stop 5 + abbrev = param_get_abbrev(10, 0, 10) + if (abbrev .ne. 'DIRPW') stop 5 + abbrev = param_get_abbrev(10, 0, 11) + if (abbrev .ne. 'PERPW') stop 5 + abbrev = param_get_abbrev(10, 0, 12) + if (abbrev .ne. 'DIRSW') stop 5 + abbrev = param_get_abbrev(10, 0, 13) + if (abbrev .ne. 'PERSW') stop 5 + abbrev = param_get_abbrev(0, 4, 0) + if (abbrev .ne. 'NSWRS') stop 5 + abbrev = param_get_abbrev(0, 5, 0) + if (abbrev .ne. 'NLWRS') stop 5 + abbrev = param_get_abbrev(0, 4, 1) + if (abbrev .ne. 'NSWRT') stop 5 + abbrev = param_get_abbrev(0, 5, 1) + if (abbrev .ne. 'NLWRT') stop 5 + abbrev = param_get_abbrev(0, 5, 2) + if (abbrev .ne. 'LWAVR') stop 5 + abbrev = param_get_abbrev(0, 4, 2) + if (abbrev .ne. 'SWAVR') stop 5 + abbrev = param_get_abbrev(0, 4, 3) + if (abbrev .ne. 'GRAD') stop 5 + abbrev = param_get_abbrev(0, 4, 4) + if (abbrev .ne. 'BRTMP') stop 5 + abbrev = param_get_abbrev(0, 4, 5) + if (abbrev .ne. 'LWRAD') stop 5 + abbrev = param_get_abbrev(0, 4, 6) + if (abbrev .ne. 'SWRAD') stop 5 + abbrev = param_get_abbrev(0, 0, 10) + if (abbrev .ne. 'LHTFL') stop 5 + abbrev = param_get_abbrev(0, 0, 11) + if (abbrev .ne. 'SHTFL') stop 5 +! abbrev = param_get_abbrev(0, 2, 20) +! if (abbrev .ne. 'BLYDP') stop 5 + abbrev = param_get_abbrev(0, 2, 17) + if (abbrev .ne. 'UFLX') stop 5 + abbrev = param_get_abbrev(0, 2, 18) + if (abbrev .ne. 'VFLX') stop 5 + abbrev = param_get_abbrev(0, 2, 19) + if (abbrev .ne. 'WMIXE') stop 5 + abbrev = param_get_abbrev(255, 255, 255) + if (abbrev .ne. 'IMGD') stop 5 + ! abbrev = param_get_abbrev(0, 3, 1) + ! if (abbrev .ne. 'MSLSA') stop 5 + abbrev = param_get_abbrev(0, 3, 192) + if (abbrev .ne. 'MSLET') stop 5 + abbrev = param_get_abbrev(0, 7, 192) + if (abbrev .ne. 'LFTX') stop 5 + abbrev = param_get_abbrev(0, 7, 193) + if (abbrev .ne. '4LFTX') stop 5 + abbrev = param_get_abbrev(0, 3, 212) + if (abbrev .ne. 'PRESN') stop 5 + abbrev = param_get_abbrev(0, 1, 197) + if (abbrev .ne. 'MCONV') stop 5 + abbrev = param_get_abbrev(0, 2, 192) + if (abbrev .ne. 'VWSH') stop 5 + abbrev = param_get_abbrev(0, 2, 219) + if (abbrev .ne. 'PVMWW') stop 5 + abbrev = param_get_abbrev(0, 1, 192) + if (abbrev .ne. 'CRAIN') stop 5 + abbrev = param_get_abbrev(0, 1, 193) + if (abbrev .ne. 'CFRZR') stop 5 + abbrev = param_get_abbrev(0, 1, 194) + if (abbrev .ne. 'CICEP') stop 5 + abbrev = param_get_abbrev(0, 1, 195) + if (abbrev .ne. 'CSNOW') stop 5 + abbrev = param_get_abbrev(2, 0, 192) + if (abbrev .ne. 'SOILW') stop 5 + abbrev = param_get_abbrev(0, 1, 200) + if (abbrev .ne. 'PEVPR') stop 5 + abbrev = param_get_abbrev(2, 0, 210) + if (abbrev .ne. 'VEGT') stop 5 + abbrev = param_get_abbrev(2, 3, 200) + if (abbrev .ne. 'BARET') stop 5 + abbrev = param_get_abbrev(2, 3, 201) + if (abbrev .ne. 'AVSFT') stop 5 + abbrev = param_get_abbrev(2, 3, 202) + if (abbrev .ne. 'RADT') stop 5 + abbrev = param_get_abbrev(2, 0, 211) + if (abbrev .ne. 'SSTOR') stop 5 + abbrev = param_get_abbrev(2, 0, 212) + if (abbrev .ne. 'LSOIL') stop 5 + abbrev = param_get_abbrev(2, 0, 213) + if (abbrev .ne. 'EWATR') stop 5 + abbrev = param_get_abbrev(0, 1, 22) + if (abbrev .ne. 'CLWMR') stop 5 + abbrev = param_get_abbrev(2, 0, 193) + if (abbrev .ne. 'GFLUX') stop 5 + abbrev = param_get_abbrev(0, 7, 7) + if (abbrev .ne. 'CIN') stop 5 + abbrev = param_get_abbrev(0, 7, 6) + if (abbrev .ne. 'CAPE') stop 5 + abbrev = param_get_abbrev(0, 19, 11) + if (abbrev .ne. 'TKE') stop 5 + abbrev = param_get_abbrev(0, 19, 192) + if (abbrev .ne. 'MXSALB') stop 5 + abbrev = param_get_abbrev(2, 3, 192) + if (abbrev .ne. 'SOILL') stop 5 + abbrev = param_get_abbrev(0, 1, 29) + if (abbrev .ne. 'ASNOW') stop 5 + abbrev = param_get_abbrev(0, 1, 221) + if (abbrev .ne. 'ARAIN') stop 5 + abbrev = param_get_abbrev(2, 0, 214) + if (abbrev .ne. 'GWREC') stop 5 + abbrev = param_get_abbrev(2, 0, 215) + if (abbrev .ne. 'QREC') stop 5 + abbrev = param_get_abbrev(0, 1, 222) + if (abbrev .ne. 'SNOWT') stop 5 + abbrev = param_get_abbrev(0, 4, 200) + if (abbrev .ne. 'VBDSF') stop 5 + abbrev = param_get_abbrev(0, 4, 201) + if (abbrev .ne. 'VDDSF') stop 5 + abbrev = param_get_abbrev(0, 4, 202) + if (abbrev .ne. 'NBDSF') stop 5 + abbrev = param_get_abbrev(0, 4, 203) + if (abbrev .ne. 'NDDSF') stop 5 + abbrev = param_get_abbrev(0, 19, 193) + if (abbrev .ne. 'SNFALB') stop 5 + abbrev = param_get_abbrev(2, 3, 193) + if (abbrev .ne. 'RLYRS') stop 5 + abbrev = param_get_abbrev(0, 2, 193) + if (abbrev .ne. 'MFLX') stop 5 + abbrev = param_get_abbrev(0, 3, 210) + if (abbrev .ne. 'LMH') stop 5 + abbrev = param_get_abbrev(0, 2, 218) + if (abbrev .ne. 'LMV') stop 5 + abbrev = param_get_abbrev(0, 191, 195) + if (abbrev .ne. 'MLYNO') stop 5 + abbrev = param_get_abbrev(0, 191, 192) + if (abbrev .ne. 'NLAT') stop 5 + abbrev = param_get_abbrev(0, 191, 193) + if (abbrev .ne. 'ELON') stop 5 + abbrev = param_get_abbrev(0, 1, 23) + if (abbrev .ne. 'ICMR') stop 5 + abbrev = param_get_abbrev(2, 0, 228) + if (abbrev .ne. 'ACOND') stop 5 + abbrev = param_get_abbrev(0, 1, 17) + if (abbrev .ne. 'SNOAG') stop 5 + abbrev = param_get_abbrev(2, 0, 199) + if (abbrev .ne. 'CCOND') stop 5 + abbrev = param_get_abbrev(0, 7, 198) + if (abbrev .ne. 'LAI') stop 5 + abbrev = param_get_abbrev(2, 0, 216) + if (abbrev .ne. 'SFCRH') stop 5 + abbrev = param_get_abbrev(0, 19, 19) + if (abbrev .ne. 'SALBD') stop 5 + abbrev = param_get_abbrev(2, 0, 217) + if (abbrev .ne. 'NDVI') stop 5 + abbrev = param_get_abbrev(2, 0, 206) + if (abbrev .ne. 'RDRIP') stop 5 + abbrev = param_get_abbrev(2, 0, 218) + if (abbrev .ne. 'LANDN') stop 5 + abbrev = param_get_abbrev(0, 7, 8) + if (abbrev .ne. 'HLCY') stop 5 + abbrev = param_get_abbrev(0, 191, 196) + if (abbrev .ne. 'NLATN') stop 5 + abbrev = param_get_abbrev(0, 191, 197) + if (abbrev .ne. 'ELONN') stop 5 + abbrev = param_get_abbrev(1, 1, 193) + if (abbrev .ne. 'CPOFP') stop 5 + abbrev = param_get_abbrev(0, 2, 194) + if (abbrev .ne. 'USTM') stop 5 + abbrev = param_get_abbrev(0, 2, 195) + if (abbrev .ne. 'VSTM') stop 5 + abbrev = param_get_abbrev(0, 1, 212) + if (abbrev .ne. 'SBSNO') stop 5 + abbrev = param_get_abbrev(2, 3, 198) + if (abbrev .ne. 'EVBS') stop 5 + abbrev = param_get_abbrev(2, 0, 229) + if (abbrev .ne. 'EVCW') stop 5 + abbrev = param_get_abbrev(0, 1, 223) + if (abbrev .ne. 'APCPN') stop 5 + abbrev = param_get_abbrev(2, 0, 200) + if (abbrev .ne. 'RSMIN') stop 5 + abbrev = param_get_abbrev(0, 4, 192) + if (abbrev .ne. 'DSWRF') stop 5 + abbrev = param_get_abbrev(0, 5, 192) + if (abbrev .ne. 'DLWRF') stop 5 + abbrev = param_get_abbrev(0, 1, 224) + if (abbrev .ne. 'ACPCPN') stop 5 + abbrev = param_get_abbrev(2, 0, 194) + if (abbrev .ne. 'MSTAV') stop 5 + abbrev = param_get_abbrev(2, 0, 195) + if (abbrev .ne. 'SFEXC') stop 5 + abbrev = param_get_abbrev(2, 0, 230) + if (abbrev .ne. 'TRANS') stop 5 + abbrev = param_get_abbrev(0, 4, 193) + if (abbrev .ne. 'USWRF') stop 5 + abbrev = param_get_abbrev(0, 5, 193) + if (abbrev .ne. 'ULWRF') stop 5 + abbrev = param_get_abbrev(0, 6, 192) + if (abbrev .ne. 'CDLYR') stop 5 + abbrev = param_get_abbrev(0, 1, 196) + if (abbrev .ne. 'CPRAT') stop 5 + abbrev = param_get_abbrev(0, 0, 193) + if (abbrev .ne. 'TTRAD') stop 5 + abbrev = param_get_abbrev(0, 3, 211) + if (abbrev .ne. 'HGTN') stop 5 + abbrev = param_get_abbrev(2, 0, 201) + if (abbrev .ne. 'WILT') stop 5 + abbrev = param_get_abbrev(2, 3, 203) + if (abbrev .ne. 'FLDCP') stop 5 + abbrev = param_get_abbrev(0, 3, 196) + if (abbrev .ne. 'HPBL') stop 5 + abbrev = param_get_abbrev(2, 3, 194) + if (abbrev .ne. 'SLTYP') stop 5 + abbrev = param_get_abbrev(2, 0, 196) + if (abbrev .ne. 'CNWAT') stop 5 + abbrev = param_get_abbrev(2, 3, 0) + if (abbrev .ne. 'SOTYP') stop 5 + abbrev = param_get_abbrev(2, 0, 198) + if (abbrev .ne. 'VGTYP') stop 5 + abbrev = param_get_abbrev(2, 0, 197) + if (abbrev .ne. 'BMIXL') stop 5 + abbrev = param_get_abbrev(2, 0, 219) + if (abbrev .ne. 'AMIXL') stop 5 + abbrev = param_get_abbrev(0, 1, 199) + if (abbrev .ne. 'PEVAP') stop 5 + abbrev = param_get_abbrev(0, 0, 192) + if (abbrev .ne. 'SNOHF') stop 5 + abbrev = param_get_abbrev(2, 3, 195) + if (abbrev .ne. 'SMREF') stop 5 + abbrev = param_get_abbrev(2, 3, 196) + if (abbrev .ne. 'SMDRY') stop 5 + abbrev = param_get_abbrev(2, 0, 220) + if (abbrev .ne. 'WVINC') stop 5 + abbrev = param_get_abbrev(2, 0, 221) + if (abbrev .ne. 'WCINC') stop 5 + abbrev = param_get_abbrev(1, 0, 192) + if (abbrev .ne. 'BGRUN') stop 5 + abbrev = param_get_abbrev(1, 0, 193) + if (abbrev .ne. 'SSRUN') stop 5 + abbrev = param_get_abbrev(2, 0, 222) + if (abbrev .ne. 'WVCONV') stop 5 + abbrev = param_get_abbrev(0, 1, 201) + if (abbrev .ne. 'SNOWC') stop 5 + abbrev = param_get_abbrev(0, 1, 208) + if (abbrev .ne. 'SNOT') stop 5 + abbrev = param_get_abbrev(2, 3, 197) + if (abbrev .ne. 'POROS') stop 5 + abbrev = param_get_abbrev(2, 0, 223) + if (abbrev .ne. 'WCCONV') stop 5 + abbrev = param_get_abbrev(2, 0, 224) + if (abbrev .ne. 'WVUFLX') stop 5 + abbrev = param_get_abbrev(2, 0, 225) + if (abbrev .ne. 'WVVFLX') stop 5 + abbrev = param_get_abbrev(2, 0, 226) + if (abbrev .ne. 'WCUFLX') stop 5 + abbrev = param_get_abbrev(2, 0, 227) + if (abbrev .ne. 'WCVFLX') stop 5 + abbrev = param_get_abbrev(2, 0, 202) + if (abbrev .ne. 'RCS') stop 5 + abbrev = param_get_abbrev(2, 0, 203) + if (abbrev .ne. 'RCT') stop 5 + abbrev = param_get_abbrev(2, 0, 204) + if (abbrev .ne. 'RCQ') stop 5 + abbrev = param_get_abbrev(2, 0, 205) + if (abbrev .ne. 'RCSOL') stop 5 + abbrev = param_get_abbrev(0, 4, 197) + if (abbrev .ne. 'SWHR') stop 5 + abbrev = param_get_abbrev(0, 5, 194) + if (abbrev .ne. 'LWHR') stop 5 + abbrev = param_get_abbrev(0, 2, 196) + if (abbrev .ne. 'CD') stop 5 + abbrev = param_get_abbrev(0, 2, 197) + if (abbrev .ne. 'FRICV') stop 5 + abbrev = param_get_abbrev(0, 7, 194) + if (abbrev .ne. 'RI') stop 5 + abbrev = param_get_abbrev(0, 1, 9) + if (abbrev .ne. 'NCPCP') stop 5 + abbrev = param_get_abbrev(0, 1, 10) + if (abbrev .ne. 'ACPCP') stop 5 + abbrev = param_get_abbrev(2, 3, 203) + if (abbrev .ne. 'FLDCP') stop 5 + abbrev = param_get_abbrev(0, 14, 200) + if (abbrev .ne. 'OZMAX1') stop 5 + abbrev = param_get_abbrev(0, 14, 201) + if (abbrev .ne. 'OZMAX8') stop 5 + abbrev = param_get_abbrev(0, 16, 197) + if (abbrev .ne. 'RETOP') stop 5 + abbrev = param_get_abbrev(0, 6, 201) + if (abbrev .ne. 'SUNSD') stop 5 + abbrev = param_get_abbrev(0, 14, 202) + if (abbrev .ne. 'PDMAX1') stop 5 + abbrev = param_get_abbrev(0, 14, 203) + if (abbrev .ne. 'PDMAX24') stop 5 + abbrev = param_get_abbrev(10, 3, 242) + if (abbrev .ne. 'TCSRG20') stop 5 + abbrev = param_get_abbrev(10, 3, 243) + if (abbrev .ne. 'TCSRG30') stop 5 + abbrev = param_get_abbrev(10, 3, 244) + if (abbrev .ne. 'TCSRG40') stop 5 + abbrev = param_get_abbrev(10, 3, 245) + if (abbrev .ne. 'TCSRG50') stop 5 + abbrev = param_get_abbrev(10, 3, 246) + if (abbrev .ne. 'TCSRG60') stop 5 + abbrev = param_get_abbrev(10, 3, 247) + if (abbrev .ne. 'TCSRG70') stop 5 + abbrev = param_get_abbrev(10, 3, 248) + if (abbrev .ne. 'TCSRG80') stop 5 + abbrev = param_get_abbrev(10, 3, 249) + if (abbrev .ne. 'TCSRG90') stop 5 + abbrev = param_get_abbrev(0, 3, 0) + if (abbrev .ne. 'PRES') stop 5 + abbrev = param_get_abbrev(0, 1, 1) + if (abbrev .ne. 'RH') stop 5 + abbrev = param_get_abbrev(0, 1, 10) + if (abbrev .ne. 'ACPCP') stop 5 + abbrev = param_get_abbrev(0, 1, 8) + if (abbrev .ne. 'APCP') stop 5 + abbrev = param_get_abbrev(0, 2, 10) + if (abbrev .ne. 'ABSV') stop 5 + abbrev = param_get_abbrev(10, 0, 3) + if (abbrev .ne. 'HTSGW') stop 5 + abbrev = param_get_abbrev(10, 0, 4) + if (abbrev .ne. 'WVDIR') stop 5 + abbrev = param_get_abbrev(10, 0, 6) + if (abbrev .ne. 'WVPER') stop 5 + abbrev = param_get_abbrev(10, 0, 7) + if (abbrev .ne. 'SWDIR') stop 5 + abbrev = param_get_abbrev(10, 0, 8) + if (abbrev .ne. 'SWELL') stop 5 + abbrev = param_get_abbrev(10, 0, 10) + if (abbrev .ne. 'DIRPW') stop 5 + abbrev = param_get_abbrev(10, 0, 11) + if (abbrev .ne. 'PERPW') stop 5 + abbrev = param_get_abbrev(10, 0, 12) + if (abbrev .ne. 'DIRSW') stop 5 + abbrev = param_get_abbrev(10, 0, 13) + if (abbrev .ne. 'PERSW') stop 5 + abbrev = param_get_abbrev(10, 191, 1) + if (abbrev .ne. 'MOSF') stop 5 + abbrev = param_get_abbrev(0, 1, 225) + if (abbrev .ne. 'FRZR') stop 5 + abbrev = param_get_abbrev(0, 1, 227) + if (abbrev .ne. 'FROZR') stop 5 + abbrev = param_get_abbrev(0, 1, 241) + if (abbrev .ne. 'TSNOW') stop 5 + abbrev = param_get_abbrev(2, 0, 7) + if (abbrev .ne. 'MTERH') stop 5 + abbrev = param_get_abbrev(10, 4, 4) + if (abbrev .ne. 'OVHD') stop 5 + abbrev = param_get_abbrev(10, 4, 5) + if (abbrev .ne. 'OVSD') stop 5 + abbrev = param_get_abbrev(10, 4, 6) + if (abbrev .ne. 'OVMD') stop 5 + abbrev = param_get_abbrev(0, 1, 12) + if (abbrev .ne. 'SRWEQ') stop 5 + abbrev = param_get_abbrev(3, 192, 6) + if (abbrev .ne. 'SBT112') stop 5 + abbrev = param_get_abbrev(3, 192, 7) + if (abbrev .ne. 'SBT113') stop 5 + abbrev = param_get_abbrev(3, 192, 8) + if (abbrev .ne. 'SBT114') stop 5 + abbrev = param_get_abbrev(3, 192, 9) + if (abbrev .ne. 'SBT115') stop 5 + abbrev = param_get_abbrev(0, 16, 198) + if (abbrev .ne. 'MAXREF') stop 5 + abbrev = param_get_abbrev(0, 7, 199) + if (abbrev .ne. 'MXUPHL') stop 5 + abbrev = param_get_abbrev(0, 2, 220) + if (abbrev .ne. 'MAXUVV') stop 5 + abbrev = param_get_abbrev(0, 2, 221) + if (abbrev .ne. 'MAXDVV') stop 5 + abbrev = param_get_abbrev(0, 2, 222) + if (abbrev .ne. 'MAXUW') stop 5 + abbrev = param_get_abbrev(0, 2, 223) + if (abbrev .ne. 'MAXVW') stop 5 + abbrev = param_get_abbrev(0, 2, 224) + if (abbrev .ne. 'VRATE') stop 5 + abbrev = param_get_abbrev(2, 4, 2) + if (abbrev .ne. 'HINDEX') stop 5 + abbrev = param_get_abbrev(0, 19, 234) + if (abbrev .ne. 'ICSEV') stop 5 + abbrev = param_get_abbrev(0, 19, 233) + if (abbrev .ne. 'ICPRB') stop 5 + abbrev = param_get_abbrev(0, 19, 217) + if (abbrev .ne. 'SIPD') stop 5 + abbrev = param_get_abbrev(0, 1, 242) + if (abbrev .ne. 'RHPW') stop 5 + abbrev = param_get_abbrev(0, 15, 3) + if (abbrev .ne. 'VIL') stop 5 + abbrev = param_get_abbrev(0, 0, 255) + if (abbrev .ne. 'MISSING') stop 5 + abbrev = param_get_abbrev(0, 20, 102) + if (abbrev .ne. 'AOTK') stop 5 + abbrev = param_get_abbrev(0, 20, 103) + if (abbrev .ne. 'SSALBK') stop 5 + abbrev = param_get_abbrev(0, 20, 104) + if (abbrev .ne. 'ASYSFK') stop 5 + abbrev = param_get_abbrev(0, 20, 105) + if (abbrev .ne. 'AECOEF') stop 5 + abbrev = param_get_abbrev(0, 20, 106) + if (abbrev .ne. 'AACOEF') stop 5 + abbrev = param_get_abbrev(0, 20, 107) + if (abbrev .ne. 'ALBSAT') stop 5 + abbrev = param_get_abbrev(0, 20, 108) + if (abbrev .ne. 'ALBGRD') stop 5 + abbrev = param_get_abbrev(0, 20, 109) + if (abbrev .ne. 'ALESAT') stop 5 + abbrev = param_get_abbrev(0, 20, 110) + if (abbrev .ne. 'ALEGRD') stop 5 + abbrev = param_get_abbrev(0, 20, 9) + if (abbrev .ne. 'WLSMFLX') stop 5 + abbrev = param_get_abbrev(0, 20, 10) + if (abbrev .ne. 'WDCPMFLX') stop 5 + abbrev = param_get_abbrev(0, 20, 11) + if (abbrev .ne. 'SEDMFLX') stop 5 + abbrev = param_get_abbrev(0, 20, 12) + if (abbrev .ne. 'DDMFLX') stop 5 + abbrev = param_get_abbrev(0, 20, 13) + if (abbrev .ne. 'TRANHH') stop 5 + abbrev = param_get_abbrev(0, 20, 14) + if (abbrev .ne. 'TRSDS') stop 5 + abbrev = param_get_abbrev(0, 20, 59) + if (abbrev .ne. 'ANCON') stop 5 + abbrev = param_get_abbrev(0, 0, 21) + if (abbrev .ne. 'APTMP') stop 5 + abbrev = param_get_abbrev(0, 17, 0) + if (abbrev .ne. 'LTNGSD') stop 5 + abbrev = param_get_abbrev(0, 1, 39) + if (abbrev .ne. 'CPOFP') stop 5 + abbrev = param_get_abbrev(10, 3, 203) + if (abbrev .ne. 'LCH') stop 5 + abbrev = param_get_abbrev(0, 20, 101) + if (abbrev .ne. 'ATMTK') stop 5 + abbrev = param_get_abbrev(0, 1, 37) + if (abbrev .ne. 'CPRAT') stop 5 + abbrev = param_get_abbrev(10, 2, 8) + if (abbrev .ne. 'ICETMP') stop 5 + abbrev = param_get_abbrev(0, 0, 28) + if (abbrev .ne. 'UCTMP') stop 5 + abbrev = param_get_abbrev(0, 0, 29) + if (abbrev .ne. 'TMPADV') stop 5 + abbrev = param_get_abbrev(0, 1, 129) + if (abbrev .ne. 'EFRCWAT') stop 5 + abbrev = param_get_abbrev(0, 1, 130) + if (abbrev .ne. 'EFRRAIN') stop 5 + abbrev = param_get_abbrev(0, 1, 131) + if (abbrev .ne. 'EFRCICE') stop 5 + abbrev = param_get_abbrev(0, 1, 132) + if (abbrev .ne. 'EFRSNOW') stop 5 + abbrev = param_get_abbrev(0, 1, 133) + if (abbrev .ne. 'EFRGRL') stop 5 + abbrev = param_get_abbrev(0, 1, 134) + if (abbrev .ne. 'EFRHAIL') stop 5 + abbrev = param_get_abbrev(0, 1, 135) + if (abbrev .ne. 'EFRSLC') stop 5 + abbrev = param_get_abbrev(0, 1, 136) + if (abbrev .ne. 'EFRSICEC') stop 5 + abbrev = param_get_abbrev(0, 1, 137) + if (abbrev .ne. 'EFARRAIN') stop 5 + abbrev = param_get_abbrev(0, 1, 138) + if (abbrev .ne. 'EFARCICE') stop 5 + abbrev = param_get_abbrev(0, 1, 139) + if (abbrev .ne. 'EFARSNOW') stop 5 + abbrev = param_get_abbrev(0, 1, 140) + if (abbrev .ne. 'EFARGRL') stop 5 + abbrev = param_get_abbrev(0, 1, 141) + if (abbrev .ne. 'EFARHAIL') stop 5 + abbrev = param_get_abbrev(0, 1, 142) + if (abbrev .ne. 'EFARSIC') stop 5 + abbrev = param_get_abbrev(0, 1, 231) + if (abbrev .ne. 'PPINDX') stop 5 + abbrev = param_get_abbrev(0, 1, 232) + if (abbrev .ne. 'PROBCIP') stop 5 + abbrev = param_get_abbrev(0, 1, 233) + if (abbrev .ne. 'SNOWLR') stop 5 + abbrev = param_get_abbrev(0, 1, 234) + if (abbrev .ne. 'PCPDUR') stop 5 + abbrev = param_get_abbrev(0, 1, 235) + if (abbrev .ne. 'CLLMR') stop 5 + abbrev = param_get_abbrev(0, 2, 231) + if (abbrev .ne. 'TPWDIR') stop 5 + abbrev = param_get_abbrev(0, 2, 232) + if (abbrev .ne. 'TPWSPD') stop 5 + abbrev = param_get_abbrev(0, 2, 36) + if (abbrev .ne. 'AFRWE') stop 5 + abbrev = param_get_abbrev(0, 3, 20) + if (abbrev .ne. 'SDSGSO') stop 5 + abbrev = param_get_abbrev(0, 3, 21) + if (abbrev .ne. 'AOSGSO') stop 5 + abbrev = param_get_abbrev(0, 3, 22) + if (abbrev .ne. 'SSGSO') stop 5 + abbrev = param_get_abbrev(0, 3, 23) + if (abbrev .ne. 'GWD') stop 5 + abbrev = param_get_abbrev(0, 3, 24) + if (abbrev .ne. 'ASGSO') stop 5 + abbrev = param_get_abbrev(0, 3, 25) + if (abbrev .ne. 'NLPRES') stop 5 + abbrev = param_get_abbrev(0, 3, 26) + if (abbrev .ne. 'EXPRES') stop 5 + abbrev = param_get_abbrev(0, 3, 27) + if (abbrev .ne. 'UMFLX') stop 5 + abbrev = param_get_abbrev(0, 3, 28) + if (abbrev .ne. 'DMFLX') stop 5 + abbrev = param_get_abbrev(0, 3, 29) + if (abbrev .ne. 'UDRATE') stop 5 + abbrev = param_get_abbrev(0, 3, 30) + if (abbrev .ne. 'DDRATE') stop 5 + abbrev = param_get_abbrev(0, 3, 31) + if (abbrev .ne. 'UCLSPRS') stop 5 + abbrev = param_get_abbrev(0, 4, 50) + if (abbrev .ne. 'UVIUCS') stop 5 + abbrev = param_get_abbrev(0, 4, 52) + if (abbrev .ne. 'DSWRFCS') stop 5 + abbrev = param_get_abbrev(0, 4, 53) + if (abbrev .ne. 'USWRFCS') stop 5 + abbrev = param_get_abbrev(0, 5, 5) + if (abbrev .ne. 'NLWRF') stop 5 + abbrev = param_get_abbrev(0, 5, 6) + if (abbrev .ne. 'NLWRCS') stop 5 + abbrev = param_get_abbrev(0, 5, 7) + if (abbrev .ne. 'BRTEMP') stop 5 + abbrev = param_get_abbrev(0, 5, 8) + if (abbrev .ne. 'DLWRFCS') stop 5 + abbrev = param_get_abbrev(0, 6, 34) + if (abbrev .ne. 'SLWTC') stop 5 + abbrev = param_get_abbrev(0, 6, 35) + if (abbrev .ne. 'SSWTC') stop 5 + abbrev = param_get_abbrev(0, 6, 36) + if (abbrev .ne. 'FSTRPC') stop 5 + abbrev = param_get_abbrev(0, 6, 37) + if (abbrev .ne. 'FCONPC') stop 5 + abbrev = param_get_abbrev(0, 6, 38) + if (abbrev .ne. 'MASSDCD') stop 5 + abbrev = param_get_abbrev(0, 6, 39) + if (abbrev .ne. 'MASSDCI') stop 5 + abbrev = param_get_abbrev(0, 6, 40) + if (abbrev .ne. 'MDCCWD') stop 5 + abbrev = param_get_abbrev(0, 6, 47) + if (abbrev .ne. 'VFRCWD') stop 5 + abbrev = param_get_abbrev(0, 6, 48) + if (abbrev .ne. 'VFRCICE') stop 5 + abbrev = param_get_abbrev(0, 6, 49) + if (abbrev .ne. 'VFRCIW') stop 5 + abbrev = param_get_abbrev(0, 7, 19) + if (abbrev .ne. 'CONAPES') stop 5 + abbrev = param_get_abbrev(0, 7, 203) + if (abbrev .ne. 'DCAPE') stop 5 + abbrev = param_get_abbrev(0, 7, 204) + if (abbrev .ne. 'EFHL') stop 5 + abbrev = param_get_abbrev(0, 7, 205) + if (abbrev .ne. 'ESP') stop 5 + abbrev = param_get_abbrev(0, 7, 206) + if (abbrev .ne. 'CANGLE') stop 5 + abbrev = param_get_abbrev(0, 7, 206) + if (abbrev .ne. 'CANGLE') stop 5 + abbrev = param_get_abbrev(0, 15, 9) + if (abbrev .ne. 'RFCD') stop 5 + abbrev = param_get_abbrev(0, 15, 10) + if (abbrev .ne. 'RFCI') stop 5 + abbrev = param_get_abbrev(0, 15, 11) + if (abbrev .ne. 'RFSNOW') stop 5 + abbrev = param_get_abbrev(0, 15, 12) + if (abbrev .ne. 'RFRAIN') stop 5 + abbrev = param_get_abbrev(0, 15, 13) + if (abbrev .ne. 'RFGRPL') stop 5 + abbrev = param_get_abbrev(0, 15, 14) + if (abbrev .ne. 'RFHAIL') stop 5 + abbrev = param_get_abbrev(0, 15, 15) + if (abbrev .ne. 'HSR') stop 5 + abbrev = param_get_abbrev(0, 15, 16) + if (abbrev .ne. 'HSRHT') stop 5 + abbrev = param_get_abbrev(0, 17, 1) + if (abbrev .ne. 'LTPINX') stop 5 + abbrev = param_get_abbrev(0, 17, 2) + if (abbrev .ne. 'CDGDLTFD') stop 5 + abbrev = param_get_abbrev(0, 17, 3) + if (abbrev .ne. 'CDCDLTFD') stop 5 + abbrev = param_get_abbrev(0, 17, 4) + if (abbrev .ne. 'TLGTFD') stop 5 + abbrev = param_get_abbrev(0, 18, 0) + if (abbrev .ne. 'ACCES') stop 5 + abbrev = param_get_abbrev(0, 18, 1) + if (abbrev .ne. 'ACIOD') stop 5 + abbrev = param_get_abbrev(0, 18, 2) + if (abbrev .ne. 'ACRADP') stop 5 + abbrev = param_get_abbrev(0, 19, 28) + if (abbrev .ne. 'MWTURB') stop 5 + abbrev = param_get_abbrev(0, 19, 29) + if (abbrev .ne. 'CATEDR') stop 5 + abbrev = param_get_abbrev(0, 19, 30) + if (abbrev .ne. 'EDPARM') stop 5 + abbrev = param_get_abbrev(0, 19, 31) + if (abbrev .ne. 'MXEDPRM') stop 5 + abbrev = param_get_abbrev(0, 19, 32) + if (abbrev .ne. 'HIFREL') stop 5 + abbrev = param_get_abbrev(0, 19, 33) + if (abbrev .ne. 'VISLFOG') stop 5 + abbrev = param_get_abbrev(0, 19, 34) + if (abbrev .ne. 'VISIFOG') stop 5 + abbrev = param_get_abbrev(0, 19, 35) + if (abbrev .ne. 'VISBSN') stop 5 + abbrev = param_get_abbrev(0, 19, 36) + if (abbrev .ne. 'PSNOWS') stop 5 + abbrev = param_get_abbrev(0, 19, 37) + if (abbrev .ne. 'ICESEV') stop 5 + abbrev = param_get_abbrev(0, 19, 238) + if (abbrev .ne. 'ELLINX') stop 5 + abbrev = param_get_abbrev(1, 0, 7) + if (abbrev .ne. 'DISRS') stop 5 + abbrev = param_get_abbrev(1, 0, 8) + if (abbrev .ne. 'GWUPS') stop 5 + abbrev = param_get_abbrev(1, 0, 9) + if (abbrev .ne. 'GWLOWS') stop 5 + abbrev = param_get_abbrev(1, 0, 10) + if (abbrev .ne. 'SFLORC') stop 5 + abbrev = param_get_abbrev(1, 0, 11) + if (abbrev .ne. 'RVERSW') stop 5 + abbrev = param_get_abbrev(1, 0, 12) + if (abbrev .ne. 'FLDPSW') stop 5 + abbrev = param_get_abbrev(1, 0, 13) + if (abbrev .ne. 'DEPWSS') stop 5 + abbrev = param_get_abbrev(1, 0, 14) + if (abbrev .ne. 'UPAPCP') stop 5 + abbrev = param_get_abbrev(1, 0, 15) + if (abbrev .ne. 'UPASM') stop 5 + abbrev = param_get_abbrev(1, 0, 16) + if (abbrev .ne. 'PERRATE') stop 5 + abbrev = param_get_abbrev(1, 2, 0) + if (abbrev .ne. 'WDPTHIL') stop 5 + abbrev = param_get_abbrev(1, 2, 1) + if (abbrev .ne. 'WTMPIL') stop 5 + abbrev = param_get_abbrev(1, 2, 2) + if (abbrev .ne. 'WFRACT') stop 5 + abbrev = param_get_abbrev(1, 2, 3) + if (abbrev .ne. 'SEDTK') stop 5 + abbrev = param_get_abbrev(1, 2, 4) + if (abbrev .ne. 'SEDTMP') stop 5 + abbrev = param_get_abbrev(1, 2, 5) + if (abbrev .ne. 'ICTKIL') stop 5 + abbrev = param_get_abbrev(1, 2, 6) + if (abbrev .ne. 'ICETIL') stop 5 + abbrev = param_get_abbrev(1, 2, 7) + if (abbrev .ne. 'ICECIL') stop 5 + abbrev = param_get_abbrev(1, 2, 8) + if (abbrev .ne. 'LANDIL') stop 5 + abbrev = param_get_abbrev(1, 2, 9) + if (abbrev .ne. 'SFSAL') stop 5 + abbrev = param_get_abbrev(1, 2, 10) + if (abbrev .ne. 'SFTMP') stop 5 + abbrev = param_get_abbrev(1, 2, 11) + if (abbrev .ne. 'ACWSR') stop 5 + abbrev = param_get_abbrev(1, 2, 12) + if (abbrev .ne. 'SALTIL') stop 5 + abbrev = param_get_abbrev(1, 2, 13) + if (abbrev .ne. 'CSAFC') stop 5 + abbrev = param_get_abbrev(2, 0, 35) + if (abbrev .ne. 'TCLASS') stop 5 + abbrev = param_get_abbrev(2, 0, 36) + if (abbrev .ne. 'TFRCT') stop 5 + abbrev = param_get_abbrev(2, 0, 37) + if (abbrev .ne. 'TPERCT') stop 5 + abbrev = param_get_abbrev(2, 0, 38) + if (abbrev .ne. 'SOILVIC') stop 5 + abbrev = param_get_abbrev(2, 0, 39) + if (abbrev .ne. 'EVAPTRAT') stop 5 + abbrev = param_get_abbrev(2, 1, 192) + if (abbrev .ne. 'CANL') stop 5 + abbrev = param_get_abbrev(2, 3, 18) + if (abbrev .ne. 'SOILTMP') stop 5 + abbrev = param_get_abbrev(2, 3, 19) + if (abbrev .ne. 'SOILMOI') stop 5 + abbrev = param_get_abbrev(2, 3, 20) + if (abbrev .ne. 'CISOILM') stop 5 + abbrev = param_get_abbrev(2, 3, 21) + if (abbrev .ne. 'SOILICE') stop 5 + abbrev = param_get_abbrev(2, 3, 22) + if (abbrev .ne. 'CISICE') stop 5 + abbrev = param_get_abbrev(2, 3, 23) + if (abbrev .ne. 'LWSNWP') stop 5 + ! abbrev = param_get_abbrev(2, 3, 23) + ! if (abbrev .ne. 'FRSTINX') stop 5 + ! abbrev = param_get_abbrev(2, 3, 23) + ! if (abbrev .ne. 'SNWDEB') stop 5 + ! abbrev = param_get_abbrev(2, 3, 23) + ! if (abbrev .ne. 'SHFLX') stop 5 + ! abbrev = param_get_abbrev(2, 3, 23) + ! if (abbrev .ne. 'SOILDEP') stop 5 + abbrev = param_get_abbrev(2, 4, 0) + if (abbrev .ne. 'FIREOLK') stop 5 + abbrev = param_get_abbrev(2, 4, 1) + if (abbrev .ne. 'FIREODT') stop 5 + abbrev = param_get_abbrev(2, 4, 3) + if (abbrev .ne. 'FBAREA') stop 5 + abbrev = param_get_abbrev(2, 4, 4) + if (abbrev .ne. 'FOSINDX') stop 5 + abbrev = param_get_abbrev(2, 4, 5) + if (abbrev .ne. 'FWINX') stop 5 + abbrev = param_get_abbrev(2, 4, 6) + if (abbrev .ne. 'FFMCODE') stop 5 + abbrev = param_get_abbrev(2, 4, 7) + if (abbrev .ne. 'DUFMCODE') stop 5 + abbrev = param_get_abbrev(2, 4, 8) + if (abbrev .ne. 'DRTCODE') stop 5 + abbrev = param_get_abbrev(2, 4, 9) + if (abbrev .ne. 'INFSINX') stop 5 + abbrev = param_get_abbrev(2, 4, 10) + if (abbrev .ne. 'FBUPINX') stop 5 + abbrev = param_get_abbrev(2, 4, 11) + if (abbrev .ne. 'FDSRTE') stop 5 + abbrev = param_get_abbrev(2, 5, 1) + if (abbrev .ne. 'GLACTMP') stop 5 + abbrev = param_get_abbrev(3, 0, 0) + if (abbrev .ne. 'SRAD') stop 5 + abbrev = param_get_abbrev(3, 0, 1) + if (abbrev .ne. 'SALBEDO') stop 5 + abbrev = param_get_abbrev(3, 0, 2) + if (abbrev .ne. 'SBTMP') stop 5 + abbrev = param_get_abbrev(3, 0, 3) + if (abbrev .ne. 'SPWAT') stop 5 + abbrev = param_get_abbrev(3, 0, 4) + if (abbrev .ne. 'SLFTI') stop 5 + abbrev = param_get_abbrev(3, 0, 5) + if (abbrev .ne. 'SCTPRES') stop 5 + abbrev = param_get_abbrev(3, 0, 6) + if (abbrev .ne. 'SSTMP') stop 5 + abbrev = param_get_abbrev(3, 0, 7) + if (abbrev .ne. 'CLOUDM') stop 5 + abbrev = param_get_abbrev(3, 0, 8) + if (abbrev .ne. 'PIXST') stop 5 + abbrev = param_get_abbrev(3, 0, 9) + if (abbrev .ne. 'FIREDI') stop 5 + abbrev = param_get_abbrev(3, 1, 194) + if (abbrev .ne. 'SWQI') stop 5 + abbrev = param_get_abbrev(3, 2, 0) + if (abbrev .ne. 'CSKPROB') stop 5 + abbrev = param_get_abbrev(3, 192, 53) + if (abbrev .ne. 'SBTAGR8') stop 5 + abbrev = param_get_abbrev(3, 192, 54) + if (abbrev .ne. 'SBTAGR9') stop 5 + abbrev = param_get_abbrev(3, 192, 55) + if (abbrev .ne. 'SBTAGR10') stop 5 + abbrev = param_get_abbrev(3, 192, 56) + if (abbrev .ne. 'SBTAGR11') stop 5 + abbrev = param_get_abbrev(3, 192, 57) + if (abbrev .ne. 'SBTAGR12') stop 5 + abbrev = param_get_abbrev(3, 192, 58) + if (abbrev .ne. 'SBTAGR13') stop 5 + abbrev = param_get_abbrev(3, 192, 59) + if (abbrev .ne. 'SBTAGR14') stop 5 + abbrev = param_get_abbrev(3, 192, 60) + if (abbrev .ne. 'SBTAGR15') stop 5 + abbrev = param_get_abbrev(3, 192, 61) + if (abbrev .ne. 'SBTAGR16') stop 5 + abbrev = param_get_abbrev(10, 0, 14) + if (abbrev .ne. 'WWSDIR') stop 5 + abbrev = param_get_abbrev(10, 0, 15) + if (abbrev .ne. 'MWSPER') stop 5 + abbrev = param_get_abbrev(10, 0, 16) + if (abbrev .ne. 'CDWW') stop 5 + abbrev = param_get_abbrev(10, 0, 17) + if (abbrev .ne. 'FRICV') stop 5 + abbrev = param_get_abbrev(10, 0, 18) + if (abbrev .ne. 'WSTR') stop 5 + abbrev = param_get_abbrev(10, 0, 19) + if (abbrev .ne. 'NWSTR') stop 5 + abbrev = param_get_abbrev(10, 0, 20) + if (abbrev .ne. 'MSSW') stop 5 + abbrev = param_get_abbrev(10, 0, 21) + if (abbrev .ne. 'USSD') stop 5 + abbrev = param_get_abbrev(10, 0, 22) + if (abbrev .ne. 'VSSD') stop 5 + abbrev = param_get_abbrev(10, 0, 23) + if (abbrev .ne. 'PMAXWH') stop 5 + abbrev = param_get_abbrev(10, 0, 24) + if (abbrev .ne. 'MAXWH') stop 5 + abbrev = param_get_abbrev(10, 0, 25) + if (abbrev .ne. 'IMWF') stop 5 + abbrev = param_get_abbrev(10, 0, 26) + if (abbrev .ne. 'IMFWW') stop 5 + abbrev = param_get_abbrev(10, 0, 27) + if (abbrev .ne. 'IMFTSW') stop 5 + abbrev = param_get_abbrev(10, 0, 28) + if (abbrev .ne. 'MZWPER') stop 5 + abbrev = param_get_abbrev(10, 0, 29) + if (abbrev .ne. 'MZPWW') stop 5 + abbrev = param_get_abbrev(10, 0, 30) + if (abbrev .ne. 'MZPTSW') stop 5 + abbrev = param_get_abbrev(10, 0, 31) + if (abbrev .ne. 'WDIRW') stop 5 + abbrev = param_get_abbrev(10, 0, 32) + if (abbrev .ne. 'DIRWWW') stop 5 + abbrev = param_get_abbrev(10, 0, 33) + if (abbrev .ne. 'DIRWTS') stop 5 + abbrev = param_get_abbrev(10, 0, 34) + if (abbrev .ne. 'PWPER') stop 5 + abbrev = param_get_abbrev(10, 0, 35) + if (abbrev .ne. 'PPERWW') stop 5 + abbrev = param_get_abbrev(10, 0, 36) + if (abbrev .ne. 'PPERTS') stop 5 + abbrev = param_get_abbrev(10, 0, 37) + if (abbrev .ne. 'ALTWH') stop 5 + abbrev = param_get_abbrev(10, 0, 38) + if (abbrev .ne. 'ALCWH') stop 5 + abbrev = param_get_abbrev(10, 0, 39) + if (abbrev .ne. 'ALRRC') stop 5 + abbrev = param_get_abbrev(10, 0, 40) + if (abbrev .ne. 'MNWSOW') stop 5 + abbrev = param_get_abbrev(10, 0, 41) + if (abbrev .ne. 'MWDIRW') stop 5 + abbrev = param_get_abbrev(10, 0, 42) + if (abbrev .ne. 'WESP') stop 5 + abbrev = param_get_abbrev(10, 0, 43) + if (abbrev .ne. 'KSSEW') stop 5 + abbrev = param_get_abbrev(10, 0, 44) + if (abbrev .ne. 'BENINX') stop 5 + abbrev = param_get_abbrev(10, 0, 45) + if (abbrev .ne. 'SPFTR') stop 5 + abbrev = param_get_abbrev(10, 0, 46) + if (abbrev .ne. 'PWAVEDIR') stop 5 + abbrev = param_get_abbrev(10, 0, 47) + if (abbrev .ne. 'SWHFSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 48) + if (abbrev .ne. 'SWHSSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 49) + if (abbrev .ne. 'SWHTSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 50) + if (abbrev .ne. 'MWPFSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 51) + if (abbrev .ne. 'MWPSSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 52) + if (abbrev .ne. 'MWPTSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 53) + if (abbrev .ne. 'MWDFSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 54) + if (abbrev .ne. 'MWDSSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 55) + if (abbrev .ne. 'MWDTSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 56) + if (abbrev .ne. 'WDWFSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 57) + if (abbrev .ne. 'WDWSSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 58) + if (abbrev .ne. 'WDWTSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 59) + if (abbrev .ne. 'WFWFSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 60) + if (abbrev .ne. 'WFWSSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 61) + if (abbrev .ne. 'WFWTSWEL') stop 5 + abbrev = param_get_abbrev(10, 0, 62) + if (abbrev .ne. 'WAVEFREW') stop 5 + abbrev = param_get_abbrev(10, 0, 63) + if (abbrev .ne. 'FREWWW') stop 5 + abbrev = param_get_abbrev(10, 0, 64) + if (abbrev .ne. 'FREWTSW') stop 5 + abbrev = param_get_abbrev(10, 1, 4) + if (abbrev .ne. 'RIPCOP') stop 5 + abbrev = param_get_abbrev(10, 2, 9) + if (abbrev .ne. 'ICEPRS') stop 5 + abbrev = param_get_abbrev(10, 2, 10) + if (abbrev .ne. 'ZVCICEP') stop 5 + abbrev = param_get_abbrev(10, 2, 11) + if (abbrev .ne. 'MVCICEP') stop 5 + abbrev = param_get_abbrev(10, 2, 12) + if (abbrev .ne. 'CICES') stop 5 + abbrev = param_get_abbrev(10, 3, 2) + if (abbrev .ne. 'CH') stop 5 + abbrev = param_get_abbrev(10, 3, 3) + if (abbrev .ne. 'PRACTSAL') stop 5 + abbrev = param_get_abbrev(10, 3, 204) + if (abbrev .ne. 'FRZSPR') stop 5 + abbrev = param_get_abbrev(10, 4, 13) + if (abbrev .ne. 'ACWSRD') stop 5 + abbrev = param_get_abbrev(10, 3, 205) + if (abbrev .ne. 'TWLWAV') stop 5 + abbrev = param_get_abbrev(10, 3, 206) + if (abbrev .ne. 'RUNUP') stop 5 + abbrev = param_get_abbrev(10, 3, 207) + if (abbrev .ne. 'SETUP') stop 5 + abbrev = param_get_abbrev(10, 3, 208) + if (abbrev .ne. 'SWASH') stop 5 + abbrev = param_get_abbrev(10, 3, 209) + if (abbrev .ne. 'TWLDT') stop 5 + abbrev = param_get_abbrev(10, 3, 210) + if (abbrev .ne. 'TWLDC') stop 5 + abbrev = param_get_abbrev(10, 3, 250) + if (abbrev .ne. 'ETCWL') stop 5 + abbrev = param_get_abbrev(10, 3, 251) + if (abbrev .ne. 'TIDE') stop 5 + abbrev = param_get_abbrev(10, 3, 252) + if (abbrev .ne. 'EROSNP') stop 5 + abbrev = param_get_abbrev(10, 3, 253) + if (abbrev .ne. 'OWASHP') stop 5 + abbrev = param_get_abbrev(10, 4, 14) + if (abbrev .ne. 'WDEPTH') stop 5 + abbrev = param_get_abbrev(10, 4, 15) + if (abbrev .ne. 'WTMPSS') stop 5 + abbrev = param_get_abbrev(10, 4, 16) + if (abbrev .ne. 'WATERDEN') stop 5 + abbrev = param_get_abbrev(10, 4, 17) + if (abbrev .ne. 'WATDENA') stop 5 + abbrev = param_get_abbrev(10, 4, 18) + if (abbrev .ne. 'WATPTEMP') stop 5 + abbrev = param_get_abbrev(10, 4, 19) + if (abbrev .ne. 'WATPDEN') stop 5 + abbrev = param_get_abbrev(10, 4, 20) + if (abbrev .ne. 'WATPDENA') stop 5 + abbrev = param_get_abbrev(10, 4, 21) + if (abbrev .ne. 'PRTSAL') stop 5 + abbrev = param_get_abbrev(0, 16, 3) + if (abbrev .ne. 'RETOP') stop 5 + abbrev = param_get_abbrev(1, 0, 5) + if (abbrev .ne. 'BGRUN') stop 5 + abbrev = param_get_abbrev(1, 0, 6) + if (abbrev .ne. 'SSRUN') stop 5 + abbrev = param_get_abbrev(2, 3, 5) + if (abbrev .ne. 'SOILL') stop 5 + + print *, 'Testing all parameters with param_g1_to_g2()...' + call param_g1_to_g2(1, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 0) stop 21 + + call param_g1_to_g2(1, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(1, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(2, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(3, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(4, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 14) stop 21 + call param_g1_to_g2(5, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(6, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(7, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(8, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(9, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(10, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(11, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(12, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(13, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(14, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(15, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(16, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(17, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(18, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(19, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(20, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(21, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 15 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(22, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 15 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(23, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 15 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(24, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(25, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(26, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(27, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(28, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(29, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(30, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(31, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(32, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(33, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(34, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(35, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(36, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(37, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(38, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(39, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(40, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(41, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(42, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(43, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 12) stop 21 + call param_g1_to_g2(44, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 13) stop 21 + call param_g1_to_g2(45, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 15) stop 21 + call param_g1_to_g2(46, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 16) stop 21 + call param_g1_to_g2(47, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(48, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(49, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(50, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(51, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(52, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(53, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(54, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(55, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(56, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(57, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(58, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(59, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(60, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(61, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(62, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(63, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(64, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 12) stop 21 + call param_g1_to_g2(65, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 13) stop 21 + call param_g1_to_g2(66, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(67, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(68, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(69, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(70, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(71, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(72, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(73, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(74, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(75, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(76, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(77, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(78, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 14) stop 21 + call param_g1_to_g2(79, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 15) stop 21 + call param_g1_to_g2(80, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(81, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(82, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(83, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(84, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(85, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(86, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(87, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(88, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(89, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(90, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(91, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(92, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(93, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(94, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(95, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(96, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(97, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(98, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(99, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 16) stop 21 + call param_g1_to_g2(100, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(101, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(102, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(103, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(104, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(105, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(106, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(107, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(108, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(109, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 12) stop 21 + call param_g1_to_g2(110, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 13) stop 21 + call param_g1_to_g2(111, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(112, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(113, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(114, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(115, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(116, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(117, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(118, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(119, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(120, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(121, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(122, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(123, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 20) stop 21 + call param_g1_to_g2(124, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 17) stop 21 + call param_g1_to_g2(125, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 18) stop 21 + call param_g1_to_g2(126, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 19) stop 21 + call param_g1_to_g2(127, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 255 .or. g2cat .ne. 255 .or. g2num .ne. 255) stop 21 + call param_g1_to_g2(229, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(153, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 22) stop 21 + call param_g1_to_g2(140, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(141, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(142, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(143, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(214, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(135, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(194, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 1 .or. g2cat .ne. 1 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(228, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(136, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(172, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(196, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(197, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(252, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(253, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(130, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(204, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(211, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(205, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(212, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(213, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(132, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(157, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(156, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(190, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(131, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(158, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(176, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 191 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(177, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 191 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(234, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 1 .or. g2cat .ne. 0 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(235, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 1 .or. g2cat .ne. 0 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(144, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(155, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(207, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(208, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(223, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(226, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(154, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(222, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(145, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(146, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(147, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(148, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(221, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(230, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(160, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(171, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(219, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(222, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(224, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(225, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(230, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(231, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(238, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(240, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(131, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 202) stop 21 + call param_g1_to_g2(132, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(133, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 203) stop 21 + call param_g1_to_g2(134, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(135, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(136, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(137, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(138, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 204) stop 21 + call param_g1_to_g2(139, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 205) stop 21 + call param_g1_to_g2(140, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(159, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(170, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(170, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 24) stop 21 + call param_g1_to_g2(171, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 25) stop 21 + call param_g1_to_g2(181, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(203, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(246, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 202) stop 21 + call param_g1_to_g2(247, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 203) stop 21 + call param_g1_to_g2(248, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 204) stop 21 + call param_g1_to_g2(249, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 205) stop 21 + call param_g1_to_g2(254, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(190, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 3 .or. g2cat .ne. 1 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(191, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 3 .or. g2cat .ne. 1 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(171, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 191 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(180, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(181, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(193, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 1 .or. g2cat .ne. 1 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(195, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 1 .or. g2cat .ne. 1 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(180, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 22) stop 21 + call param_g1_to_g2(31, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(32, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(33, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(34, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(100, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(101, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(103, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(107, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(108, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(109, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 12) stop 21 + call param_g1_to_g2(110, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 13) stop 21 + call param_g1_to_g2(156, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 13 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(157, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 13 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(11, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(129, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(163, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 13 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(164, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 13 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(178, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 23) stop 21 + call param_g1_to_g2(179, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 32) stop 21 + call param_g1_to_g2(186, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 206) stop 21 + call param_g1_to_g2(187, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 17 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(188, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 206) stop 21 + call param_g1_to_g2(189, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 15) stop 21 + call param_g1_to_g2(198, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 207) stop 21 + call param_g1_to_g2(239, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 208) stop 21 + call param_g1_to_g2(128, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(137, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(141, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(200, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(201, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(201, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 207) stop 21 + call param_g1_to_g2(209, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 204) stop 21 + call param_g1_to_g2(216, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(211, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 16 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(212, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 16 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(161, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(168, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 209) stop 21 + call param_g1_to_g2(169, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 210) stop 21 + call param_g1_to_g2(181, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(182, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 202) stop 21 + call param_g1_to_g2(183, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 203) stop 21 + call param_g1_to_g2(184, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 204) stop 21 + call param_g1_to_g2(254, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(91, 1, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(49, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(50, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(80, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(82, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(88, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(49, 1, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(50, 1, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(80, 1, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(88, 1, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(40, 1, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(67, 1, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(2, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(7, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(130, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(217, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(218, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 27) stop 21 + call param_g1_to_g2(161, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 29) stop 21 + call param_g1_to_g2(165, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 16 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(166, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 16 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(167, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 16 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(192, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(193, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(188, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(189, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(207, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 202) stop 21 + call param_g1_to_g2(208, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 203) stop 21 + call param_g1_to_g2(198, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(33, 1, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(34, 1, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(2, 1, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(7, 1, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(186, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(187, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(177, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(178, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(179, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(183, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(184, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(179, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 205) stop 21 + call param_g1_to_g2(185, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 206) stop 21 + call param_g1_to_g2(186, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 207) stop 21 + call param_g1_to_g2(187, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 208) stop 21 + call param_g1_to_g2(177, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 209) stop 21 + call param_g1_to_g2(178, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 210) stop 21 + call param_g1_to_g2(189, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 211) stop 21 + call param_g1_to_g2(190, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 212) stop 21 + call param_g1_to_g2(191, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 213) stop 21 + call param_g1_to_g2(192, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 214) stop 21 + call param_g1_to_g2(149, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(188, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 211) stop 21 + call param_g1_to_g2(192, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 205) stop 21 + call param_g1_to_g2(219, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 13) stop 21 + call param_g1_to_g2(220, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 12) stop 21 + call param_g1_to_g2(179, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 228) stop 21 + call param_g1_to_g2(198, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 212) stop 21 + call param_g1_to_g2(199, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(200, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 229) stop 21 + call param_g1_to_g2(210, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 230) stop 21 + call param_g1_to_g2(182, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 204) stop 21 + call param_g1_to_g2(241, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(242, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(168, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 20) stop 21 + call param_g1_to_g2(169, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 20) stop 21 + call param_g1_to_g2(170, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 21) stop 21 + call param_g1_to_g2(171, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 21) stop 21 + call param_g1_to_g2(172, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 22) stop 21 + call param_g1_to_g2(173, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 22) stop 21 + call param_g1_to_g2(174, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 25) stop 21 + call param_g1_to_g2(175, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 255 .or. g2cat .ne. 255 .or. g2num .ne. 255) stop 21 + call param_g1_to_g2(176, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 255 .or. g2cat .ne. 255 .or. g2num .ne. 255) stop 21 + call param_g1_to_g2(177, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 255 .or. g2cat .ne. 255 .or. g2num .ne. 255) stop 21 + call param_g1_to_g2(178, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 255 .or. g2cat .ne. 255 .or. g2num .ne. 255) stop 21 + call param_g1_to_g2(179, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(180, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(181, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 255 .or. g2cat .ne. 255 .or. g2num .ne. 255) stop 21 + call param_g1_to_g2(182, 140, g2disc, g2cat, g2num) + if (g2disc .ne. 255 .or. g2cat .ne. 255 .or. g2num .ne. 255) stop 21 + call param_g1_to_g2(76, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(104, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(105, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(106, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(102, 0, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(213, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 3 .or. g2cat .ne. 192 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(214, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 3 .or. g2cat .ne. 192 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(215, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 3 .or. g2cat .ne. 192 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(216, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 3 .or. g2cat .ne. 192 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(221, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 3 .or. g2cat .ne. 192 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(222, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 3 .or. g2cat .ne. 192 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(228, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(229, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(149, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 14) stop 21 + call param_g1_to_g2(150, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(151, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(152, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(202, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(33, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(34, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(40, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(124, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 17) stop 21 + call param_g1_to_g2(125, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 18) stop 21 + call param_g1_to_g2(8, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(13, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(88, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(49, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(50, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(215, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(217, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(154, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(250, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(251, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(160, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(162, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(163, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(164, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(165, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(166, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(167, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(168, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 202) stop 21 + call param_g1_to_g2(169, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 203) stop 21 + call param_g1_to_g2(206, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(219, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(220, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 206) stop 21 + call param_g1_to_g2(244, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(246, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 202) stop 21 + call param_g1_to_g2(243, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 213) stop 21 + call param_g1_to_g2(245, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 214) stop 21 + call param_g1_to_g2(249, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 215) stop 21 + call param_g1_to_g2(247, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 208) stop 21 + call param_g1_to_g2(248, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 209) stop 21 + call param_g1_to_g2(202, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(232, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 204) stop 21 + call param_g1_to_g2(233, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 205) stop 21 + call param_g1_to_g2(231, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(202, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(203, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 232) stop 21 + call param_g1_to_g2(238, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(66, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(133, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(134, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(191, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(195, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(171, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(180, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(193, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(194, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(190, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(185, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(199, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 202) stop 21 + call param_g1_to_g2(197, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(159, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 216) stop 21 + call param_g1_to_g2(175, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 191 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(223, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 65) stop 21 + call param_g1_to_g2(224, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 66) stop 21 + call param_g1_to_g2(225, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 67) stop 21 + call param_g1_to_g2(226, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 68) stop 21 + call param_g1_to_g2(227, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(87, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(130, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 1 .or. g2cat .ne. 1 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(240, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(164, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(165, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(166, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(167, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(168, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(169, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(203, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(206, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 12) stop 21 + call param_g1_to_g2(220, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 13) stop 21 + call param_g1_to_g2(234, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 192 .or. g2num .ne. 14) stop 21 + call param_g1_to_g2(201, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 203) stop 21 + call param_g1_to_g2(195, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 218) stop 21 + call param_g1_to_g2(204, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 219) stop 21 + call param_g1_to_g2(205, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 220) stop 21 + call param_g1_to_g2(181, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 210) stop 21 + call param_g1_to_g2(182, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 211) stop 21 + call param_g1_to_g2(183, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 212) stop 21 + call param_g1_to_g2(184, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 213) stop 21 + call param_g1_to_g2(236, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 214) stop 21 + call param_g1_to_g2(154, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 215) stop 21 + call param_g1_to_g2(196, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 216) stop 21 + call param_g1_to_g2(197, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 217) stop 21 + call param_g1_to_g2(202, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 207) stop 21 + call param_g1_to_g2(209, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 208) stop 21 + call param_g1_to_g2(219, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 209) stop 21 + call param_g1_to_g2(173, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 217) stop 21 + call param_g1_to_g2(174, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(175, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(188, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(139, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(239, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(185, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 208) stop 21 + call param_g1_to_g2(186, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 209) stop 21 + call param_g1_to_g2(193, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 218) stop 21 + call param_g1_to_g2(229, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(194, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 204) stop 21 + call param_g1_to_g2(185, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 219) stop 21 + call param_g1_to_g2(182, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(173, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 210) stop 21 + call param_g1_to_g2(174, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 218) stop 21 + call param_g1_to_g2(1, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(2, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(3, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(4, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 14) stop 21 + call param_g1_to_g2(5, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(6, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(7, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(8, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(9, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(10, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(11, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(12, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(13, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(14, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(15, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(16, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(17, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(18, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(19, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(20, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(21, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 15 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(22, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 15 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(23, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 15 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(24, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(25, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(26, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(27, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(28, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(29, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(30, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(31, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(32, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(33, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(34, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(35, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(36, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(37, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(38, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(39, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(40, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(41, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(42, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(43, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 12) stop 21 + call param_g1_to_g2(44, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 13) stop 21 + call param_g1_to_g2(45, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 15) stop 21 + call param_g1_to_g2(46, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 16) stop 21 + call param_g1_to_g2(47, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(48, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(49, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(50, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 1 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(51, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(52, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(53, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(54, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(55, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(56, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(57, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(58, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(59, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(60, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(61, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(62, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(63, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(64, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 12) stop 21 + call param_g1_to_g2(65, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 13) stop 21 + call param_g1_to_g2(66, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(67, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(68, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(69, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(70, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(71, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(72, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(73, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(74, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(75, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(76, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(77, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(78, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 14) stop 21 + call param_g1_to_g2(79, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 15) stop 21 + call param_g1_to_g2(80, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(81, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(82, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(83, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(84, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(85, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(86, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(87, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(88, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(89, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(90, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(91, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(92, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(93, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(94, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(95, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(96, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(97, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(98, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 2 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(99, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 16) stop 21 + call param_g1_to_g2(100, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(101, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(102, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(103, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(104, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(105, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(106, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(107, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(108, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(109, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 12) stop 21 + call param_g1_to_g2(110, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 13) stop 21 + call param_g1_to_g2(111, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(112, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(113, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(114, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(115, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(116, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(117, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(118, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(119, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(120, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(121, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(122, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(123, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 20) stop 21 + call param_g1_to_g2(124, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 17) stop 21 + call param_g1_to_g2(125, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 18) stop 21 + call param_g1_to_g2(126, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 19) stop 21 + call param_g1_to_g2(127, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 255 .or. g2cat .ne. 255 .or. g2num .ne. 255) stop 21 + call param_g1_to_g2(128, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(130, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(131, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(132, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(134, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 212) stop 21 + call param_g1_to_g2(135, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(136, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(137, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 219) stop 21 + call param_g1_to_g2(140, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(141, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(142, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(143, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(144, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(145, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(146, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 210) stop 21 + call param_g1_to_g2(147, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(148, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(149, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 202) stop 21 + call param_g1_to_g2(150, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 211) stop 21 + call param_g1_to_g2(151, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 212) stop 21 + call param_g1_to_g2(152, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 213) stop 21 + call param_g1_to_g2(153, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 22) stop 21 + call param_g1_to_g2(155, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(156, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(157, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(158, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(159, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(160, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(161, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 29) stop 21 + call param_g1_to_g2(162, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 221) stop 21 + call param_g1_to_g2(163, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 214) stop 21 + call param_g1_to_g2(164, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 215) stop 21 + call param_g1_to_g2(165, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 222) stop 21 + call param_g1_to_g2(166, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(167, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(168, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 202) stop 21 + call param_g1_to_g2(169, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 203) stop 21 + call param_g1_to_g2(170, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(171, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(172, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(173, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 210) stop 21 + call param_g1_to_g2(174, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 218) stop 21 + call param_g1_to_g2(175, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 191 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(176, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 191 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(177, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 191 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(178, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 23) stop 21 + call param_g1_to_g2(179, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 228) stop 21 + call param_g1_to_g2(180, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 17) stop 21 + call param_g1_to_g2(181, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(182, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(183, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 216) stop 21 + call param_g1_to_g2(184, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 19) stop 21 + call param_g1_to_g2(187, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 217) stop 21 + call param_g1_to_g2(188, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 206) stop 21 + call param_g1_to_g2(189, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 218) stop 21 + call param_g1_to_g2(190, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(191, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 191 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(192, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 191 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(194, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 1 .or. g2cat .ne. 1 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(196, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(197, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(198, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 212) stop 21 + call param_g1_to_g2(199, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(200, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 229) stop 21 + call param_g1_to_g2(202, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 223) stop 21 + call param_g1_to_g2(203, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(204, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(205, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(206, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 224) stop 21 + call param_g1_to_g2(207, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(208, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(210, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 230) stop 21 + call param_g1_to_g2(211, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(212, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(213, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(214, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(216, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(218, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 211) stop 21 + call param_g1_to_g2(219, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(220, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 203) stop 21 + call param_g1_to_g2(221, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(222, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(223, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(224, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(225, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(226, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(227, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 219) stop 21 + call param_g1_to_g2(228, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(229, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(230, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 195) stop 21 + call param_g1_to_g2(231, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(232, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 220) stop 21 + call param_g1_to_g2(233, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 221) stop 21 + call param_g1_to_g2(234, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 1 .or. g2cat .ne. 0 .or. g2num .ne. 192) stop 21 + call param_g1_to_g2(235, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 1 .or. g2cat .ne. 0 .or. g2num .ne. 193) stop 21 + call param_g1_to_g2(237, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 222) stop 21 + call param_g1_to_g2(238, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(239, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 208) stop 21 + call param_g1_to_g2(240, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(241, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 223) stop 21 + call param_g1_to_g2(242, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 224) stop 21 + call param_g1_to_g2(243, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 225) stop 21 + call param_g1_to_g2(244, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 226) stop 21 + call param_g1_to_g2(245, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 227) stop 21 + call param_g1_to_g2(246, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 202) stop 21 + call param_g1_to_g2(247, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 203) stop 21 + call param_g1_to_g2(248, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 204) stop 21 + call param_g1_to_g2(249, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 205) stop 21 + call param_g1_to_g2(250, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 4 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(251, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 5 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(252, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 196) stop 21 + call param_g1_to_g2(253, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(254, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 194) stop 21 + call param_g1_to_g2(62, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(63, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(220, 131, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 203) stop 21 + call param_g1_to_g2(231, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 200) stop 21 + call param_g1_to_g2(232, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(240, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 16 .or. g2num .ne. 197) stop 21 + call param_g1_to_g2(191, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 6 .or. g2num .ne. 201) stop 21 + call param_g1_to_g2(233, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 202) stop 21 + call param_g1_to_g2(234, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 14 .or. g2num .ne. 203) stop 21 + call param_g1_to_g2(242, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 242) stop 21 + call param_g1_to_g2(243, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 243) stop 21 + call param_g1_to_g2(244, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 244) stop 21 + call param_g1_to_g2(245, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 245) stop 21 + call param_g1_to_g2(246, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 246) stop 21 + call param_g1_to_g2(247, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 247) stop 21 + call param_g1_to_g2(248, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 248) stop 21 + call param_g1_to_g2(249, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 3 .or. g2num .ne. 249) stop 21 + call param_g1_to_g2(1, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 3 .or. g2num .ne. 0) stop 21 + call param_g1_to_g2(52, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(63, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(61, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(41, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(100, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(101, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(103, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(104, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(105, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(107, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 10) stop 21 + call param_g1_to_g2(108, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 11) stop 21 + call param_g1_to_g2(109, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 12) stop 21 + call param_g1_to_g2(110, 3, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 0 .or. g2num .ne. 13) stop 21 + call param_g1_to_g2(192, 133, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 191 .or. g2num .ne. 1) stop 21 + call param_g1_to_g2(193, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 225) stop 21 + call param_g1_to_g2(194, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 227) stop 21 + call param_g1_to_g2(195, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 241) stop 21 + call param_g1_to_g2(196, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 0 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(195, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 4) stop 21 + call param_g1_to_g2(196, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 5) stop 21 + call param_g1_to_g2(197, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 10 .or. g2cat .ne. 4 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(64, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 12) stop 21 + call param_g1_to_g2(241, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 3 .or. g2cat .ne. 192 .or. g2num .ne. 6) stop 21 + call param_g1_to_g2(242, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 3 .or. g2cat .ne. 192 .or. g2num .ne. 7) stop 21 + call param_g1_to_g2(243, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 3 .or. g2cat .ne. 192 .or. g2num .ne. 8) stop 21 + call param_g1_to_g2(244, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 3 .or. g2cat .ne. 192 .or. g2num .ne. 9) stop 21 + call param_g1_to_g2(235, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 16 .or. g2num .ne. 198) stop 21 + call param_g1_to_g2(236, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 7 .or. g2num .ne. 199) stop 21 + call param_g1_to_g2(237, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 220) stop 21 + call param_g1_to_g2(238, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 221) stop 21 + call param_g1_to_g2(253, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 222) stop 21 + call param_g1_to_g2(254, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 223) stop 21 + call param_g1_to_g2(241, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 2 .or. g2num .ne. 224) stop 21 + call param_g1_to_g2(250, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 2 .or. g2cat .ne. 4 .or. g2num .ne. 2) stop 21 + call param_g1_to_g2(175, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 234) stop 21 + call param_g1_to_g2(176, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 233) stop 21 + call param_g1_to_g2(236, 2, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 19 .or. g2num .ne. 217) stop 21 + call param_g1_to_g2(230, 129, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 242) stop 21 + call param_g1_to_g2(206, 130, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 15 .or. g2num .ne. 3) stop 21 + call param_g1_to_g2(255, 255, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 0 .or. g2num .ne. 255) stop 21 + ! call param_g1_to_g2(240, 129, g2disc, g2cat, g2num) + ! if (g2disc .ne. 0 .or. g2cat .ne. 16 .or. g2num .ne. 3) stop 21 + ! call param_g1_to_g2(234, 2, g2disc, g2cat, g2num) + ! if (g2disc .ne. 1 .or. g2cat .ne. 0 .or. g2num .ne. 5) stop 21 + ! call param_g1_to_g2(235, 2, g2disc, g2cat, g2num) + ! if (g2disc .ne. 1 .or. g2cat .ne. 0 .or. g2num .ne. 6) stop 21 + ! call param_g1_to_g2(160, 130, g2disc, g2cat, g2num) + ! if (g2disc .ne. 2 .or. g2cat .ne. 3 .or. g2num .ne. 5) stop 21 + + print *, 'SUCCESS!' + +end program test_params diff --git a/tests/test_params_ecmwf.F90 b/tests/test_params_ecmwf.F90 new file mode 100644 index 00000000..e27ffeae --- /dev/null +++ b/tests/test_params_ecmwf.F90 @@ -0,0 +1,28 @@ +! This program tests the params_ecmwf module of the NCEPLIBS-g2 +! project. +! +! Ed Hartnett 9/30/21 +program test_params_ecmwf + use params_ecmwf + implicit none + + integer :: g2disc, g2cat, g2num, g1val, g1ver + + print *, 'Testing the params_ecmwf module.' + + print *, 'Testing param_ecmwf_g1_to_g2...' + call param_ecmwf_g1_to_g2(1, 128, g2disc, g2cat, g2num) + if (g2disc .ne. 255 .or. g2cat .ne. 255 .or. g2num .ne. 255) stop 2 + call param_ecmwf_g1_to_g2(52, 1, g2disc, g2cat, g2num) + if (g2disc .ne. 0 .or. g2cat .ne. 1 .or. g2num .ne. 1) stop 3 + + print *, 'Testing param_ecmwf_g2_to_g1...' + call param_ecmwf_g2_to_g1(0, 3, 1, g1val, g1ver) + if (g1val .ne. 151 .or. g1ver .ne. 128) stop 4 + ! There are two matches here. param_ecmwf_g2_to_g1() returns the first. + call param_ecmwf_g2_to_g1(0, 0, 5, g1val, g1ver) + if (g1val .ne. 202 .or. g1ver .ne. 128) stop 5 + + print *, 'SUCCESS!' + +end program test_params_ecmwf diff --git a/tests/test_pdstemplates.F90 b/tests/test_pdstemplates.F90 new file mode 100644 index 00000000..919ff291 --- /dev/null +++ b/tests/test_pdstemplates.F90 @@ -0,0 +1,66 @@ +! This is a test for the NCEPLIBS-g2 project. +! +! This program tests pdstemplates.F90. +! +! Brian Curtis 11/09/2021, Ed Hartnett +program test_pdstemplates + use pdstemplates + implicit none + + integer :: idx + integer :: nummap + integer :: iret, i + integer, dimension(15) :: map_comp, list + integer, dimension(MAXLEN) :: map + !integer, dimension(MAXLEN) :: map1 + logical :: needext + integer :: pdtlen + + print *, 'Testing pdstemplates, expect and ignore error messages...' + + print *, 'Testing getpdsindex() ...' + ! Fortran is base 1, so index 0 should = 1 + idx = getpdsindex(0) + if (idx .ne. 1) stop 3 + ! Index -1 will still equal -1 because it doesn't exist + idx = getpdsindex(-1) + if (idx .ne. -1) stop 4 + + print *, 'testing getpdstemplate() ...' + pdtlen = getpdtlen(0) + if (pdtlen .ne. 15) stop 5 + map_comp = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4/) + call getpdstemplate(0, nummap, map, needext, iret) + if (iret .ne. 0) stop 6 + if (pdtlen .ne. nummap) stop 7 + do i = 1, nummap + if (map(i) .ne. map_comp(i)) stop 8 + end do + if (needext) stop 9 + + print *, 'testing getpdtlen() with template -1 (nonexistent)...' + pdtlen = getpdtlen(-1) + if (pdtlen .ne. 0) stop 10 + + print *, 'testing getpdstemplate() with template -1 (nonexistent)...' + call getpdstemplate(-1, nummap, map, needext, iret) + if (iret .eq. 0) stop 11 + if (pdtlen .ne. nummap) stop 12 + if (needext) stop 13 + + print *, 'testing extpdstemplate()...' + call extpdstemplate(0, list, nummap, map) + if (nummap .ne. 0) stop 14 + + ! print *, 'testing extpdstemplate() some more...' + ! pdtlen = getpdtlen(3) + ! if (pdtlen .ne. 31) stop 5 + ! call getpdstemplate(3, nummap, map, needext, iret) + ! if (iret .ne. 0) stop 6 + ! if (nummap .ne. 31) stop 20 + ! call extpdstemplate(3, map, nummap, map1) + ! print *, 'nummap = ', nummap + ! if (nummap .ne. 32) stop 20 + + print *, 'SUCCESS' +end program test_pdstemplates diff --git a/tests/test_pdstemplates_2.F90 b/tests/test_pdstemplates_2.F90 new file mode 100644 index 00000000..d0286434 --- /dev/null +++ b/tests/test_pdstemplates_2.F90 @@ -0,0 +1,340 @@ +! This is a test for the NCEPLIBS-g2 project. +! +! This program tests pdstemplates.F90. +! +! Brian Curtis 11/09/2021, Ed Hartnett +program test_pdstemplates + use pdstemplates + implicit none + + integer :: nummap + integer, dimension(MAXLEN) :: map + integer, dimension(15) :: expected_map_0 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4 /) + integer, dimension(18) :: expected_map_1 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1 /) + integer, dimension(17) :: expected_map_2 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1 /) + integer, dimension(31) :: expected_map_3 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 1, & + 1, 1, 1, -4, -4, 4, 4, 1, -1, 4, -1, 4 /) + integer, dimension(30) :: expected_map_4 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 1, & + 1, 1, 1, -4, 4, 4, 1, -1, 4, -1, 4 /) + integer, dimension(22) :: expected_map_5 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, -1, & + -4, -1, -4 /) + integer, dimension(16) :: expected_map_6 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1 /) + integer, dimension(15) :: expected_map_7 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4 /) + integer, dimension(29) :: expected_map_8 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 2, 1, 1, 1, 1, & + 1, 1, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(36) :: expected_map_9 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, -1, -4, & + -1, -4, 2, 1, 1, 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(30) :: expected_map_10 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 2, 1, 1, 1, 1, & + 1, 1, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(32) :: expected_map_11 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 2, 1, 1, & + 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(31) :: expected_map_12 = (/ 1, 1, 1, 1, 1, 2, 1, 1, 4, 1, -1, -4, 1, -1, -4, 1, 1, 2, 1, 1, 1, 1, & + 1, 1, -4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(45) :: expected_map_13 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 1, 1, 1, & + 1, -4, -4, 4, 4, 1, -1, 4, -1, 4, 2, 1, 1, 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(44) :: expected_map_14 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 1, 1, 1, & + 1, -4, 4, 4, 1, -1, 4, -1, 4, 2, 1, 1, 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(19) :: expected_map_20 = (/ 1, 1, 1, 1, 1, -4, 4, 2, -4, 2, 1, 1, 1, 1, 1, 2, 1, 3, 2 /) + integer, dimension(5) :: expected_map_30 = (/ 1, 1, 1, 1, 1 /) + integer, dimension(3) :: expected_map_254 = (/ 1, 1, 4 /) + integer, dimension(9) :: expected_map_1000 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4 /) + integer, dimension(16) :: expected_map_1001 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(15) :: expected_map_1002 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, 1, 1, 4, 4, 2 /) + integer, dimension(15) :: expected_map_1100 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4 /) + integer, dimension(22) :: expected_map_1101 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(5) :: expected_map_31 = (/ 1, 1, 1, 1, 1 /) + integer, dimension(18) :: expected_map_15 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1 /) + integer, dimension(16) :: expected_map_40 = (/ 1, 1, 2, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4 /) + integer, dimension(19) :: expected_map_41 = (/ 1, 1, 2, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1 /) + integer, dimension(30) :: expected_map_42 = (/ 1, 1, 2, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 2, 1, 1, 1, 1, 1, & + 1, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(33) :: expected_map_43 = (/ 1, 1, 2, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, 2, 1, 1, & + 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(21) :: expected_map_44 = (/ 1, 1, 2, 1, -1, -4, -1, -4, 1, 1, 1, 2, 1, 1, -2, 1, -1, -4, 1, -1, -4 /) + integer, dimension(24) :: expected_map_45 = (/ 1, 1, 2, 1, -1, -4, -1, -4, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, & + 1, 1, 1 /) + integer, dimension(35) :: expected_map_46 = (/ 1, 1, 2, 1, -1, -4, -1, -4, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, & + 2, 1, 1, 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(38) :: expected_map_47 = (/ 1, 1, 1, 2, 1, -1, -4, -1, -4, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, & + 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(21) :: expected_map_50 = (/ 1, 1, 1, 1, 1, 2, 1, 1, 4, 1, -1, -4, 1, -1, -4, 1, 1, 4, 4, 4, 4 /) + integer, dimension(16) :: expected_map_51 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1 /) + integer, dimension(36) :: expected_map_91 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1, -1, -4, -1, & + -4, 2, 1, 1, 1, 1, 1, 1, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(10) :: expected_map_32 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1 /) + integer, dimension(26) :: expected_map_48 = (/ 1, 1, 2, 1, -1, -4, -1, -4, 1, -1, -4, -1, -4, 1, 1, 1, 2, 1, 1, -4, 1, & + -1, -4, 1, -1, -4 /) +! integer, dimension(21) :: expected_map_40 = (/ 1, 1, 1, 1, 1, 2, 1, 1, 4, 1, -1, -4, 1, -1, -4, 1, 1, 4, 4, 4, 4 /) + integer, dimension(15) :: expected_map_52 = (/ 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 4, 1, -1, -4 /) + integer, dimension(18) :: expected_map_33 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, 2, 2, 2, -1, -4, 1, 1, 1 /) + integer, dimension(32) :: expected_map_34 = (/ 1, 1, 1, 1, 1, 2, 1, 1, -4, 1, 2, 2, 2, -1, -4, 1, 1, 1, 2, 1, 1, 1, 1, 1, & + 1, 4, 1, 1, 1, 4, 1, 4 /) + integer, dimension(19) :: expected_map_53 = (/ 1, 1, 1, 1, 4, 2, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4 /) + integer, dimension(22) :: expected_map_54 = (/ 1, 1, 1, 1, 4, 2, 1, 1, 1, 2, 1, 1, -4, 1, -1, -4, 1, -1, -4, 1, 1, 1 /) + logical :: needext + integer :: m + integer :: iret + + print *, 'Testing pdstemplates complete contents...' + + print *, 'testing getpdstemplate()...' + call getpdstemplate(0, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 15 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_0(m)) stop 100 + end do + + call getpdstemplate(1, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 18 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_1(m)) stop 100 + end do + + call getpdstemplate(2, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 17 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_2(m)) stop 100 + end do + + call getpdstemplate(3, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 31 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_3(m)) stop 100 + end do + + call getpdstemplate(4, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 30 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_4(m)) stop 100 + end do + + call getpdstemplate(5, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 22 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_5(m)) stop 100 + end do + + call getpdstemplate(6, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 16 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_6(m)) stop 100 + end do + + call getpdstemplate(7, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 15 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_7(m)) stop 100 + end do + + call getpdstemplate(8, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 29 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_8(m)) stop 100 + end do + + call getpdstemplate(9, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 36 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_9(m)) stop 100 + end do + + call getpdstemplate(10, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 30 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_10(m)) stop 100 + end do + + call getpdstemplate(11, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 32 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_11(m)) stop 100 + end do + + call getpdstemplate(12, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 31 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_12(m)) stop 100 + end do + + call getpdstemplate(13, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 45 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_13(m)) stop 100 + end do + + call getpdstemplate(14, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 44 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_14(m)) stop 100 + end do + + call getpdstemplate(20, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 19 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_20(m)) stop 100 + end do + + call getpdstemplate(30, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 5 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_30(m)) stop 100 + end do + + call getpdstemplate(254, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 3 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_254(m)) stop 100 + end do + + call getpdstemplate(1000, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 9 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_1000(m)) stop 100 + end do + + call getpdstemplate(1001, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 16 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_1001(m)) stop 100 + end do + + call getpdstemplate(1002, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 15 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_1002(m)) stop 100 + end do + + call getpdstemplate(1100, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 15 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_1100(m)) stop 100 + end do + + call getpdstemplate(1101, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 22 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_1101(m)) stop 100 + end do + + call getpdstemplate(31, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 5 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_31(m)) stop 100 + end do + + call getpdstemplate(15, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 18 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_15(m)) stop 100 + end do + + call getpdstemplate(40, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 16 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_40(m)) stop 100 + end do + + call getpdstemplate(41, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 19 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_41(m)) stop 100 + end do + + call getpdstemplate(42, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 30 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_42(m)) stop 100 + end do + + call getpdstemplate(43, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 33 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_43(m)) stop 100 + end do + + call getpdstemplate(44, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 21 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_44(m)) stop 100 + end do + + call getpdstemplate(45, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 24 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_45(m)) stop 100 + end do + + call getpdstemplate(46, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 35 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_46(m)) stop 100 + end do + + call getpdstemplate(47, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 38 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_47(m)) stop 100 + end do + + call getpdstemplate(51, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 16 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_51(m)) stop 100 + end do + + call getpdstemplate(91, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 36 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_91(m)) stop 100 + end do + + call getpdstemplate(32, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 10 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_32(m)) stop 100 + end do + + call getpdstemplate(48, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 26 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_48(m)) stop 100 + end do + + call getpdstemplate(50, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 21 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_50(m)) stop 100 + end do + + call getpdstemplate(52, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 15 .or. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_52(m)) stop 100 + end do + + call getpdstemplate(33, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 18 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_33(m)) stop 100 + end do + + call getpdstemplate(34, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 32 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_34(m)) stop 100 + end do + + call getpdstemplate(53, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 19 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_53(m)) stop 100 + end do + + call getpdstemplate(54, nummap, map, needext, iret) + if (iret .ne. 0 .or. nummap .ne. 22 .or. .not. needext) stop 99 + do m = 1, nummap + if (map(m) .ne. expected_map_54(m)) stop 100 + end do + + print *, 'SUCCESS' +end program test_pdstemplates diff --git a/tests/test_pngpack.F90 b/tests/test_pngpack.F90 new file mode 100644 index 00000000..7e0d4061 --- /dev/null +++ b/tests/test_pngpack.F90 @@ -0,0 +1,48 @@ +! This program tests the pngpack subroutine of the NCEPLIBS-g2 +! project. +! +! Brian Curtis 2021-10-04 +program test_pngpack + + implicit none + + integer, parameter :: width=2, height=2, ndpts=4 + real, parameter :: delta = 0.0000001 + real :: fld(ndpts), fld2(ndpts) + integer :: idrstmpl(7) + character(len=1) :: cpack(100) + integer :: lcpack = 100 + integer :: i + + print *, 'Testing pngpack()/pngunpack()...' + + ! Create the fld variable with data to pack + fld = (/1.0, 2.0, 3.0, 4.0/) + + ! No idea what this needs to be, documentation confusing + idrstmpl(1)=0 + idrstmpl(2)=1 + idrstmpl(3)=1 + idrstmpl(4)=8 + idrstmpl(5)=0 + idrstmpl(6)=0 + idrstmpl(7)=1 + + ! Testing pngpack + call pngpack(fld, width, height, idrstmpl, cpack, lcpack) + print *, 'lcpack: ', lcpack + + ! Testing pngunpack + call pngunpack(cpack, lcpack, idrstmpl, ndpts, fld2) + + ! Compare each value to see match, reals do not compare well + do i = 1, ndpts + if (abs(fld(i) - fld2(i)) .ge. delta) then + print *, fld(i), fld2(i), 'do not match' + stop 4 + end if + end do + + print *, 'SUCCESS!' + +end program test_pngpack diff --git a/tests/test_realloc.F90 b/tests/test_realloc.F90 new file mode 100644 index 00000000..efea79d0 --- /dev/null +++ b/tests/test_realloc.F90 @@ -0,0 +1,63 @@ +! This is a test program for NCEPLIBS-g2. +! +! This program tests the code in realloc.f90. +! +! Ed Hartnett 7/21/22 +program test_realloc + use re_alloc + implicit none + + character(len=1), pointer, dimension(:) :: c + integer, pointer, dimension(:) :: i + integer n, m, istat + + print *, 'Testing realloc...' + + ! Initialize parameters. + n = 1 + m = 2 + nullify(c) + nullify(i) + + ! These will fail for character data. + call realloc(c, -1, m, istat) + if (istat .ne. 10) stop 3 + call realloc(c, n, 0, istat) + if (istat .ne. 10) stop 3 + + ! This will succeed in allocating new memory for character data. + call realloc(c, n, m, istat) + if (istat .ne. 0) stop 4 + c(1) = 'a' + c(2) = 'b' + + ! This will succeed in reallocating memory for character data. + call realloc(c, 2, 4, istat) + if (istat .ne. 0) stop 4 + if (c(1) .ne. 'a' .or. c(2) .ne. 'b') stop 5 + c(3) = 'c' + c(4) = 'd' + deallocate(c) + + ! These will fail for integer data. + call realloc(i, -1, m, istat) + if (istat .ne. 10) stop 3 + call realloc(i, n, 0, istat) + if (istat .ne. 10) stop 3 + + ! This will succeed in allocating new memory for integer data. + call realloc(i, n, m, istat) + if (istat .ne. 0) stop 40 + i(1) = 42 + i(2) = 43 + + ! This will succeed in re-allocating memory for integer data. + call realloc(i, 2, 4, istat) + if (istat .ne. 0) stop 40 + if (i(1) .ne. 42 .or. i(2) .ne. 43) stop 41 + i(3) = 44 + i(4) = 45 + deallocate(i) + + print *, 'SUCCESS!' +end program test_realloc diff --git a/tests/test_simpack.F90 b/tests/test_simpack.F90 new file mode 100644 index 00000000..5724c50b --- /dev/null +++ b/tests/test_simpack.F90 @@ -0,0 +1,39 @@ +! This program tests the simple packing and unpacking subroutines of +! the NCEPLIBS-g2 project. Link this to the _4 build of the library. +! +! Ed Hartnett 10/3/21 +program test_simpack + implicit none + + integer, parameter :: ndpts = 4 + real :: fld(ndpts) + real :: fld_in(ndpts) + integer :: idrstmpl(5) + character, dimension(10) :: cpack + character, dimension(4) :: expected_cpack + integer :: lcpack + integer :: i + + print *, 'Testing simpack.' + expected_cpack = (/ char(0), char(93), char(108), char(64) /) + + print *, 'Testing simple call to simpack...' + fld = (/ 42.3, 43.2, 44.1, 45.0/) + idrstmpl = (/ 42, 2, 2, 0, 0/) + call simpack(fld, ndpts, idrstmpl, cpack, lcpack) +! print *, 'lcpack: ', lcpack + do i = 1, lcpack +! print *, ichar(cpack(i)) + if (cpack(i) .ne. expected_cpack(i)) stop 3 + end do + if (lcpack .ne. 4) stop 2 + + print *, 'Testing simple call to simunpack...' + call simunpack(cpack, lcpack, idrstmpl, ndpts, fld_in) + do i = 1, ndpts + if (abs(fld(i) - fld_in(i)) .gt. .1) stop 10 + end do + + print *, 'SUCCESS!' + +end program test_simpack