diff --git a/README.md b/README.md index caf9b72c..b0b5b2cd 100644 --- a/README.md +++ b/README.md @@ -7,6 +7,24 @@ CCPP infrastructure code and physics code, both of which are included as git submodules within the SCM code. This package can be considered a simple example for an atmospheric model to interact with physics through the CCPP. +## Prerequisite +There are several utility libraries as part of the NCEPlibs package that must be installed prior to building the SCM. +* bacio - Binary I/O Library +* sp - Spectral Transformation Library +* w3nco - GRIB decoder and encoder library + +These libraries are prebuilt on most NOAA machines using the Intel compiler. For those needing to build the libraries themselves, GMTB recommends using the source code from GitHub at https://github.com/NCAR/NCEPlibs.git, which includes build files for various compilers and machines using OpenMP flags and which are threadsafe. Instructions for installing NCEPlibs are included on the GitHub repository webpage, but for the sake of example, execute the following for obtaining and building from source in /usr/local/NCEPlibs on a Mac: +1. `cd /usr/local/src` +2. `git clone https://github.com/NCAR/NCEPlibs.git` +3. `cd NCEPlibs` +4. `./make_ncep_libs.sh -s macosx -c gnu -d /usr/local/NCEPlibs -o 1` + +Once NCEPlibs is built, the NCEPLIBS_DIR environment variable must be set to the location of the installation. For example, if NCEPlibs was installed in /usr/local/NCEPlibs, one would execute + +`export NCEPLIB_DIR=/usr/local/NCEPlibs` + +If using Theia or Cheyenne HPC systems, this environment variable is automatically set to an appropriate installation of NCEPlibs on those machines through use of one of the setup scripts described below. + ## Obtaining Code 1. Download a compressed file or clone the source using * `git clone https://[username]@github.com/NCAR/gmtb-scm.git` diff --git a/ccpp/framework b/ccpp/framework index 0c04005e..db5c28c3 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 0c04005ed3eed7be0e2f9d053ee080368383b6fa +Subproject commit db5c28c35e87500ec040011c756de1397aec1bff diff --git a/ccpp/physics b/ccpp/physics index fba8a177..245d228a 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit fba8a177bf6f57e238507b0df943b7c0db7333fa +Subproject commit 245d228a1d26b24f91b7f8d4014a7a66c21b8441 diff --git a/external/bacio/v2.0.1/src/CMakeLists.txt b/external/bacio/v2.0.1/src/CMakeLists.txt deleted file mode 100644 index fe10d3bd..00000000 --- a/external/bacio/v2.0.1/src/CMakeLists.txt +++ /dev/null @@ -1,56 +0,0 @@ -SET(bacio_source_code ${BACIOLIB_SRC}/baciof.f - ${BACIOLIB_SRC}/bacio.c -) - -#set Fortran compiler flags, depends on compiler -if (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") - set(f_flags -O3 -fbacktrace -fPIC) -elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "Intel") - set(f_flags -O3 -xHOST -traceback -fPIC) -elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "PGI") - set(f_flags -O3 -traceback -fPIC) -else (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") - message ("CMAKE_Fortran_COMPILER full path: " ${CMAKE_Fortran_COMPILER}) - message ("Fortran compiler: " ${CMAKE_Fortran_COMPILER_ID}) - message (FATAL_ERROR "This library has only been compiled with gfortran, pgf90 and ifort. If another compiler is needed, the appropriate flags must be added in ${BACIOLIB_SRC}/CMakeLists.txt") -endif (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") - -#set C compiler flags, depends on compiler and os -# compiler -if (${CMAKE_C_COMPILER_ID} MATCHES "GNU" OR ${CMAKE_C_COMPILER_ID} MATCHES "Clang") - set(c_flags -O3 -DUNDERSCORE -fPIC) -elseif (${CMAKE_C_COMPILER_ID} MATCHES "Intel") - set(c_flags -O3 -DUNDERSCORE -fPIC) -elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "PGI") - set(c_flags -O3 -DUNDERSCORE -fPIC) -else (${CMAKE_C_COMPILER_ID} MATCHES "GNU" OR ${CMAKE_C_COMPILER_ID} MATCHES "Clang") - message ("CMAKE_Fortran_COMPILER full path: " ${CMAKE_C_COMPILER}) - message ("Fortran compiler: " ${CMAKE_C_COMPILER_ID}) - message (FATAL_ERROR "This program has only been compiled with gcc, clang, pgcc and icc. If another compiler is needed, the appropriate flags must be added in ${BACIOLIB_SRC}/CMakeLists.txt") -endif (${CMAKE_C_COMPILER_ID} MATCHES "GNU" OR ${CMAKE_C_COMPILER_ID} MATCHES "Clang") -# os -if (${CMAKE_SYSTEM_NAME} MATCHES "Darwin") - set(c_flags ${c_flags} -DMACOSX) -elseif (${CMAKE_SYSTEM_NAME} MATCHES "Linux") - set(c_flags ${c_flags} -DLINUX) -else (${CMAKE_SYSTEM_NAME} MATCHES "Darwin") - message (FATAL_ERROR "This library has only been compiled on Linux and Darwin platforms. If another platform is needed, the appropriate flags must be added in ${BACIOLIB_SRC}/CMakeLists.txt") -endif (${CMAKE_SYSTEM_NAME} MATCHES "Darwin") - -#add OpenMP -set(c_flags ${c_flags} ${OpenMP_C_FLAGS}) -set(f_flags ${f_flags} ${OpenMP_Fortran_FLAGS}) - -if(${CMAKE_VERSION} LESS 3.3) - file(GLOB f_files *.f) - string (REPLACE ";" " " f_flags_str "${f_flags}") - set(CMAKE_Fortran_FLAGS "${f_flags_str}") - file(GLOB c_files *.c) - string (REPLACE ";" " " c_flags_str "${c_flags}") - set(CMAKE_C_FLAGS "${c_flags_str}") -else(${CMAKE_VERSION} LESS 3.3) - add_compile_options("$<$:${f_flags}>") - add_compile_options("$<$:${c_flags}>") -endif (${CMAKE_VERSION} LESS 3.3) - -ADD_LIBRARY(bacio STATIC ${bacio_source_code}) diff --git a/external/bacio/v2.0.1/src/Makefile b/external/bacio/v2.0.1/src/Makefile deleted file mode 100644 index 5426588c..00000000 --- a/external/bacio/v2.0.1/src/Makefile +++ /dev/null @@ -1,43 +0,0 @@ -# bacio Makefile - -############################################################### -# -# AUTHOR: Gilbert - W/NP11 -# -# DATE: 01/11/1999 -# -# PURPOSE: This script uses the make utility to update the bacio -# archive libraries. -# -############################################################### - -include ../../../../macros.make - -FCMP = $(FCserial) -CCMP = $(CC) -LIB = ../../../../libbacio_4.a -FFLAGS = $(BACIO_FFLAGS) -AFLAGS = $(ARFLAGS) -CFLAGS = $(BACIO_CFLAGS) -OBJS = bacio.o baciof.o bafrio.o byteswap.o chk_endianc.o - -$(LIB): $(OBJS) - ar -rv $(AFLAGS) $@ $^ - -bacio.o: bacio.c clib.h - $(CCMP) -c $(CFLAGS) bacio.c - -baciof.o: baciof.f - $(FCMP) -c $(FFLAGS) baciof.f - -bafrio.o: bafrio.f - $(FCMP) -c $(FFLAGS) bafrio.f - -byteswap.o: byteswap.c - $(CCMP) -c $(CFLAGS) byteswap.c - -chk_endianc.o: chk_endianc.f - $(FCMP) -c $(FFLAGS) chk_endianc.f - -clean: - $(RM) *.o *.mod $(LIB) diff --git a/external/bacio/v2.0.1/src/bacio.c b/external/bacio/v2.0.1/src/bacio.c deleted file mode 100644 index f6b0834a..00000000 --- a/external/bacio/v2.0.1/src/bacio.c +++ /dev/null @@ -1,1245 +0,0 @@ -/* Fortran-callable routines to read and write characther (bacio) and */ -/* numeric (banio) data byte addressably */ -/* Robert Grumbine 16 March 1998 */ -/* v1.1: Put diagnostic output under control of define VERBOSE or QUIET */ -/* Add option of non-seeking read/write */ -/* Return code for fewer data read/written than requested */ -/* v1.2: Add cray compatibility 20 April 1998 Robert Grumbine */ -/* v1.3: Add IBMSP compatibility (IBM4, IBM8) - Add modes BAOPEN_WONLY_TRUNC, BAOPEN_WONLY_APPEND - Use isgraph instead of isalnum + a short list of accepted characters - for filename check - 12 Dec 2000 Stephen Gilbert */ -/* negative return codes are wrapped to positive, revise return codes - verify that banio and bacio have same contents - update comments - 29 Oct 2008 Robert Grumbine */ -/* v1.4: 21 Nov 2008 - Add baciol and baniol functions, versions to work with files - over 2 Gb - Robert Grumbine */ -/* Aug 2012 Jun Wang: fix c filename length because the c string - needs to end with "null" terminator , and free allocated cfile - name realname to avoid memory leak */ -/* Sep 2012 Jun Wang: remove execute permission on the data file - generated by bacio */ - -#include -#include -#include -#include -#include -#ifdef MACOSX -#include -#else -#include -#endif -#include -#include - -/* Include the C library file for definition/control */ -/* Things that might be changed for new systems are there. */ -/* This source file should not (need to) be edited, merely recompiled */ -#include "clib.h" - - -/* Return Codes: */ -/* 0 All was well */ -/* 255 Tried to open read only _and_ write only */ -/* 254 Tried to read and write in the same call */ -/* 253 Internal failure in name processing */ -/* 252 Failure in opening file */ -/* 251 Tried to read on a write-only file */ -/* 250 Failed in read to find the 'start' location */ -/* 249 Tried to write to a read only file */ -/* 248 Failed in write to find the 'start' location */ -/* 247 Error in close */ -/* 246 Read or wrote fewer data than requested */ -/* 102 Massive catastrophe -- datary pointer is NULL */ - -/* Note: In your Fortran code, call bacio, not bacio_. */ -/*int bacio_(int * mode, int * start, int * size, int * no, int * nactual, */ -/* int * fdes, const char *fname, char *data, int namelen, */ -/* int datanamelen) */ -/* Arguments: */ -/* Mode is the integer specifying operations to be performed */ -/* see the clib.inc file for the values. Mode is obtained */ -/* by adding together the values corresponding to the operations */ -/* The best method is to include the clib.inc file and refer to the */ -/* names for the operations rather than rely on hard-coded values */ -/* Start is the byte number to start your operation from. 0 is the first */ -/* byte in the file, not 1. */ -/* Newpos is the position in the file after a read or write has been */ -/* performed. You'll need this if you're doing 'seeking' read/write */ -/* Size is the size of the objects you are trying to read. Rely on the */ -/* values in the locale.inc file. Types are CHARACTER, INTEGER, REAL, */ -/* COMPLEX. Specify the correct value by using SIZEOF_type, where type */ -/* is one of these. (After having included the locale.inc file) */ -/* no is the number of things to read or write (characters, integers, */ -/* whatever) */ -/* nactual is the number of things actually read or written. Check that */ -/* you got what you wanted. */ -/* fdes is an integer 'file descriptor'. This is not a Fortran Unit Number */ -/* You can use it, however, to refer to files you've previously opened. */ -/* fname is the name of the file. This only needs to be defined when you */ -/* are opening a file. It must be (on the Fortran side) declared as */ -/* CHARACTER*N, where N is a length greater than or equal to the length */ -/* of the file name. CHARACTER*1 fname[80] (for example) will fail. */ -/* data is the name of the entity (variable, vector, array) that you want */ -/* to write data out from or read it in to. The fact that C is declaring */ -/* it to be a char * does not affect your fortran. */ -/* namelen - Do NOT specify this. It is created automagically by the */ -/* Fortran compiler */ -/* datanamelen - Ditto */ - - -/* What is going on here is that although the Fortran caller will always */ -/* be calling bacio, the called C routine name will change from system */ -/* to system. */ -#ifdef CRAY90 - #include - int BACIO - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, - _fcd fcd_fname, _fcd fcd_datary) { - char *fname, *datary; - int namelen; -#endif -#ifdef HP - int bacio - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef SGI - int bacio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef LINUX - int bacio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef LINUXF90 - int BACIO - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef MACOSX - int bacio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef VPP5000 - int bacio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef IBM4 - int bacio - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef IBM8 - long long int bacio - (long long int * mode, long long int * start, long long int *newpos, - long long int * size, long long int * no, - long long int * nactual, long long int * fdes, const char *fname, - char *datary, - long long int namelen, long long int datanamelen) { -#endif - int i, j, jret, seekret; - char *realname; - int tcharval; - size_t count; - -/* Initialization(s) */ - *nactual = 0; - -/* Check for illegal combinations of options */ - if (( BAOPEN_RONLY & *mode) && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("illegal -- trying to open both read only and write only\n"); - #endif - return 255; - } - if ( (BAREAD & *mode ) && (BAWRITE & *mode) ) { - #ifdef VERBOSE - printf("illegal -- trying to both read and write in the same call\n"); - #endif - return 254; - } - -/* This section handles Fortran to C translation of strings so as to */ -/* be able to open the files Fortran is expecting to be opened. */ - #ifdef CRAY90 - namelen = _fcdlen(fcd_fname); - fname = _fcdtocp(fcd_fname); - #endif - if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || - (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || - (BAOPEN_RW & *mode) ) { - #ifdef VERBOSE - printf("Will be opening a file %s %d\n", fname, namelen); fflush(stdout); - printf("Strlen %d namelen %d\n", strlen(fname), namelen); fflush(stdout); - #endif - realname = (char *) malloc( (namelen+1) * sizeof(char) ) ; - if (realname == NULL) { - #ifdef VERBOSE - printf("failed to mallocate realname %d = namelen\n", namelen); - fflush(stdout); - #endif - return 253; - } - - i=0; - while (i < namelen && isgraph(fname[i])) { - realname[i]=fname[i]; - i++; - } - realname[i] = '\0'; - } - -/* Open files with correct read/write and file permission. */ - if (BAOPEN_RONLY & *mode) { - #ifdef VERBOSE - printf("open read only %s\n", realname); - #endif - *fdes = open(realname, O_RDONLY , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_WONLY & *mode ) { - #ifdef VERBOSE - printf("open write only %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_WONLY_TRUNC & *mode ) { - #ifdef VERBOSE - printf("open write only with truncation %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_TRUNC , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_WONLY_APPEND & *mode ) { - #ifdef VERBOSE - printf("open write only with append %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_APPEND , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_RW & *mode) { - #ifdef VERBOSE - printf("open read-write %s\n", realname); - #endif - *fdes = open(realname, O_RDWR | O_CREAT , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else { - #ifdef VERBOSE - printf("no openings\n"); - #endif - } - if (*fdes < 0) { - #ifdef VERBOSE - printf("error in file descriptor! *fdes %d\n", *fdes); - #endif - return 252; - } - else { - #ifdef VERBOSE - printf("file descriptor = %d\n",*fdes ); - #endif - } - - -/* Read data as requested */ - if (BAREAD & *mode && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("Error, trying to read while in write only mode!\n"); - #endif - return 251; - } - else if (BAREAD & *mode ) { - /* Read in some data */ - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return 250; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - #ifdef CRAY90 - datary = _fcdtocp(fcd_datary); - #endif - if (datary == NULL) { - printf("Massive catastrophe -- datary pointer is NULL\n"); - return 102; - } - #ifdef VERBOSE - printf("file descriptor, datary = %d %d\n", *fdes, (int) datary); - #endif - count = (size_t) *no; - jret = read(*fdes, (void *) datary, count); - if (jret != *no) { - #ifdef VERBOSE - printf("did not read in the requested number of bytes\n"); - printf("read in %d bytes instead of %d \n",jret, *no); - #endif - } - else { - #ifdef VERBOSE - printf("read in %d bytes requested \n", *no); - #endif - } - *nactual = jret; - *newpos = *start + jret; - } -/* Done with reading */ - -/* See if we should be writing */ - if ( BAWRITE & *mode && BAOPEN_RONLY & *mode ) { - #ifdef VERBOSE - printf("Trying to write on a read only file \n"); - #endif - return 249; - } - else if ( BAWRITE & *mode ) { - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return 248; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - #ifdef CRAY90 - datary = _fcdtocp(fcd_datary); - #endif - if (datary == NULL) { - printf("Massive catastrophe -- datary pointer is NULL\n"); - return 102; - } - #ifdef VERBOSE - printf("write file descriptor, datary = %d %d\n", *fdes, (int) datary); - #endif - count = (size_t) *no; - jret = write(*fdes, (void *) datary, count); - if (jret != *no) { - #ifdef VERBOSE - printf("did not write out the requested number of bytes\n"); - printf("wrote %d bytes instead\n", jret); - #endif - *nactual = jret; - *newpos = *start + jret; - } - else { - #ifdef VERBOSE - printf("wrote %d bytes \n", jret); - #endif - *nactual = jret; - *newpos = *start + jret; - } - } -/* Done with writing */ - - -/* Close file if requested */ - if (BACLOSE & *mode ) { - jret = close(*fdes); - if (jret != 0) { - #ifdef VERBOSE - printf("close failed! jret = %d\n",jret); - #endif - return 247; - } - } -/* Done closing */ - -/* Free the realname pointer to prevent memory leak */ - if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || - (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || - (BAOPEN_RW & *mode) ) { - free(realname); - } - -/* Check that if we were reading or writing, that we actually got what */ -/* we expected, else return a -10. Return 0 (success) if we're here */ -/* and weren't reading or writing */ - if ( (*mode & BAREAD || *mode & BAWRITE) && (*nactual != *no) ) { - return 246; - } - else { - return 0; - } -} -#ifdef CRAY90 - #include - int BANIO - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, - _fcd fcd_fname, void *datary) { - char *fname; - int namelen; -#endif -#ifdef HP - int banio - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef SGI - int banio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef LINUX - int banio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef LINUXF90 - int BANIO - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef MACOSX - int banio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef VPP5000 - int banio_ - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef IBM4 - int banio - (int * mode, int * start, int *newpos, int * size, int * no, - int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef IBM8 - long long int banio - (long long int * mode, long long int * start, long long int *newpos, - long long int * size, long long int * no, - long long int * nactual, long long int * fdes, const char *fname, - char *datary, - long long int namelen ) { -#endif - int i, j, jret, seekret; - char *realname; - int tcharval; - size_t count; - -/* Initialization(s) */ - *nactual = 0; - -/* Check for illegal combinations of options */ - if (( BAOPEN_RONLY & *mode) && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("illegal -- trying to open both read only and write only\n"); - #endif - return 255; - } - if ( (BAREAD & *mode ) && (BAWRITE & *mode) ) { - #ifdef VERBOSE - printf("illegal -- trying to both read and write in the same call\n"); - #endif - return 254; - } - -/* This section handles Fortran to C translation of strings so as to */ -/* be able to open the files Fortran is expecting to be opened. */ - #ifdef CRAY90 - namelen = _fcdlen(fcd_fname); - fname = _fcdtocp(fcd_fname); - #endif - if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || - (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || - (BAOPEN_RW & *mode) ) { - #ifdef VERBOSE - printf("Will be opening a file %s %d\n", fname, namelen); fflush(stdout); - printf("Strlen %d namelen %d\n", strlen(fname), namelen); fflush(stdout); - #endif - realname = (char *) malloc( (namelen+1) * sizeof(char) ) ; - if (realname == NULL) { - #ifdef VERBOSE - printf("failed to mallocate realname %d = namelen\n", namelen); - fflush(stdout); - #endif - return 253; - } - - i=0; - while (i < namelen && isgraph(fname[i])) { - realname[i]=fname[i]; - i++; - } - realname[i] = '\0'; - } - -/* Open files with correct read/write and file permission. */ - if (BAOPEN_RONLY & *mode) { - #ifdef VERBOSE - printf("open read only %s\n", realname); - #endif - *fdes = open(realname, O_RDONLY , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_WONLY & *mode ) { - #ifdef VERBOSE - printf("open write only %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_WONLY_TRUNC & *mode ) { - #ifdef VERBOSE - printf("open write only with truncation %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_TRUNC , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_WONLY_APPEND & *mode ) { - #ifdef VERBOSE - printf("open write only with append %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_APPEND , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_RW & *mode) { - #ifdef VERBOSE - printf("open read-write %s\n", realname); - #endif - *fdes = open(realname, O_RDWR | O_CREAT , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else { - #ifdef VERBOSE - printf("no openings\n"); - #endif - } - if (*fdes < 0) { - #ifdef VERBOSE - printf("error in file descriptor! *fdes %d\n", *fdes); - #endif - return 252; - } - else { - #ifdef VERBOSE - printf("file descriptor = %d\n",*fdes ); - #endif - } - - -/* Read data as requested */ - if (BAREAD & *mode && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("Error, trying to read while in write only mode!\n"); - #endif - return 251; - } - else if (BAREAD & *mode ) { - /* Read in some data */ - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return 250; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - jret = read(*fdes, datary, *no*(*size) ); - if (jret != *no*(*size) ) { - #ifdef VERBOSE - printf("did not read in the requested number of items\n"); - printf("read in %d items of %d \n",jret/(*size), *no); - #endif - *nactual = jret/(*size); - *newpos = *start + jret; - } - #ifdef VERBOSE - printf("read in %d items \n", jret/(*size)); - #endif - *nactual = jret/(*size); - *newpos = *start + jret; - } -/* Done with reading */ - -/* See if we should be writing */ - if ( BAWRITE & *mode && BAOPEN_RONLY & *mode ) { - #ifdef VERBOSE - printf("Trying to write on a read only file \n"); - #endif - return 249; - } - else if ( BAWRITE & *mode ) { - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return 248; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - jret = write(*fdes, datary, *no*(*size)); - if (jret != *no*(*size)) { - #ifdef VERBOSE - printf("did not write out the requested number of items\n"); - printf("wrote %d items instead\n", jret/(*size) ); - #endif - *nactual = jret/(*size) ; - *newpos = *start + jret; - } - else { - #ifdef VERBOSE - printf("wrote %d items \n", jret/(*size) ); - #endif - *nactual = jret/(*size) ; - *newpos = *start + jret; - } - } -/* Done with writing */ - - -/* Close file if requested */ - if (BACLOSE & *mode ) { - jret = close(*fdes); - if (jret != 0) { - #ifdef VERBOSE - printf("close failed! jret = %d\n",jret); - #endif - return 247; - } - } -/* Done closing */ - -/* Free the realname pointer to prevent memory leak */ - if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || - (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || - (BAOPEN_RW & *mode) ) { - free(realname); - } - -/* Check that if we were reading or writing, that we actually got what */ -/* we expected, else return a -10. Return 0 (success) if we're here */ -/* and weren't reading or writing */ - if ( (*mode & BAREAD || *mode & BAWRITE) && (*nactual != *no) ) { - return 246; - } - else { - return 0; - } -} - -/* Now repeat with new names for long int arguments, needed for */ -/* files > 2 Gb */ -/* Robert Grumbine 21 November 2008 */ - -/* Note: In your Fortran code, call bacio, not bacio_. */ -/*int baciol_(int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, */ -/* int * fdes, const char *fname, char *data, int namelen, */ -/* int datanamelen) */ -#ifdef CRAY90 - #include - int BACIOL - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, - _fcd fcd_fname, _fcd fcd_datary) { - char *fname, *datary; - int namelen; -#endif -#ifdef HP - int baciol - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef SGI - int baciol_ - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef LINUX - int baciol_ - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef LINUXF90 - int BACIOL - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef MACOSX - int baciol_ - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef VPP5000 - int baciol_ - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef IBM4 - int baciol - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen, int datanamelen) { -#endif -#ifdef IBM8 - long long int baciol - (long long int * mode, long long int * start, long long int *newpos, - long long int * size, long long int * no, - long long int * nactual, long long int * fdes, const char *fname, - char *datary, - long long int namelen, long long int datanamelen) { -#endif - int i, j, jret, seekret; - char *realname; - int tcharval; - size_t count; - -/* Initialization(s) */ - *nactual = 0; - -/* Check for illegal combinations of options */ - if (( BAOPEN_RONLY & *mode) && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("illegal -- trying to open both read only and write only\n"); - #endif - return 255; - } - if ( (BAREAD & *mode ) && (BAWRITE & *mode) ) { - #ifdef VERBOSE - printf("illegal -- trying to both read and write in the same call\n"); - #endif - return 254; - } - -/* This section handles Fortran to C translation of strings so as to */ -/* be able to open the files Fortran is expecting to be opened. */ - #ifdef CRAY90 - namelen = _fcdlen(fcd_fname); - fname = _fcdtocp(fcd_fname); - #endif - if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || - (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || - (BAOPEN_RW & *mode) ) { - #ifdef VERBOSE - printf("Will be opening a file %s %d\n", fname, namelen); fflush(stdout); - printf("Strlen %d namelen %d\n", strlen(fname), namelen); fflush(stdout); - #endif - realname = (char *) malloc( (namelen+1) * sizeof(char) ) ; - if (realname == NULL) { - #ifdef VERBOSE - printf("failed to mallocate realname %d = namelen\n", namelen); - fflush(stdout); - #endif - return 253; - } - - i=0; - while (i < namelen && isgraph(fname[i])) { - realname[i]=fname[i]; - i++; - } - realname[i] = '\0'; - - } - -/* Open files with correct read/write and file permission. */ - if (BAOPEN_RONLY & *mode) { - #ifdef VERBOSE - printf("open read only %s\n", realname); - #endif - *fdes = open(realname, O_RDONLY , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_WONLY & *mode ) { - #ifdef VERBOSE - printf("open write only %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_WONLY_TRUNC & *mode ) { - #ifdef VERBOSE - printf("open write only with truncation %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_TRUNC , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_WONLY_APPEND & *mode ) { - #ifdef VERBOSE - printf("open write only with append %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_APPEND , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_RW & *mode) { - #ifdef VERBOSE - printf("open read-write %s\n", realname); - #endif - *fdes = open(realname, O_RDWR | O_CREAT , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else { - #ifdef VERBOSE - printf("no openings\n"); - #endif - } - if (*fdes < 0) { - #ifdef VERBOSE - printf("error in file descriptor! *fdes %d\n", *fdes); - #endif - return 252; - } - else { - #ifdef VERBOSE - printf("file descriptor = %d\n",*fdes ); - #endif - } - - -/* Read data as requested */ - if (BAREAD & *mode && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("Error, trying to read while in write only mode!\n"); - #endif - return 251; - } - else if (BAREAD & *mode ) { - /* Read in some data */ - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return 250; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - #ifdef CRAY90 - datary = _fcdtocp(fcd_datary); - #endif - if (datary == NULL) { - printf("Massive catastrophe -- datary pointer is NULL\n"); - return 102; - } - #ifdef VERBOSE - printf("file descriptor, datary = %d %d\n", *fdes, (int) datary); - #endif - count = (size_t) *no; - jret = read(*fdes, (void *) datary, count); - if (jret != *no) { - #ifdef VERBOSE - printf("did not read in the requested number of bytes\n"); - printf("read in %d bytes instead of %d \n",jret, *no); - #endif - } - else { - #ifdef VERBOSE - printf("read in %d bytes requested \n", *no); - #endif - } - *nactual = jret; - *newpos = *start + jret; - } -/* Done with reading */ - -/* See if we should be writing */ - if ( BAWRITE & *mode && BAOPEN_RONLY & *mode ) { - #ifdef VERBOSE - printf("Trying to write on a read only file \n"); - #endif - return 249; - } - else if ( BAWRITE & *mode ) { - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return 248; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - #ifdef CRAY90 - datary = _fcdtocp(fcd_datary); - #endif - if (datary == NULL) { - printf("Massive catastrophe -- datary pointer is NULL\n"); - return 102; - } - #ifdef VERBOSE - printf("write file descriptor, datary = %d %d\n", *fdes, (int) datary); - #endif - count = (size_t) *no; - jret = write(*fdes, (void *) datary, count); - if (jret != *no) { - #ifdef VERBOSE - printf("did not write out the requested number of bytes\n"); - printf("wrote %d bytes instead\n", jret); - #endif - *nactual = jret; - *newpos = *start + jret; - } - else { - #ifdef VERBOSE - printf("wrote %d bytes \n", jret); - #endif - *nactual = jret; - *newpos = *start + jret; - } - } -/* Done with writing */ - - -/* Close file if requested */ - if (BACLOSE & *mode ) { - jret = close(*fdes); - if (jret != 0) { - #ifdef VERBOSE - printf("close failed! jret = %d\n",jret); - #endif - return 247; - } - } -/* Done closing */ - -/* Free the realname pointer to prevent memory leak */ - if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || - (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || - (BAOPEN_RW & *mode) ) { - free(realname); - } - -/* Check that if we were reading or writing, that we actually got what */ -/* we expected, else return a -10. Return 0 (success) if we're here */ -/* and weren't reading or writing */ - if ( (*mode & BAREAD || *mode & BAWRITE) && (*nactual != *no) ) { - return 246; - } - else { - return 0; - } -} -#ifdef CRAY90 - #include - int BANI0L - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, - _fcd fcd_fname, void *datary) { - char *fname; - int namelen; -#endif -#ifdef HP - int baniol - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef SGI - int baniol_ - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef LINUX - int baniol_ - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef LINUXF90 - int BANIO - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef MACOSX - int baniol_ - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef VPP5000 - int baniol_ - (int * mode, long int * start, long int *newpos, int * size, long int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef IBM4 - int baniol - (int * mode, long int * start, long int *newpos, long int * size, int * no, - long int * nactual, int * fdes, const char *fname, char *datary, - int namelen ) { -#endif -#ifdef IBM8 - long long int baniol - (long long int * mode, long long int * start, long long int *newpos, - long long int * size, long long int * no, - long long int * nactual, long long int * fdes, const char *fname, - char *datary, - long long int namelen ) { -#endif - int i, j, jret, seekret; - char *realname; - int tcharval; - size_t count; - -/* Initialization(s) */ - *nactual = 0; - -/* Check for illegal combinations of options */ - if (( BAOPEN_RONLY & *mode) && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("illegal -- trying to open both read only and write only\n"); - #endif - return 255; - } - if ( (BAREAD & *mode ) && (BAWRITE & *mode) ) { - #ifdef VERBOSE - printf("illegal -- trying to both read and write in the same call\n"); - #endif - return 254; - } - -/* This section handles Fortran to C translation of strings so as to */ -/* be able to open the files Fortran is expecting to be opened. */ - #ifdef CRAY90 - namelen = _fcdlen(fcd_fname); - fname = _fcdtocp(fcd_fname); - #endif - if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || - (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || - (BAOPEN_RW & *mode) ) { - #ifdef VERBOSE - printf("Will be opening a file %s %d\n", fname, namelen); fflush(stdout); - printf("Strlen %d namelen %d\n", strlen(fname), namelen); fflush(stdout); - #endif - realname = (char *) malloc( (namelen+1) * sizeof(char) ) ; - if (realname == NULL) { - #ifdef VERBOSE - printf("failed to mallocate realname %d = namelen\n", namelen); - fflush(stdout); - #endif - return 253; - } - i=0; - while (i < namelen && isgraph(fname[i])) { - realname[i]=fname[i]; - i++; - } - realname[i] = '\0'; - - } - -/* Open files with correct read/write and file permission. */ - if (BAOPEN_RONLY & *mode) { - #ifdef VERBOSE - printf("open read only %s\n", realname); - #endif - *fdes = open(realname, O_RDONLY , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_WONLY & *mode ) { - #ifdef VERBOSE - printf("open write only %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_WONLY_TRUNC & *mode ) { - #ifdef VERBOSE - printf("open write only with truncation %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_TRUNC , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_WONLY_APPEND & *mode ) { - #ifdef VERBOSE - printf("open write only with append %s\n", realname); - #endif - *fdes = open(realname, O_WRONLY | O_CREAT | O_APPEND , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else if (BAOPEN_RW & *mode) { - #ifdef VERBOSE - printf("open read-write %s\n", realname); - #endif - *fdes = open(realname, O_RDWR | O_CREAT , S_IRUSR | S_IRGRP | S_IROTH | S_IWUSR | S_IWGRP ); - } - else { - #ifdef VERBOSE - printf("no openings\n"); - #endif - } - if (*fdes < 0) { - #ifdef VERBOSE - printf("error in file descriptor! *fdes %d\n", *fdes); - #endif - return 252; - } - else { - #ifdef VERBOSE - printf("file descriptor = %d\n",*fdes ); - #endif - } - - -/* Read data as requested */ - if (BAREAD & *mode && - ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { - #ifdef VERBOSE - printf("Error, trying to read while in write only mode!\n"); - #endif - return 251; - } - else if (BAREAD & *mode ) { - /* Read in some data */ - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return 250; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - jret = read(*fdes, datary, *no*(*size) ); - if (jret != *no*(*size) ) { - #ifdef VERBOSE - printf("did not read in the requested number of items\n"); - printf("read in %d items of %d \n",jret/(*size), *no); - #endif - *nactual = jret/(*size); - *newpos = *start + jret; - } - #ifdef VERBOSE - printf("read in %d items \n", jret/(*size)); - #endif - *nactual = jret/(*size); - *newpos = *start + jret; - } -/* Done with reading */ - -/* See if we should be writing */ - if ( BAWRITE & *mode && BAOPEN_RONLY & *mode ) { - #ifdef VERBOSE - printf("Trying to write on a read only file \n"); - #endif - return 249; - } - else if ( BAWRITE & *mode ) { - if (! (*mode & NOSEEK) ) { - seekret = lseek(*fdes, *start, SEEK_SET); - if (seekret == -1) { - #ifdef VERBOSE - printf("error in seeking to %d\n",*start); - #endif - return 248; - } - #ifdef VERBOSE - else { - printf("Seek successful, seek ret %d, start %d\n", seekret, *start); - } - #endif - } - jret = write(*fdes, datary, *no*(*size)); - if (jret != *no*(*size)) { - #ifdef VERBOSE - printf("did not write out the requested number of items\n"); - printf("wrote %d items instead\n", jret/(*size) ); - #endif - *nactual = jret/(*size) ; - *newpos = *start + jret; - } - else { - #ifdef VERBOSE - printf("wrote %d items \n", jret/(*size) ); - #endif - *nactual = jret/(*size) ; - *newpos = *start + jret; - } - } -/* Done with writing */ - - -/* Close file if requested */ - if (BACLOSE & *mode ) { - jret = close(*fdes); - if (jret != 0) { - #ifdef VERBOSE - printf("close failed! jret = %d\n",jret); - #endif - return 247; - } - } -/* Done closing */ - -/* Free the realname pointer to prevent memory leak */ - if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || - (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || - (BAOPEN_RW & *mode) ) { - free(realname); - } - -/* Check that if we were reading or writing, that we actually got what */ -/* we expected, else return a -10. Return 0 (success) if we're here */ -/* and weren't reading or writing */ - if ( (*mode & BAREAD || *mode & BAWRITE) && (*nactual != *no) ) { - return 246; - } - else { - return 0; - } -} diff --git a/external/bacio/v2.0.1/src/baciof.f b/external/bacio/v2.0.1/src/baciof.f deleted file mode 100644 index 0412013a..00000000 --- a/external/bacio/v2.0.1/src/baciof.f +++ /dev/null @@ -1,730 +0,0 @@ -C----------------------------------------------------------------------- - MODULE BACIO_MODULE -C$$$ F90-MODULE DOCUMENTATION BLOCK -C -C F90-MODULE: BACIO_MODULE BYTE-ADDRESSABLE I/O MODULE -C PRGMMR: IREDELL ORG: NP23 DATE: 98-06-04 -C -C ABSTRACT: MODULE TO SHARE FILE DESCRIPTORS -C IN THE BYTE-ADDESSABLE I/O PACKAGE. -C -C PROGRAM HISTORY LOG: -C 98-06-04 IREDELL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - INTEGER,EXTERNAL:: BACIO,BACIOL - INTEGER,PARAMETER :: FDDIM=9999 - INTEGER,DIMENSION(FDDIM),SAVE:: FD=FDDIM*0 - INTEGER,DIMENSION(20),SAVE:: BAOPTS=0 - INCLUDE 'baciof.h' - END -C----------------------------------------------------------------------- - SUBROUTINE BASETO(NOPT,VOPT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BASETO BYTE-ADDRESSABLE SET OPTIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: SET OPTIONS FOR BYTE-ADDRESSABLE I/O. -C ALL OPTIONS DEFAULT TO 0. -C OPTION 1: BLOCKED READING OPTION -C IF THE OPTION VALUE IS 1, THEN THE READING IS BLOCKED -C INTO FOUR 4096-BYTE BUFFERS. THIS MAY BE EFFICIENT IF -C THE READS WILL BE REQUESTED IN MUCH SMALLER CHUNKS. -C OTHERWISE, EACH CALL TO BAREAD INITIATES A PHYSICAL READ. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BASETO(NOPT,VOPT) -C INPUT ARGUMENTS: -C NOPT INTEGER OPTION NUMBER -C VOPT INTEGER OPTION VALUE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - INTEGER NOPT,VOPT -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(NOPT.GE.1.AND.NOPT.LE.20) BAOPTS(NOPT)=VOPT -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAOPEN(LU,CFN,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAOPEN BYTE-ADDRESSABLE OPEN -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BAOPEN(LU,CFN,IRET) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO OPEN -C CFN CHARACTER FILENAME TO OPEN -C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER CFN*(*) - CHARACTER(80) CMSG - integer(kind=8) IB,JB,NB,KA -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(LU.LT.001.OR.LU.GT.FDDIM) THEN - IRET=6 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IRET=BACIOL(BACIO_OPENRW,IB,JB,1,NB,KA,FD(LU),CFN,A) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAOPENR(LU,CFN,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAOPENR BYTE-ADDRESSABLE OPEN -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR READ ONLY. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BAOPENR(LU,CFN,IRET) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO OPEN -C CFN CHARACTER FILENAME TO OPEN -C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER CFN*(*) - INTEGER LU,iret - integer(kind=8) IB,JB,NB,KA -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(LU.LT.001.OR.LU.GT.FDDIM) THEN - IRET=6 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IRET=BACIOL(BACIO_OPENR,IB,JB,1,NB,KA,FD(LU),CFN,A) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAOPENW(LU,CFN,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAOPENW BYTE-ADDRESSABLE OPEN -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BAOPENW(LU,CFN,IRET) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO OPEN -C CFN CHARACTER FILENAME TO OPEN -C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER CFN*(*) - integer(kind=8) IB,JB,NB,KA -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(LU.LT.001.OR.LU.GT.FDDIM) THEN - IRET=6 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IRET=BACIOL(BACIO_OPENW,IB,JB,1,NB,KA,FD(LU),CFN,A) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAOPENWT(LU,CFN,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAOPENWT BYTE-ADDRESSABLE OPEN -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY WITH TRUNCATION. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BAOPENWT(LU,CFN,IRET) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO OPEN -C CFN CHARACTER FILENAME TO OPEN -C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER CFN*(*) - integer(kind=8) IB,JB,NB,KA -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(LU.LT.001.OR.LU.GT.FDDIM) THEN - IRET=6 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IRET=BACIOL(BACIO_OPENWT,IB,JB,1,NB,KA,FD(LU),CFN,A) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAOPENWA(LU,CFN,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAOPENWA BYTE-ADDRESSABLE OPEN -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY WITH APPEND. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BAOPENWA(LU,CFN,IRET) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO OPEN -C CFN CHARACTER FILENAME TO OPEN -C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - CHARACTER CFN*(*) - integer(kind=8) IB,JB,NB,KA -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(LU.LT.001.OR.LU.GT.FDDIM) THEN - IRET=6 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IRET=BACIOL(BACIO_OPENWA,IB,JB,1,NB,KA,FD(LU),CFN,A) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BACLOSE(LU,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BACLOSE BYTE-ADDRESSABLE CLOSE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: CLOSE A BYTE-ADDRESSABLE FILE. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C -C USAGE: CALL BACLOSE(LU,IRET) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO CLOSE -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE - integer(kind=8) IB,JB,NB,KA -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(LU.LT.001.OR.LU.GT.FDDIM) THEN - IRET=6 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IRET=BACIOL(BACIO_CLOSE,IB,JB,1,NB,KA,FD(LU),CHAR(0),A) - IF(IRET.EQ.0) FD(LU)=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END -C----------------------------------------------------------------------- - SUBROUTINE BAREAD(LU,IB,NB,KA,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAREAD BYTE-ADDRESSABLE READ -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: THIS BAREAD IS CALLING BAREADL TO READ A GIVEN NUMBER OF -C BYTES FROM AN UNBLOCKED FILE,SKIPPING A GIVEN NUMBER OF BYTES. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C 2009-04-20 J. WANG -C -C USAGE: CALL BAREAD(LU,IB,NB,KA,A) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO READ -C IB INTEGER NUMBER OF BYTES TO SKIP -C (IF IB<0, THEN THE FILE IS ACCESSED WITH NO SEEKING) -C NB INTEGER NUMBER OF BYTES TO READ -C OUTPUT ARGUMENTS: -C KA INTEGER NUMBER OF BYTES ACTUALLY READ -C A CHARACTER*1 (NB) DATA READ -C -C SUBPROGRAMS CALLED: -C BAREADL BYTE-ADDRESSABLE READ SUBROUTINE -C -C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -! - IMPLICIT NONE - INTEGER,INTENT(IN) :: LU,IB,NB - INTEGER,INTENT(OUT) :: KA - CHARACTER,INTENT(OUT) :: A(NB) - INTEGER(KIND=8) :: LONG_IB,LONG_NB,LONG_KA -! - if(NB<0 ) THEN - print *,'WRONG: in BAREAD read data size NB < 0, STOP! '// & - & 'Consider using BAREADL and long integer' - KA=0 - return - ENDIF - LONG_IB=IB - LONG_NB=NB - CALL BAREADL(LU,LONG_IB,LONG_NB,LONG_KA,A) - KA=LONG_KA - - END SUBROUTINE BAREAD -C----------------------------------------------------------------------- - SUBROUTINE BAREADL(LU,IB,NB,KA,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAREAD BYTE-ADDRESSABLE READ -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: THIS SUBROUYTINE IS USING UPDATED BACIOL I/O PACKAGE TO READ -C A GIVEN NUMBER OF BYTES FROM AN UNBLOCKED FILE, SKIPPING A GIVEN -C NUMBER OF BYTES. -C THE PHYSICAL I/O IS BLOCKED INTO FOUR 4096-BYTE BUFFERS -C IF THE BYTE-ADDRESSABLE OPTION 1 HAS BEEN SET TO 1 BY BASETO. -C THIS BUFFERED READING IS INCOMPATIBLE WITH NO-SEEK READING. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C 2009-04-20 J. WANG -C -C USAGE: CALL BAREAD(LU,IB,NB,KA,A) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO READ -C IB INTEGER(8) NUMBER OF BYTES TO SKIP -C (IF IB<0, THEN THE FILE IS ACCESSED WITH NO SEEKING) -C NB INTEGER(8) NUMBER OF BYTES TO READ -C OUTPUT ARGUMENTS: -C KA INTEGER(8) NUMBER OF BYTES ACTUALLY READ -C A CHARACTER*1 (NB) DATA READ -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIOL BYTE-ADDRESSABLE I/O C PACKAGE -C -C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE -! - IMPLICIT NONE - INTEGER,intent(in) :: LU - INTEGER(kind=8),intent(in) :: IB,NB - INTEGER(kind=8),intent(out) :: KA - CHARACTER,intent(out) :: A(NB) - integer(kind=8),PARAMETER :: NY=4096,MY=4 - INTEGER(KIND=8) NS(MY),NN(MY) - INTEGER(kind=8) JB,LONG_0,KY,I,K,IY,JY,LUX - INTEGER IRET -! INTEGER LU,IB,NB,KA - CHARACTER Y(NY,MY) - DATA LUX/0/ - SAVE JY,NS,NN,Y,LUX -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(FD(LU).LE.0) THEN - KA=0 - RETURN - ENDIF - IF(IB.LT.0.AND.BAOPTS(1).EQ.1) THEN - KA=0 - RETURN - ENDIF - IF(NB.LE.0) THEN - KA=0 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - LONG_0=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C UNBUFFERED I/O - IF(BAOPTS(1).NE.1) THEN - KA=0 - IF(IB.GE.0) THEN - IRET=BACIOL(BACIO_READ,IB,JB,1,NB,KA,FD(LU),CHAR(0),A) - ELSE - IRET=BACIOL(BACIO_READ+BACIO_NOSEEK,LONG_0,JB,1,NB,KA, & - & FD(LU),CHAR(0),A) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C BUFFERED I/O -C GET DATA FROM PREVIOUS CALL IF POSSIBLE - ELSE - KA=0 - IF(LUX.NE.LU) THEN - JY=0 - NS=0 - NN=0 - ELSE - DO I=1,MY - IY=MOD(JY+I-1,MY)+1 - KY=IB+KA-NS(IY) - IF(KA.LT.NB.AND.KY.GE.LONG_0.AND.KY.LT.NN(IY)) THEN - K=MIN(NB-KA,NN(IY)-KY) - A(KA+1:KA+K)=Y(KY+1:KY+K,IY) - KA=KA+K - ENDIF - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SET POSITION AND READ BUFFER AND GET DATA - IF(KA.LT.NB) THEN - LUX=ABS(LU) - JY=MOD(JY,MY)+1 - NS(JY)=IB+KA - IRET=BACIOL(BACIO_READ,NS(JY),JB,1,NY,NN(JY), - & FD(LUX),CHAR(0),Y(1,JY)) - IF(NN(JY).GT.0) THEN - K=MIN(NB-KA,NN(JY)) - A(KA+1:KA+K)=Y(1:K,JY) - KA=KA+K - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CONTINUE TO READ BUFFER AND GET DATA - DOWHILE(NN(JY).EQ.NY.AND.KA.LT.NB) - JY=MOD(JY,MY)+1 - NS(JY)=NS(JY)+NN(JY) - IRET=BACIOL(BACIO_READ+BACIO_NOSEEK,NS(JY),JB,1,NY,NN(JY), - & FD(LUX),CHAR(0),Y(1,JY)) - IF(NN(JY).GT.0) THEN - K=MIN(NB-KA,NN(JY)) - A(KA+1:KA+K)=Y(1:K,JY) - KA=KA+K - ENDIF - ENDDO - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE BAREADL -C----------------------------------------------------------------------- - SUBROUTINE BAWRITE(LU,IB,NB,KA,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAWRITE BYTE-ADDRESSABLE WRITE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: THIS PROGRAM IS CALLING BAWRITEL TO WRITE A GIVEN NUMBER OF -C BYTES TO AN UNBLOCKED FILE,SKIPPING A GIVEN NUMBER OF BYTES. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C 2009-04-20 J. WANG -C -C USAGE: CALL BAWRITE(LU,IB,NB,KA,A) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO WRITE -C IB INTEGER NUMBER OF BYTES TO SKIP -C (IF IB<0, THEN THE FILE IS ACCESSED WITH NO SEEKING) -C NB INTEGER NUMBER OF BYTES TO WRITE -C A CHARACTER*1 (NB) DATA TO WRITE -C OUTPUT ARGUMENTS: -C KA INTEGER NUMBER OF BYTES ACTUALLY WRITTEN -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -! - IMPLICIT NONE - INTEGER,INTENT(IN) :: LU,IB,NB - INTEGER,INTENT(OUT) :: KA - CHARACTER,INTENT(IN) :: A(NB) - INTEGER(KIND=8) :: LONG_IB,LONG_NB,LONG_KA -! - if(NB<0 ) THEN - print *,'WRONG: in BAWRITE read data size NB <0, STOP! '// & - & 'Consider using BAWRITEL and long integer' - KA=0 - return - ENDIF -! - LONG_IB=IB - LONG_NB=NB - CALL BAWRITEL(LU,LONG_IB,LONG_NB,LONG_KA,A) - KA=LONG_KA - - END SUBROUTINE BAWRITE -C----------------------------------------------------------------------- - SUBROUTINE BAWRITEL(LU,IB,NB,KA,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAWRITEL BYTE-ADDRESSABLE WRITE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: THIS SUBROUYTINE IS USING UPDATED BACIOL I/O PACKAGE TO WRITE -C A GIVEN NUMBER OF BYTES TO AN UNBLOCKED FILE, SKIPPING A GIVEN NUMBER -C OF BYTES. -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C 2009-04-20 J. WANG -C -C USAGE: CALL BAWRITEL(LU,IB,NB,KA,A) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO WRITE -C IB INTEGER(8) NUMBER OF BYTES TO SKIP -C (IF IB<0, THEN THE FILE IS ACCESSED WITH NO SEEKING) -C NB INTEGER(8) NUMBER OF BYTES TO WRITE -C A CHARACTER*1 (NB) DATA TO WRITE -C OUTPUT ARGUMENTS: -C KA INTEGER(8) NUMBER OF BYTES ACTUALLY WRITTEN -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIOL BYTE-ADDRESSABLE I/O C PACKAGE -C -C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE -! - IMPLICIT NONE -! - INTEGER,intent(in) :: LU - INTEGER(kind=8),intent(in) :: IB,NB - INTEGER(kind=8),intent(out):: KA - CHARACTER,intent(in) :: A(NB) -! - INTEGER(kind=8) :: JB,LONG_0 - INTEGER :: IRET -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(FD(LU).LE.0) THEN - KA=0 - RETURN - ENDIF - IF(NB.LE.0) THEN - KA=0 - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - LONG_0=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(IB.GE.0) THEN - KA=0 - IRET=BACIOL(BACIO_WRITE,IB,JB,1,NB,KA,FD(LU),CHAR(0),A) - ELSE - KA=0 - IRET=BACIOL(BACIO_WRITE+BACIO_NOSEEK,LONG_0,JB,1,NB,KA, & - & FD(LU),CHAR(0),A) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE BAWRITEL -C----------------------------------------------------------------------- - SUBROUTINE WRYTE(LU,NB,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRYTE WRITE DATA OUT BY BYTES -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: THSI SUBROUTINE IS CALLING WRYTEL TO WRITE A GIVEN NUMBER OF -C BYTES TO AN UNBLOCKED FILE. -C -C PROGRAM HISTORY LOG: -C 92-10-31 IREDELL -C 95-10-31 IREDELL WORKSTATION VERSION -C 1998-06-04 IREDELL BACIO VERSION -C 2009-04-20 J. WANG WRYTEL VERSION -C -C USAGE: CALL WRYTE(LU,NB,A) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO WHICH TO WRITE -C NB INTEGER(4) NUMBER OF BYTES TO WRITE -C A CHARACTER*1 (NB) DATA TO WRITE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIO BYTE-ADDRESSABLE I/O C PACKAGE -C -C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -! - USE BACIO_MODULE -! - IMPLICIT NONE -! - INTEGER,intent(in) :: LU - INTEGER,intent(in) :: NB - CHARACTER,intent(in) :: A(NB) - INTEGER(kind=8) :: LONG_NB -! - IF(NB<0) THEN - PRINT *,'WRONG: NB: the number of bytes to write <0, STOP!' - RETURN - ENDIF - LONG_NB=NB - CALL WRYTEL(LU,LONG_NB,A) -! - END SUBROUTINE WRYTE -C----------------------------------------------------------------------- - SUBROUTINE WRYTEL(LU,NB,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: WRYTE WRITE DATA OUT BY BYTES -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 -C -C ABSTRACT: WRITE A GIVEN NUMBER OF BYTES TO AN UNBLOCKED FILE. -C -C PROGRAM HISTORY LOG: -C 92-10-31 IREDELL -C 95-10-31 IREDELL WORKSTATION VERSION -C 1998-06-04 IREDELL BACIO VERSION -C 2009-04-20 J. WANG BACIOL VERSION -C -C USAGE: CALL WRYTE(LU,NB,A) -C INPUT ARGUMENTS: -C LU INTEGER UNIT TO WHICH TO WRITE -C NB INTEGER(8) NUMBER OF BYTES TO WRITE -C A CHARACTER*1 (NB) DATA TO WRITE -C -C MODULES USED: -C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE -C -C SUBPROGRAMS CALLED: -C BACIOL BYTE-ADDRESSABLE I/O C PACKAGE -C -C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - USE BACIO_MODULE -! - IMPLICIT NONE - INTEGER,intent(in) :: LU - INTEGER(kind=8),intent(in) :: NB - CHARACTER,INTENT(in) :: A(NB) - INTEGER(kind=8) :: LONG_0,JB,KA - INTEGER :: IRET -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(FD(LU).LE.0) THEN - RETURN - ENDIF - IF(NB.LE.0) THEN - RETURN - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - LONG_0=0 - KA=0 - JB=0 - IRET=BACIOL(BACIO_WRITE+BACIO_NOSEEK,LONG_0,JB,1,NB,KA, & - & FD(LU),CHAR(0),A) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/bacio/v2.0.1/src/baciof.h b/external/bacio/v2.0.1/src/baciof.h deleted file mode 100644 index 4153e27d..00000000 --- a/external/bacio/v2.0.1/src/baciof.h +++ /dev/null @@ -1,11 +0,0 @@ -! Include file to define variables for Fortran to C interface(s) -! Robert Grumbine 16 March 1998 - INTEGER,PARAMETER:: BACIO_OPENR=1 ! Open file for read only - INTEGER,PARAMETER:: BACIO_OPENW=2 ! Open file for write only - INTEGER,PARAMETER:: BACIO_OPENRW=4 ! Open file for read or write - INTEGER,PARAMETER:: BACIO_CLOSE=8 ! Close file - INTEGER,PARAMETER:: BACIO_READ=16 ! Read from the file - INTEGER,PARAMETER:: BACIO_WRITE=32 ! Write to the file - INTEGER,PARAMETER:: BACIO_NOSEEK=64 ! Start I/O from previous spot - INTEGER,PARAMETER:: BACIO_OPENWT=128 ! Open for write only with truncation - INTEGER,PARAMETER:: BACIO_OPENWA=256 ! Open for write only with append diff --git a/external/bacio/v2.0.1/src/bafrio.f b/external/bacio/v2.0.1/src/bafrio.f deleted file mode 100644 index 0a29a7ad..00000000 --- a/external/bacio/v2.0.1/src/bafrio.f +++ /dev/null @@ -1,427 +0,0 @@ -C----------------------------------------------------------------------- -! -! revision history: -! -! Aug, 2012 Jun Wang bafrio for big and little endian files -! -! note: -! This version of bafrio.f is revised to have byteswap in FORTRAN -! data file control words. It is designed to be run on -! on WCOSS(little endian machine) and to generate big endian files. -! It does byteswap on fortran record control words(4 byte integer -! before and after data field), not on data field itself. Users need -! to byteswap their data after(for reading)/before(for writing) -! calling subroutines this file. This is considered to be the best -! way to keep subroutine inerfaces intact for backward compatible. -! -C----------------------------------------------------------------------- - SUBROUTINE BAFRINDEX(LU,IB,LX,IX) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAFRINDEX BYTE-ADDRESSABLE FORTRAN RECORD INDEX -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1999-01-21 -C -C ABSTRACT: THIS SUBPROGRAM IS CALLING BAFRINDEXL TO EITHER READ AN -C UNFORMATTED FORTRAN RECORD -C AND RETURN ITS LENGTH AND START BYTE OF THE NEXT FORTRAN RECORD; -C OR GIVEN THE RECORD LENGTH, WITHOUT I/O IT DETERMINES THE START BYTE -C OF THE NEXT FORTRAN RECORD. THE DIFFERENCE BETWEEN BAFRINDEX AND -C BAFRINDEXL IS THE KIND TYPE OF INTERGERS IN THE ARGUMENT LIST -C -C PROGRAM HISTORY LOG: -C 1999-01-21 IREDELL -C 2009-04-20 J. WANG -C -C USAGE: CALL BAFRINDEX(LU,IB,LX,IX) -C INPUT ARGUMENTS: -C LU INTEGER LOGICAL UNIT TO READ -C IF LU<=0, THEN DETERMINE IX FROM LX -C IB INTEGER FORTRAN RECORD START BYTE -C (FOR THE FIRST FORTRAN RECORD, IB SHOULD BE 0) -C LX INTEGER RECORD LENGTH IN BYTES IF LU<=0 -C -C OUTPUT ARGUMENTS: -C LX INTEGER RECORD LENGTH IN BYTES IF LU>0, -C OR LX=-1 FOR I/O ERROR (PROBABLE END OF FILE), -C OR LX=-2 FOR I/O ERROR (INVALID FORTRAN RECORD) -C IX INTEGER START BYTE FOR THE NEXT FORTRAN RECORD -C (COMPUTED ONLY IF LX>=0) -C -C SUBPROGRAMS CALLED: -C BAFRINDEXL BYTE-ADDRESSABLE FORTRAN RECORD INDEX -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -! - IMPLICIT NONE - INTEGER,INTENT(IN):: LU,IB - INTEGER,INTENT(INOUT):: LX - INTEGER,INTENT(OUT):: IX - integer(kind=8) :: LONG_IB,LONG_LX ,LONG_IX -! - LONG_IB=IB - LONG_LX=LX - call BAFRINDEXL(LU,LONG_IB,LONG_LX,LONG_IX) - LX=LONG_LX - IX=LONG_IX - - return - end SUBROUTINE BAFRINDEX -C----------------------------------------------------------------------- - SUBROUTINE BAFRINDEXL(LU,IB,LX,IX) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAFRINDEXL BYTE-ADDRESSABLE FORTRAN RECORD INDEX -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1999-01-21 -C -C ABSTRACT: THIS SUBPROGRAM EITHER READS AN UNFORMATTED FORTRAN RECORD -C AND RETURN ITS LENGTH AND START BYTE OF THE NEXT FORTRAN RECORD; -C OR GIVEN THE RECORD LENGTH, WITHOUT I/O IT DETERMINES THE START BYTE -C OF THE NEXT FORTRAN RECORD. -C -C PROGRAM HISTORY LOG: -C 1999-01-21 IREDELL -C 2009-04-20 J. WANG -C -C USAGE: CALL BAFRINDEXL(LU,IB,LX,IX) -C INPUT ARGUMENTS: -C LU INTEGER LOGICAL UNIT TO READ -C IF LU<=0, THEN DETERMINE IX FROM LX -C IB INTEGER(8) FORTRAN RECORD START BYTE -C (FOR THE FIRST FORTRAN RECORD, IB SHOULD BE 0) -C LX INTEGER(8) RECORD LENGTH IN BYTES IF LU<=0 -C -C OUTPUT ARGUMENTS: -C LX INTEGER(8) RECORD LENGTH IN BYTES IF LU>0, -C OR LX=-1 FOR I/O ERROR (PROBABLE END OF FILE), -C OR LX=-2 FOR I/O ERROR (INVALID FORTRAN RECORD) -C IX INTEGER(8) START BYTE FOR THE NEXT FORTRAN RECORD -C (COMPUTED ONLY IF LX>=0) -C -C SUBPROGRAMS CALLED: -C BAREADL BYTE-ADDRESSABLE READ -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: LU - INTEGER(KIND=8),INTENT(IN):: IB - INTEGER(KIND=8),INTENT(INOUT):: LX - INTEGER(KIND=8),INTENT(OUT):: IX - INTEGER(KIND=8),PARAMETER:: LBCW=4 - INTEGER(KIND=LBCW):: BCW1,BCW2 - INTEGER(KIND=8):: KR - CHARACTER(16) :: MACHINE_ENDIAN - LOGICAL :: DO_BYTESWAP -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPARE FIRST BLOCK CONTROL WORD AND TRAILING BLOCK CONTROL WORD - IF(LU.GT.0) THEN -! -!-- set do_byteswap from machine endianness and file endianness - CALL CHK_ENDIANC(MACHINE_ENDIAN) - IF( LU<=999) THEN - IF( trim(MACHINE_ENDIAN)=="big_endian") THEN - DO_BYTESWAP=.false. - ELSEIF( trim(MACHINE_ENDIAN)=="little_endian") THEN - DO_BYTESWAP=.true. - ENDIF - ELSEIF(LU<=1999) THEN - IF( trim(MACHINE_ENDIAN)=="big_endian") THEN - DO_BYTESWAP=.true. - ELSEIF( trim(MACHINE_ENDIAN)=="little_endian") THEN - DO_BYTESWAP=.false. - ENDIF - ENDIF -! -! -!-- read out control word - CALL BAREADL(LU,IB,LBCW,KR,BCW1) - IF(DO_BYTESWAP) CALL Byteswap(BCW1,LBCW,1) -! - IF(KR.NE.LBCW) THEN - LX=-1 - ELSE - CALL BAREADL(LU,IB+LBCW+BCW1,LBCW,KR,BCW2) - IF(DO_BYTESWAP) CALL Byteswap(BCW2,LBCW,1) -! - IF(KR.NE.LBCW.OR.BCW1.NE.BCW2) THEN - LX=-2 - ELSE - LX=BCW1 - ENDIF - ENDIF -! -!end luif - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE START BYTE FOR THE NEXT FORTRAN RECORD - IF(LX.GE.0) IX=IB+LBCW+LX+LBCW -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE BAFRINDEXL -C----------------------------------------------------------------------- - SUBROUTINE BAFRREAD(LU,IB,NB,KA,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAFRREAD BYTE-ADDRESSABLE FORTRAN RECORD READ -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1999-01-21 -C -C ABSTRACT: THIS SUBPROGRAM IS CALLING BAFREAD TO REAS AN UNFORMATTED -C FORTRAN RECORD. THE DIFFERENCE BETWEEN BAFRREAD AND BAFRREADL IS -C THE KIND TYPE OF INTERGERS IN THE ARGUMENT LIST -C -C PROGRAM HISTORY LOG: -C 1999-01-21 IREDELL -C 2009-04-20 J. WANG -C -C USAGE: CALL BAFRREAD(LU,IB,NB,KA,A) -C INPUT ARGUMENTS: -C LU INTEGER LOGICAL UNIT TO READ -C IB INTEGER FORTRAN RECORD START BYTE -C (FOR THE FIRST FORTRAN RECORD, IB SHOULD BE 0) -C NB INTEGER NUMBER OF BYTES TO READ -C -C OUTPUT ARGUMENTS: -C KA INTEGER NUMBER OF BYTES IN FORTRAN RECORD -C (IN WHICH CASE THE NEXT FORTRAN RECORD -C SHOULD HAVE A START BYTE OF IB+KA), -C OR KA=-1 FOR I/O ERROR (PROBABLE END OF FILE), -C OR KA=-2 FOR I/O ERROR (INVALID FORTRAN RECORD), -C OR KA=-3 FOR I/O ERROR (REQUEST LONGER THAN RECORD) -C A CHARACTER*1 (NB) DATA READ -C -C SUBPROGRAMS CALLED: -C BAFRREADL BYTE-ADDRESSABLE READ -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -! - IMPLICIT NONE - INTEGER,INTENT(IN):: LU,IB,NB - INTEGER,INTENT(OUT):: KA - CHARACTER,INTENT(OUT):: A(NB) - INTEGER(KIND=8) :: LONG_IB,LONG_NB,LONG_KA -! - if((IB<0.and.IB/=-1) .or. NB<0 ) THEN - print *,'WRONG: in BAFRREAD starting postion IB or read '// & - & 'data size NB < 0, STOP! Consider use BAFREADL and long integer' - KA=0 - return - ENDIF - LONG_IB=IB - LONG_NB=NB - CALL BAFRREADL(LU,LONG_IB,LONG_NB,LONG_KA,A) - KA=LONG_KA - END SUBROUTINE BAFRREAD -C----------------------------------------------------------------------- - SUBROUTINE BAFRREADL(LU,IB,NB,KA,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAFRREADL BYTE-ADDRESSABLE FORTRAN RECORD READ -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1999-01-21 -C -C ABSTRACT: THIS SUBPROGRAM READS AN UNFORMATTED FORTRAN RECORD -C -C PROGRAM HISTORY LOG: -C 1999-01-21 IREDELL -C 2009-04-20 J. WANG -C -C USAGE: CALL BAFRREADL(LU,IB,NB,KA,A) -C INPUT ARGUMENTS: -C LU INTEGER LOGICAL UNIT TO READ -C IB INTEGER(8) FORTRAN RECORD START BYTE -C (FOR THE FIRST FORTRAN RECORD, IB SHOULD BE 0) -C NB INTEGER(8) NUMBER OF BYTES TO READ -C -C OUTPUT ARGUMENTS: -C KA INTEGER(8) NUMBER OF BYTES IN FORTRAN RECORD -C (IN WHICH CASE THE NEXT FORTRAN RECORD -C SHOULD HAVE A START BYTE OF IB+KA), -C OR KA=-1 FOR I/O ERROR (PROBABLE END OF FILE), -C OR KA=-2 FOR I/O ERROR (INVALID FORTRAN RECORD), -C OR KA=-3 FOR I/O ERROR (REQUEST LONGER THAN RECORD) -C A CHARACTER*1 (NB) DATA READ -C -C SUBPROGRAMS CALLED: -C BAFRINDEXL BYTE-ADDRESSABLE FORTRAN RECORD INDEX -C BAREADL BYTE-ADDRESSABLE READ -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: LU - INTEGER(kind=8),INTENT(IN):: IB,NB - INTEGER(kind=8),INTENT(OUT):: KA - CHARACTER,INTENT(OUT):: A(NB) - INTEGER(kind=8),PARAMETER:: LBCW=4 - INTEGER(kind=8):: LX,IX - INTEGER(kind=8):: KR -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C VALIDATE FORTRAN RECORD - CALL BAFRINDEXL(LU,IB,LX,IX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ IF VALID - IF(LX.LT.0) THEN - KA=LX - ELSEIF(LX.LT.NB) THEN - KA=-3 - ELSE - CALL BAREADL(LU,IB+LBCW,NB,KR,A) - IF(KR.NE.NB) THEN - KA=-1 - ELSE - KA=LBCW+LX+LBCW - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE BAFRREADL -C----------------------------------------------------------------------- - SUBROUTINE BAFRWRITE(LU,IB,NB,KA,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAFRWRITE BYTE-ADDRESSABLE FORTRAN RECORD WRITE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1999-01-21 -C -C ABSTRACT: THIS SUBPROGRAM IS CALLING BAFRWRITE TO WRITE AN UNFORMATTED -C FORTRAN RECORD. THE DIFFERENCE BETWEEN BAFRWRITE AND BAFRWRITEL IS -C THE KIND TYPE OF INTERGERS IN THE ARGUMENT LIST -C -C PROGRAM HISTORY LOG: -C 1999-01-21 IREDELL -C 2009-04-20 J. WANG -C -C USAGE: CALL BAFRWRITE(LU,IB,NB,KA,A) -C INPUT ARGUMENTS: -C LU INTEGER LOGICAL UNIT TO WRITE -C IB INTEGER FORTRAN RECORD START BYTE -C (FOR THE FIRST FORTRAN RECORD, IB SHOULD BE 0) -C NB INTEGER NUMBER OF BYTES TO WRITE -C A CHARACTER*1 (NB) DATA TO WRITE -C -C OUTPUT ARGUMENTS: -C KA INTEGER NUMBER OF BYTES IN FORTRAN RECORD -C (IN WHICH CASE THE NEXT FORTRAN RECORD -C SHOULD HAVE A START BYTE OF IB+KA), -C OR KA=-1 FOR I/O ERROR -C -C SUBPROGRAMS CALLED: -C BAWRITEL BYTE-ADDRESSABLE WRITE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - -! - IMPLICIT NONE - INTEGER,INTENT(IN):: LU,IB,NB - INTEGER,INTENT(OUT):: KA - CHARACTER,INTENT(IN):: A(NB) - INTEGER(KIND=8) :: LONG_IB,LONG_NB,LONG_KA -! - if((IB<0.and.IB/=-1) .or. NB<0 ) THEN - print *,'WRONG: in BAFRWRITE starting postion IB or read '// & - & 'data size NB <0, STOP! ' // & - & 'Consider use BAFRRWRITEL and long integer' - KA=0 - return - ENDIF - LONG_IB=IB - LONG_NB=NB - CALL BAFRWRITEL(LU,LONG_IB,LONG_NB,LONG_KA,A) - KA=LONG_KA -! - END SUBROUTINE BAFRWRITE -C----------------------------------------------------------------------- - SUBROUTINE BAFRWRITEL(LU,IB,NB,KA,A) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: BAFRWRITEL BYTE-ADDRESSABLE FORTRAN RECORD WRITE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1999-01-21 -C -C ABSTRACT: THIS SUBPROGRAM WRITES AN UNFORMATTED FORTRAN RECORD -C -C PROGRAM HISTORY LOG: -C 1999-01-21 IREDELL -C 2009-04-20 J. WANG -C -C USAGE: CALL BAFRWRITEL(LU,IB,NB,KA,A) -C INPUT ARGUMENTS: -C LU INTEGER LOGICAL UNIT TO WRITE -C IB INTEGER(8) FORTRAN RECORD START BYTE -C (FOR THE FIRST FORTRAN RECORD, IB SHOULD BE 0) -C NB INTEGER(8) NUMBER OF BYTES TO WRITE -C A CHARACTER*1 (NB) DATA TO WRITE -C -C OUTPUT ARGUMENTS: -C KA INTEGER(8) NUMBER OF BYTES IN FORTRAN RECORD -C (IN WHICH CASE THE NEXT FORTRAN RECORD -C SHOULD HAVE A START BYTE OF IB+KA), -C OR KA=-1 FOR I/O ERROR -C -C SUBPROGRAMS CALLED: -C BAWRITEL BYTE-ADDRESSABLE WRITE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: LU - INTEGER(KIND=8),INTENT(IN):: IB,NB - INTEGER(kind=8),INTENT(OUT):: KA - CHARACTER,INTENT(IN):: A(NB) -! - INTEGER(kind=8),PARAMETER:: LBCW=4 - INTEGER(kind=LBCW):: BCW - INTEGER(kind=8):: KR - INTEGER(LBCW):: BCW2,LBCW2 - CHARACTER(16) :: MACHINE_ENDIAN - LOGICAL :: DO_BYTESWAP -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C WRITE DATA BRACKETED BY BLOCK CONTROL WORDS -! -!-- set do_byteswap from machine endianness and file endianness - CALL CHK_ENDIANC(MACHINE_ENDIAN) - IF( LU<=999) THEN - IF( trim(MACHINE_ENDIAN)=="big_endian") THEN - DO_BYTESWAP=.false. - ELSEIF( trim(MACHINE_ENDIAN)=="little_endian") THEN - DO_BYTESWAP=.true. - ENDIF - ELSEIF(LU<=1999) THEN - IF( trim(MACHINE_ENDIAN)=="big_endian") THEN - DO_BYTESWAP=.true. - ELSEIF( trim(MACHINE_ENDIAN)=="little_endian") THEN - DO_BYTESWAP=.false. - ENDIF - ENDIF -! -! - BCW=NB - IF(DO_BYTESWAP) CALL Byteswap(BCW,LBCW,1) - CALL BAWRITEL(LU,IB,LBCW,KR,BCW) - IF(KR.NE.LBCW) THEN - KA=-1 - ELSE - CALL BAWRITEL(LU,IB+LBCW,NB,KR,A) - IF(KR.NE.NB) THEN - KA=-1 - ELSE - CALL BAWRITEL(LU,IB+LBCW+NB,LBCW,KR,BCW) - IF(KR.NE.LBCW) THEN - KA=-1 - ELSE - KA=LBCW+NB+LBCW - ENDIF - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE BAFRWRITEL diff --git a/external/bacio/v2.0.1/src/byteswap.c b/external/bacio/v2.0.1/src/byteswap.c deleted file mode 100644 index 5e89dae3..00000000 --- a/external/bacio/v2.0.1/src/byteswap.c +++ /dev/null @@ -1,52 +0,0 @@ -/*--------------------------------------------------------------------*/ -/* Documentation block */ -/* */ -/* byteswap: to reverse the order of a sequence of bytes. it takes */ -/* an data array, the number of bytes to swap for each data */ -/* and the number of data elements in the data array to swap, */ -/* then swaps each data element, and returns with swapped data */ -/* Aug 2012 Jun Wang */ -/* input : */ -/* char* data: input data array */ -/* int (or long long int) *nbyte: the number of bytes to swap */ -/* for 4 byte data, the number of bytes is 4 */ -/* for 8 byte data, the number of bytes is 8 */ -/* the maximal number of bytes to swap is 256 */ -/* int *nnum: the number of data elements to swap */ -/* output : */ -/* */ -/* char* data: swappted data array */ -/*--------------------------------------------------------------------*/ - -#ifdef LINUX - void byteswap_ - (char *data, int *nbyte, int *nnum) { -#endif -#ifdef MACOSX - void byteswap_ - (char *data, int *nbyte, int *nnum) { -#endif -#ifdef IBM4 - void byteswap - (char *data, int *nbyte, int *nnum) { -#endif -#ifdef IBM8 - void byteswap - (char *data, long long int *nbyte, long long int *nnum) { -#endif - int i, j; - char swap[256]; - int nb=*nbyte; - int nn=*nnum; - - - for (j=0; j - -/* Do not change things below here yourself */ - -/* IO-related (bacio.c, banio.c) */ -#define BAOPEN_RONLY 1 -#define BAOPEN_WONLY 2 -#define BAOPEN_RW 4 -#define BACLOSE 8 -#define BAREAD 16 -#define BAWRITE 32 -#define NOSEEK 64 -#define BAOPEN_WONLY_TRUNC 128 -#define BAOPEN_WONLY_APPEND 256 diff --git a/external/sp/v2.0.2/src/CMakeLists.txt b/external/sp/v2.0.2/src/CMakeLists.txt deleted file mode 100644 index 7ef8950b..00000000 --- a/external/sp/v2.0.2/src/CMakeLists.txt +++ /dev/null @@ -1,30 +0,0 @@ -SET(sp_source_code ${SPLIB_SRC}/splat.F - ${SPLIB_SRC}/lapack_gen.F - -) - -if (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") - set(f_flags -O3 -fdefault-real-8 -fconvert=big-endian -cpp -DLINUX -fPIC) - # -fp-model strict -real-size 32 -elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "Intel") - set(f_flags -O3 -auto -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX -fPIC) -elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "PGI") - set(f_flags -O3 -Mrecursive -i4 -r8 -byteswapio -Kieee -Mpreprocess -DLINUX -fPIC) -else (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") - message ("CMAKE_Fortran_COMPILER full path: " ${CMAKE_Fortran_COMPILER}) - message ("Fortran compiler: " ${CMAKE_Fortran_COMPILER_ID}) - message ("This program has only been compiled with gfortran, pgf90 and ifort. If another compiler is needed, the appropriate flags must be added in ${SPLIB_SRC}/CMakeLists.txt") -endif (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") - -#add OpenMP -set(c_flags ${c_flags} ${OpenMP_C_FLAGS}) -set(f_flags ${f_flags} ${OpenMP_Fortran_FLAGS}) - -if(${CMAKE_VERSION} LESS 3.3) - string (REPLACE ";" " " f_flags_str "${f_flags}") - SET_SOURCE_FILES_PROPERTIES(${sp_source_code} PROPERTIES COMPILE_FLAGS ${f_flags_str}) -else(${CMAKE_VERSION} LESS 3.3) - add_compile_options("$<$:${f_flags}>") -endif (${CMAKE_VERSION} LESS 3.3) - -ADD_LIBRARY(sp STATIC ${sp_source_code}) diff --git a/external/sp/v2.0.2/src/Makefile b/external/sp/v2.0.2/src/Makefile deleted file mode 100644 index 5c756bf0..00000000 --- a/external/sp/v2.0.2/src/Makefile +++ /dev/null @@ -1,63 +0,0 @@ -#sp Makefile - -############################################################### -# -# AUTHOR: Vuong - W/NP11 -# -# DATE: 12/04/2000 -# -# PURPOSE: This script uses the make utility to update the libsp -# archive libraries. -# It first reads a list of source files in the library and -# then generates a makefile used to update the archive -# libraries. The make command is then executed for each -# archive library, where the archive library name and -# compilation flags are passed to the makefile through -# environment variables. -# -# REMARKS: Only source files that have been modified since the last -# library update are recompiled and replaced in the object -# archive libraries. The make utility determines this -# from the file modification times. -# -# New source files are also compiled and added to the object -# archive libraries -# -# 11-29-12 Mirvis: Added Intel comp, optimization and OMP flags -# and libsp_*g.a builds -# -# 05-29-14 Mirvis: Updated to ver 2.0.2 -############################################################### - -# -# Generate a list of object files that corresponds to the -# list of Fortran ( .f ) files in the current directory - -# Set flags for Double Precision (Size of Real 8-byte and default Integer) version -# of libsp_d.a - -include ../../../../macros.make - -FC = $(FCserial) -SRCS = $(wildcard *.f *.F) -OBJS = $(addsuffix .o, $(basename $(SRCS))) -LIB = ../../../../libsp_v2.0.2_d.a -# libsp_v2.0.2_d.a -FFLAGS = $(SP_FFLAGS) -AFLAGS = $(SP_ARFLAGS) - -$(LIB): $(OBJS) - $(AR) $(AFLAGS) $@ $^ - -.f.a: - $(FC) -c $(FFLAGS) $< - $(AR) $(AFLAGS) $@ $*.o - $(RM) $*.o - -.F.a: - $(FC) -c $(FFLAGS) $< - $(AR) $(AFLAGS) $@ $*.o - $(RM) $*.o - -clean: - $(RM) *.o *.mod $(LIB) diff --git a/external/sp/v2.0.2/src/comp_list b/external/sp/v2.0.2/src/comp_list deleted file mode 100644 index fdfc5820..00000000 --- a/external/sp/v2.0.2/src/comp_list +++ /dev/null @@ -1,660 +0,0 @@ -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spanaly.f -ar -ruv ../splib_v2/libsp_4.a spanaly.o -r - spanaly.o -rm -f spanaly.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spdz2uv.f -ar -ruv ../splib_v2/libsp_4.a spdz2uv.o -r - spdz2uv.o -rm -f spdz2uv.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX speps.f -ar -ruv ../splib_v2/libsp_4.a speps.o -r - speps.o -rm -f speps.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spfft1.f -ar -ruv ../splib_v2/libsp_4.a spfft1.o -r - spfft1.o -rm -f spfft1.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spffte.f -ar -ruv ../splib_v2/libsp_4.a spffte.o -r - spffte.o -rm -f spffte.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spfft.f -ar -ruv ../splib_v2/libsp_4.a spfft.o -r - spfft.o -rm -f spfft.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spfftpt.f -ar -ruv ../splib_v2/libsp_4.a spfftpt.o -r - spfftpt.o -rm -f spfftpt.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spgradq.f -ar -ruv ../splib_v2/libsp_4.a spgradq.o -r - spgradq.o -rm -f spgradq.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spgradx.f -ar -ruv ../splib_v2/libsp_4.a spgradx.o -r - spgradx.o -rm -f spgradx.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spgrady.f -ar -ruv ../splib_v2/libsp_4.a spgrady.o -r - spgrady.o -rm -f spgrady.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX splaplac.f -ar -ruv ../splib_v2/libsp_4.a splaplac.o -r - splaplac.o -rm -f splaplac.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX splegend.f -ar -ruv ../splib_v2/libsp_4.a splegend.o -r - splegend.o -rm -f splegend.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sppad.f -ar -ruv ../splib_v2/libsp_4.a sppad.o -r - sppad.o -rm -f sppad.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spsynth.f -ar -ruv ../splib_v2/libsp_4.a spsynth.o -r - spsynth.o -rm -f spsynth.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptezd.f -ar -ruv ../splib_v2/libsp_4.a sptezd.o -r - sptezd.o -rm -f sptezd.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptez.f -ar -ruv ../splib_v2/libsp_4.a sptez.o -r - sptez.o -rm -f sptez.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptezmd.f -ar -ruv ../splib_v2/libsp_4.a sptezmd.o -r - sptezmd.o -rm -f sptezmd.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptezm.f -ar -ruv ../splib_v2/libsp_4.a sptezm.o -r - sptezm.o -rm -f sptezm.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptezmv.f -ar -ruv ../splib_v2/libsp_4.a sptezmv.o -r - sptezmv.o -rm -f sptezmv.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptezv.f -ar -ruv ../splib_v2/libsp_4.a sptezv.o -r - sptezv.o -rm -f sptezv.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptgpmd.f -ar -ruv ../splib_v2/libsp_4.a sptgpmd.o -r - sptgpmd.o -rm -f sptgpmd.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptgpm.f -ar -ruv ../splib_v2/libsp_4.a sptgpm.o -r - sptgpm.o -rm -f sptgpm.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptgpmv.f -ar -ruv ../splib_v2/libsp_4.a sptgpmv.o -r - sptgpmv.o -rm -f sptgpmv.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptgpsd.f -ar -ruv ../splib_v2/libsp_4.a sptgpsd.o -r - sptgpsd.o -rm -f sptgpsd.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptgps.f -ar -ruv ../splib_v2/libsp_4.a sptgps.o -r - sptgps.o -rm -f sptgps.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptgpsv.f -ar -ruv ../splib_v2/libsp_4.a sptgpsv.o -r - sptgpsv.o -rm -f sptgpsv.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptgptd.f -ar -ruv ../splib_v2/libsp_4.a sptgptd.o -r - sptgptd.o -rm -f sptgptd.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptgpt.f -ar -ruv ../splib_v2/libsp_4.a sptgpt.o -r - sptgpt.o -rm -f sptgpt.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptgptsd.f -ar -ruv ../splib_v2/libsp_4.a sptgptsd.o -r - sptgptsd.o -rm -f sptgptsd.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptgptvd.f -ar -ruv ../splib_v2/libsp_4.a sptgptvd.o -r - sptgptvd.o -rm -f sptgptvd.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptgptv.f -ar -ruv ../splib_v2/libsp_4.a sptgptv.o -r - sptgptv.o -rm -f sptgptv.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptrand.f -ar -ruv ../splib_v2/libsp_4.a sptrand.o -r - sptrand.o -rm -f sptrand.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptran.f -ar -ruv ../splib_v2/libsp_4.a sptran.o -r - sptran.o -rm -f sptran.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptranf0.f -ar -ruv ../splib_v2/libsp_4.a sptranf0.o -r - sptranf0.o -rm -f sptranf0.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptranf1.f -ar -ruv ../splib_v2/libsp_4.a sptranf1.o -r - sptranf1.o -rm -f sptranf1.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptranf.f -ar -ruv ../splib_v2/libsp_4.a sptranf.o -r - sptranf.o -rm -f sptranf.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptranfv.f -ar -ruv ../splib_v2/libsp_4.a sptranfv.o -r - sptranfv.o -rm -f sptranfv.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptranv.f -ar -ruv ../splib_v2/libsp_4.a sptranv.o -r - sptranv.o -rm -f sptranv.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptrund.f -ar -ruv ../splib_v2/libsp_4.a sptrund.o -r - sptrund.o -rm -f sptrund.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptrun.f -ar -ruv ../splib_v2/libsp_4.a sptrun.o -r - sptrun.o -rm -f sptrun.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptrung.f -ar -ruv ../splib_v2/libsp_4.a sptrung.o -r - sptrung.o -rm -f sptrung.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptrungv.f -ar -ruv ../splib_v2/libsp_4.a sptrungv.o -r - sptrungv.o -rm -f sptrungv.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptrunl.f -ar -ruv ../splib_v2/libsp_4.a sptrunl.o -r - sptrunl.o -rm -f sptrunl.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptrunm.f -ar -ruv ../splib_v2/libsp_4.a sptrunm.o -r - sptrunm.o -rm -f sptrunm.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptrunmv.f -ar -ruv ../splib_v2/libsp_4.a sptrunmv.o -r - sptrunmv.o -rm -f sptrunmv.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptruns.f -ar -ruv ../splib_v2/libsp_4.a sptruns.o -r - sptruns.o -rm -f sptruns.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptrunsv.f -ar -ruv ../splib_v2/libsp_4.a sptrunsv.o -r - sptrunsv.o -rm -f sptrunsv.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX sptrunv.f -ar -ruv ../splib_v2/libsp_4.a sptrunv.o -r - sptrunv.o -rm -f sptrunv.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spuv2dz.f -ar -ruv ../splib_v2/libsp_4.a spuv2dz.o -r - spuv2dz.o -rm -f spuv2dz.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spvar.f -ar -ruv ../splib_v2/libsp_4.a spvar.o -r - spvar.o -rm -f spvar.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX spwget.f -ar -ruv ../splib_v2/libsp_4.a spwget.o -r - spwget.o -rm -f spwget.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX fftpack.F -ar -ruv ../splib_v2/libsp_4.a fftpack.o -r - fftpack.o -rm -f fftpack.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX lapack_gen.F -ar -ruv ../splib_v2/libsp_4.a lapack_gen.o -r - lapack_gen.o -rm -f lapack_gen.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX ncpus.F -ar -ruv ../splib_v2/libsp_4.a ncpus.o -r - ncpus.o -rm -f ncpus.o -ifort -c -O3 -auto -openmp -i4 -convert big_endian -assume byterecl -fp-model strict -real-size 32 -fpp -DLINUX splat.F -ar -ruv ../splib_v2/libsp_4.a splat.o -r - splat.o -rm -f splat.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spanaly.f -ar -ruv ../splib_v2/libsp_8.a spanaly.o -r - spanaly.o -rm -f spanaly.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spdz2uv.f -ar -ruv ../splib_v2/libsp_8.a spdz2uv.o -r - spdz2uv.o -rm -f spdz2uv.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX speps.f -ar -ruv ../splib_v2/libsp_8.a speps.o -r - speps.o -rm -f speps.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spfft1.f -ar -ruv ../splib_v2/libsp_8.a spfft1.o -r - spfft1.o -rm -f spfft1.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spffte.f -ar -ruv ../splib_v2/libsp_8.a spffte.o -r - spffte.o -rm -f spffte.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spfft.f -ar -ruv ../splib_v2/libsp_8.a spfft.o -r - spfft.o -rm -f spfft.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spfftpt.f -ar -ruv ../splib_v2/libsp_8.a spfftpt.o -r - spfftpt.o -rm -f spfftpt.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spgradq.f -ar -ruv ../splib_v2/libsp_8.a spgradq.o -r - spgradq.o -rm -f spgradq.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spgradx.f -ar -ruv ../splib_v2/libsp_8.a spgradx.o -r - spgradx.o -rm -f spgradx.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spgrady.f -ar -ruv ../splib_v2/libsp_8.a spgrady.o -r - spgrady.o -rm -f spgrady.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX splaplac.f -ar -ruv ../splib_v2/libsp_8.a splaplac.o -r - splaplac.o -rm -f splaplac.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX splegend.f -ar -ruv ../splib_v2/libsp_8.a splegend.o -r - splegend.o -rm -f splegend.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sppad.f -ar -ruv ../splib_v2/libsp_8.a sppad.o -r - sppad.o -rm -f sppad.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spsynth.f -ar -ruv ../splib_v2/libsp_8.a spsynth.o -r - spsynth.o -rm -f spsynth.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptezd.f -ar -ruv ../splib_v2/libsp_8.a sptezd.o -r - sptezd.o -rm -f sptezd.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptez.f -ar -ruv ../splib_v2/libsp_8.a sptez.o -r - sptez.o -rm -f sptez.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptezmd.f -ar -ruv ../splib_v2/libsp_8.a sptezmd.o -r - sptezmd.o -rm -f sptezmd.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptezm.f -ar -ruv ../splib_v2/libsp_8.a sptezm.o -r - sptezm.o -rm -f sptezm.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptezmv.f -ar -ruv ../splib_v2/libsp_8.a sptezmv.o -r - sptezmv.o -rm -f sptezmv.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptezv.f -ar -ruv ../splib_v2/libsp_8.a sptezv.o -r - sptezv.o -rm -f sptezv.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgpmd.f -ar -ruv ../splib_v2/libsp_8.a sptgpmd.o -r - sptgpmd.o -rm -f sptgpmd.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgpm.f -ar -ruv ../splib_v2/libsp_8.a sptgpm.o -r - sptgpm.o -rm -f sptgpm.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgpmv.f -ar -ruv ../splib_v2/libsp_8.a sptgpmv.o -r - sptgpmv.o -rm -f sptgpmv.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgpsd.f -ar -ruv ../splib_v2/libsp_8.a sptgpsd.o -r - sptgpsd.o -rm -f sptgpsd.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgps.f -ar -ruv ../splib_v2/libsp_8.a sptgps.o -r - sptgps.o -rm -f sptgps.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgpsv.f -ar -ruv ../splib_v2/libsp_8.a sptgpsv.o -r - sptgpsv.o -rm -f sptgpsv.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgptd.f -ar -ruv ../splib_v2/libsp_8.a sptgptd.o -r - sptgptd.o -rm -f sptgptd.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgpt.f -ar -ruv ../splib_v2/libsp_8.a sptgpt.o -r - sptgpt.o -rm -f sptgpt.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgptsd.f -ar -ruv ../splib_v2/libsp_8.a sptgptsd.o -r - sptgptsd.o -rm -f sptgptsd.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgptvd.f -ar -ruv ../splib_v2/libsp_8.a sptgptvd.o -r - sptgptvd.o -rm -f sptgptvd.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgptv.f -ar -ruv ../splib_v2/libsp_8.a sptgptv.o -r - sptgptv.o -rm -f sptgptv.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrand.f -ar -ruv ../splib_v2/libsp_8.a sptrand.o -r - sptrand.o -rm -f sptrand.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptran.f -ar -ruv ../splib_v2/libsp_8.a sptran.o -r - sptran.o -rm -f sptran.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptranf0.f -ar -ruv ../splib_v2/libsp_8.a sptranf0.o -r - sptranf0.o -rm -f sptranf0.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptranf1.f -ar -ruv ../splib_v2/libsp_8.a sptranf1.o -r - sptranf1.o -rm -f sptranf1.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptranf.f -ar -ruv ../splib_v2/libsp_8.a sptranf.o -r - sptranf.o -rm -f sptranf.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptranfv.f -ar -ruv ../splib_v2/libsp_8.a sptranfv.o -r - sptranfv.o -rm -f sptranfv.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptranv.f -ar -ruv ../splib_v2/libsp_8.a sptranv.o -r - sptranv.o -rm -f sptranv.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrund.f -ar -ruv ../splib_v2/libsp_8.a sptrund.o -r - sptrund.o -rm -f sptrund.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrun.f -ar -ruv ../splib_v2/libsp_8.a sptrun.o -r - sptrun.o -rm -f sptrun.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrung.f -ar -ruv ../splib_v2/libsp_8.a sptrung.o -r - sptrung.o -rm -f sptrung.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrungv.f -ar -ruv ../splib_v2/libsp_8.a sptrungv.o -r - sptrungv.o -rm -f sptrungv.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrunl.f -ar -ruv ../splib_v2/libsp_8.a sptrunl.o -r - sptrunl.o -rm -f sptrunl.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrunm.f -ar -ruv ../splib_v2/libsp_8.a sptrunm.o -r - sptrunm.o -rm -f sptrunm.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrunmv.f -ar -ruv ../splib_v2/libsp_8.a sptrunmv.o -r - sptrunmv.o -rm -f sptrunmv.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptruns.f -ar -ruv ../splib_v2/libsp_8.a sptruns.o -r - sptruns.o -rm -f sptruns.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrunsv.f -ar -ruv ../splib_v2/libsp_8.a sptrunsv.o -r - sptrunsv.o -rm -f sptrunsv.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrunv.f -ar -ruv ../splib_v2/libsp_8.a sptrunv.o -r - sptrunv.o -rm -f sptrunv.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spuv2dz.f -ar -ruv ../splib_v2/libsp_8.a spuv2dz.o -r - spuv2dz.o -rm -f spuv2dz.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spvar.f -ar -ruv ../splib_v2/libsp_8.a spvar.o -r - spvar.o -rm -f spvar.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spwget.f -ar -ruv ../splib_v2/libsp_8.a spwget.o -r - spwget.o -rm -f spwget.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX fftpack.F -ar -ruv ../splib_v2/libsp_8.a fftpack.o -r - fftpack.o -rm -f fftpack.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX lapack_gen.F -ar -ruv ../splib_v2/libsp_8.a lapack_gen.o -r - lapack_gen.o -rm -f lapack_gen.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX ncpus.F -ar -ruv ../splib_v2/libsp_8.a ncpus.o -r - ncpus.o -rm -f ncpus.o -ifort -c -O3 -auto -openmp -i8 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX splat.F -ar -ruv ../splib_v2/libsp_8.a splat.o -r - splat.o -rm -f splat.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spanaly.f -ar -ruv ../splib_v2/libsp_d.a spanaly.o -r - spanaly.o -rm -f spanaly.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spdz2uv.f -ar -ruv ../splib_v2/libsp_d.a spdz2uv.o -r - spdz2uv.o -rm -f spdz2uv.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX speps.f -ar -ruv ../splib_v2/libsp_d.a speps.o -r - speps.o -rm -f speps.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spfft1.f -ar -ruv ../splib_v2/libsp_d.a spfft1.o -r - spfft1.o -rm -f spfft1.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spffte.f -ar -ruv ../splib_v2/libsp_d.a spffte.o -r - spffte.o -rm -f spffte.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spfft.f -ar -ruv ../splib_v2/libsp_d.a spfft.o -r - spfft.o -rm -f spfft.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spfftpt.f -ar -ruv ../splib_v2/libsp_d.a spfftpt.o -r - spfftpt.o -rm -f spfftpt.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spgradq.f -ar -ruv ../splib_v2/libsp_d.a spgradq.o -r - spgradq.o -rm -f spgradq.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spgradx.f -ar -ruv ../splib_v2/libsp_d.a spgradx.o -r - spgradx.o -rm -f spgradx.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spgrady.f -ar -ruv ../splib_v2/libsp_d.a spgrady.o -r - spgrady.o -rm -f spgrady.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX splaplac.f -ar -ruv ../splib_v2/libsp_d.a splaplac.o -r - splaplac.o -rm -f splaplac.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX splegend.f -ar -ruv ../splib_v2/libsp_d.a splegend.o -r - splegend.o -rm -f splegend.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sppad.f -ar -ruv ../splib_v2/libsp_d.a sppad.o -r - sppad.o -rm -f sppad.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spsynth.f -ar -ruv ../splib_v2/libsp_d.a spsynth.o -r - spsynth.o -rm -f spsynth.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptezd.f -ar -ruv ../splib_v2/libsp_d.a sptezd.o -r - sptezd.o -rm -f sptezd.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptez.f -ar -ruv ../splib_v2/libsp_d.a sptez.o -r - sptez.o -rm -f sptez.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptezmd.f -ar -ruv ../splib_v2/libsp_d.a sptezmd.o -r - sptezmd.o -rm -f sptezmd.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptezm.f -ar -ruv ../splib_v2/libsp_d.a sptezm.o -r - sptezm.o -rm -f sptezm.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptezmv.f -ar -ruv ../splib_v2/libsp_d.a sptezmv.o -r - sptezmv.o -rm -f sptezmv.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptezv.f -ar -ruv ../splib_v2/libsp_d.a sptezv.o -r - sptezv.o -rm -f sptezv.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgpmd.f -ar -ruv ../splib_v2/libsp_d.a sptgpmd.o -r - sptgpmd.o -rm -f sptgpmd.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgpm.f -ar -ruv ../splib_v2/libsp_d.a sptgpm.o -r - sptgpm.o -rm -f sptgpm.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgpmv.f -ar -ruv ../splib_v2/libsp_d.a sptgpmv.o -r - sptgpmv.o -rm -f sptgpmv.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgpsd.f -ar -ruv ../splib_v2/libsp_d.a sptgpsd.o -r - sptgpsd.o -rm -f sptgpsd.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgps.f -ar -ruv ../splib_v2/libsp_d.a sptgps.o -r - sptgps.o -rm -f sptgps.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgpsv.f -ar -ruv ../splib_v2/libsp_d.a sptgpsv.o -r - sptgpsv.o -rm -f sptgpsv.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgptd.f -ar -ruv ../splib_v2/libsp_d.a sptgptd.o -r - sptgptd.o -rm -f sptgptd.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgpt.f -ar -ruv ../splib_v2/libsp_d.a sptgpt.o -r - sptgpt.o -rm -f sptgpt.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgptsd.f -ar -ruv ../splib_v2/libsp_d.a sptgptsd.o -r - sptgptsd.o -rm -f sptgptsd.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgptvd.f -ar -ruv ../splib_v2/libsp_d.a sptgptvd.o -r - sptgptvd.o -rm -f sptgptvd.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptgptv.f -ar -ruv ../splib_v2/libsp_d.a sptgptv.o -r - sptgptv.o -rm -f sptgptv.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrand.f -ar -ruv ../splib_v2/libsp_d.a sptrand.o -r - sptrand.o -rm -f sptrand.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptran.f -ar -ruv ../splib_v2/libsp_d.a sptran.o -r - sptran.o -rm -f sptran.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptranf0.f -ar -ruv ../splib_v2/libsp_d.a sptranf0.o -r - sptranf0.o -rm -f sptranf0.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptranf1.f -ar -ruv ../splib_v2/libsp_d.a sptranf1.o -r - sptranf1.o -rm -f sptranf1.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptranf.f -ar -ruv ../splib_v2/libsp_d.a sptranf.o -r - sptranf.o -rm -f sptranf.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptranfv.f -ar -ruv ../splib_v2/libsp_d.a sptranfv.o -r - sptranfv.o -rm -f sptranfv.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptranv.f -ar -ruv ../splib_v2/libsp_d.a sptranv.o -r - sptranv.o -rm -f sptranv.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrund.f -ar -ruv ../splib_v2/libsp_d.a sptrund.o -r - sptrund.o -rm -f sptrund.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrun.f -ar -ruv ../splib_v2/libsp_d.a sptrun.o -r - sptrun.o -rm -f sptrun.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrung.f -ar -ruv ../splib_v2/libsp_d.a sptrung.o -r - sptrung.o -rm -f sptrung.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrungv.f -ar -ruv ../splib_v2/libsp_d.a sptrungv.o -r - sptrungv.o -rm -f sptrungv.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrunl.f -ar -ruv ../splib_v2/libsp_d.a sptrunl.o -r - sptrunl.o -rm -f sptrunl.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrunm.f -ar -ruv ../splib_v2/libsp_d.a sptrunm.o -r - sptrunm.o -rm -f sptrunm.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrunmv.f -ar -ruv ../splib_v2/libsp_d.a sptrunmv.o -r - sptrunmv.o -rm -f sptrunmv.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptruns.f -ar -ruv ../splib_v2/libsp_d.a sptruns.o -r - sptruns.o -rm -f sptruns.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrunsv.f -ar -ruv ../splib_v2/libsp_d.a sptrunsv.o -r - sptrunsv.o -rm -f sptrunsv.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX sptrunv.f -ar -ruv ../splib_v2/libsp_d.a sptrunv.o -r - sptrunv.o -rm -f sptrunv.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spuv2dz.f -ar -ruv ../splib_v2/libsp_d.a spuv2dz.o -r - spuv2dz.o -rm -f spuv2dz.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spvar.f -ar -ruv ../splib_v2/libsp_d.a spvar.o -r - spvar.o -rm -f spvar.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX spwget.f -ar -ruv ../splib_v2/libsp_d.a spwget.o -r - spwget.o -rm -f spwget.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX fftpack.F -ar -ruv ../splib_v2/libsp_d.a fftpack.o -r - fftpack.o -rm -f fftpack.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX lapack_gen.F -ar -ruv ../splib_v2/libsp_d.a lapack_gen.o -r - lapack_gen.o -rm -f lapack_gen.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX ncpus.F -ar -ruv ../splib_v2/libsp_d.a ncpus.o -r - ncpus.o -rm -f ncpus.o -ifort -c -O3 -auto -openmp -i4 -r8 -convert big_endian -assume byterecl -fp-model strict -fpp -DLINUX splat.F -ar -ruv ../splib_v2/libsp_d.a splat.o -r - splat.o -rm -f splat.o diff --git a/external/sp/v2.0.2/src/fftpack.F b/external/sp/v2.0.2/src/fftpack.F deleted file mode 100644 index afc1790c..00000000 --- a/external/sp/v2.0.2/src/fftpack.F +++ /dev/null @@ -1,1091 +0,0 @@ -#if LINUX - SUBROUTINE dcrft(init,x,ldx,y,ldy,n,m,isign,scale, - & table,n1,wrk,n2,z,nz) - - implicit none - integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j - real x(2*ldx,*),y(ldy,*),scale,table(44002),wrk,z - - IF (init.ne.0) THEN - CALL rffti(n,table) - ELSE -!OCL NOVREC - DO j=1,m - y(1,j)=x(1,j) - DO i=2,n - y(i,j)=x(i+1,j) - ENDDO - CALL rfftb(n,y(1,j),table) - DO i=1,n - y(i,j)=scale*y(i,j) - ENDDO - ENDDO - ENDIF - - RETURN - END - - SUBROUTINE scrft(init,x,ldx,y,ldy,n,m,isign,scale, - & table,n1,wrk,n2,z,nz) - - implicit none - integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j - real x(2*ldx,*),y(ldy,*),scale,table(44002),wrk,z - - IF (init.ne.0) THEN - CALL rffti(n,table) - ELSE -!OCL NOVREC - DO j=1,m - y(1,j)=x(1,j) - DO i=2,n - y(i,j)=x(i+1,j) - ENDDO - CALL rfftb(n,y(1,j),table) - DO i=1,n - y(i,j)=scale*y(i,j) - ENDDO - ENDDO - ENDIF - - RETURN - END -c -c*********************************************************************** -c - SUBROUTINE csfft(isign,n,scale,x,y,table,work,isys) - - implicit none - integer isign,n,isys,i - real scale,x(*),y(*),table(*),work(*) - - IF (isign.eq.0) THEN - CALL rffti(n,table) - ENDIF - IF (isign.eq.1) THEN - y(1)=x(1) - DO i=2,n - y(i)=x(i+1) - ENDDO - CALL rfftb(n,y,table) - DO i=1,n - y(i)=scale*y(i) - ENDDO - ENDIF - - RETURN - END -c -c*********************************************************************** -c - SUBROUTINE drcft(init,x,ldx,y,ldy,n,m,isign,scale, - & table,n1,wrk,n2,z,nz) - - implicit none - integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j - real x(ldx,*),y(2*ldy,*),scale,table(44002),wrk,z - - IF (init.ne.0) THEN - CALL rffti(n,table) - ELSE - DO j=1,m - DO i=1,n - y(i,j)=x(i,j) - ENDDO - CALL rfftf(n,y(1,j),table) - DO i=1,n - y(i,j)=scale*y(i,j) - ENDDO - DO i=n,2,-1 - y(i+1,j)=y(i,j) - ENDDO - y(2,j)=0. -C 01/17/2013 vvvvvvvvvvvvv E.Mirvis added ver 2.0.1 by S.Moorthi request. No +|- demo. - y(n+2,j) = 0. - ENDDO - ENDIF - - RETURN - END - - SUBROUTINE srcft(init,x,ldx,y,ldy,n,m,isign,scale, - & table,n1,wrk,n2,z,nz) - - implicit none - integer init,ldx,ldy,n,m,isign,n1,n2,nz,i,j - real x(ldx,*),y(2*ldy,*),scale,table(44002),wrk,z - - IF (init.ne.0) THEN - CALL rffti(n,table) - ELSE - DO j=1,m - DO i=1,n - y(i,j)=x(i,j) - ENDDO - CALL rfftf(n,y(1,j),table) - DO i=1,n - y(i,j)=scale*y(i,j) - ENDDO - DO i=n,2,-1 - y(i+1,j)=y(i,j) - ENDDO - y(2,j)=0. - y(n+2,j) = 0. -C 01/17/2013 ^^^^^^^^^^E.Mirvis added ver 2.0.1 by S.Moorthi request. No +|- demo. - ENDDO - ENDIF - - RETURN - END -c -c*********************************************************************** -c - SUBROUTINE scfft(isign,n,scale,x,y,table,work,isys) - - implicit none - integer isign,n,isys,i - real scale,x(*),y(*),table(*),work(*) - - IF (isign.eq.0) THEN - CALL rffti(n,table) - ENDIF - IF (isign.eq.-1) THEN - DO i=1,n - y(i)=x(i) - ENDDO - CALL rfftf(n,y,table) - DO i=1,n - y(i)=scale*y(i) - ENDDO - DO i=n,2,-1 - y(i+1)=y(i) - ENDDO - y(2)=0. - ENDIF - - RETURN - END -c -c ****************************************************************** -c ****************************************************************** -c ****** ****** -c ****** FFTPACK ****** -c ****** ****** -c ****************************************************************** -c ****************************************************************** -c - SUBROUTINE RFFTF (N,R,WSAVE) - DIMENSION R(1) ,WSAVE(1) - IF (N .EQ. 1) RETURN - CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END - SUBROUTINE RFFTB (N,R,WSAVE) - DIMENSION R(1) ,WSAVE(1) - IF (N .EQ. 1) RETURN - CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END - SUBROUTINE RFFTI (N,WSAVE) - DIMENSION WSAVE(1) - IF (N .EQ. 1) RETURN - CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1)) - RETURN - END - SUBROUTINE RFFTB1 (N,C,CH,WA,IFAC) - DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(*) - NF = IFAC(2) - NA = 0 - L1 = 1 - IW = 1 - DO 116 K1=1,NF - IP = IFAC(K1+2) - L2 = IP*L1 - IDO = N/L2 - IDL1 = IDO*L1 - IF (IP .NE. 4) GO TO 103 - IX2 = IW+IDO - IX3 = IX2+IDO - IF (NA .NE. 0) GO TO 101 - CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 102 - 101 CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - 102 NA = 1-NA - GO TO 115 - 103 IF (IP .NE. 2) GO TO 106 - IF (NA .NE. 0) GO TO 104 - CALL RADB2 (IDO,L1,C,CH,WA(IW)) - GO TO 105 - 104 CALL RADB2 (IDO,L1,CH,C,WA(IW)) - 105 NA = 1-NA - GO TO 115 - 106 IF (IP .NE. 3) GO TO 109 - IX2 = IW+IDO - IF (NA .NE. 0) GO TO 107 - CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2)) - GO TO 108 - 107 CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2)) - 108 NA = 1-NA - GO TO 115 - 109 IF (IP .NE. 5) GO TO 112 - IX2 = IW+IDO - IX3 = IX2+IDO - IX4 = IX3+IDO - IF (NA .NE. 0) GO TO 110 - CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 111 - 110 CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - 111 NA = 1-NA - GO TO 115 - 112 IF (NA .NE. 0) GO TO 113 - CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - GO TO 114 - 113 CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - 114 IF (IDO .EQ. 1) NA = 1-NA - 115 L1 = L2 - IW = IW+(IP-1)*IDO - 116 CONTINUE - IF (NA .EQ. 0) RETURN - DO 117 I=1,N - C(I) = CH(I) - 117 CONTINUE - RETURN - END - - - SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC) - DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(*) - NF = IFAC(2) - NA = 1 - L2 = N - IW = N - DO 111 K1=1,NF - KH = NF-K1 - IP = IFAC(KH+3) - L1 = L2/IP - IDO = N/L2 - IDL1 = IDO*L1 - IW = IW-(IP-1)*IDO - NA = 1-NA - IF (IP .NE. 4) GO TO 102 - IX2 = IW+IDO - IX3 = IX2+IDO - IF (NA .NE. 0) GO TO 101 - CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 110 - 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - GO TO 110 - 102 IF (IP .NE. 2) GO TO 104 - IF (NA .NE. 0) GO TO 103 - CALL RADF2 (IDO,L1,C,CH,WA(IW)) - GO TO 110 - 103 CALL RADF2 (IDO,L1,CH,C,WA(IW)) - GO TO 110 - 104 IF (IP .NE. 3) GO TO 106 - IX2 = IW+IDO - IF (NA .NE. 0) GO TO 105 - CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) - GO TO 110 - 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) - GO TO 110 - 106 IF (IP .NE. 5) GO TO 108 - IX2 = IW+IDO - IX3 = IX2+IDO - IX4 = IX3+IDO - IF (NA .NE. 0) GO TO 107 - CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 110 - 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 110 - 108 IF (IDO .EQ. 1) NA = 1-NA - IF (NA .NE. 0) GO TO 109 - CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - NA = 1 - GO TO 110 - 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - NA = 0 - 110 L2 = L1 - 111 CONTINUE - IF (NA .EQ. 1) RETURN - DO 112 I=1,N - C(I) = CH(I) - 112 CONTINUE - RETURN - END - - - SUBROUTINE RFFTI1 (N,WA,IFAC) - DIMENSION WA(1) ,IFAC(*) ,NTRYH(4) - DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ - NL = N - NF = 0 - J = 0 - 101 J = J+1 - IF (J-4) 102,102,103 - 102 NTRY = NTRYH(J) - GO TO 104 - 103 NTRY = NTRY+2 - 104 NQ = NL/NTRY - NR = NL-NTRY*NQ - IF (NR) 101,105,101 - 105 NF = NF+1 - IFAC(NF+2) = NTRY - NL = NQ - IF (NTRY .NE. 2) GO TO 107 - IF (NF .EQ. 1) GO TO 107 - DO 106 I=2,NF - IB = NF-I+2 - IFAC(IB+2) = IFAC(IB+1) - 106 CONTINUE - IFAC(3) = 2 - 107 IF (NL .NE. 1) GO TO 104 - IFAC(1) = N - IFAC(2) = NF - TPI = 6.28318530717959 - ARGH = TPI/FLOAT(N) - IS = 0 - NFM1 = NF-1 - L1 = 1 - IF (NFM1 .EQ. 0) RETURN -!OCL NOVREC - DO 110 K1=1,NFM1 - IP = IFAC(K1+2) - LD = 0 - L2 = L1*IP - IDO = N/L2 - IPM = IP-1 - DO 109 J=1,IPM - LD = LD+L1 - I = IS - ARGLD = FLOAT(LD)*ARGH - FI = 0 -!OCL SCALAR - DO 108 II=3,IDO,2 - I = I+2 - FI = FI+1 - ARG = FI*ARGLD - WA(I-1) = COS(ARG) - WA(I) = SIN(ARG) - 108 CONTINUE - IS = IS+IDO - 109 CONTINUE - L1 = L2 - 110 CONTINUE - RETURN - END - - - SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1) - DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,2) , - 1 WA1(1) - DO 101 K=1,L1 - CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) - CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 -!OCL NOVREC - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) - TR2 = CC(I-1,1,K)-CC(IC-1,2,K) - CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) - TI2 = CC(I,1,K)+CC(IC,2,K) - CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 - CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) - CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) - 106 CONTINUE - 107 RETURN - END - - - SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2) - DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,3) , - 1 WA1(1) ,WA2(1) - DATA TAUR,TAUI /-.5,.866025403784439/ - DO 101 K=1,L1 - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - CR2 = CC(1,1,K)+TAUR*TR2 - CH(1,K,1) = CC(1,1,K)+TR2 - CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) - CH(1,K,2) = CR2-CI3 - CH(1,K,3) = CR2+CI3 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 -!OCL NOVREC - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - CR2 = CC(I-1,1,K)+TAUR*TR2 - CH(I-1,K,1) = CC(I-1,1,K)+TR2 - TI2 = CC(I,3,K)-CC(IC,2,K) - CI2 = CC(I,1,K)+TAUR*TI2 - CH(I,K,1) = CC(I,1,K)+TI2 - CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) - CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) - DR2 = CR2-CI3 - DR3 = CR2+CI3 - DI2 = CI2+CR3 - DI3 = CI2-CR3 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - 102 CONTINUE - 103 CONTINUE - RETURN - END - - - SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3) - DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) , - 1 WA1(1) ,WA2(1) ,WA3(1) - DATA SQRT2 /1.414213562373095/ - DO 101 K=1,L1 - TR1 = CC(1,1,K)-CC(IDO,4,K) - TR2 = CC(1,1,K)+CC(IDO,4,K) - TR3 = CC(IDO,2,K)+CC(IDO,2,K) - TR4 = CC(1,3,K)+CC(1,3,K) - CH(1,K,1) = TR2+TR3 - CH(1,K,2) = TR1-TR4 - CH(1,K,3) = TR2-TR3 - CH(1,K,4) = TR1+TR4 - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 -!OCL NOVREC - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - TI1 = CC(I,1,K)+CC(IC,4,K) - TI2 = CC(I,1,K)-CC(IC,4,K) - TI3 = CC(I,3,K)-CC(IC,2,K) - TR4 = CC(I,3,K)+CC(IC,2,K) - TR1 = CC(I-1,1,K)-CC(IC-1,4,K) - TR2 = CC(I-1,1,K)+CC(IC-1,4,K) - TI4 = CC(I-1,3,K)-CC(IC-1,2,K) - TR3 = CC(I-1,3,K)+CC(IC-1,2,K) - CH(I-1,K,1) = TR2+TR3 - CR3 = TR2-TR3 - CH(I,K,1) = TI2+TI3 - CI3 = TI2-TI3 - CR2 = TR1-TR4 - CR4 = TR1+TR4 - CI2 = TI1+TI4 - CI4 = TI1-TI4 - CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 - CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 - CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 - CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 - CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 - CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 CONTINUE - DO 106 K=1,L1 - TI1 = CC(1,2,K)+CC(1,4,K) - TI2 = CC(1,4,K)-CC(1,2,K) - TR1 = CC(IDO,1,K)-CC(IDO,3,K) - TR2 = CC(IDO,1,K)+CC(IDO,3,K) - CH(IDO,K,1) = TR2+TR2 - CH(IDO,K,2) = SQRT2*(TR1-TI1) - CH(IDO,K,3) = TI2+TI2 - CH(IDO,K,4) = -SQRT2*(TR1+TI1) - 106 CONTINUE - 107 RETURN - END - - - SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,5) , - 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) - DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, - 1-.809016994374947,.587785252292473/ - DO 101 K=1,L1 - TI5 = CC(1,3,K)+CC(1,3,K) - TI4 = CC(1,5,K)+CC(1,5,K) - TR2 = CC(IDO,2,K)+CC(IDO,2,K) - TR3 = CC(IDO,4,K)+CC(IDO,4,K) - CH(1,K,1) = CC(1,1,K)+TR2+TR3 - CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 - CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 - CI5 = TI11*TI5+TI12*TI4 - CI4 = TI12*TI5-TI11*TI4 - CH(1,K,2) = CR2-CI5 - CH(1,K,3) = CR3-CI4 - CH(1,K,4) = CR3+CI4 - CH(1,K,5) = CR2+CI5 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - TI5 = CC(I,3,K)+CC(IC,2,K) - TI2 = CC(I,3,K)-CC(IC,2,K) - TI4 = CC(I,5,K)+CC(IC,4,K) - TI3 = CC(I,5,K)-CC(IC,4,K) - TR5 = CC(I-1,3,K)-CC(IC-1,2,K) - TR2 = CC(I-1,3,K)+CC(IC-1,2,K) - TR4 = CC(I-1,5,K)-CC(IC-1,4,K) - TR3 = CC(I-1,5,K)+CC(IC-1,4,K) - CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 - CH(I,K,1) = CC(I,1,K)+TI2+TI3 - CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 - CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 - CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 - CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 - CR5 = TI11*TR5+TI12*TR4 - CI5 = TI11*TI5+TI12*TI4 - CR4 = TI12*TR5-TI11*TR4 - CI4 = TI12*TI5-TI11*TI4 - DR3 = CR3-CI4 - DR4 = CR3+CI4 - DI3 = CI3+CR4 - DI4 = CI3-CR4 - DR5 = CR2+CI5 - DR2 = CR2-CI5 - DI5 = CI2-CR5 - DI2 = CI2+CR5 - CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 - CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 - CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 - CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 - CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 - CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 - CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 - CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 - 102 CONTINUE - 103 CONTINUE - RETURN - END - - - SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , - 1 C1(IDO,L1,IP) ,C2(IDL1,IP), - 2 CH2(IDL1,IP) ,WA(1) - DATA TPI/6.28318530717959/ - ARG = TPI/FLOAT(IP) - DCP = COS(ARG) - DSP = SIN(ARG) - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IPP2 = IP+2 - IPPH = (IP+1)/2 - IF (IDO .LT. L1) GO TO 103 - DO 102 K=1,L1 - DO 101 I=1,IDO - CH(I,K,1) = CC(I,1,K) - 101 CONTINUE - 102 CONTINUE - GO TO 106 - 103 DO 105 I=1,IDO - DO 104 K=1,L1 - CH(I,K,1) = CC(I,1,K) - 104 CONTINUE - 105 CONTINUE -!OCL NOVREC - 106 DO 108 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 107 K=1,L1 - CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) - CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) - 107 CONTINUE - 108 CONTINUE - IF (IDO .EQ. 1) GO TO 116 - IF (NBD .LT. L1) GO TO 112 -!OCL NOVREC - DO 111 J=2,IPPH - JC = IPP2-J - DO 110 K=1,L1 - DO 109 I=3,IDO,2 - IC = IDP2-I - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 109 CONTINUE - 110 CONTINUE - 111 CONTINUE - GO TO 116 - 112 DO 115 J=2,IPPH - JC = IPP2-J - DO 114 I=3,IDO,2 - IC = IDP2-I - DO 113 K=1,L1 - CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) - CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) - CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) - CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) - 113 CONTINUE - 114 CONTINUE - 115 CONTINUE - 116 AR1 = 1. - AI1 = 0. -!OCL NOVREC - DO 120 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 117 IK=1,IDL1 - C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) - C2(IK,LC) = AI1*CH2(IK,IP) - 117 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 -!OCL NOVREC - DO 119 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 118 IK=1,IDL1 - C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) - C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) - 118 CONTINUE - 119 CONTINUE - 120 CONTINUE -!OCL NOVREC - DO 122 J=2,IPPH - DO 121 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+CH2(IK,J) - 121 CONTINUE - 122 CONTINUE -!OCL NOVREC - DO 124 J=2,IPPH - JC = IPP2-J - DO 123 K=1,L1 - CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) - CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) - 123 CONTINUE - 124 CONTINUE - IF (IDO .EQ. 1) GO TO 132 - IF (NBD .LT. L1) GO TO 128 -!OCL NOVREC - DO 127 J=2,IPPH - JC = IPP2-J - DO 126 K=1,L1 - DO 125 I=3,IDO,2 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - GO TO 132 - 128 DO 131 J=2,IPPH - JC = IPP2-J - DO 130 I=3,IDO,2 - DO 129 K=1,L1 - CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) - CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) - CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) - CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) - 129 CONTINUE - 130 CONTINUE - 131 CONTINUE - 132 CONTINUE - IF (IDO .EQ. 1) RETURN - DO 133 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 133 CONTINUE - DO 135 J=2,IP - DO 134 K=1,L1 - C1(1,K,J) = CH(1,K,J) - 134 CONTINUE - 135 CONTINUE - IF (NBD .GT. L1) GO TO 139 - IS = -IDO - DO 138 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 137 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 136 K=1,L1 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 136 CONTINUE - 137 CONTINUE - 138 CONTINUE - GO TO 143 - 139 IS = -IDO -!OCL NOVREC - DO 142 J=2,IP - IS = IS+IDO - DO 141 K=1,L1 - IDIJ = IS - DO 140 I=3,IDO,2 - IDIJ = IDIJ+2 - C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) - C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) - 140 CONTINUE - 141 CONTINUE - 142 CONTINUE - 143 RETURN - END - - - SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1) - DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) , - 1 WA1(1) - DO 101 K=1,L1 - CH(1,1,K) = CC(1,K,1)+CC(1,K,2) - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CH(I,1,K) = CC(I,K,1)+TI2 - CH(IC,2,K) = TI2-CC(I,K,1) - CH(I-1,1,K) = CC(I-1,K,1)+TR2 - CH(IC-1,2,K) = CC(I-1,K,1)-TR2 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(1,2,K) = -CC(IDO,K,2) - CH(IDO,1,K) = CC(IDO,K,1) - 106 CONTINUE - 107 RETURN - END - - - SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2) - DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) , - 1 WA1(1) ,WA2(1) - DATA TAUR,TAUI /-.5,.866025403784439/ - DO 101 K=1,L1 - CR2 = CC(1,K,2)+CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2 - CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) - CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR2 = DR2+DR3 - CI2 = DI2+DI3 - CH(I-1,1,K) = CC(I-1,K,1)+CR2 - CH(I,1,K) = CC(I,K,1)+CI2 - TR2 = CC(I-1,K,1)+TAUR*CR2 - TI2 = CC(I,K,1)+TAUR*CI2 - TR3 = TAUI*(DI2-DI3) - TI3 = TAUI*(DR3-DR2) - CH(I-1,3,K) = TR2+TR3 - CH(IC-1,2,K) = TR2-TR3 - CH(I,3,K) = TI2+TI3 - CH(IC,2,K) = TI3-TI2 - 102 CONTINUE - 103 CONTINUE - RETURN - END - SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) - DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) , - 1 WA1(1) ,WA2(1) ,WA3(1) - DATA HSQT2 /.7071067811865475/ - DO 101 K=1,L1 - TR1 = CC(1,K,2)+CC(1,K,4) - TR2 = CC(1,K,1)+CC(1,K,3) - CH(1,1,K) = TR1+TR2 - CH(IDO,4,K) = TR2-TR1 - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) - CH(1,3,K) = CC(1,K,4)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 -!OCL NOVREC - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - TR1 = CR2+CR4 - TR4 = CR4-CR2 - TI1 = CI2+CI4 - TI4 = CI2-CI4 - TI2 = CC(I,K,1)+CI3 - TI3 = CC(I,K,1)-CI3 - TR2 = CC(I-1,K,1)+CR3 - TR3 = CC(I-1,K,1)-CR3 - CH(I-1,1,K) = TR1+TR2 - CH(IC-1,4,K) = TR2-TR1 - CH(I,1,K) = TI1+TI2 - CH(IC,4,K) = TI1-TI2 - CH(I-1,3,K) = TI4+TR3 - CH(IC-1,2,K) = TR3-TI4 - CH(I,3,K) = TR4+TI3 - CH(IC,2,K) = TR4-TI3 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 CONTINUE - DO 106 K=1,L1 - TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) - TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) - CH(IDO,1,K) = TR1+CC(IDO,K,1) - CH(IDO,3,K) = CC(IDO,K,1)-TR1 - CH(1,2,K) = TI1-CC(IDO,K,3) - CH(1,4,K) = TI1+CC(IDO,K,3) - 106 CONTINUE - 107 RETURN - END - - - SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) , - 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) - DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, - 1-.809016994374947,.587785252292473/ - DO 101 K=1,L1 - CR2 = CC(1,K,5)+CC(1,K,2) - CI5 = CC(1,K,5)-CC(1,K,2) - CR3 = CC(1,K,4)+CC(1,K,3) - CI4 = CC(1,K,4)-CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2+CR3 - CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 - CH(1,3,K) = TI11*CI5+TI12*CI4 - CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 - CH(1,5,K) = TI12*CI5-TI11*CI4 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) - DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) - CR2 = DR2+DR5 - CI5 = DR5-DR2 - CR5 = DI2-DI5 - CI2 = DI2+DI5 - CR3 = DR3+DR4 - CI4 = DR4-DR3 - CR4 = DI3-DI4 - CI3 = DI3+DI4 - CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 - CH(I,1,K) = CC(I,K,1)+CI2+CI3 - TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 - TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 - TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 - TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 - TR5 = TI11*CR5+TI12*CR4 - TI5 = TI11*CI5+TI12*CI4 - TR4 = TI12*CR5-TI11*CR4 - TI4 = TI12*CI5-TI11*CI4 - CH(I-1,3,K) = TR2+TR5 - CH(IC-1,2,K) = TR2-TR5 - CH(I,3,K) = TI2+TI5 - CH(IC,2,K) = TI5-TI2 - CH(I-1,5,K) = TR3+TR4 - CH(IC-1,4,K) = TR3-TR4 - CH(I,5,K) = TI3+TI4 - CH(IC,4,K) = TI4-TI3 - 102 CONTINUE - 103 CONTINUE - RETURN - END - - - SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , - 1 C1(IDO,L1,IP) ,C2(IDL1,IP), - 2 CH2(IDL1,IP) ,WA(1) - DATA TPI/6.28318530717959/ - ARG = TPI/FLOAT(IP) - DCP = COS(ARG) - DSP = SIN(ARG) - IPPH = (IP+1)/2 - IPP2 = IP+2 - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IF (IDO .EQ. 1) GO TO 119 - DO 101 IK=1,IDL1 - CH2(IK,1) = C2(IK,1) - 101 CONTINUE - DO 103 J=2,IP - DO 102 K=1,L1 - CH(1,K,J) = C1(1,K,J) - 102 CONTINUE - 103 CONTINUE - IF (NBD .GT. L1) GO TO 107 - IS = -IDO - DO 106 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 105 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 104 K=1,L1 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 104 CONTINUE - 105 CONTINUE - 106 CONTINUE - GO TO 111 - 107 IS = -IDO - DO 110 J=2,IP - IS = IS+IDO - DO 109 K=1,L1 - IDIJ = IS - DO 108 I=3,IDO,2 - IDIJ = IDIJ+2 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 108 CONTINUE - 109 CONTINUE - 110 CONTINUE - 111 IF (NBD .LT. L1) GO TO 115 - DO 114 J=2,IPPH - JC = IPP2-J - DO 113 K=1,L1 - DO 112 I=3,IDO,2 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 112 CONTINUE - 113 CONTINUE - 114 CONTINUE - GO TO 121 - 115 DO 118 J=2,IPPH - JC = IPP2-J - DO 117 I=3,IDO,2 - DO 116 K=1,L1 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 116 CONTINUE - 117 CONTINUE - 118 CONTINUE - GO TO 121 - 119 DO 120 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 120 CONTINUE - 121 DO 123 J=2,IPPH - JC = IPP2-J - DO 122 K=1,L1 - C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) - C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) - 122 CONTINUE - 123 CONTINUE -C - AR1 = 1. - AI1 = 0. - DO 127 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 124 IK=1,IDL1 - CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) - CH2(IK,LC) = AI1*C2(IK,IP) - 124 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 - DO 126 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 125 IK=1,IDL1 - CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) - CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - DO 129 J=2,IPPH - DO 128 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+C2(IK,J) - 128 CONTINUE - 129 CONTINUE -C - IF (IDO .LT. L1) GO TO 132 - DO 131 K=1,L1 - DO 130 I=1,IDO - CC(I,1,K) = CH(I,K,1) - 130 CONTINUE - 131 CONTINUE - GO TO 135 - 132 DO 134 I=1,IDO - DO 133 K=1,L1 - CC(I,1,K) = CH(I,K,1) - 133 CONTINUE - 134 CONTINUE - 135 DO 137 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 136 K=1,L1 - CC(IDO,J2-2,K) = CH(1,K,J) - CC(1,J2-1,K) = CH(1,K,JC) - 136 CONTINUE - 137 CONTINUE - IF (IDO .EQ. 1) RETURN - IF (NBD .LT. L1) GO TO 141 - DO 140 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 139 K=1,L1 - DO 138 I=3,IDO,2 - IC = IDP2-I - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 138 CONTINUE - 139 CONTINUE - 140 CONTINUE - RETURN - 141 DO 144 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 143 I=3,IDO,2 - IC = IDP2-I - DO 142 K=1,L1 - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 142 CONTINUE - 143 CONTINUE - 144 CONTINUE - RETURN - END - -#endif diff --git a/external/sp/v2.0.2/src/lapack_gen.F b/external/sp/v2.0.2/src/lapack_gen.F deleted file mode 100644 index 3f550f9b..00000000 --- a/external/sp/v2.0.2/src/lapack_gen.F +++ /dev/null @@ -1,105 +0,0 @@ -#if LINUX -!---------------------------------------------------------------------- -! From Numerical Recipes -! added two Numerical Recipes routines for matrix inversion -! LUBKSB - solves a system of linear equations, follows call to LUDCMP -! LUDCMP - replaces an NxN matrix a with the LU decomposition -! -! 2012-11-05 E.Mirvis separated this generic LU from the splat.F -!---------------------------------------------------------------------- - SUBROUTINE LUBKSB(A,N,NP,INDX,B) - REAL A(NP,NP),B(N) - INTEGER INDX(N) - II=0 - DO 12 I=1,N - LL=INDX(I) - SUM=B(LL) - B(LL)=B(I) - IF (II.NE.0)THEN - DO 11 J=II,I-1 - SUM=SUM-A(I,J)*B(J) - 11 CONTINUE - ELSE IF (SUM.NE.0.) THEN - II=I - ENDIF - B(I)=SUM - 12 CONTINUE - DO 14 I=N,1,-1 - SUM=B(I) - IF(I.LT.N)THEN - DO 13 J=I+1,N - SUM=SUM-A(I,J)*B(J) - 13 CONTINUE - ENDIF - B(I)=SUM/A(I,I) - 14 CONTINUE - RETURN - END - - SUBROUTINE LUDCMP(A,N,NP,INDX) -C PARAMETER (NMAX=400,TINY=1.0E-20) - PARAMETER (TINY=1.0E-20) -C==EM==^^^ -C - REAL A(NP,NP),VV(N),D -C REAL A(NP,NP),VV(NMAX),D -C==EM==^^^ - INTEGER INDX(N) - D=1. - DO 12 I=1,N - AAMAX=0. - DO 11 J=1,N - IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J)) - 11 CONTINUE - IF (AAMAX.EQ.0.) print *, 'SINGULAR MATRIX.' - VV(I)=1./AAMAX - 12 CONTINUE - DO 19 J=1,N - IF (J.GT.1) THEN - DO 14 I=1,J-1 - SUM=A(I,J) - IF (I.GT.1)THEN - DO 13 K=1,I-1 - SUM=SUM-A(I,K)*A(K,J) - 13 CONTINUE - A(I,J)=SUM - ENDIF - 14 CONTINUE - ENDIF - AAMAX=0. - DO 16 I=J,N - SUM=A(I,J) - IF (J.GT.1)THEN - DO 15 K=1,J-1 - SUM=SUM-A(I,K)*A(K,J) - 15 CONTINUE - A(I,J)=SUM - ENDIF - DUM=VV(I)*ABS(SUM) - IF (DUM.GE.AAMAX) THEN - IMAX=I - AAMAX=DUM - ENDIF - 16 CONTINUE - IF (J.NE.IMAX)THEN - DO 17 K=1,N - DUM=A(IMAX,K) - A(IMAX,K)=A(J,K) - A(J,K)=DUM - 17 CONTINUE - D=-D - VV(IMAX)=VV(J) - ENDIF - INDX(J)=IMAX - IF(J.NE.N)THEN - IF(A(J,J).EQ.0.)A(J,J)=TINY - DUM=1./A(J,J) - DO 18 I=J+1,N - A(I,J)=A(I,J)*DUM - 18 CONTINUE - ENDIF - 19 CONTINUE - IF(A(N,N).EQ.0.)A(N,N)=TINY - RETURN - END -#endif diff --git a/external/sp/v2.0.2/src/ncpus.F b/external/sp/v2.0.2/src/ncpus.F deleted file mode 100644 index 4ff8ee0d..00000000 --- a/external/sp/v2.0.2/src/ncpus.F +++ /dev/null @@ -1,46 +0,0 @@ -C----------------------------------------------------------------------- - FUNCTION NCPUS() -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: NCPUS SET NUMBER OF CPUS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-08-19 -C -C ABSTRACT: SET NUMBER OF CPUS -C DESIGNATING THE NUMBER OF PROCESSORS OVER WHICH TO PARALLELIZE. -C -C PROGRAM HISTORY LOG: -C 94-08-19 IREDELL -C 98-11-09 VUONG ADD DOC BLOCK AND REMOVE CRAY REFERENCES -C 1998-12-18 IREDELL IBM SMP VERSION -C 2010-11-16 SLOVACEK LINUX MUST HAVE DIFFERENT CALL -C 2012-11-01 MIRVIS Multi- threading on LINUX-IBM/TIDE -C -C USAGE: NC=NCPUS() -C OUTPUT ARGUMENTS: -C NCPUS INTEGER NUMBER OF CPUS -C -C SUBPROGRAMS CALLED: -C NUM_PARTHDS XLF INTRINSIC TO RETURN NUMBER OF THREADSRTHDS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN -C -C$$$ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - INTEGER NTHREADS, TID, OMP_GET_NUM_THREADS,OMP_GET_THREAD_NUM -C Obtain thread number -#ifdef LINUX -!$OMP PARALLEL PRIVATE(TID) - TID = OMP_GET_THREAD_NUM() -! PRINT *, '...............thread # ', TID - if (TID. eq. 0) then - NCPUS=OMP_GET_NUM_THREADS() -! PRINT *, 'totaly #------------------- of threads = ',NCPUS - endif -!$OMP END PARALLEL -#else - NCPUS=NUM_PARTHDS() -#endif - - RETURN - END diff --git a/external/sp/v2.0.2/src/spanaly.f b/external/sp/v2.0.2/src/spanaly.f deleted file mode 100644 index 6a58d111..00000000 --- a/external/sp/v2.0.2/src/spanaly.f +++ /dev/null @@ -1,89 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPANALY(I,M,IM,IX,NC,NCTOP,KM,WGT,CLAT,PLN,PLNTOP,MP, - & F,SPC,SPCTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPANALY ANALYZE SPECTRAL FROM FOURIER -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: ANALYZES SPECTRAL COEFFICIENTS FROM FOURIER COEFFICIENTS -C FOR A LATITUDE PAIR (NORTHERN AND SOUTHERN HEMISPHERES). -C VECTOR COMPONENTS ARE MULTIPLIED BY COSINE OF LATITUDE. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C 94-08-01 MARK IREDELL MOVED ZONAL WAVENUMBER LOOP INSIDE -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPANALY(I,M,IM,IX,NC,NCTOP,KM,WGT,CLAT,PLN,PLNTOP,MP, -C & F,SPC,SPCTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C IM - INTEGER EVEN NUMBER OF FOURIER COEFFICIENTS -C IX - INTEGER DIMENSION OF FOURIER COEFFICIENTS (IX>=IM+2) -C NC - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS -C (NC>=(M+1)*((I+1)*M+2)) -C NCTOP - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS OVER TOP -C (NCTOP>=2*(M+1)) -C KM - INTEGER NUMBER OF FIELDS -C WGT - REAL GAUSSIAN WEIGHT -C CLAT - REAL COSINE OF LATITUDE -C PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIALS -C PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP -C MP - INTEGER (KM) IDENTIFIERS (0 FOR SCALAR, 1 FOR VECTOR) -C F - REAL (IX,2,KM) FOURIER COEFFICIENTS COMBINED -C SPC - REAL (NC,KM) SPECTRAL COEFFICIENTS -C SPCTOP - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP -C -C OUTPUT ARGUMENT LIST: -C SPC - REAL (NC,KM) SPECTRAL COEFFICIENTS -C SPCTOP - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - INTEGER MP(KM) - REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1) - REAL F(IX,2,KM) - REAL SPC(NC,KM),SPCTOP(NCTOP,KM) - REAL FW(2,2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FOR EACH ZONAL WAVENUMBER, ANALYZE TERMS OVER TOTAL WAVENUMBER. -C ANALYZE EVEN AND ODD POLYNOMIALS SEPARATELY. - LX=MIN(M,IM/2) -!C$OMP PARALLEL DO PRIVATE(L,NT,KS,KP,FW) - DO K=1,KM - DO L=0,LX - NT=MOD(M+1+(I-1)*L,2)+1 - KS=L*(2*M+(I-1)*(L-1)) - KP=KS/2+1 - IF(MP(K).EQ.0) THEN - FW(1,1)=WGT*(F(2*L+1,1,K)+F(2*L+1,2,K)) - FW(2,1)=WGT*(F(2*L+2,1,K)+F(2*L+2,2,K)) - FW(1,2)=WGT*(F(2*L+1,1,K)-F(2*L+1,2,K)) - FW(2,2)=WGT*(F(2*L+2,1,K)-F(2*L+2,2,K)) - ELSE - FW(1,1)=WGT*CLAT*(F(2*L+1,1,K)+F(2*L+1,2,K)) - FW(2,1)=WGT*CLAT*(F(2*L+2,1,K)+F(2*L+2,2,K)) - FW(1,2)=WGT*CLAT*(F(2*L+1,1,K)-F(2*L+1,2,K)) - FW(2,2)=WGT*CLAT*(F(2*L+2,1,K)-F(2*L+2,2,K)) - SPCTOP(2*L+1,K)=SPCTOP(2*L+1,K)+PLNTOP(L+1)*FW(1,NT) - SPCTOP(2*L+2,K)=SPCTOP(2*L+2,K)+PLNTOP(L+1)*FW(2,NT) - ENDIF - DO N=L,I*L+M,2 - SPC(KS+2*N+1,K)=SPC(KS+2*N+1,K)+PLN(KP+N)*FW(1,1) - SPC(KS+2*N+2,K)=SPC(KS+2*N+2,K)+PLN(KP+N)*FW(2,1) - ENDDO - DO N=L+1,I*L+M,2 - SPC(KS+2*N+1,K)=SPC(KS+2*N+1,K)+PLN(KP+N)*FW(1,2) - SPC(KS+2*N+2,K)=SPC(KS+2*N+2,K)+PLN(KP+N)*FW(2,2) - ENDDO - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/sp/v2.0.2/src/spdz2uv.f b/external/sp/v2.0.2/src/spdz2uv.f deleted file mode 100644 index 2ec5796a..00000000 --- a/external/sp/v2.0.2/src/spdz2uv.f +++ /dev/null @@ -1,85 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPDZ2UV(I,M,ENN1,ELONN1,EON,EONTOP,D,Z,U,V,UTOP,VTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE WIND COMPONENTS FROM DIVERGENCE AND VORTICITY -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE ZONAL WIND COMPONENT U IS COMPUTED AS -C U(L,N)=-I*L/(N*(N+1))*A*D(L,N) -C +EPS(L,N+1)/(N+1)*A*Z(L,N+1)-EPS(L,N)/N*A*Z(L,N-1) -C AND THE MERIDIONAL WIND COMPONENT V IS COMPUTED AS -C V(L,N)=-I*L/(N*(N+1))*A*Z(L,N) -C -EPS(L,N+1)/(N+1)*A*D(L,N+1)+EPS(L,N)/N*A*D(L,N-1) -C WHERE D IS DIVERGENCE AND Z IS VORTICITY. -C U AND V ARE WEIGHTED BY THE COSINE OF LATITUDE. -C EXTRA TERMS ARE COMPUTED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPDZ2UV(I,M,ENN1,ELONN1,EON,EONTOP,D,Z,U,V,UTOP,VTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C D - REAL ((M+1)*((I+1)*M+2)) DIVERGENCE -C Z - REAL ((M+1)*((I+1)*M+2)) VORTICITY -C -C OUTPUT ARGUMENT LIST: -C U - REAL ((M+1)*((I+1)*M+2)) ZONAL WIND (TIMES COSLAT) -C V - REAL ((M+1)*((I+1)*M+2)) MERID WIND (TIMES COSLAT) -C UTOP - REAL (2*(M+1)) ZONAL WIND (TIMES COSLAT) OVER TOP -C VTOP - REAL (2*(M+1)) MERID WIND (TIMES COSLAT) OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2) - REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1) - REAL D((M+1)*((I+1)*M+2)),Z((M+1)*((I+1)*M+2)) - REAL U((M+1)*((I+1)*M+2)),V((M+1)*((I+1)*M+2)) - REAL UTOP(2*(M+1)),VTOP(2*(M+1)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE WINDS IN THE SPECTRAL DOMAIN - K=1 - U(2*K-1)=EON(K+1)*Z(2*K+1) - U(2*K)=EON(K+1)*Z(2*K+2) - V(2*K-1)=-EON(K+1)*D(2*K+1) - V(2*K)=-EON(K+1)*D(2*K+2) - DO K=2,(M+1)*((I+1)*M+2)/2-1 - U(2*K-1)=ELONN1(K)*D(2*K)+EON(K+1)*Z(2*K+1)-EON(K)*Z(2*K-3) - U(2*K)=-ELONN1(K)*D(2*K-1)+EON(K+1)*Z(2*K+2)-EON(K)*Z(2*K-2) - V(2*K-1)=ELONN1(K)*Z(2*K)-EON(K+1)*D(2*K+1)+EON(K)*D(2*K-3) - V(2*K)=-ELONN1(K)*Z(2*K-1)-EON(K+1)*D(2*K+2)+EON(K)*D(2*K-2) - ENDDO - K=(M+1)*((I+1)*M+2)/2 - U(2*K-1)=ELONN1(K)*D(2*K)-EON(K)*Z(2*K-3) - U(2*K)=-ELONN1(K)*D(2*K-1)-EON(K)*Z(2*K-2) - V(2*K-1)=ELONN1(K)*Z(2*K)+EON(K)*D(2*K-3) - V(2*K)=-ELONN1(K)*Z(2*K-1)+EON(K)*D(2*K-2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE WINDS OVER TOP OF THE SPECTRAL DOMAIN - DO L=0,M - K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1 - UTOP(2*L+1)=-EONTOP(L+1)*Z(2*K-1) - UTOP(2*L+2)=-EONTOP(L+1)*Z(2*K) - VTOP(2*L+1)=EONTOP(L+1)*D(2*K-1) - VTOP(2*L+2)=EONTOP(L+1)*D(2*K) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/sp/v2.0.2/src/speps.f b/external/sp/v2.0.2/src/speps.f deleted file mode 100644 index bb7ad721..00000000 --- a/external/sp/v2.0.2/src/speps.f +++ /dev/null @@ -1,67 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPEPS(I,M,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPEPS COMPUTE UTILITY SPECTRAL FIELDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES CONSTANT FIELDS INDEXED IN THE SPECTRAL DOMAIN -C IN "IBM ORDER" (ZONAL WAVENUMBER IS THE SLOWER INDEX). -C IF L IS THE ZONAL WAVENUMBER AND N IS THE TOTAL WAVENUMBER -C AND A IS THE EARTH RADIUS, THEN THE FIELDS RETURNED ARE: -C (1) NORMALIZING FACTOR EPSILON=SQRT((N**2-L**2)/(4*N**2-1)) -C (2) LAPLACIAN FACTOR N*(N+1)/A**2 -C (3) ZONAL DERIVATIVE/LAPLACIAN FACTOR L/(N*(N+1))*A -C (4) MERIDIONAL DERIVATIVE/LAPLACIAN FACTOR EPSILON/N*A -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPEPS(I,M,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C -C OUTPUT ARGUMENT LIST: -C EPS - REAL ((M+1)*((I+1)*M+2)/2) SQRT((N**2-L**2)/(4*N**2-1)) -C EPSTOP - REAL (M+1) SQRT((N**2-L**2)/(4*N**2-1)) OVER TOP -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL EPS((M+1)*((I+1)*M+2)/2),EPSTOP(M+1) - REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2) - REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1) - PARAMETER(RERTH=6.3712E6,RA2=1./RERTH**2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DO L=0,M - K=L*(2*M+(I-1)*(L-1))/2+L+1 - EPS(K)=0. - ENN1(K)=RA2*L*(L+1) - ELONN1(K)=RERTH/(L+1) - EON(K)=0. - ENDDO - DO L=0,M - DO N=L+1,I*L+M - K=L*(2*M+(I-1)*(L-1))/2+N+1 - EPS(K)=SQRT(FLOAT(N**2-L**2)/FLOAT(4*N**2-1)) - ENN1(K)=RA2*N*(N+1) - ELONN1(K)=RERTH*L/(N*(N+1)) - EON(K)=RERTH/N*EPS(K) - ENDDO - ENDDO - DO L=0,M - N=I*L+M+1 - EPSTOP(L+1)=SQRT(FLOAT(N**2-L**2)/FLOAT(4*N**2-1)) - EONTOP(L+1)=RERTH/N*EPSTOP(L+1) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/sp/v2.0.2/src/spfft.f b/external/sp/v2.0.2/src/spfft.f deleted file mode 100644 index d429aac8..00000000 --- a/external/sp/v2.0.2/src/spfft.f +++ /dev/null @@ -1,93 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPFFT(IMAX,INCW,INCG,KMAX,W,G,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPFFT PERFORM MULTIPLE FAST FOURIER TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS MULTIPLE FAST FOURIER TRANSFORMS -C BETWEEN COMPLEX AMPLITUDES IN FOURIER SPACE AND REAL VALUES -C IN CYCLIC PHYSICAL SPACE. -C SUBPROGRAM SPFFT MUST BE INVOKED FIRST WITH IDIR=0 -C TO INITIALIZE TRIGONEMETRIC DATA. USE SUBPROGRAM SPFFT1 -C TO PERFORM AN FFT WITHOUT PREVIOUS INITIALIZATION. -C THIS VERSION INVOKES THE IBM ESSL FFT. -C -C PROGRAM HISTORY LOG: -C 1998-12-18 IREDELL -C -C USAGE: CALL SPFFT(IMAX,INCW,INCG,KMAX,W,G,IDIR) -C -C INPUT ARGUMENT LIST: -C IMAX - INTEGER NUMBER OF VALUES IN THE CYCLIC PHYSICAL SPACE -C (SEE LIMITATIONS ON IMAX IN REMARKS BELOW.) -C INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -C (INCW >= IMAX/2+1) -C INCG - INTEGER FIRST DIMENSION OF THE REAL VALUE ARRAY -C (INCG >= IMAX) -C KMAX - INTEGER NUMBER OF TRANSFORMS TO PERFORM -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR>0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR<0 -C IDIR - INTEGER DIRECTION FLAG -C IDIR=0 TO INITIALIZE INTERNAL TRIGONOMETRIC DATA -C IDIR>0 TO TRANSFORM FROM FOURIER TO PHYSICAL SPACE -C IDIR<0 TO TRANSFORM FROM PHYSICAL TO FOURIER SPACE -C -C OUTPUT ARGUMENT LIST: -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR<0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -C SRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C REMARKS: -C THE RESTRICTIONS ON IMAX ARE THAT IT MUST BE A MULTIPLE -C OF 1 TO 25 FACTORS OF TWO, UP TO 2 FACTORS OF THREE, -C AND UP TO 1 FACTOR OF FIVE, SEVEN AND ELEVEN. -C -C IF IDIR=0, THEN W AND G NEED NOT CONTAIN ANY VALID DATA. -C THE OTHER PARAMETERS MUST BE SUPPLIED AND CANNOT CHANGE -C IN SUCCEEDING CALLS UNTIL THE NEXT TIME IT IS CALLED WITH IDIR=0. -C -C THIS SUBPROGRAM IS NOT THREAD-SAFE WHEN IDIR=0. ON THE OTHER HAND, -C WHEN IDIR IS NOT ZERO, IT CAN BE CALLED FROM A THREADED REGION. -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR - COMPLEX,INTENT(INOUT):: W(INCW,KMAX) - REAL,INTENT(INOUT):: G(INCG,KMAX) - INTEGER,SAVE:: NAUX1=0 - REAL,SAVE,ALLOCATABLE:: AUX1CR(:),AUX1RC(:) - INTEGER:: NAUX2 - REAL:: AUX2(20000+INT(0.57*IMAX)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NAUX2=20000+INT(0.57*IMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C INITIALIZATION. -C ALLOCATE AND FILL AUXILIARY ARRAYS WITH TRIGONOMETRIC DATA - SELECT CASE(IDIR) - CASE(0) - IF(NAUX1.GT.0) DEALLOCATE(AUX1CR,AUX1RC) - NAUX1=25000+INT(0.82*IMAX) - ALLOCATE(AUX1CR(NAUX1),AUX1RC(NAUX1)) - CALL SCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1CR,NAUX1,AUX2,NAUX2,0.,0) - CALL SRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1RC,NAUX1,AUX2,NAUX2,0.,0) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FOURIER TO PHYSICAL TRANSFORM. - CASE(1:) - CALL SCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1CR,NAUX1,AUX2,NAUX2,0.,0) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PHYSICAL TO FOURIER TRANSFORM. - CASE(:-1) - CALL SRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1RC,NAUX1,AUX2,NAUX2,0.,0) - END SELECT - END SUBROUTINE diff --git a/external/sp/v2.0.2/src/spfft1.f b/external/sp/v2.0.2/src/spfft1.f deleted file mode 100644 index fe506a57..00000000 --- a/external/sp/v2.0.2/src/spfft1.f +++ /dev/null @@ -1,79 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPFFT1 PERFORM MULTIPLE FAST FOURIER TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS MULTIPLE FAST FOURIER TRANSFORMS -C BETWEEN COMPLEX AMPLITUDES IN FOURIER SPACE AND REAL VALUES -C IN CYCLIC PHYSICAL SPACE. -C SUBPROGRAM SPFFT1 INITIALIZES TRIGONOMETRIC DATA EACH CALL. -C USE SUBPROGRAM SPFFT TO SAVE TIME AND INITIALIZE ONCE. -C THIS VERSION INVOKES THE IBM ESSL FFT. -C -C PROGRAM HISTORY LOG: -C 1998-12-18 IREDELL -C -C USAGE: CALL SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR) -C -C INPUT ARGUMENT LIST: -C IMAX - INTEGER NUMBER OF VALUES IN THE CYCLIC PHYSICAL SPACE -C (SEE LIMITATIONS ON IMAX IN REMARKS BELOW.) -C INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -C (INCW >= IMAX/2+1) -C INCG - INTEGER FIRST DIMENSION OF THE REAL VALUE ARRAY -C (INCG >= IMAX) -C KMAX - INTEGER NUMBER OF TRANSFORMS TO PERFORM -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR>0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR<0 -C IDIR - INTEGER DIRECTION FLAG -C IDIR>0 TO TRANSFORM FROM FOURIER TO PHYSICAL SPACE -C IDIR<0 TO TRANSFORM FROM PHYSICAL TO FOURIER SPACE -C -C OUTPUT ARGUMENT LIST: -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR<0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -C SRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C REMARKS: -C THE RESTRICTIONS ON IMAX ARE THAT IT MUST BE A MULTIPLE -C OF 1 TO 25 FACTORS OF TWO, UP TO 2 FACTORS OF THREE, -C AND UP TO 1 FACTOR OF FIVE, SEVEN AND ELEVEN. -C -C THIS SUBPROGRAM IS THREAD-SAFE. -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR - COMPLEX,INTENT(INOUT):: W(INCW,KMAX) - REAL,INTENT(INOUT):: G(INCG,KMAX) - REAL:: AUX1(25000+INT(0.82*IMAX)) - REAL:: AUX2(20000+INT(0.57*IMAX)) - INTEGER:: NAUX1,NAUX2 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NAUX1=25000+INT(0.82*IMAX) - NAUX2=20000+INT(0.57*IMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FOURIER TO PHYSICAL TRANSFORM. - SELECT CASE(IDIR) - CASE(1:) - CALL SCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL SCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1., - & AUX1,NAUX1,AUX2,NAUX2,0.,0) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PHYSICAL TO FOURIER TRANSFORM. - CASE(:-1) - CALL SRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - CALL SRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX, - & AUX1,NAUX1,AUX2,NAUX2,0.,0) - END SELECT - END SUBROUTINE diff --git a/external/sp/v2.0.2/src/spffte.f b/external/sp/v2.0.2/src/spffte.f deleted file mode 100644 index c52c81d7..00000000 --- a/external/sp/v2.0.2/src/spffte.f +++ /dev/null @@ -1,148 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPFFTE PERFORM MULTIPLE FAST FOURIER TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS MULTIPLE FAST FOURIER TRANSFORMS -C BETWEEN COMPLEX AMPLITUDES IN FOURIER SPACE AND REAL VALUES -C IN CYCLIC PHYSICAL SPACE. -C SUBPROGRAM SPFFTE MUST BE INVOKED FIRST WITH IDIR=0 -C TO INITIALIZE TRIGONEMETRIC DATA. USE SUBPROGRAM SPFFT1 -C TO PERFORM AN FFT WITHOUT PREVIOUS INITIALIZATION. -C THIS VERSION INVOKES THE IBM ESSL FFT. -C -C PROGRAM HISTORY LOG: -C 1998-12-18 IREDELL -C 2012-11-12 MIRVIS -fixing hard-wired types problem on Intel/Linux - -C USAGE: CALL SPFFTE(IMAX,INCW,INCG,KMAX,W,G,IDIR,AFFT) -C -C INPUT ARGUMENT LIST: -C IMAX - INTEGER NUMBER OF VALUES IN THE CYCLIC PHYSICAL SPACE -C (SEE LIMITATIONS ON IMAX IN REMARKS BELOW.) -C INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -C (INCW >= IMAX/2+1) -C INCG - INTEGER FIRST DIMENSION OF THE REAL VALUE ARRAY -C (INCG >= IMAX) -C KMAX - INTEGER NUMBER OF TRANSFORMS TO PERFORM -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR>0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR<0 -C IDIR - INTEGER DIRECTION FLAG -C IDIR=0 TO INITIALIZE TRIGONOMETRIC DATA -C IDIR>0 TO TRANSFORM FROM FOURIER TO PHYSICAL SPACE -C IDIR<0 TO TRANSFORM FROM PHYSICAL TO FOURIER SPACE -C AFFT REAL(8) (50000+4*IMAX) AUXILIARY ARRAY IF IDIR<>0 -C -C OUTPUT ARGUMENT LIST: -C W - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR<0 -C G - REAL(INCG,KMAX) REAL VALUES IF IDIR>0 -C AFFT REAL(8) (50000+4*IMAX) AUXILIARY ARRAY IF IDIR=0 -C -C SUBPROGRAMS CALLED: -C SCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -C DCRFT IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM -C SRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -C DRCFT IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C REMARKS: -C THE RESTRICTIONS ON IMAX ARE THAT IT MUST BE A MULTIPLE -C OF 1 TO 25 FACTORS OF TWO, UP TO 2 FACTORS OF THREE, -C AND UP TO 1 FACTOR OF FIVE, SEVEN AND ELEVEN. -C -C IF IDIR=0, THEN W AND G NEED NOT CONTAIN ANY VALID DATA. -C THE OTHER PARAMETERS MUST BE SUPPLIED AND CANNOT CHANGE -C IN SUCCEEDING CALLS UNTIL THE NEXT TIME IT IS CALLED WITH IDIR=0. -C -C THIS SUBPROGRAM IS THREAD-SAFE. -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR - REAL,INTENT(INOUT):: W(2*INCW,KMAX) - REAL,INTENT(INOUT):: G(INCG,KMAX) - REAL(8),INTENT(INOUT):: AFFT(50000+4*IMAX) - INTEGER:: INIT,INC2X,INC2Y,N,M,ISIGN,NAUX1,NAUX2,NAUX3 -C ==EM== ^(4) - REAL:: SCALE - REAL(8):: AUX2(20000+2*IMAX),AUX3 - INTEGER:: IACR,IARC -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NAUX1=25000+2*IMAX - NAUX2=20000+2*IMAX - NAUX3=1 - IACR=1 - IARC=1+NAUX1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C INITIALIZATION. -C FILL AUXILIARY ARRAYS WITH TRIGONOMETRIC DATA - SELECT CASE(IDIR) - CASE(0) - INIT=1 - INC2X=INCW - INC2Y=INCG - N=IMAX - M=KMAX - ISIGN=-1 - SCALE=1. - IF(DIGITS(1.).LT.DIGITS(1._8)) THEN - CALL SCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IACR),NAUX1,AUX2,NAUX2,AUX3,NAUX3) - ELSE - CALL DCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IACR),NAUX1,AUX2,NAUX2) - ENDIF - INIT=1 - INC2X=INCG - INC2Y=INCW - N=IMAX - M=KMAX - ISIGN=+1 - SCALE=1./IMAX - IF(DIGITS(1.).LT.DIGITS(1._8)) THEN - CALL SRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IARC),NAUX1,AUX2,NAUX2,AUX3,NAUX3) - ELSE - CALL DRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IARC),NAUX1,AUX2,NAUX2) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FOURIER TO PHYSICAL TRANSFORM. - CASE(1:) - INIT=0 - INC2X=INCW - INC2Y=INCG - N=IMAX - M=KMAX - ISIGN=-1 - SCALE=1. - IF(DIGITS(1.).LT.DIGITS(1._8)) THEN - CALL SCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IACR),NAUX1,AUX2,NAUX2,AUX3,NAUX3) - ELSE - CALL DCRFT(INIT,W,INC2X,G,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IACR),NAUX1,AUX2,NAUX2) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PHYSICAL TO FOURIER TRANSFORM. - CASE(:-1) - INIT=0 - INC2X=INCG - INC2Y=INCW - N=IMAX - M=KMAX - ISIGN=+1 - SCALE=1./IMAX - IF(DIGITS(1.).LT.DIGITS(1._8)) THEN - CALL SRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IARC),NAUX1,AUX2,NAUX2,AUX3,NAUX3) - ELSE - CALL DRCFT(INIT,G,INC2X,W,INC2Y,N,M,ISIGN,SCALE, - & AFFT(IARC),NAUX1,AUX2,NAUX2) - ENDIF - END SELECT - END SUBROUTINE diff --git a/external/sp/v2.0.2/src/spfftpt.f b/external/sp/v2.0.2/src/spfftpt.f deleted file mode 100644 index 68f6bc57..00000000 --- a/external/sp/v2.0.2/src/spfftpt.f +++ /dev/null @@ -1,64 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPFFTPT(M,N,INCW,INCG,KMAX,RLON,W,G) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPFFTPT COMPUTE FOURIER TRANSFORM TO GRIDPOINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: THIS SUBPROGRAM COMPUTES A SLOW FOURIER TRANSFORM -C FROM FOURIER SPACE TO A SET OF GRIDPOINTS. -C -C PROGRAM HISTORY LOG: -C 1998-12-18 IREDELL -C -C USAGE: CALL SPFFTPT(M,N,INCW,INCG,KMAX,RLON,W,G) -C -C INPUT ARGUMENT LIST: -C M - INTEGER FOURIER WAVENUMBER TRUNCATION -C N - INTEGER NUMBER OF GRIDPOINTS -C INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -C (INCW >= M+1) -C INCG - INTEGER FIRST DIMENSION OF THE GRIDPOINT ARRAY -C (INCG >= N) -C KMAX - INTEGER NUMBER OF FOURIER FIELDS -C RLON - REAL(N) GRID LONGITUDES IN DEGREES -C W - COMPLEX(INCW,KMAX) FOURIER AMPLITUDES -C -C OUTPUT ARGUMENT LIST: -C G - REAL(INCG,KMAX) GRIDPOINT VALUES -C -C SUBPROGRAMS CALLED: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C REMARKS: -C THIS SUBPROGRAM IS THREAD-SAFE. -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: M,N,INCW,INCG,KMAX - REAL,INTENT(IN):: RLON(N) - REAL,INTENT(IN):: W(2*INCW,KMAX) - REAL,INTENT(OUT):: G(INCG,KMAX) - INTEGER I,K,L - REAL RADLON,SLON(M),CLON(M) - REAL,PARAMETER:: PI=3.14159265358979 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DO I=1,N - RADLON=PI/180*RLON(I) - DO L=1,M - SLON(L)=SIN(L*RADLON) - CLON(L)=COS(L*RADLON) - ENDDO - DO K=1,KMAX - G(I,K)=W(1,K) - ENDDO - DO L=1,M - DO K=1,KMAX - G(I,K)=G(I,K)+2.*(W(2*L+1,K)*CLON(L)-W(2*L+2,K)*SLON(L)) - ENDDO - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE diff --git a/external/sp/v2.0.2/src/spgradq.f b/external/sp/v2.0.2/src/spgradq.f deleted file mode 100644 index f8bef431..00000000 --- a/external/sp/v2.0.2/src/spgradq.f +++ /dev/null @@ -1,76 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPGRADQ(I,M,ENN1,ELONN1,EON,EONTOP,Q,QDX,QDY,QDYTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPGRADQ COMPUTE GRADIENT IN SPECTRAL SPACE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE HORIZONTAL VECTOR GRADIENT OF A SCALAR FIELD -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE ZONAL GRADIENT OF Q(L,N) IS SIMPLY I*L/A*Q(L,N) -C WHILE THE MERIDIONAL GRADIENT OF Q(L,N) IS COMPUTED AS -C EPS(L,N+1)*(N+2)/A*Q(L,N+1)-EPS(L,N+1)*(N-1)/A*Q(L,N-1). -C EXTRA TERMS ARE COMPUTED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPGRADQ(I,M,ENN1,ELONN1,EON,EONTOP,Q,QDX,QDY,QDYTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C Q - REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C -C OUTPUT ARGUMENT LIST: -C QDX - REAL ((M+1)*((I+1)*M+2)) ZONAL GRADIENT (TIMES COSLAT) -C QDY - REAL ((M+1)*((I+1)*M+2)) MERID GRADIENT (TIMES COSLAT) -C QDYTOP - REAL (2*(M+1)) MERID GRADIENT (TIMES COSLAT) OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2) - REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1) - REAL Q((M+1)*((I+1)*M+2)) - REAL QDX((M+1)*((I+1)*M+2)),QDY((M+1)*((I+1)*M+2)) - REAL QDYTOP(2*(M+1)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE ZONAL AND MERIDIONAL GRADIENTS - K=1 - QDX(2*K-1)=0. - QDX(2*K)=0. - QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1) - QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2) - DO K=2,(M+1)*((I+1)*M+2)/2-1 - QDX(2*K-1)=-ELONN1(K)*ENN1(K)*Q(2*K) - QDX(2*K)=ELONN1(K)*ENN1(K)*Q(2*K-1) - QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1)-EON(K)*ENN1(K-1)*Q(2*K-3) - QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2)-EON(K)*ENN1(K-1)*Q(2*K-2) - ENDDO - K=(M+1)*((I+1)*M+2)/2 - QDX(2*K-1)=-ELONN1(K)*ENN1(K)*Q(2*K) - QDX(2*K)=ELONN1(K)*ENN1(K)*Q(2*K-1) - QDY(2*K-1)=-EON(K)*ENN1(K-1)*Q(2*K-3) - QDY(2*K)=-EON(K)*ENN1(K-1)*Q(2*K-2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE MERIDIONAL GRADIENT OVER TOP - DO L=0,M - K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1 - QDYTOP(2*L+1)=-EONTOP(L+1)*ENN1(K)*Q(2*K-1) - QDYTOP(2*L+2)=-EONTOP(L+1)*ENN1(K)*Q(2*K) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/sp/v2.0.2/src/spgradx.f b/external/sp/v2.0.2/src/spgradx.f deleted file mode 100644 index 911d8e2b..00000000 --- a/external/sp/v2.0.2/src/spgradx.f +++ /dev/null @@ -1,86 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPGRADX(M,INCW,KMAX,MP,CLAT,W,WX) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPGRADX COMPUTE X-GRADIENT IN FOURIER SPACE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: THIS SUBPROGRAM COMPUTES THE X-GRADIENT OF FIELDS -C IN COMPLEX FOURIER SPACE. -C THE X-GRADIENT OF A VECTOR FIELD W IS -C WX=CONJG(W)*L/RERTH -C WHERE L IS THE WAVENUMBER AND RERTH IS THE EARTH RADIUS, -C SO THAT THE RESULT IS THE X-GRADIENT OF THE PSEUDO-VECTOR. -C THE X-GRADIENT OF A SCALAR FIELD W IS -C WX=CONJG(W)*L/(RERTH*CLAT) -C WHERE CLAT IS THE COSINE OF LATITUDE. -C AT THE POLE THIS IS UNDEFINED, SO THE WAY TO GET -C THE X-GRADIENT AT THE POLE IS BY PASSING BOTH -C THE WEIGHTED WAVENUMBER 0 AND THE UNWEIGHTED WAVENUMBER 1 -C AMPLITUDES AT THE POLE AND SETTING MP=10. -C IN THIS CASE, THE WAVENUMBER 1 AMPLITUDES ARE USED -C TO COMPUTE THE X-GRADIENT AND THEN ZEROED OUT. -C -C PROGRAM HISTORY LOG: -C 1998-12-18 IREDELL -C -C USAGE: CALL SPGRADX(M,INCW,KMAX,W,WX) -C -C INPUT ARGUMENT LIST: -C M - INTEGER FOURIER WAVENUMBER TRUNCATION -C INCW - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY -C (INCW >= M+1) -C KMAX - INTEGER NUMBER OF FOURIER FIELDS -C MP - INTEGER (KM) IDENTIFIERS -C (0 OR 10 FOR SCALAR, 1 FOR VECTOR) -C CLAT - REAL COSINE OF LATITUDE -C W - COMPLEX(INCW,KMAX) FOURIER AMPLITUDES -C -C OUTPUT ARGUMENT LIST: -C W - COMPLEX(INCW,KMAX) FOURIER AMPLITUDES -C CORRECTED WHEN MP=10 AND CLAT=0 -C WX - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES OF X-GRADIENTS -C -C SUBPROGRAMS CALLED: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C REMARKS: -C THIS SUBPROGRAM IS THREAD-SAFE. -C -C$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: M,INCW,KMAX,MP(KMAX) - REAL,INTENT(IN):: CLAT - REAL,INTENT(INOUT):: W(2*INCW,KMAX) - REAL,INTENT(OUT):: WX(2*INCW,KMAX) - INTEGER K,L - REAL,PARAMETER:: RERTH=6.3712E6 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DO K=1,KMAX - IF(MP(K).EQ.1) THEN - DO L=0,M - WX(2*L+1,K)=-W(2*L+2,K)*(L/RERTH) - WX(2*L+2,K)=+W(2*L+1,K)*(L/RERTH) - ENDDO - ELSEIF(CLAT.EQ.0.) THEN - DO L=0,M - WX(2*L+1,K)=0 - WX(2*L+2,K)=0 - ENDDO - IF(MP(K).EQ.10.AND.M.GE.2) THEN - WX(3,K)=-W(4,K)/RERTH - WX(4,K)=+W(3,K)/RERTH - W(3,K)=0 - W(4,K)=0 - ENDIF - ELSE - DO L=0,M - WX(2*L+1,K)=-W(2*L+2,K)*(L/(RERTH*CLAT)) - WX(2*L+2,K)=+W(2*L+1,K)*(L/(RERTH*CLAT)) - ENDDO - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END SUBROUTINE diff --git a/external/sp/v2.0.2/src/spgrady.f b/external/sp/v2.0.2/src/spgrady.f deleted file mode 100644 index 5a77922b..00000000 --- a/external/sp/v2.0.2/src/spgrady.f +++ /dev/null @@ -1,67 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPGRADY(I,M,ENN1,EON,EONTOP,Q,QDY,QDYTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPGRADY COMPUTE Y-GRADIENT IN SPECTRAL SPACE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE HORIZONTAL VECTOR Y-GRADIENT OF A SCALAR FIELD -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE MERIDIONAL GRADIENT OF Q(L,N) IS COMPUTED AS -C EPS(L,N+1)*(N+2)/A*Q(L,N+1)-EPS(L,N+1)*(N-1)/A*Q(L,N-1). -C EXTRA TERMS ARE COMPUTED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPGRADY(I,M,ENN1,EON,EONTOP,Q,QDY,QDYTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C Q - REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C -C OUTPUT ARGUMENT LIST: -C QDY - REAL ((M+1)*((I+1)*M+2)) MERID GRADIENT (TIMES COSLAT) -C QDYTOP - REAL (2*(M+1)) MERID GRADIENT (TIMES COSLAT) OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL ENN1((M+1)*((I+1)*M+2)/2) - REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1) - REAL Q((M+1)*((I+1)*M+2)) - REAL QDY((M+1)*((I+1)*M+2)) - REAL QDYTOP(2*(M+1)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE MERIDIONAL GRADIENT - K=1 - QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1) - QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2) - DO K=2,(M+1)*((I+1)*M+2)/2-1 - QDY(2*K-1)=EON(K+1)*ENN1(K+1)*Q(2*K+1)-EON(K)*ENN1(K-1)*Q(2*K-3) - QDY(2*K)=EON(K+1)*ENN1(K+1)*Q(2*K+2)-EON(K)*ENN1(K-1)*Q(2*K-2) - ENDDO - K=(M+1)*((I+1)*M+2)/2 - QDY(2*K-1)=-EON(K)*ENN1(K-1)*Q(2*K-3) - QDY(2*K)=-EON(K)*ENN1(K-1)*Q(2*K-2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE MERIDIONAL GRADIENT OVER TOP - DO L=0,M - K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1 - QDYTOP(2*L+1)=-EONTOP(L+1)*ENN1(K)*Q(2*K-1) - QDYTOP(2*L+2)=-EONTOP(L+1)*ENN1(K)*Q(2*K) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/sp/v2.0.2/src/splaplac.f b/external/sp/v2.0.2/src/splaplac.f deleted file mode 100644 index 5ee7eed5..00000000 --- a/external/sp/v2.0.2/src/splaplac.f +++ /dev/null @@ -1,61 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPLAPLAC(I,M,ENN1,Q,QD2,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE LAPLACIAN OR THE INVERSE LAPLACIAN -C OF A SCALAR FIELD IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C THE LAPLACIAN OF Q(L,N) IS SIMPLY -N*(N+1)/A**2*Q(L,N) -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPLAPLAC(I,M,ENN1,Q,QD2,IDIR) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C Q - IF IDIR > 0, REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C QD2 - IF IDIR < 0, REAL ((M+1)*((I+1)*M+2)) LAPLACIAN -C IDIR - INTEGER FLAG -C IDIR > 0 TO TAKE LAPLACIAN -C IDIR < 0 TO TAKE INVERSE LAPLACIAN -C -C OUTPUT ARGUMENT LIST: -C Q - IF IDIR < 0, REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C (Q(0,0) IS NOT COMPUTED) -C QD2 - IF IDIR > 0, REAL ((M+1)*((I+1)*M+2)) LAPLACIAN -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL ENN1((M+1)*((I+1)*M+2)/2) - REAL Q((M+1)*((I+1)*M+2)) - REAL QD2((M+1)*((I+1)*M+2)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE LAPLACIAN - IF(IDIR.GT.0) THEN - K=1 - QD2(2*K-1)=0. - QD2(2*K)=0. - DO K=2,(M+1)*((I+1)*M+2)/2 - QD2(2*K-1)=Q(2*K-1)*(-ENN1(K)) - QD2(2*K)=Q(2*K)*(-ENN1(K)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE INVERSE LAPLACIAN - ELSE - DO K=2,(M+1)*((I+1)*M+2)/2 - Q(2*K-1)=QD2(2*K-1)/(-ENN1(K)) - Q(2*K)=QD2(2*K)/(-ENN1(K)) - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/sp/v2.0.2/src/splat.F b/external/sp/v2.0.2/src/splat.F deleted file mode 100644 index 604072a6..00000000 --- a/external/sp/v2.0.2/src/splat.F +++ /dev/null @@ -1,213 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPLAT(IDRT,JMAX,SLAT,WLAT) -C SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLAT COMPUTE LATITUDE FUNCTIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: COMPUTES COSINES OF COLATITUDE AND GAUSSIAN WEIGHTS -C FOR ONE OF THE FOLLOWING SPECIFIC GLOBAL SETS OF LATITUDES. -C GAUSSIAN LATITUDES (IDRT=4) -C EQUALLY-SPACED LATITUDES INCLUDING POLES (IDRT=0) -C EQUALLY-SPACED LATITUDES EXCLUDING POLES (IDRT=256) -C THE GAUSSIAN LATITUDES ARE LOCATED AT THE ZEROES OF THE -C LEGENDRE POLYNOMIAL OF THE GIVEN ORDER. THESE LATITUDES -C ARE EFFICIENT FOR REVERSIBLE TRANSFORMS FROM SPECTRAL SPACE. -C (ABOUT TWICE AS MANY EQUALLY-SPACED LATITUDES ARE NEEDED.) -C THE WEIGHTS FOR THE EQUALLY-SPACED LATITUDES ARE BASED ON -C ELLSAESSER (JAM,1966). (NO WEIGHT IS GIVEN THE POLE POINT.) -C NOTE THAT WHEN ANALYZING GRID TO SPECTRAL IN LATITUDE PAIRS, -C IF AN EQUATOR POINT EXISTS, ITS WEIGHT SHOULD BE HALVED. -C THIS VERSION INVOKES THE IBM ESSL MATRIX SOLVER. -C -C PROGRAM HISTORY LOG: -C 96-02-20 IREDELL -C 97-10-20 IREDELL ADJUST PRECISION -C 98-06-11 IREDELL GENERALIZE PRECISION USING FORTRAN 90 INTRINSIC -C 1998-12-03 IREDELL GENERALIZE PRECISION FURTHER -C 1998-12-03 IREDELL USES AIX ESSL BLAS CALLS -C 2009-12-27 DSTARK updated to switch between ESSL calls on an AIX -C platform, and Numerical Recipies calls elsewise. -C 2010-12-30 SLOVACEK update alignment so preprocessor does not cause -C compilation failure -C 2012-09-01 E.Mirvis & M.Iredell merging & debugging linux errors -C of _d and _8 using generic LU factorization. -C 2012-11-05 E.Mirvis generic FFTPACK and LU lapack were removed -C---------------------------------------------------------------- -C USAGE: CALL SPLAT(IDRT,JMAX,SLAT,WLAT) -C -C INPUT ARGUMENT LIST: -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C JMAX - INTEGER NUMBER OF LATITUDES. -C -C OUTPUT ARGUMENT LIST: -C SLAT - REAL (JMAX) SINES OF LATITUDE. -C WLAT - REAL (JMAX) GAUSSIAN WEIGHTS. -C -C SUBPROGRAMS CALLED: -C DGEF MATRIX FACTORIZATION - ESSL -C DGES MATRIX SOLVER - ESSL -C LUDCMP LU factorization - numerical recipies -C LUBKSB Matrix solver - numerical recipies -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C - REAL SLAT(JMAX),WLAT(JMAX) - INTEGER,PARAMETER:: KD=SELECTED_REAL_KIND(15,45) - REAL(KIND=KD):: PK(JMAX/2),PKM1(JMAX/2),PKM2(JMAX/2) - REAL(KIND=KD):: SLATD(JMAX/2),SP,SPMAX,EPS=10.*EPSILON(SP) - PARAMETER(JZ=50) - REAL BZ(JZ) - DATA BZ / 2.4048255577, 5.5200781103, - $ 8.6537279129, 11.7915344391, 14.9309177086, 18.0710639679, - $ 21.2116366299, 24.3524715308, 27.4934791320, 30.6346064684, - $ 33.7758202136, 36.9170983537, 40.0584257646, 43.1997917132, - $ 46.3411883717, 49.4826098974, 52.6240518411, 55.7655107550, - $ 58.9069839261, 62.0484691902, 65.1899648002, 68.3314693299, - $ 71.4729816036, 74.6145006437, 77.7560256304, 80.8975558711, - $ 84.0390907769, 87.1806298436, 90.3221726372, 93.4637187819, - $ 96.6052679510, 99.7468198587, 102.888374254, 106.029930916, - $ 109.171489649, 112.313050280, 115.454612653, 118.596176630, - $ 121.737742088, 124.879308913, 128.020877005, 131.162446275, - $ 134.304016638, 137.445588020, 140.587160352, 143.728733573, - $ 146.870307625, 150.011882457, 153.153458019, 156.295034268 / - REAL:: DLT,D1=1. - REAL AWORK((JMAX+1)/2,((JMAX+1)/2)),BWORK(((JMAX+1)/2)) - INTEGER:: JHE,JHO,J0=0 - INTEGER IPVT((JMAX+1)/2) - PARAMETER(PI=3.14159265358979,C=(1.-(2./PI)**2)*0.25) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GAUSSIAN LATITUDES - IF(IDRT.EQ.4) THEN - JH=JMAX/2 - JHE=(JMAX+1)/2 - R=1./SQRT((JMAX+0.5)**2+C) - DO J=1,MIN(JH,JZ) - SLATD(J)=COS(BZ(J)*R) - ENDDO - DO J=JZ+1,JH - SLATD(J)=COS((BZ(JZ)+(J-JZ)*PI)*R) - ENDDO - SPMAX=1. - DO WHILE(SPMAX.GT.EPS) - SPMAX=0. - DO J=1,JH - PKM1(J)=1. - PK(J)=SLATD(J) - ENDDO - DO N=2,JMAX - DO J=1,JH - PKM2(J)=PKM1(J) - PKM1(J)=PK(J) - PK(J)=((2*N-1)*SLATD(J)*PKM1(J)-(N-1)*PKM2(J))/N - ENDDO - ENDDO - DO J=1,JH - SP=PK(J)*(1.-SLATD(J)**2)/(JMAX*(PKM1(J)-SLATD(J)*PK(J))) - SLATD(J)=SLATD(J)-SP - SPMAX=MAX(SPMAX,ABS(SP)) - ENDDO - ENDDO -CDIR$ IVDEP - DO J=1,JH - SLAT(J)=SLATD(J) - WLAT(J)=(2.*(1.-SLATD(J)**2))/(JMAX*PKM1(J))**2 - SLAT(JMAX+1-J)=-SLAT(J) - WLAT(JMAX+1-J)=WLAT(J) - ENDDO - IF(JHE.GT.JH) THEN - SLAT(JHE)=0. - WLAT(JHE)=2./JMAX**2 - DO N=2,JMAX,2 - WLAT(JHE)=WLAT(JHE)*N**2/(N-1)**2 - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C EQUALLY-SPACED LATITUDES INCLUDING POLES - ELSEIF(IDRT.EQ.0) THEN - JH=JMAX/2 - JHE=(JMAX+1)/2 - JHO=JHE-1 - DLT=PI/(JMAX-1) - SLAT(1)=1. - DO J=2,JH - SLAT(J)=COS((J-1)*DLT) - ENDDO - DO JS=1,JHO - DO J=1,JHO - AWORK(JS,J)=COS(2*(JS-1)*J*DLT) - ENDDO - ENDDO - DO JS=1,JHO - BWORK(JS)=-D1/(4*(JS-1)**2-1) - ENDDO -#if IBM4 || IBM8 - CALL DGEF(AWORK,JHE,JHO,IPVT) - CALL DGES(AWORK,JHE,JHO,IPVT,BWORK,J0) -#endif -#if LINUX - call ludcmp(awork,jho,jhe,ipvt) - call lubksb(awork,jho,jhe,ipvt,bwork) -#endif - WLAT(1)=0. - DO J=1,JHO - WLAT(J+1)=BWORK(J) - ENDDO -CDIR$ IVDEP - DO J=1,JH - SLAT(JMAX+1-J)=-SLAT(J) - WLAT(JMAX+1-J)=WLAT(J) - ENDDO - IF(JHE.GT.JH) THEN - SLAT(JHE)=0. - WLAT(JHE)=2.*WLAT(JHE) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C EQUALLY-SPACED LATITUDES EXCLUDING POLES - ELSEIF(IDRT.EQ.256) THEN - JH=JMAX/2 - JHE=(JMAX+1)/2 - JHO=JHE - DLT=PI/JMAX - SLAT(1)=1. - DO J=1,JH - SLAT(J)=COS((J-0.5)*DLT) - ENDDO - DO JS=1,JHO - DO J=1,JHO - AWORK(JS,J)=COS(2*(JS-1)*(J-0.5)*DLT) - ENDDO - ENDDO - DO JS=1,JHO - BWORK(JS)=-D1/(4*(JS-1)**2-1) - ENDDO -#if IBM4 || IBM8 - CALL DGEF(AWORK,JHE,JHO,IPVT) - CALL DGES(AWORK,JHE,JHO,IPVT,BWORK,J0) -#endif -#if LINUX - call ludcmp(awork,jho,jhe,ipvt,d) - call lubksb(awork,jho,jhe,ipvt,bwork) -#endif - WLAT(1)=0. - DO J=1,JHO - WLAT(J)=BWORK(J) - ENDDO -CDIR$ IVDEP - DO J=1,JH - SLAT(JMAX+1-J)=-SLAT(J) - WLAT(JMAX+1-J)=WLAT(J) - ENDDO - IF(JHE.GT.JH) THEN - SLAT(JHE)=0. - WLAT(JHE)=2.*WLAT(JHE) - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/sp/v2.0.2/src/splegend.f b/external/sp/v2.0.2/src/splegend.f deleted file mode 100644 index d8b1bccd..00000000 --- a/external/sp/v2.0.2/src/splegend.f +++ /dev/null @@ -1,134 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPLEGEND(I,M,SLAT,CLAT,EPS,EPSTOP,PLN,PLNTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: EVALUATES THE ORTHONORMAL ASSOCIATED LEGENDRE POLYNOMIALS -C IN THE SPECTRAL DOMAIN AT A GIVEN LATITUDE. -C SUBPROGRAM SPLEGEND SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C AND EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) THEN -C THE FOLLOWING BOOTSTRAPPING FORMULAS ARE USED: -C PLN(0,0)=SQRT(0.5) -C PLN(L,L)=PLN(L-1,L-1)*CLAT*SQRT(FLOAT(2*L+1)/FLOAT(2*L)) -C PLN(L,N)=(SLAT*PLN(L,N-1)-EPS(L,N-1)*PLN(L,N-2))/EPS(L,N) -C SYNTHESIS AT THE POLE NEEDS ONLY TWO ZONAL WAVENUMBERS. -C SCALAR FIELDS ARE SYNTHESIZED WITH ZONAL WAVENUMBER 0 WHILE -C VECTOR FIELDS ARE SYNTHESIZED WITH ZONAL WAVENUMBER 1. -C (THUS POLAR VECTOR FIELDS ARE IMPLICITLY DIVIDED BY CLAT.) -C THE FOLLOWING BOOTSTRAPPING FORMULAS ARE USED AT THE POLE: -C PLN(0,0)=SQRT(0.5) -C PLN(1,1)=SQRT(0.75) -C PLN(L,N)=(PLN(L,N-1)-EPS(L,N-1)*PLN(L,N-2))/EPS(L,N) -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C 98-06-10 MARK IREDELL GENERALIZE PRECISION -C -C USAGE: CALL SPLEGEND(I,M,SLAT,CLAT,EPS,EPSTOP,PLN,PLNTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C SLAT - REAL SINE OF LATITUDE -C CLAT - REAL COSINE OF LATITUDE -C EPS - REAL ((M+1)*((I+1)*M+2)/2) SQRT((N**2-L**2)/(4*N**2-1)) -C EPSTOP - REAL (M+1) SQRT((N**2-L**2)/(4*N**2-1)) OVER TOP -C -C OUTPUT ARGUMENT LIST: -C PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIAL -C PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -CFPP$ NOCONCUR R - REAL EPS((M+1)*((I+1)*M+2)/2),EPSTOP(M+1) - REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1) - REAL(KIND=SELECTED_REAL_KIND(15,45)):: DLN((M+1)*((I+1)*M+2)/2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C ITERATIVELY COMPUTE PLN WITHIN SPECTRAL DOMAIN AT POLE - M1=M+1 - M2=2*M+I+1 - MX=(M+1)*((I+1)*M+2)/2 - IF(CLAT.EQ.0.) THEN - DLN(1)=SQRT(0.5) - IF(M.GT.0) THEN - DLN(M1+1)=SQRT(0.75) - DLN(2)=SLAT*DLN(1)/EPS(2) - ENDIF - IF(M.GT.1) THEN - DLN(M1+2)=SLAT*DLN(M1+1)/EPS(M1+2) - DLN(3)=(SLAT*DLN(2)-EPS(2)*DLN(1))/EPS(3) - DO N=3,M - K=1+N - DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K) - K=M1+N - DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K) - ENDDO - IF(I.EQ.1) THEN - K=M2 - DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K) - ENDIF - DO K=M2+1,MX - DLN(K)=0. - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE POLYNOMIALS OVER TOP OF SPECTRAL DOMAIN - K=M1+1 - PLNTOP(1)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPSTOP(1) - IF(M.GT.0) THEN - K=M2+1 - PLNTOP(2)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPSTOP(2) - DO L=2,M - PLNTOP(L+1)=0. - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C ITERATIVELY COMPUTE PLN(L,L) (BOTTOM HYPOTENUSE OF DOMAIN) - ELSE - NML=0 - K=1 - DLN(K)=SQRT(0.5) - DO L=1,M+(I-1)*NML - KP=K - K=L*(2*M+(I-1)*(L-1))/2+L+NML+1 - DLN(K)=DLN(KP)*CLAT*SQRT(FLOAT(2*L+1)/FLOAT(2*L)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE PLN(L,L+1) (DIAGONAL NEXT TO BOTTOM HYPOTENUSE OF DOMAIN) - NML=1 -CDIR$ IVDEP - DO L=0,M+(I-1)*NML - K=L*(2*M+(I-1)*(L-1))/2+L+NML+1 - DLN(K)=SLAT*DLN(K-1)/EPS(K) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE REMAINING PLN IN SPECTRAL DOMAIN - DO NML=2,M -CDIR$ IVDEP - DO L=0,M+(I-1)*NML - K=L*(2*M+(I-1)*(L-1))/2+L+NML+1 - DLN(K)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPS(K) - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE POLYNOMIALS OVER TOP OF SPECTRAL DOMAIN - DO L=0,M - NML=M+1+(I-1)*L - K=L*(2*M+(I-1)*(L-1))/2+L+NML+1 - PLNTOP(L+1)=(SLAT*DLN(K-1)-EPS(K-1)*DLN(K-2))/EPSTOP(L+1) - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C RETURN VALUES - DO K=1,MX - PLN(K)=DLN(K) - ENDDO - RETURN - END diff --git a/external/sp/v2.0.2/src/splib.doc b/external/sp/v2.0.2/src/splib.doc deleted file mode 100644 index 5db4205a..00000000 --- a/external/sp/v2.0.2/src/splib.doc +++ /dev/null @@ -1,2621 +0,0 @@ -Documentation of the spectral transform library splib May 2, 1996 --------------------------------------------------------------------------------- - -I. Introduction - -The spectral transform library splib contains FORTRAN subprograms -to be used for a variety of spectral transform functions. -The library has been optimized for the CRAY machines, taking full advantage -of both the vector and parallel capabilities. The library is particularly -efficient when transforming many fields at one time. Some entry points -will diagnose the environmental number of CPUs available, but others require -the number of CPUs used be specified. The library is reasonably transportable -to other platforms with compilers allowing dynamic automatic arrays. - -The library can handle both scalar and two-dimensional vector fields. -Each vector field will be represented in spectral space appropriately -by its respective spherical divergence and curl (vorticity), thus -avoiding the pole problems associated with representing components separately. - -Some of the functions performed by the library are spectral interpolations -between two grids, spectral truncations in place on a grid, and basic -spectral transforms between grid and wave space. Only global Gaussian -or global equidistant cylindrical grids are allowed for transforming into -wave space. There are no such restricitions on grids for transforming from -wave space. However, there are special fast entry points for transforming wave -space to polar stereographic and Mercator grids as well as the aforementioned -cylindrical grids. - -The indexing of the cylindrical transform grids is totally general. -The grids may run north to south or south to north; they may run east to west -or west to east; they may start at any longitude as long as the prime meridian -is on the grid; they may be dimensioned in any order (e.g. (i,j,k), (k,j,i), -(i,k,nfield,j), etc.). Furthermore, the transform may be performed on only -some of the latitudes at one time as long as both hemisphere counterparts -are transformed at the same time (as in the global spectral model). -The grid indexing will default to the customary global indexing, i.e. north to -south, east to west, prime meridian as first longitude, and (i,j,k) order. - -The wave space may be either triangular or rhomboidal in shape. -Its internal indexing is strictly "IBM order", i.e. zonal wavenumber is the -slower index with the real and imaginary components always paired together. -The imaginary components of all the zonally symmetric modes should always -be zero, as should the global mean of any divergence and vorticity fields. -The stride between the start of successive wave fields is general, -defaulting to the computed length of each field. - -This documentation is divided into 4 chapters. Chapter I is this introduction. -Chapter II is a list of all entry points. Chapter III is a set of examples. -Chapter IV is a recapitulation of all the docblocks. The chapters all start -on a line number that is 1 modulo 60 in order to facilitate laser printing. - - - - - - - - - - -II. Entry point list - - Name Function - ---- ------------------------------------------------------------------ - - Spectral interpolations or truncations between grid and grid - - SPTRUN SPECTRALLY TRUNCATE GRIDDED SCALAR FIELDS - SPTRUNV SPECTRALLY TRUNCATE GRIDDED VECTOR FIELDS - SPTRUNG SPECTRALLY INTERPOLATE SCALARS TO STATIONS - SPTRUNGV SPECTRALLY INTERPOLATE VECTORS TO STATIONS - SPTRUNS SPECTRALLY INTERPOLATE SCALARS TO POLAR STEREO - SPTRUNSV SPECTRALLY INTERPOLATE VECTORS TO POLAR STEREO - SPTRUNM SPECTRALLY INTERPOLATE SCALARS TO MERCATOR - SPTRUNMV SPECTRALLY INTERPOLATE VECTORS TO MERCATOR - - Spectral transforms between wave and grid - - SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM - SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM - SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM - SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS - SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS - SPTGPTD TRANSFORM SPECTRAL TO STATION POINT GRADIENTS - SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO - SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO - SPTGPSD TRANSFORM SPECTRAL TO POLAR STEREO GRADIENTS - SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR - SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR - SPTGPMD TRANSFORM SPECTRAL TO MERCATOR GRADIENTS - - Spectral transform utilities - - SPGGET GET GRID-SPACE CONSTANTS - SPWGET GET WAVE-SPACE CONSTANTS - SPLAT COMPUTE LATITUDE FUNCTIONS - SPEPS COMPUTE UTILITY SPECTRAL FIELDS - SPLEGEND COMPUTE LEGENDRE POLYNOMIALS - SPANALY ANALYZE SPECTRAL FROM FOURIER - SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL - SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY - SPUV2DZ COMPUTE DIVERGENCE AND VORTICITY FROM WINDS - SPGRADQ COMPUTE GRADIENT IN SPECTRAL SPACE - SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE - - - - - - - - - - - - - - - - -III. Examples - -Example 1. Interpolate heights and winds from a latlon grid - to two antipodal polar stereographic grids. - Subprograms GETGB and PUTGB from w3lib are referenced. - -c unit number 11 is the input latlon grib file -c unit number 31 is the input latlon grib index file -c unit number 51 is the output northern polar stereographic grib file -c unit number 52 is the output southern polar stereographic grib file -c nominal spectral truncation is r40 -c maximum input gridsize is 360x181 -c maximum number of levels wanted is 12 - parameter(lug=11,lui=31,lun=51,lus=52) - parameter(iromb=1,maxwv=40,jf=360*181,kx=12) - integer kp5(kx),kp6(kx),kp7(kx) - integer kpo(kx) - data kpo/1000,850,700,500,400,300,250,200,150,100,70,50/ -c height - km=12 - kp5=7 - kp6=100 - kp7=kpo - call gs65(lug,lui,lun,lus,jf,km,kp5,kp6,kp7,iromb,maxwv) -c winds - km=12 - kp5=33 - kp6=100 - kp7=kpo - call gv65(lug,lui,lun,lus,jf,km,kp5,kp6,kp7,iromb,maxwv) -c - stop - end -c - subroutine gs65(lug,lui,lun,lus,jf,km,kp5,kp6,kp7,iromb,maxwv) -c interpolates a scalar field using spectral transforms. - integer kp5(km),kp6(km),kp7(km) -c output grids are 65x65 (381 km true at latitide 60). -c nh grid oriented at 280E; sh grid oriented at 100E. - parameter(nph=32,nps=2*nph+1,npq=nps*nps) - parameter(true=60.,xmesh=381.e3,orient=280.) - parameter(rerth=6.3712e6) - parameter(pi=3.14159265358979,dpr=180./pi) - real gn(npq,km),gs(npq,km) - integer jpds(25),jgds(22),kpds(25,km),kgds(22,km) - logical lb(jf) - real f(jf,km) -c - g2=((1.+sin(abs(true)/dpr))*rerth/xmesh)**2 - r2=2*nph**2 - rlatn1=dpr*asin((g2-r2)/(g2+r2)) - rlonn1=mod(orient+315,360.) - rlats1=-rlatn1 - rlons1=mod(rlonn1+270,360.) - jpds=-1 - do k=1,km - jpds(5)=kp5(k) - jpds(6)=kp6(k) - jpds(7)=kp7(k) - j=0 - call getgb(lug,lui,jf,j,jpds,jgds,kf,j,kpds(1,k),kgds(1,k), - & lb,f(1,k),iret) - if(iret.ne.0) call exit(1) - if(mod(kpds(4,k)/64,2).eq.1) call exit(2) - enddo - idrt=kgds(1,1) - imax=kgds(2,1) - jmax=kgds(3,1) -c - call sptruns(iromb,maxwv,idrt,imax,jmax,km,nps, - & 0,0,0,jf,0,0,0,0,true,xmesh,orient,f,gn,gs) -c - do k=1,km - kpds(3,k)=27 - kgds(1,k)=5 - kgds(2,k)=nps - kgds(3,k)=nps - kgds(4,k)=nint(rlatn1*1.e3) - kgds(5,k)=nint(rlonn1*1.e3) - kgds(6,k)=8 - kgds(7,k)=nint(orient*1.e3) - kgds(8,k)=nint(xmesh) - kgds(9,k)=nint(xmesh) - kgds(10,k)=0 - kgds(11,k)=64 - call putgb(lun,npq,kpds(1,k),kgds(1,k),lb,gn(1,k),iret) - enddo - do k=1,km - kpds(3,k)=28 - kgds(1,k)=5 - kgds(2,k)=nps - kgds(3,k)=nps - kgds(4,k)=nint(rlats1*1.e3) - kgds(5,k)=nint(rlons1*1.e3) - kgds(6,k)=8 - kgds(7,k)=nint(mod(orient+180,360.)*1.e3) - kgds(8,k)=nint(xmesh) - kgds(9,k)=nint(xmesh) - kgds(10,k)=128 - kgds(11,k)=64 - call putgb(lus,npq,kpds(1,k),kgds(1,k),lb,gs(1,k),iret) - enddo -c - end -c - subroutine gv65(lug,lui,lun,lus,jf,km,kp5,kp6,kp7,iromb,maxwv) -c interpolates a vector field using spectral transforms. - integer kp5(km),kp6(km),kp7(km) -c output grids are 65x65 (381 km true at latitide 60). -c nh grid oriented at 280E; sh grid oriented at 100E. -c winds are rotated to be relative to grid coordinates. - parameter(nph=32,nps=2*nph+1,npq=nps*nps) - parameter(true=60.,xmesh=381.e3,orient=280.) - parameter(rerth=6.3712e6) - parameter(pi=3.14159265358979,dpr=180./pi) - real un(npq,km),vn(npq,km),us(npq,km),vs(npq,km) - integer jpds(25),jgds(22),kpds(25,km),kgds(22,km) - logical lb(jf) - real u(jf,km),v(jf,km) -c - g2=((1.+sin(abs(true)/dpr))*rerth/xmesh)**2 - r2=2*nph**2 - rlatn1=dpr*asin((g2-r2)/(g2+r2)) - rlonn1=mod(orient+315,360.) - rlats1=-rlatn1 - rlons1=mod(rlonn1+270,360.) - jpds=-1 - do k=1,km - jpds(5)=kp5(k) - jpds(6)=kp6(k) - jpds(7)=kp7(k) - j=0 - call getgb(lug,lui,jf,j,jpds,jgds,kf,j,kpds(1,k),kgds(1,k), - & lb,u(1,k),iret) - if(iret.ne.0) call exit(1) - if(mod(kpds(4,k)/64,2).eq.1) call exit(2) - jpds=kpds(:,k) - jgds=kgds(:,k) - jpds(5)=jpds(5)+1 - j=0 - call getgb(lug,lui,jf,j,jpds,jgds,kf,j,kpds(1,k),kgds(1,k), - & lb,v(1,k),iret) - if(iret.ne.0) call exit(1) - if(mod(kpds(4,k)/64,2).eq.1) call exit(2) - enddo - idrt=kgds(1,1) - imax=kgds(2,1) - jmax=kgds(3,1) -c - call sptrunsv(iromb,maxwv,idrt,imax,jmax,km,nps, - & 0,0,0,jf,0,0,0,0,true,xmesh,orient,u,v, - & .true.,un,vn,us,vs,.false.,dum,dum,dum,dum, - & .false.,dum,dum,dum,dum) -c - do k=1,km - kpds(3,k)=27 - kgds(1,k)=5 - kgds(2,k)=nps - kgds(3,k)=nps - kgds(4,k)=nint(rlatn1*1.e3) - kgds(5,k)=nint(rlonn1*1.e3) - kgds(6,k)=8 - kgds(7,k)=nint(orient*1.e3) - kgds(8,k)=nint(xmesh) - kgds(9,k)=nint(xmesh) - kgds(10,k)=0 - kgds(11,k)=64 - kpds(5,k)=kp5(k) - call putgb(lun,npq,kpds(1,k),kgds(1,k),lb,un(1,k),iret) - enddo - do k=1,km - kpds(3,k)=27 - kgds(1,k)=5 - kgds(2,k)=nps - kgds(3,k)=nps - kgds(4,k)=nint(rlatn1*1.e3) - kgds(5,k)=nint(rlonn1*1.e3) - kgds(6,k)=8 - kgds(7,k)=nint(orient*1.e3) - kgds(8,k)=nint(xmesh) - kgds(9,k)=nint(xmesh) - kgds(10,k)=0 - kgds(11,k)=64 - kpds(5,k)=kp5(k)+1 - call putgb(lun,npq,kpds(1,k),kgds(1,k),lb,vn(1,k),iret) - enddo - do k=1,km - kpds(3,k)=28 - kgds(1,k)=5 - kgds(2,k)=nps - kgds(3,k)=nps - kgds(4,k)=nint(rlats1*1.e3) - kgds(5,k)=nint(rlons1*1.e3) - kgds(6,k)=8 - kgds(7,k)=nint(mod(orient+180,360.)*1.e3) - kgds(8,k)=nint(xmesh) - kgds(9,k)=nint(xmesh) - kgds(10,k)=128 - kgds(11,k)=64 - kpds(5,k)=kp5(k) - call putgb(lus,npq,kpds(1,k),kgds(1,k),lb,us(1,k),iret) - enddo - do k=1,km - kpds(3,k)=28 - kgds(1,k)=5 - kgds(2,k)=nps - kgds(3,k)=nps - kgds(4,k)=nint(rlats1*1.e3) - kgds(5,k)=nint(rlons1*1.e3) - kgds(6,k)=8 - kgds(7,k)=nint(mod(orient+180,360.)*1.e3) - kgds(8,k)=nint(xmesh) - kgds(9,k)=nint(xmesh) - kgds(10,k)=128 - kgds(11,k)=64 - kpds(5,k)=kp5(k)+1 - call putgb(lus,npq,kpds(1,k),kgds(1,k),lb,vs(1,k),iret) - enddo -c - end - -Example 2. Spectrally truncate winds in place on a latlon grid. - -c unit number 11 is the input latlon grib file -c unit number 31 is the input latlon grib index file -c unit number 51 is the output latlon grib file -c nominal spectral truncation is r40 -c maximum input gridsize is 360x181 -c maximum number of levels wanted is 12 - parameter(lug=11,lui=31,luo=51) - parameter(iromb=1,maxwv=40,jf=360*181,kx=12) - integer kp5(kx),kp6(kx),kp7(kx) - integer kpo(kx) - data kpo/1000,850,700,500,400,300,250,200,150,100,70,50/ -c winds - km=12 - kp5=33 - kp6=100 - kp7=kpo - call gvr40(lug,lui,luo,jf,km,kp5,kp6,kp7,iromb,maxwv) -c - stop - end -c - subroutine gvr40(lug,lui,luo,jf,km,kp5,kp6,kp7,iromb,maxwv) -c interpolates a vector field using spectral transforms. - integer kp5(km),kp6(km),kp7(km) - integer jpds(25),jgds(22),kpds(25,km),kgds(22,km) - logical lb(jf) - real u(jf,km),v(jf,km) -c - jpds=-1 - do k=1,km - jpds(5)=kp5(k) - jpds(6)=kp6(k) - jpds(7)=kp7(k) - j=0 - call getgb(lug,lui,jf,j,jpds,jgds,kf,j,kpds(1,k),kgds(1,k), - & lb,u(1,k),iret) - if(iret.ne.0) call exit(1) - if(mod(kpds(4,k)/64,2).eq.1) call exit(2) - jpds=kpds(:,k) - jgds=kgds(:,k) - jpds(5)=jpds(5)+1 - j=0 - call getgb(lug,lui,jf,j,jpds,jgds,kf,j,kpds(1,k),kgds(1,k), - & lb,v(1,k),iret) - if(iret.ne.0) call exit(1) - if(mod(kpds(4,k)/64,2).eq.1) call exit(2) - enddo - idrt=kgds(1,1) - imax=kgds(2,1) - jmax=kgds(3,1) -c - call sptrunv(iromb,maxwv,idrt,imax,jmax,idrt,imax,jmax,km, - & 0,0,0,jf,0,0,jf,0,u,v,.true.,u,v, - & .false.,dum,dum,.false.,dum,dum) -c - do k=1,km - kpds(5,k)=kp5(k) - call putgb(luo,kf,kpds(1,k),kgds(1,k),lb,u(1,k),iret) - enddo - do k=1,km - kpds(5,k)=kp5(k)+1 - call putgb(luo,kf,kpds(1,k),kgds(1,k),lb,v(1,k),iret) - enddo -c - end - -Example 3. Compute latlon temperatures from spectral temperatures and - compute latlon winds from spectral divergence and vorticity. - -c unit number 11 is the input sigma file -c unit number 51 is the output latlon file -c nominal spectral truncation is t62 -c output gridsize is 144x73 -c number of levels is 28 - parameter(iromb=0,maxwv=62) - parameter(idrt=0,im=144,jm=73) - parameter(levs=28) - parameter(mx=(maxwv+1)*((iromb+1)*maxwv+2)/2) - real t(mx,levs),d(mx,levs),z(mx,levs) - real tg(im,jm,km),ug(im,jm,km),vg(im,jm,km) -c temperature - do k=1,4 - read(11) - enddo - do k=1,levs - read(11) (t(m,k),m=1,mx) - enddo - call sptran(iromb,maxwv,idrt,im,jm,levs,0,0,0,0,0,0,0,0,1, - & t,tg(1,1,1),tg(1,jm,1),1) - call sptran( - do k=1,levs - write(51) ((tg(i,j,k),i=1,im),j=1,jm) - enddo -c winds - do k=1,levs - read(11) (d(m,k),m=1,mx) - read(11) (z(m,k),m=1,mx) - enddo - call sptranv(iromb,maxwv,idrt,im,jm,levs,0,0,0,0,0,0,0,0,1, - & d,z,ug(1,1,1),ug(1,jm,1),vg(1,1,1),vg(1,jm,1),1) - do k=1,levs - write(51) ((ug(i,j,k),i=1,im),j=1,jm) - write(51) ((vg(i,j,k),i=1,im),j=1,jm) - enddo - end - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -IV. Docblocks - -The primary documentation of splib is via the docblocks in its subprograms. -The following recapitulation of docblocks is current as of May, 1996. - -Docblock for sptrun. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUN SPECTRALLY TRUNCATE GRIDDED SCALAR FIELDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,IDRTO,IMAXO,JMAXO, -C & KMAX,IPRIME,ISKIPI,JSKIPI,KSKIPI, -C & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDI,GRIDO) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C IDRTO - INTEGER OUTPUT GRID IDENTIFIER -C (IDRTO=4 FOR GAUSSIAN GRID, -C IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES. -C JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPO=0) -C JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXO IF JSKIPO=0) -C KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS -C (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GRIDO - REAL (*) OUTPUT GRID FIELDS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrunv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNV SPECTRALLY TRUNCATE GRIDDED VECTOR FIELDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, -C & IDRTO,IMAXO,JMAXO,KMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI, -C & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDUI,GRIDVI, -C & LUV,GRIDUO,GRIDVO,LDZ,GRIDDO,GRIDZO, -C & LPS,GRIDPO,GRIDSO) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C IDRTO - INTEGER OUTPUT GRID IDENTIFIER -C (IDRTO=4 FOR GAUSSIAN GRID, -C IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES. -C JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPO=0) -C JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXO IF JSKIPO=0) -C KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS -C (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C GRIDUO - REAL (*) OUTPUT U-WINDS IF LUV -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDVO - REAL (*) OUTPUT V-WINDS IF LUV -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDDO - REAL (*) OUTPUT DIVERGENCES IF LDZ -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDZO - REAL (*) OUTPUT VORTICITIES IF LDZ -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDPO - REAL (*) OUTPUT POTENTIALS IF LPS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDSO - REAL (*) OUTPUT STREAMFCNS IF LPS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrung. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNG SPECTRALLY INTERPOLATE SCALARS TO STATIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID AND POINT FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNG(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDI,GP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GP - REAL (*) STATION POINT SETS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrungv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNGV SPECTRALLY INTERPOLATE VECTORS TO STATIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTORS FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID AND POINT FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNGV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDUI,GRIDVI, -C & LUV,UP,VP,LDZ,DP,ZP,LPS,PP,SP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C UP - REAL (*) STATION U-WINDS IF LUV -C VP - REAL (*) STATION V-WINDS IF LUV -C DP - REAL (*) STATION DIVERGENCES IF LDZ -C ZP - REAL (*) STATION VORTICITIES IF LDZ -C PP - REAL (*) STATION POTENTIALS IF LPS -C SP - REAL (*) STATION STREAMFCNS IF LPS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptruns. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNS SPECTRALLY INTERPOLATE SCALARS TO POLAR STEREO -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIC PAIRS OF POLAR STEREOGRAPHIC SCALAR FIELDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNS(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT, -C & GRIDI,GN,GS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GN - REAL (*) NORTHERN POLAR STEREOGRAPHIC FIELDS -C GS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC FIELDS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO. -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrunsv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNSV SPECTRALLY INTERPOLATE VECTORS TO POLAR STEREO -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIC PAIRS OF POLAR STEREOGRAPHIC SCALAR FIELDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNSV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT, -C & GRIDUI,GRIDVI, -C & LUV,UN,VN,US,VS,LDZ,DN,ZN,DS,ZS, -C & LPS,PN,SN,PS,SS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C UN - REAL (*) NORTHERN PS U-WINDS IF LUV -C VN - REAL (*) NORTHERN PS V-WINDS IF LUV -C US - REAL (*) SOUTHERN PS U-WINDS IF LUV -C VS - REAL (*) SOUTHERN PS V-WINDS IF LUV -C DN - REAL (*) NORTHERN DIVERGENCES IF LDZ -C ZN - REAL (*) NORTHERN VORTICITIES IF LDZ -C DS - REAL (*) SOUTHERN DIVERGENCES IF LDZ -C ZS - REAL (*) SOUTHERN VORTICITIES IF LDZ -C PN - REAL (*) NORTHERN POTENTIALS IF LPS -C SN - REAL (*) NORTHERN STREAMFCNS IF LPS -C PS - REAL (*) SOUTHERN POTENTIALS IF LPS -C SS - REAL (*) SOUTHERN STREAMFCNS IF LPS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO. -C SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO. -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrunm. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNM SPECTRALLY INTERPOLATE SCALARS TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNM(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON, -C & GRIDI,GM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GM - REAL (*) MERCATOR FIELDS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrunmv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNMV SPECTRALLY INTERPOLATE VECTORS TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNMV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON, -C & GRIDUI,GRIDVI,LUV,UM,VM,LDZ,DM,ZM,LPS,PM,SM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C UM - REAL (*) MERCATOR U-WINDS IF LUV -C VM - REAL (*) MERCATOR V-WINDS IF LUV -C DM - REAL (*) MERCATOR DIVERGENCES IF LDZ -C ZM - REAL (*) MERCATOR VORTICITIES IF LDZ -C PM - REAL (*) MERCATOR POTENTIALS IF LPS -C SM - REAL (*) MERCATOR STREAMFCNS IF LPS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR -C SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptran. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C AND FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRAN(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, -C & JBEG,JEND,JCPU, -C & WAVE,GRIDN,GRIDS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C ISKIP - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C (DEFAULTS TO 1 IF ISKIP=0) -C JNSKIP - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C (DEFAULTS TO IMAX IF JNSKIP=0) -C JSSKIP - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAX IF JSSKIP=0) -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO IMAX*JMAX IF KGSKIP=0) -C JBEG - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C (DEFAULTS TO 1 IF JBEG=0) -C (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM) -C JEND - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C (DEFAULTS TO (JMAX+1)/2 IF JEND=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVE - REAL (*) WAVE FIELDS IF IDIR>0 -C GRIDN - REAL (*) N.H. GRID FIELDS (STARTING AT JBEG) IF IDIR<0 -C GRIDS - REAL (*) S.H. GRID FIELDS (STARTING AT JBEG) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (*) WAVE FIELDS IF IDIR<0 -C GRIDN - REAL (*) N.H. GRID FIELDS (STARTING AT JBEG) IF IDIR>0 -C GRIDS - REAL (*) S.H. GRID FIELDS (STARTING AT JBEG) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPGGET GET GRID-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPANALY ANALYZE SPECTRAL FROM FOURIER -C RFFTMLT PERFORM FAST FOURIER TRANSFORM -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptranv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C AND VECTOR FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, -C & JBEG,JEND,JCPU, -C & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C ISKIP - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C (DEFAULTS TO 1 IF ISKIP=0) -C JNSKIP - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C (DEFAULTS TO IMAX IF JNSKIP=0) -C JSSKIP - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAX IF JSSKIP=0) -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO IMAX*JMAX IF KGSKIP=0) -C JBEG - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C (DEFAULTS TO 1 IF JBEG=0) -C (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM) -C JEND - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C (DEFAULTS TO (JMAX+1)/2 IF JEND=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR>0 -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS IF IDIR>0 -C GRIDUN - REAL (*) N.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR<0 -C GRIDUS - REAL (*) S.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR<0 -C GRIDVN - REAL (*) N.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR<0 -C GRIDVS - REAL (*) S.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR<0 -C [WAVED=(D(GRIDU)/DLAM+D(CLAT*GRIDV)/DPHI)/(CLAT*RERTH)] -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS IF IDIR<0 -C [WAVEZ=(D(GRIDV)/DLAM-D(CLAT*GRIDU)/DPHI)/(CLAT*RERTH)] -C GRIDUN - REAL (*) N.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR>0 -C GRIDUS - REAL (*) S.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR>0 -C GRIDVN - REAL (*) N.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR>0 -C GRIDVS - REAL (*) S.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPGGET GET GRID-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPANALY ANALYZE SPECTRAL FROM FOURIER -C RFFTMLT PERFORM FAST FOURIER TRANSFORM -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C SPUV2DZ COMPUTE DIVERGENCE AND VORTICITY FROM WINDS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptrand. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C AND THEIR MEANS AND GRADIENTS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, -C & JBEG,JEND,JCPU, -C & WAVE,GRIDMN,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C ISKIP - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C (DEFAULTS TO 1 IF ISKIP=0) -C JNSKIP - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C (DEFAULTS TO IMAX IF JNSKIP=0) -C JSSKIP - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAX IF JSSKIP=0) -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO IMAX*JMAX IF KGSKIP=0) -C JBEG - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C (DEFAULTS TO 1 IF JBEG=0) -C (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM) -C JEND - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C (DEFAULTS TO (JMAX+1)/2 IF JEND=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVE - REAL (*) WAVE FIELDS IF IDIR>0 -C GRIDMN - REAL (KMAX) GLOBAL MEANS IF IDIR<0 -C GRIDXN - REAL (*) N.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C GRIDXS - REAL (*) S.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C GRIDYN - REAL (*) N.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C GRIDYS - REAL (*) S.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (*) WAVE FIELDS IF IDIR<0 -C GRIDMN - REAL (KMAX) GLOBAL MEANS IF IDIR>0 -C GRIDXN - REAL (*) N.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C GRIDXS - REAL (*) S.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C [GRIDX=(D(WAVE)/DLAM)/(CLAT*RERTH)] -C GRIDYN - REAL (*) N.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C GRIDYS - REAL (*) S.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C [GRIDY=(D(WAVE)/DPHI)/RERTH] -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgpt. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVE,GP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GP - REAL (*) STATION POINT SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgptv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO SPECIFIED SETS OF STATION POINT VECTORS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPTV(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVED,WAVEZ,UP,VP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C UP - REAL (*) STATION POINT U-WIND SETS -C VP - REAL (*) STATION POINT V-WIND SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgptd. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPTD TRANSFORM SPECTRAL TO STATION POINT GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C TO SPECIFIED SETS OF STATION POINT GRADIENTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPTD(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVE,XP,YP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C XP - REAL (*) STATION POINT X-GRADIENT SETS -C YP - REAL (*) STATION POINT Y-GRADIENT SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgps. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO. -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SCALAR FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED -C ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. -C -C THE TRANSFORM IS MADE EFFICIENT \ 4 | 5 / -C BY COMBINING POINTS IN EIGHT SECTORS \ | / -C OF EACH POLAR STEREOGRAPHIC GRID, 3 \ | / 6 -C NUMBERED AS IN THE DIAGRAM AT RIGHT. \|/ -C THE POLE AND THE SECTOR BOUNDARIES ----+---- -C ARE TREATED SPECIALLY IN THE CODE. /|\ -C UNFORTUNATELY, THIS APPROACH INDUCES 2 / | \ 7 -C SOME HAIRY INDEXING AND CODE LOQUACITY, / | \ -C FOR WHICH THE DEVELOPER APOLOGIZES. / 1 | 8 \ -C -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPS(IROMB,MAXWV,KMAX,NPS, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & TRUE,XMESH,ORIENT,WAVE,GN,GS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GN - REAL (*) NORTHERN POLAR STEREOGRAPHIC FIELDS -C GS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC FIELDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgpsv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO. -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO VECTOR FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED -C ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. -C THE VECTORS ARE AUTOMATICALLY ROTATED TO BE RESOLVED -C RELATIVE TO THE RESPECTIVE POLAR STEREOGRAPHIC GRIDS. -C -C THE TRANSFORM IS MADE EFFICIENT \ 4 | 5 / -C BY COMBINING POINTS IN EIGHT SECTORS \ | / -C OF EACH POLAR STEREOGRAPHIC GRID, 3 \ | / 6 -C NUMBERED AS IN THE DIAGRAM AT RIGHT. \|/ -C THE POLE AND THE SECTOR BOUNDARIES ----+---- -C ARE TREATED SPECIALLY IN THE CODE. /|\ -C UNFORTUNATELY, THIS APPROACH INDUCES 2 / | \ 7 -C SOME HAIRY INDEXING AND CODE LOQUACITY, / | \ -C FOR WHICH THE DEVELOPER APOLOGIZES. / 1 | 8 \ -C -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPSV(IROMB,MAXWV,KMAX,NPS, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & TRUE,XMESH,ORIENT,WAVED,WAVEZ,UN,VN,US,VS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C UN - REAL (*) NORTHERN POLAR STEREOGRAPHIC U-WINDS -C VN - REAL (*) NORTHERN POLAR STEREOGRAPHIC V-WINDS -C US - REAL (*) SOUTHERN POLAR STEREOGRAPHIC U-WINDS -C VS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC V-WINDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgpsd. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPSD TRANSFORM SPECTRAL TO POLAR STEREO. GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C TO GRADIENT FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED -C ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. -C THE VECTORS ARE AUTOMATICALLY ROTATED TO BE RESOLVED -C RELATIVE TO THE RESPECTIVE POLAR STEREOGRAPHIC GRIDS. -C -C THE TRANSFORM IS MADE EFFICIENT \ 4 | 5 / -C BY COMBINING POINTS IN EIGHT SECTORS \ | / -C OF EACH POLAR STEREOGRAPHIC GRID, 3 \ | / 6 -C NUMBERED AS IN THE DIAGRAM AT RIGHT. \|/ -C THE POLE AND THE SECTOR BOUNDARIES ----+---- -C ARE TREATED SPECIALLY IN THE CODE. /|\ -C UNFORTUNATELY, THIS APPROACH INDUCES 2 / | \ 7 -C SOME HAIRY INDEXING AND CODE LOQUACITY, / | \ -C FOR WHICH THE DEVELOPER APOLOGIZES. / 1 | 8 \ -C -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPSD(IROMB,MAXWV,KMAX,NPS, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & TRUE,XMESH,ORIENT,WAVE,XP,YP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C XN - REAL (*) NORTHERN POLAR STEREOGRAPHIC X-GRADIENTS -C YN - REAL (*) NORTHERN POLAR STEREOGRAPHIC Y-GRADIENTS -C XS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC X-GRADIENTS -C YS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC Y-GRADIENTS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgpm. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SCALAR FIELDS ON A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE MERCATOR GRID IS IDENTIFIED BY THE LOCATION -C OF ITS FIRST POINT AND BY ITS RESPECTIVE INCREMENTS. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & RLAT1,RLON1,DLAT,DLON,WAVE,GM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GM - REAL (*) MERCATOR FIELDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgpmv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO VECTOR FIELDS ON A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE MERCATOR GRID IS IDENTIFIED BY THE LOCATION -C OF ITS FIRST POINT AND BY ITS RESPECTIVE INCREMENTS. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & RLAT1,RLON1,DLAT,DLON,WAVED,WAVEZ,UM,VM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C UM - REAL (*) MERCATOR U-WINDS -C VM - REAL (*) MERCATOR V-WINDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for sptgpmd. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPMD TRANSFORM SPECTRAL TO MERCATOR GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C TO GRADIENT FIELDS ON A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE MERCATOR GRID IS IDENTIFIED BY THE LOCATION -C OF ITS FIRST POINT AND BY ITS RESPECTIVE INCREMENTS. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTGPMD(IROMB,MAXWV,KMAX,MI,MJ, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & RLAT1,RLON1,DLAT,DLON,WAVE,XM,YM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C XM - REAL (*) MERCATOR X-GRADIENTS -C YM - REAL (*) MERCATOR Y-GRADIENTS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for spgget. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPGGET GET GRID-SPACE CONSTANTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM GETS GRID-SPACE CONSTANTS. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPGGET(IDRT,IMAX,JMAX,CLAT,SLAT,WLAT,TRIG,IFAX) -C INPUT ARGUMENTS: -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C OUTPUT ARGUMENTS: -C CLAT - REAL (JMAX) COSINES LATITUDE -C SLAT - REAL (JMAX) SINES LATITUDE -C WLAT - REAL (JMAX) GAUSSIAN WEIGHTS -C TRIG - REAL (2*IMAX) FFT TRIG VALUES -C IFAX - INTEGER (20) FFT FACTORS -C -C SUBPROGRAMS CALLED: -C SPLAT COMPUTE LATITUDE FUNCTIONS -C FFTFAX COMPUTE FFT CONSTANTS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for spwget. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPWGET GET WAVE-SPACE CONSTANTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM GETS WAVE-SPACE CONSTANTS. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C OUTPUT ARGUMENTS: -C EPS - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EPSTOP - REAL (MAXWV+1) -C ENN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C ELONN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EON - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EONTOP - REAL (MAXWV+1) -C -C SUBPROGRAMS CALLED: -C SPEPS COMPUTE UTILITY SPECTRAL FIELDS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for splat. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLAT COMPUTE LATITUDE FUNCTIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-20 -C -C ABSTRACT: COMPUTES COSINES OF COLATITUDE AND GAUSSIAN WEIGHTS -C FOR ONE OF THE FOLLOWING SPECIFIC GLOBAL SETS OF LATITUDES. -C GAUSSIAN LATITUDES (IDRT=4) -C EQUALLY-SPACED LATITUDES INCLUDING POLES (IDRT=0) -C EQUALLY-SPACED LATITUDES EXCLUDING POLES (IDRT=256) -C THE GAUSSIAN LATITUDES ARE LOCATED AT THE ZEROES OF THE -C LEGENDRE POLYNOMIAL OF THE GIVEN ORDER. THESE LATITUDES -C ARE EFFICIENT FOR REVERSIBLE TRANSFORMS FROM SPECTRAL SPACE. -C (ABOUT TWICE AS MANY EQUALLY-SPACED LATITUDES ARE NEEDED.) -C THE WEIGHTS FOR THE EQUALLY-SPACED LATITUDES ARE BASED ON -C ELLSAESSER (JAM,1966). (NO WEIGHT IS GIVEN THE POLE POINT.) -C NOTE THAT WHEN ANALYZING GRID TO SPECTRAL IN LATITUDE PAIRS, -C IF AN EQUATOR POINT EXISTS, ITS WEIGHT SHOULD BE HALVED. -C -C PROGRAM HISTORY LOG: -C 96-02-20 IREDELL -C -C USAGE: CALL SPLAT(IDRT,JMAX,SLAT,WLAT) -C -C INPUT ARGUMENT LIST: -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C JMAX - INTEGER NUMBER OF LATITUDES. -C -C OUTPUT ARGUMENT LIST: -C SLAT - REAL (JMAX) SINES OF LATITUDE. -C WLAT - REAL (JMAX) GAUSSIAN WEIGHTS. -C -C SUBPROGRAMS CALLED: -C MINV SOLVES FULL MATRIX PROBLEM -C -C REMARKS: FORTRAN 90 EXTENSIONS ARE USED. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - -Docblock for speps. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPEPS COMPUTE UTILITY SPECTRAL FIELDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES CONSTANT FIELDS INDEXED IN THE SPECTRAL DOMAIN -C IN "IBM ORDER" (ZONAL WAVENUMBER IS THE SLOWER INDEX). -C IF L IS THE ZONAL WAVENUMBER AND N IS THE TOTAL WAVENUMBER -C AND A IS THE EARTH RADIUS, THEN THE FIELDS RETURNED ARE: -C (1) NORMALIZING FACTOR EPSILON=SQRT((N**2-L**2)/(4*N**2-1)) -C (2) LAPLACIAN FACTOR N*(N+1)/A**2 -C (3) ZONAL DERIVATIVE/LAPLACIAN FACTOR L/(N*(N+1))*A -C (4) MERIDIONAL DERIVATIVE/LAPLACIAN FACTOR EPSILON/N*A -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPEPS(I,M,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C -C OUTPUT ARGUMENT LIST: -C EPS - REAL ((M+1)*((I+1)*M+2)/2) SQRT((N**2-L**2)/(4*N**2-1)) -C EPSTOP - REAL (M+1) SQRT((N**2-L**2)/(4*N**2-1)) OVER TOP -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for splegend. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: EVALUATES THE ORTHONORMAL ASSOCIATED LEGENDRE POLYNOMIALS -C IN THE SPECTRAL DOMAIN AT A GIVEN LATITUDE. -C SUBPROGRAM SPLEGEND SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C AND EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) THEN -C THE FOLLOWING BOOTSTRAPPING FORMULAS ARE USED: -C PLN(0,0)=SQRT(0.5) -C PLN(L,L)=PLN(L-1,L-1)*CLAT*SQRT(FLOAT(2*L+1)/FLOAT(2*L)) -C PLN(L,N)=(SLAT*PLN(L,N-1)-EPS(L,N-1)*PLN(L,N-2))/EPS(L,N) -C SYNTHESIS AT THE POLE NEEDS ONLY TWO ZONAL WAVENUMBERS. -C SCALAR FIELDS ARE SYNTHESIZED WITH ZONAL WAVENUMBER 0 WHILE -C VECTOR FIELDS ARE SYNTHESIZED WITH ZONAL WAVENUMBER 1. -C (THUS POLAR VECTOR FIELDS ARE IMPLICITLY DIVIDED BY CLAT.) -C THE FOLLOWING BOOTSTRAPPING FORMULAS ARE USED AT THE POLE: -C PLN(0,0)=SQRT(0.5) -C PLN(1,1)=SQRT(0.75) -C PLN(L,N)=(PLN(L,N-1)-EPS(L,N-1)*PLN(L,N-2))/EPS(L,N) -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPLEGEND(I,M,SLAT,CLAT,EPS,EPSTOP,PLN,PLNTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C SLAT - REAL SINE OF LATITUDE -C CLAT - REAL COSINE OF LATITUDE -C EPS - REAL ((M+1)*((I+1)*M+2)/2) SQRT((N**2-L**2)/(4*N**2-1)) -C EPSTOP - REAL (M+1) SQRT((N**2-L**2)/(4*N**2-1)) OVER TOP -C -C OUTPUT ARGUMENT LIST: -C PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIAL -C PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for spanaly. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPANALY ANALYZE SPECTRAL FROM FOURIER -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: ANALYZES SPECTRAL COEFFICIENTS FROM FOURIER COEFFICIENTS -C FOR A LATITUDE PAIR (NORTHERN AND SOUTHERN HEMISPHERES). -C VECTOR COMPONENTS ARE MULTIPLIED BY COSINE OF LATITUDE. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C 94-08-01 MARK IREDELL MOVED ZONAL WAVENUMBER LOOP INSIDE -C -C USAGE: CALL SPANALY(I,M,IM,IX,NC,NCTOP,KM,WGT,CLAT,PLN,PLNTOP,MP, -C & F,SPC,SPCTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C IM - INTEGER EVEN NUMBER OF FOURIER COEFFICIENTS -C IX - INTEGER DIMENSION OF FOURIER COEFFICIENTS (IX>=IM+2) -C NC - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS -C (NC>=(M+1)*((I+1)*M+2)) -C NCTOP - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS OVER TOP -C (NCTOP>=2*(M+1)) -C KM - INTEGER NUMBER OF FIELDS -C WGT - REAL GAUSSIAN WEIGHT -C CLAT - REAL COSINE OF LATITUDE -C PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIALS -C PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP -C MP - INTEGER (KM) IDENTIFIERS (0 FOR SCALAR, 1 FOR VECTOR) -C F - REAL (IX,2,KM) FOURIER COEFFICIENTS COMBINED -C SPC - REAL (NC,KM) SPECTRAL COEFFICIENTS -C SPCTOP - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP -C -C OUTPUT ARGUMENT LIST: -C SPC - REAL (NC,KM) SPECTRAL COEFFICIENTS -C SPCTOP - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP -C -C SUBPROGRAMS CALLED: -C SGERX1 CRAY LIBRARY MATRIX RANK 1 UPDATE -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for spsynth. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: SYNTHESIZES FOURIER COEFFICIENTS FROM SPECTRAL COEFFICIENTS -C FOR A LATITUDE PAIR (NORTHERN AND SOUTHERN HEMISPHERES). -C VECTOR COMPONENTS ARE DIVIDED BY COSINE OF LATITUDE. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPSYNTH(I,M,IM,IX,NC,NCTOP,KM,CLAT,PLN,PLNTOP,MP, -C & SPC,SPCTOP,F) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C IM - INTEGER EVEN NUMBER OF FOURIER COEFFICIENTS -C IX - INTEGER DIMENSION OF FOURIER COEFFICIENTS (IX>=IM+2) -C NC - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS -C (NC>=(M+1)*((I+1)*M+2)) -C NCTOP - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS OVER TOP -C (NCTOP>=2*(M+1)) -C KM - INTEGER NUMBER OF FIELDS -C CLAT - REAL COSINE OF LATITUDE -C PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIAL -C PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP -C SPC - REAL (NC,KM) SPECTRAL COEFFICIENTS -C SPCTOP - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP -C MP - INTEGER (KM) IDENTIFIERS (0 FOR SCALAR, 1 FOR VECTOR) -C -C OUTPUT ARGUMENT LIST: -C F - REAL (IX,2,KM) FOURIER COEFFICIENTS FOR LATITUDE PAIR -C -C SUBPROGRAMS CALLED: -C SGEMVX1 CRAY LIBRARY MATRIX TIMES VECTOR -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for spdz2uv. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE WIND COMPONENTS FROM DIVERGENCE AND VORTICITY -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE ZONAL WIND COMPONENT U IS COMPUTED AS -C U(L,N)=-I*L/(N*(N+1))*A*D(L,N) -C +EPS(L,N+1)/(N+1)*A*Z(L,N+1)-EPS(L,N)/N*A*Z(L,N-1) -C AND THE MERIDIONAL WIND COMPONENT V IS COMPUTED AS -C V(L,N)=-I*L/(N*(N+1))*A*Z(L,N) -C -EPS(L,N+1)/(N+1)*A*D(L,N+1)+EPS(L,N)/N*A*D(L,N-1) -C WHERE D IS DIVERGENCE AND Z IS VORTICITY. -C U AND V ARE WEIGHTED BY THE COSINE OF LATITUDE. -C EXTRA TERMS ARE COMPUTED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPDZ2UV(I,M,ENN1,ELONN1,EON,EONTOP,D,Z,U,V,UTOP,VTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C D - REAL ((M+1)*((I+1)*M+2)) DIVERGENCE -C Z - REAL ((M+1)*((I+1)*M+2)) VORTICITY -C -C OUTPUT ARGUMENT LIST: -C U - REAL ((M+1)*((I+1)*M+2)) ZONAL WIND (TIMES COSLAT) -C V - REAL ((M+1)*((I+1)*M+2)) MERID WIND (TIMES COSLAT) -C UTOP - REAL (2*(M+1)) ZONAL WIND (TIMES COSLAT) OVER TOP -C VTOP - REAL (2*(M+1)) MERID WIND (TIMES COSLAT) OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for spuv2dz. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPUV2DZ COMPUTE DIVERGENCE AND VORTICITY FROM WINDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE DIVERGENCE AND VORTICITY FROM WIND COMPONENTS -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE DIVERGENCE D IS COMPUTED AS -C D(L,N)=I*L*A*U(L,N) -C +EPS(L,N+1)*N*A*V(L,N+1)-EPS(L,N)*(N+1)*A*V(L,N-1) -C AND THE VORTICITY Z IS COMPUTED AS -C Z(L,N)=I*L*A*V(L,N) -C -EPS(L,N+1)*N*A*U(L,N+1)+EPS(L,N)*(N+1)*A*U(L,N-1) -C WHERE U IS THE ZONAL WIND AND V IS THE MERIDIONAL WIND. -C U AND V ARE WEIGHTED BY THE SECANT OF LATITUDE. -C EXTRA TERMS ARE USED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPUV2DZ(I,M,ENN1,ELONN1,EON,EONTOP,U,V,UTOP,VTOP,D,Z) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C U - REAL ((M+1)*((I+1)*M+2)) ZONAL WIND (OVER COSLAT) -C V - REAL ((M+1)*((I+1)*M+2)) MERID WIND (OVER COSLAT) -C UTOP - REAL (2*(M+1)) ZONAL WIND (OVER COSLAT) OVER TOP -C VTOP - REAL (2*(M+1)) MERID WIND (OVER COSLAT) OVER TOP -C -C OUTPUT ARGUMENT LIST: -C D - REAL ((M+1)*((I+1)*M+2)) DIVERGENCE -C Z - REAL ((M+1)*((I+1)*M+2)) VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for spgradq. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPGRADQ COMPUTE GRADIENT IN SPECTRAL SPACE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE HORIZONTAL VECTOR GRADIENT OF A SCALAR FIELD -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE ZONAL GRADIENT OF Q(L,N) IS SIMPLY I*L/A*Q(L,N) -C WHILE THE MERIDIONAL GRADIENT OF Q(L,N) IS COMPUTED AS -C EPS(L,N+1)*(N+2)/A*Q(L,N+1)-EPS(L,N+1)*(N-1)/A*Q(L,N-1). -C EXTRA TERMS ARE COMPUTED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPGRADQ(I,M,ENN1,ELONN1,EON,EONTOP,Q,QDX,QDY,QDYTOP) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C Q - REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C -C OUTPUT ARGUMENT LIST: -C QDX - REAL ((M+1)*((I+1)*M+2)) ZONAL GRADIENT (TIMES COSLAT) -C QDY - REAL ((M+1)*((I+1)*M+2)) MERID GRADIENT (TIMES COSLAT) -C QDYTOP - REAL (2*(M+1)) MERID GRADIENT (TIMES COSLAT) OVER TOP -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - -Docblock for splaplac. - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE LAPLACIAN OR THE INVERSE LAPLACIAN -C OF A SCALAR FIELD IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C THE LAPLACIAN OF Q(L,N) IS SIMPLY -N*(N+1)/A**2*Q(L,N) -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPLAPLAC(I,M,ENN1,Q,QD2,IDIR) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C Q - IF IDIR > 0, REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C QD2 - IF IDIR < 0, REAL ((M+1)*((I+1)*M+2)) LAPLACIAN -C IDIR - INTEGER FLAG -C IDIR > 0 TO TAKE LAPLACIAN -C IDIR < 0 TO TAKE INVERSE LAPLACIAN -C -C OUTPUT ARGUMENT LIST: -C Q - IF IDIR < 0, REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C (Q(0,0) IS NOT COMPUTED) -C QD2 - IF IDIR > 0, REAL ((M+1)*((I+1)*M+2)) LAPLACIAN -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ diff --git a/external/sp/v2.0.2/src/sppad.f b/external/sp/v2.0.2/src/sppad.f deleted file mode 100644 index 8d7140d4..00000000 --- a/external/sp/v2.0.2/src/sppad.f +++ /dev/null @@ -1,49 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPPAD(I1,M1,Q1,I2,M2,Q2) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPPAD PAD OR TRUNCATE A SPECTRAL FIELD -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: PAD OR TRUNCATE A SPECTRAL FIELD -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPPAD(I1,M1,Q1,I2,M2,Q2) -C -C INPUT ARGUMENT LIST: -C I1 - INTEGER INPUT SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M1 - INTEGER INPUT SPECTRAL TRUNCATION -C Q1 - REAL ((M+1)*((I+1)*M+2)) INPUT FIELD -C I2 - INTEGER OUTPUT SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M2 - INTEGER OUTPUT SPECTRAL TRUNCATION -C -C OUTPUT ARGUMENT LIST: -C Q2 - REAL ((M+1)*((I+1)*M+2)) OUTPUT FIELD -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN -C -C$$$ - REAL Q1((M1+1)*((I1+1)*M1+2)) - REAL Q2((M2+1)*((I2+1)*M2+2)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DO L=0,M2 - DO N=L,I2*L+M2 - KS2=L*(2*M2+(I2-1)*(L-1))+2*N - IF(L.LE.M1.AND.N.LE.I1*L+M1) THEN - KS1=L*(2*M1+(I1-1)*(L-1))+2*N - Q2(KS2+1)=Q1(KS1+1) - Q2(KS2+2)=Q1(KS1+2) - ELSE - Q2(KS2+1)=0 - Q2(KS2+2)=0 - ENDIF - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/sp/v2.0.2/src/spsynth.f b/external/sp/v2.0.2/src/spsynth.f deleted file mode 100644 index 4f6c0f48..00000000 --- a/external/sp/v2.0.2/src/spsynth.f +++ /dev/null @@ -1,165 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPSYNTH(I,M,IM,IX,NC,NCTOP,KM,CLAT,PLN,PLNTOP,MP, - & SPC,SPCTOP,F) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: SYNTHESIZES FOURIER COEFFICIENTS FROM SPECTRAL COEFFICIENTS -C FOR A LATITUDE PAIR (NORTHERN AND SOUTHERN HEMISPHERES). -C VECTOR COMPONENTS ARE DIVIDED BY COSINE OF LATITUDE. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C 1998-12-18 MARK IREDELL INCLUDE SCALAR AND GRADIENT OPTION -C -C USAGE: CALL SPSYNTH(I,M,IM,IX,NC,NCTOP,KM,CLAT,PLN,PLNTOP,MP, -C & SPC,SPCTOP,F) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C IM - INTEGER EVEN NUMBER OF FOURIER COEFFICIENTS -C IX - INTEGER DIMENSION OF FOURIER COEFFICIENTS (IX>=IM+2) -C NC - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS -C (NC>=(M+1)*((I+1)*M+2)) -C NCTOP - INTEGER DIMENSION OF SPECTRAL COEFFICIENTS OVER TOP -C (NCTOP>=2*(M+1)) -C KM - INTEGER NUMBER OF FIELDS -C CLAT - REAL COSINE OF LATITUDE -C PLN - REAL ((M+1)*((I+1)*M+2)/2) LEGENDRE POLYNOMIAL -C PLNTOP - REAL (M+1) LEGENDRE POLYNOMIAL OVER TOP -C SPC - REAL (NC,KM) SPECTRAL COEFFICIENTS -C SPCTOP - REAL (NCTOP,KM) SPECTRAL COEFFICIENTS OVER TOP -C MP - INTEGER (KM) IDENTIFIERS (0 FOR SCALAR, 1 FOR VECTOR, -C OR 10 FOR SCALAR AND GRADIENT) -C -C OUTPUT ARGUMENT LIST: -C F - REAL (IX,2,KM) FOURIER COEFFICIENTS FOR LATITUDE PAIR -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1) - INTEGER MP(KM) - REAL SPC(NC,KM),SPCTOP(NCTOP,KM) - REAL F(IX,2,KM) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C ZERO OUT FOURIER COEFFICIENTS. - DO K=1,KM - DO L=0,IM/2 - F(2*L+1,1,K)=0. - F(2*L+2,1,K)=0. - F(2*L+1,2,K)=0. - F(2*L+2,2,K)=0. - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SYNTHESIS OVER POLE. -C INITIALIZE FOURIER COEFFICIENTS WITH TERMS OVER TOP OF THE SPECTRUM. -C INITIALIZE EVEN AND ODD POLYNOMIALS SEPARATELY. - IF(CLAT.EQ.0) THEN - LTOPE=MOD(M+1+I,2) -!C$OMP PARALLEL DO PRIVATE(LB,LE,L,KS,KP,N,F1R,F1I) - DO K=1,KM - LB=MP(K) - LE=MP(K) - IF(MP(K).EQ.10) THEN - LB=0 - LE=1 - ENDIF - L=LB - IF(L.EQ.1) THEN - IF(L.EQ.LTOPE) THEN - F(2*L+1,1,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K) - F(2*L+2,1,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K) - ELSE - F(2*L+1,2,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K) - F(2*L+2,2,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K) - ENDIF - ENDIF -C FOR EACH ZONAL WAVENUMBER, SYNTHESIZE TERMS OVER TOTAL WAVENUMBER. -C SYNTHESIZE EVEN AND ODD POLYNOMIALS SEPARATELY. - DO L=LB,LE - KS=L*(2*M+(I-1)*(L-1)) - KP=KS/2+1 - DO N=L,I*L+M,2 - F(2*L+1,1,K)=F(2*L+1,1,K)+PLN(KP+N)*SPC(KS+2*N+1,K) - F(2*L+2,1,K)=F(2*L+2,1,K)+PLN(KP+N)*SPC(KS+2*N+2,K) - ENDDO - DO N=L+1,I*L+M,2 - F(2*L+1,2,K)=F(2*L+1,2,K)+PLN(KP+N)*SPC(KS+2*N+1,K) - F(2*L+2,2,K)=F(2*L+2,2,K)+PLN(KP+N)*SPC(KS+2*N+2,K) - ENDDO -C SEPARATE FOURIER COEFFICIENTS FROM EACH HEMISPHERE. -C ODD POLYNOMIALS CONTRIBUTE NEGATIVELY TO THE SOUTHERN HEMISPHERE. - F1R=F(2*L+1,1,K) - F1I=F(2*L+2,1,K) - F(2*L+1,1,K)=F1R+F(2*L+1,2,K) - F(2*L+2,1,K)=F1I+F(2*L+2,2,K) - F(2*L+1,2,K)=F1R-F(2*L+1,2,K) - F(2*L+2,2,K)=F1I-F(2*L+2,2,K) - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SYNTHESIS OVER FINITE LATITUDE. -C INITIALIZE FOURIER COEFFICIENTS WITH TERMS OVER TOP OF THE SPECTRUM. -C INITIALIZE EVEN AND ODD POLYNOMIALS SEPARATELY. - ELSE - LX=MIN(M,IM/2) - LTOPE=MOD(M+1,2) - LTOPO=1-LTOPE - LE=1+I*LTOPE - LO=2-I*LTOPO -!C$OMP PARALLEL DO PRIVATE(L,KS,KP,N,F1R,F1I) - DO K=1,KM - IF(MP(K).EQ.1) THEN - DO L=LTOPE,LX,2 - F(2*L+1,LE,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K) - F(2*L+2,LE,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K) - ENDDO - DO L=LTOPO,LX,2 - F(2*L+1,LO,K)=PLNTOP(L+1)*SPCTOP(2*L+1,K) - F(2*L+2,LO,K)=PLNTOP(L+1)*SPCTOP(2*L+2,K) - ENDDO - ENDIF -C FOR EACH ZONAL WAVENUMBER, SYNTHESIZE TERMS OVER TOTAL WAVENUMBER. -C SYNTHESIZE EVEN AND ODD POLYNOMIALS SEPARATELY. - DO L=0,LX - KS=L*(2*M+(I-1)*(L-1)) - KP=KS/2+1 - DO N=L,I*L+M,2 - F(2*L+1,1,K)=F(2*L+1,1,K)+PLN(KP+N)*SPC(KS+2*N+1,K) - F(2*L+2,1,K)=F(2*L+2,1,K)+PLN(KP+N)*SPC(KS+2*N+2,K) - ENDDO - DO N=L+1,I*L+M,2 - F(2*L+1,2,K)=F(2*L+1,2,K)+PLN(KP+N)*SPC(KS+2*N+1,K) - F(2*L+2,2,K)=F(2*L+2,2,K)+PLN(KP+N)*SPC(KS+2*N+2,K) - ENDDO - ENDDO -C SEPARATE FOURIER COEFFICIENTS FROM EACH HEMISPHERE. -C ODD POLYNOMIALS CONTRIBUTE NEGATIVELY TO THE SOUTHERN HEMISPHERE. -C DIVIDE VECTOR COMPONENTS BY COSINE LATITUDE. - DO L=0,LX - F1R=F(2*L+1,1,K) - F1I=F(2*L+2,1,K) - F(2*L+1,1,K)=F1R+F(2*L+1,2,K) - F(2*L+2,1,K)=F1I+F(2*L+2,2,K) - F(2*L+1,2,K)=F1R-F(2*L+1,2,K) - F(2*L+2,2,K)=F1I-F(2*L+2,2,K) - ENDDO - IF(MP(K).EQ.1) THEN - DO L=0,LX - F(2*L+1,1,K)=F(2*L+1,1,K)/CLAT - F(2*L+2,1,K)=F(2*L+2,1,K)/CLAT - F(2*L+1,2,K)=F(2*L+1,2,K)/CLAT - F(2*L+2,2,K)=F(2*L+2,2,K)/CLAT - ENDDO - ENDIF - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptez.f b/external/sp/v2.0.2/src/sptez.f deleted file mode 100644 index 68f006c2..00000000 --- a/external/sp/v2.0.2/src/sptez.f +++ /dev/null @@ -1,83 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTEZ(IROMB,MAXWV,IDRT,IMAX,JMAX,WAVE,GRID,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTEZ PERFORM A SIMPLE SCALAR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF A SCALAR QUANTITY -C AND A FIELD ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER'. -C THE GRID FIELD IS INDEXED EAST TO WEST, THEN NORTH TO SOUTH. -C FOR MORE FLEXIBILITY AND EFFICIENCY, CALL SPTRAN. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTEZ(IROMB,MAXWV,IDRT,IMAX,JMAX,WAVE,GRID,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C WAVE - REAL (2*MX) WAVE FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRID - REAL (IMAX,JMAX) GRID FIELD (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (2*MX) WAVE FIELD IF IDIR<0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRID - REAL (IMAX,JMAX) GRID FIELD (E->W,N->S) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANF PERFORM A SCALAR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE((MAXWV+1)*((IROMB+1)*MAXWV+2)) - REAL GRID(IMAX,JMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - IP=1 - IS=1 - JN=IMAX - JS=-JN - KW=2*MX - KG=IMAX*JMAX - JB=1 - JE=(JMAX+1)/2 - JC=NCPUS() -! print *, " EM: SPTEZ:::JJJJJJJJJJJJJJJJJJJCCCCCCCCCCC=" ,JC - IF(IDIR.LT.0) WAVE=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,1, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVE,GRID,GRID(1,JMAX),IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptezd.f b/external/sp/v2.0.2/src/sptezd.f deleted file mode 100644 index d2818bd8..00000000 --- a/external/sp/v2.0.2/src/sptezd.f +++ /dev/null @@ -1,75 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTEZD(IROMB,MAXWV,IDRT,IMAX,JMAX, - & WAVE,GRIDMN,GRIDX,GRIDY,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTEZD PERFORM A SIMPLE GRADIENT SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF A SCALAR FIELD -C AND ITS MEAN AND GRADIENT ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER'. -C THE GRID FIELS IS INDEXED EAST TO WEST, THEN NORTH TO SOUTH. -C FOR MORE FLEXIBILITY AND EFFICIENCY, CALL SPTRAN. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTEZD(IROMB,MAXWV,IDRT,IMAX,JMAX, -C & WAVE,GRIDMN,GRIDX,GRIDY,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C WAVE - REAL (*) WAVE FIELD IF IDIR>0 -C GRIDMN - REAL GLOBAL MEAN IF IDIR<0 -C GRIDX - REAL (IMAX,JMAX) GRID X-GRADIENTS (E->W,N->S) IF IDIR<0 -C GRIDY - REAL (IMAX,JMAX) GRID Y-GRADIENTS (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (*) WAVE FIELD IF IDIR<0 -C GRIDMN - REAL GLOBAL MEAN IF IDIR>0 -C GRIDX - REAL (IMAX,JMAX) GRID X-GRADIENTS (E->W,N->S) IF IDIR>0 -C GRIDY - REAL (IMAX,JMAX) GRID Y-GRADIENTS (E->W,N->S) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),GRIDX(IMAX,JMAX),GRIDY(IMAX,JMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - JC=NCPUS() - CALL SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,1, - & 0,0,0,0,0,0,0,0,JC, - & WAVE,GRIDMN, - & GRIDX,GRIDX(1,JMAX),GRIDY,GRIDY(1,JMAX),1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptezm.f b/external/sp/v2.0.2/src/sptezm.f deleted file mode 100644 index 5e78444a..00000000 --- a/external/sp/v2.0.2/src/sptezm.f +++ /dev/null @@ -1,83 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTEZM(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,WAVE,GRID,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTEZ PERFORM SIMPLE SCALAR SPHERICAL TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS SPHERICAL TRANSFORMS -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C AND FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C WAVE FIELDS ARE IN SEQUENTIAL 'IBM ORDER'. -C GRID FIELDS ARE INDEXED EAST TO WEST, THEN NORTH TO SOUTH. -C FOR MORE FLEXIBILITY AND EFFICIENCY, CALL SPTRAN. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTEZM(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX,WAVE,GRID,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES -C JMAX - INTEGER NUMBER OF LATITUDES -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM -C WAVE - REAL (2*MX,KMAX) WAVE FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRID - REAL (IMAX,JMAX,KMAX) GRID FIELD (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (2*MX,KMAX) WAVE FIELD IF IDIR<0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRID - REAL (IMAX,JMAX,KMAX) GRID FIELD (E->W,N->S) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANF PERFORM A SCALAR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE((MAXWV+1)*((IROMB+1)*MAXWV+2),KMAX) - REAL GRID(IMAX,JMAX,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - IP=1 - IS=1 - JN=IMAX - JS=-JN - KW=2*MX - KG=IMAX*JMAX - JB=1 - JE=(JMAX+1)/2 - JC=NCPUS() - IF(IDIR.LT.0) WAVE=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVE,GRID,GRID(1,JMAX,1),IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptezmd.f b/external/sp/v2.0.2/src/sptezmd.f deleted file mode 100644 index 4c91cf41..00000000 --- a/external/sp/v2.0.2/src/sptezmd.f +++ /dev/null @@ -1,78 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTEZMD(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & WAVE,GRIDMN,GRIDX,GRIDY,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTEZMD PERFORM SIMPLE GRADIENT SPHERICAL TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS SPHERICAL TRANSFORMS -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C AND THEIR MEANS AND GRADIENTS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE FIELDS ARE IN SEQUENTIAL 'IBM ORDER'. -C THE GRID FIELDS ARE INDEXED EAST TO WEST, THEN NORTH TO SOUTH. -C FOR MORE FLEXIBILITY AND EFFICIENCY, CALL SPTRAN. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTEZMD(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & WAVE,GRIDMN,GRIDX,GRIDY,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C WAVE - REAL (MX,KMAX) WAVE FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2) -C GRIDMN - REAL (KMAX) GLOBAL MEAN IF IDIR<0 -C GRIDX - REAL (IMAX,JMAX,KMAX) GRID X-GRADIENTS (E->W,N->S) IF IDIR<0 -C GRIDY - REAL (IMAX,JMAX,KMAX) GRID Y-GRADIENTS (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (MX,KMAX) WAVE FIELD IF IDIR<0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2) -C GRIDMN - REAL (KMAX) GLOBAL MEAN IF IDIR>0 -C GRIDX - REAL (IMAX,JMAX,KMAX) GRID X-GRADIENTS (E->W,N->S) IF IDIR>0 -C GRIDY - REAL (IMAX,JMAX,KMAX) GRID Y-GRADIENTS (E->W,N->S) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE((MAXWV+1)*((IROMB+1)*MAXWV+2),KMAX) - REAL GRIDMN(KMAX),GRIDX(IMAX,JMAX,KMAX),GRIDY(IMAX,JMAX,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - JC=NCPUS() - CALL SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & 0,0,0,0,0,0,0,0,JC, - & WAVE,GRIDMN, - & GRIDX,GRIDX(1,JMAX,1),GRIDY,GRIDY(1,JMAX,1),IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptezmv.f b/external/sp/v2.0.2/src/sptezmv.f deleted file mode 100644 index b33bcaff..00000000 --- a/external/sp/v2.0.2/src/sptezmv.f +++ /dev/null @@ -1,95 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTEZMV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & WAVED,WAVEZ,GRIDU,GRIDV,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTEZVM PERFORM SIMPLE VECTOR SPHERICAL TRANSFORMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS SPHERICAL TRANSFORMS -C BETWEEN SPECTRAL COEFFICIENTS OF DIVERGENCE AND CURL -C AND VECTOR FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C WAVE FIELDS ARE IN SEQUENTIAL 'IBM ORDER'. -C GRID FIELDS ARE INDEXED EAST TO WEST, THEN NORTH TO SOUTH. -C FOR MORE FLEXIBILITY AND EFFICIENCY, CALL SPTRAN. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTEZMV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & WAVED,WAVEZ,GRIDU,GRIDV,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES -C JMAX - INTEGER NUMBER OF LATITUDES -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM -C WAVED - REAL (2*MX,KMAX) WAVE DIVERGENCE FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C WAVEZ - REAL (2*MX,KMAX) WAVE VORTICITY FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRIDU - REAL (IMAX,JMAX,KMAX) GRID U-WIND (E->W,N->S) IF IDIR<0 -C GRIDV - REAL (IMAX,JMAX,KMAX) GRID V-WIND (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVED - REAL (2*MX,KMAX) WAVE DIVERGENCE FIELD IF IDIR<0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C WAVEZ - REAL (2*MX,KMAX) WAVE VORTICITY FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRIDU - REAL (IMAX,JMAX,KMAX) GRID U-WIND (E->W,N->S) IF IDIR>0 -C GRIDV - REAL (IMAX,JMAX,KMAX) GRID V-WIND (E->W,N->S) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANFV PERFORM A VECTOR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVED((MAXWV+1)*((IROMB+1)*MAXWV+2),KMAX) - REAL WAVEZ((MAXWV+1)*((IROMB+1)*MAXWV+2),KMAX) - REAL GRIDU(IMAX,JMAX,KMAX) - REAL GRIDV(IMAX,JMAX,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - IP=1 - IS=1 - JN=IMAX - JS=-JN - KW=2*MX - KG=IMAX*JMAX - JB=1 - JE=(JMAX+1)/2 - JC=NCPUS() - IF(IDIR.LT.0) WAVED=0 - IF(IDIR.LT.0) WAVEZ=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVED,WAVEZ, - & GRIDU,GRIDU(1,JMAX,1),GRIDV,GRIDV(1,JMAX,1),IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptezv.f b/external/sp/v2.0.2/src/sptezv.f deleted file mode 100644 index 97fadcdd..00000000 --- a/external/sp/v2.0.2/src/sptezv.f +++ /dev/null @@ -1,94 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTEZV(IROMB,MAXWV,IDRT,IMAX,JMAX, - & WAVED,WAVEZ,GRIDU,GRIDV,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTEZV PERFORM A SIMPLE VECTOR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF DIVERGENCE AND CURL -C AND A VECTOR FIELD ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER'. -C THE GRID FIELS IS INDEXED EAST TO WEST, THEN NORTH TO SOUTH. -C FOR MORE FLEXIBILITY AND EFFICIENCY, CALL SPTRAN. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTEZV(IROMB,MAXWV,IDRT,IMAX,JMAX, -C & WAVED,WAVEZ,GRIDU,GRIDV,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C WAVED - REAL (2*MX) WAVE DIVERGENCE FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C WAVEZ - REAL (2*MX) WAVE VORTICITY FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRIDU - REAL (IMAX,JMAX) GRID U-WIND (E->W,N->S) IF IDIR<0 -C GRIDV - REAL (IMAX,JMAX) GRID V-WIND (E->W,N->S) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVED - REAL (2*MX) WAVE DIVERGENCE FIELD IF IDIR<0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C WAVEZ - REAL (2*MX) WAVE VORTICITY FIELD IF IDIR>0 -C WHERE MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 -C GRIDU - REAL (IMAX,JMAX) GRID U-WIND (E->W,N->S) IF IDIR>0 -C GRIDV - REAL (IMAX,JMAX) GRID V-WIND (E->W,N->S) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANFV PERFORM A VECTOR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVED((MAXWV+1)*((IROMB+1)*MAXWV+2)) - REAL WAVEZ((MAXWV+1)*((IROMB+1)*MAXWV+2)) - REAL GRIDU(IMAX,JMAX) - REAL GRIDV(IMAX,JMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - IP=1 - IS=1 - JN=IMAX - JS=-JN - KW=2*MX - KG=IMAX*JMAX - JB=1 - JE=(JMAX+1)/2 - JC=NCPUS() - IF(IDIR.LT.0) WAVED=0 - IF(IDIR.LT.0) WAVEZ=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,1, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVED,WAVEZ, - & GRIDU,GRIDU(1,JMAX),GRIDV,GRIDV(1,JMAX),IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptgpm.f b/external/sp/v2.0.2/src/sptgpm.f deleted file mode 100644 index c1ad5513..00000000 --- a/external/sp/v2.0.2/src/sptgpm.f +++ /dev/null @@ -1,137 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPM(IROMB,MAXWV,KMAX,MI,MJ, - & KWSKIP,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WAVE,GM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SCALAR FIELDS ON A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE MERCATOR GRID IS IDENTIFIED BY THE LOCATION -C OF ITS FIRST POINT AND BY ITS RESPECTIVE INCREMENTS. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & RLAT1,RLON1,DLAT,DLON,WAVE,GM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GM - REAL (*) MERCATOR FIELDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),GM(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(KMAX) - REAL WTOP(2*(MAXWV+1),KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+3,2,KMAX) - REAL CLAT(MJ),SLAT(MJ),CLON(MAXWV,MI),SLON(MAXWV,MI) - PARAMETER(RERTH=6.3712E6) - PARAMETER(PI=3.14159265358979,DPR=180./PI) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - IDIM=2*MAXWV+3 - KW=KWSKIP - KG=KGSKIP - NI=NISKIP - NJ=NJSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=MI*MJ - IF(NI.EQ.0) NI=1 - IF(NJ.EQ.0) NJ=MI - DO I=1,MI - RLON=MOD(RLON1+DLON*(I-1)+3600,360.) - DO L=1,MAXWV - CLON(L,I)=COS(L*RLON/DPR) - SLON(L,I)=SIN(L*RLON/DPR) - ENDDO - ENDDO - YE=1-LOG(TAN((RLAT1+90)/2/DPR))*DPR/DLAT - DO J=1,MJ - RLAT=ATAN(EXP(DLAT/DPR*(J-YE)))*2*DPR-90 - CLAT(J)=COS(RLAT/DPR) - SLAT(J)=SIN(RLAT/DPR) - ENDDO - MP=0 -C$OMP PARALLEL DO - DO K=1,KMAX - WTOP(1:2*MXTOP,K)=0 - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM TO GRID -C$OMP PARALLEL DO PRIVATE(PLN,PLNTOP,F,IJK) - DO J=1,MJ - CALL SPLEGEND(IROMB,MAXWV,SLAT(J),CLAT(J),EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX, - & CLAT(J),PLN,PLNTOP,MP,WAVE,WTOP,F) - DO K=1,KMAX - DO I=1,MI - IJK=(I-1)*NI+(J-1)*NJ+(K-1)*KG+1 - GM(IJK)=F(1,1,K) - ENDDO - DO L=1,MAXWV - DO I=1,MI - IJK=(I-1)*NI+(J-1)*NJ+(K-1)*KG+1 - GM(IJK)=GM(IJK)+2.*(F(2*L+1,1,K)*CLON(L,I) - & -F(2*L+2,1,K)*SLON(L,I)) - ENDDO - ENDDO - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptgpmd.f b/external/sp/v2.0.2/src/sptgpmd.f deleted file mode 100644 index e083ce48..00000000 --- a/external/sp/v2.0.2/src/sptgpmd.f +++ /dev/null @@ -1,96 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPMD(IROMB,MAXWV,KMAX,MI,MJ, - & KWSKIP,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WAVE,XM,YM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPMD TRANSFORM SPECTRAL TO MERCATOR GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C TO GRADIENT FIELDS ON A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE MERCATOR GRID IS IDENTIFIED BY THE LOCATION -C OF ITS FIRST POINT AND BY ITS RESPECTIVE INCREMENTS. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPMD(IROMB,MAXWV,KMAX,MI,MJ, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & RLAT1,RLON1,DLAT,DLON,WAVE,XM,YM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C XM - REAL (*) MERCATOR X-GRADIENTS -C YM - REAL (*) MERCATOR Y-GRADIENTS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),XM(*),YM(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - KW=KWSKIP - IF(KW.EQ.0) KW=2*MX -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE GRADIENTS -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),1) - WZ(1:2*MX,K)=0. - ENDDO - CALL SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WD,WZ,XM,YM) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptgpmv.f b/external/sp/v2.0.2/src/sptgpmv.f deleted file mode 100644 index 317ac6a3..00000000 --- a/external/sp/v2.0.2/src/sptgpmv.f +++ /dev/null @@ -1,152 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ, - & KWSKIP,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WAVED,WAVEZ,UM,VM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO VECTOR FIELDS ON A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE MERCATOR GRID IS IDENTIFIED BY THE LOCATION -C OF ITS FIRST POINT AND BY ITS RESPECTIVE INCREMENTS. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & RLAT1,RLON1,DLAT,DLON,WAVED,WAVEZ,UM,VM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C UM - REAL (*) MERCATOR U-WINDS -C VM - REAL (*) MERCATOR V-WINDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVED(*),WAVEZ(*),UM(*),VM(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(2*KMAX) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,2*KMAX) - REAL WTOP(2*(MAXWV+1),2*KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+3,2,2*KMAX) - REAL CLAT(MJ),SLAT(MJ),CLON(MAXWV,MI),SLON(MAXWV,MI) - PARAMETER(RERTH=6.3712E6) - PARAMETER(PI=3.14159265358979,DPR=180./PI) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - MDIM=2*MX+1 - IDIM=2*MAXWV+3 - KW=KWSKIP - KG=KGSKIP - NI=NISKIP - NJ=NJSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=MI*MJ - IF(NI.EQ.0) NI=1 - IF(NJ.EQ.0) NJ=MI - DO I=1,MI - RLON=MOD(RLON1+DLON*(I-1)+3600,360.) - DO L=1,MAXWV - CLON(L,I)=COS(L*RLON/DPR) - SLON(L,I)=SIN(L*RLON/DPR) - ENDDO - ENDDO - YE=1-LOG(TAN((RLAT1+90)/2/DPR))*DPR/DLAT - DO J=1,MJ - RLAT=ATAN(EXP(DLAT/DPR*(J-YE)))*2*DPR-90 - CLAT(J)=COS(RLAT/DPR) - SLAT(J)=SIN(RLAT/DPR) - ENDDO - MP=1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE SPECTRAL WINDS -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP, - & WAVED(KWS+1),WAVEZ(KWS+1), - & W(1,K),W(1,KMAX+K),WTOP(1,K),WTOP(1,KMAX+K)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM TO GRID -C$OMP PARALLEL DO PRIVATE(PLN,PLNTOP,F,KU,KV,IJK) - DO J=1,MJ - CALL SPLEGEND(IROMB,MAXWV,SLAT(J),CLAT(J),EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT(J),PLN,PLNTOP,MP,W,WTOP,F) - DO K=1,KMAX - KU=K - KV=K+KMAX - DO I=1,MI - IJK=(I-1)*NI+(J-1)*NJ+(K-1)*KG+1 - UM(IJK)=F(1,1,KU) - VM(IJK)=F(1,1,KV) - ENDDO - DO L=1,MAXWV - DO I=1,MI - IJK=(I-1)*NI+(J-1)*NJ+(K-1)*KG+1 - UM(IJK)=UM(IJK)+2.*(F(2*L+1,1,KU)*CLON(L,I) - & -F(2*L+2,1,KU)*SLON(L,I)) - VM(IJK)=VM(IJK)+2.*(F(2*L+1,1,KV)*CLON(L,I) - & -F(2*L+2,1,KV)*SLON(L,I)) - ENDDO - ENDDO - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptgps.f b/external/sp/v2.0.2/src/sptgps.f deleted file mode 100644 index 867fc711..00000000 --- a/external/sp/v2.0.2/src/sptgps.f +++ /dev/null @@ -1,540 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPS(IROMB,MAXWV,KMAX,NPS, - & KWSKIP,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WAVE,GN,GS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO. -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SCALAR FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED -C ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. -C -C THE TRANSFORM IS MADE EFFICIENT \ 4 | 5 / -C BY COMBINING POINTS IN EIGHT SECTORS \ | / -C OF EACH POLAR STEREOGRAPHIC GRID, 3 \ | / 6 -C NUMBERED AS IN THE DIAGRAM AT RIGHT. \|/ -C THE POLE AND THE SECTOR BOUNDARIES ----+---- -C ARE TREATED SPECIALLY IN THE CODE. /|\ -C UNFORTUNATELY, THIS APPROACH INDUCES 2 / | \ 7 -C SOME HAIRY INDEXING AND CODE LOQUACITY, / | \ -C FOR WHICH THE DEVELOPER APOLOGIZES. / 1 | 8 \ -C -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPS(IROMB,MAXWV,KMAX,NPS, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & TRUE,XMESH,ORIENT,WAVE,GN,GS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GN - REAL (*) NORTHERN POLAR STEREOGRAPHIC FIELDS -C GS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC FIELDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),GN(*),GS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(KMAX) - REAL SLON(MAXWV,8),CLON(MAXWV,8),SROT(0:3),CROT(0:3) - REAL WTOP(2*(MAXWV+1),KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+3,2,KMAX) - DATA SROT/0.,1.,0.,-1./,CROT/1.,0.,-1.,0./ - PARAMETER(RERTH=6.3712E6) - PARAMETER(PI=3.14159265358979,DPR=180./PI) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - IDIM=2*MAXWV+3 - KW=KWSKIP - KG=KGSKIP - NI=NISKIP - NJ=NJSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=NPS*NPS - IF(NI.EQ.0) NI=1 - IF(NJ.EQ.0) NJ=NPS - MP=0 - NPH=(NPS-1)/2 - GQ=((1.+SIN(TRUE/DPR))*RERTH/XMESH)**2 -C$OMP PARALLEL DO - DO K=1,KMAX - WTOP(1:2*MXTOP,K)=0 - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE POLE POINT - I1=NPH+1 - J1=NPH+1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - SLAT1=1. - CLAT1=0. - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX, - & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F) -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - GN(IJK1)=F(1,1,K) - GS(IJK1)=F(1,2,K) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE POINTS ALONG THE ROW AND COLUMN OF THE POLE, -C STARTING AT THE ORIENTATION LONGITUDE AND GOING CLOCKWISE. -C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8) -C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8) -C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8) -C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,LR,LI) - DO J1=1,NPH - I1=NPH+1 - RADLON=ORIENT/DPR - J3=NPS+1-I1 - I3=J1 - J5=NPS+1-J1 - I5=NPS+1-I1 - J7=I1 - I7=NPS+1-J1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - IJ3=(I3-1)*NI+(J3-1)*NJ+1 - IJ5=(I5-1)*NI+(J5-1)*NJ+1 - IJ7=(I7-1)*NI+(J7-1)*NJ+1 - DI1=I1-NPH-1 - DJ1=J1-NPH-1 - RQ=DI1**2+DJ1**2 - SLAT1=(GQ-RQ)/(GQ+RQ) - CLAT1=SQRT(1.-SLAT1**2) - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX, - & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F) - DO L=1,MAXWV - SLON(L,1)=SIN(L*RADLON) - CLON(L,1)=COS(L*RADLON) - SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4)) - & -CLON(L,1)*SROT(MOD(1*L,4)) - CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4)) - & +SLON(L,1)*SROT(MOD(1*L,4)) - SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4)) - & -CLON(L,1)*SROT(MOD(2*L,4)) - CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4)) - & +SLON(L,1)*SROT(MOD(2*L,4)) - SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4)) - & -CLON(L,1)*SROT(MOD(3*L,4)) - CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4)) - & +SLON(L,1)*SROT(MOD(3*L,4)) - ENDDO -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - GN(IJK1)=F(1,1,K) - GN(IJK3)=F(1,1,K) - GN(IJK5)=F(1,1,K) - GN(IJK7)=F(1,1,K) - GS(IJK1)=F(1,2,K) - GS(IJK3)=F(1,2,K) - GS(IJK5)=F(1,2,K) - GS(IJK7)=F(1,2,K) - ENDDO - IF(KMAX.EQ.1) THEN - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 - GN(IJ1)=GN(IJ1)+2*(F(LR,1,1)*CLON(L,1) - & -F(LI,1,1)*SLON(L,1)) - GN(IJ3)=GN(IJ3)+2*(F(LR,1,1)*CLON(L,3) - & -F(LI,1,1)*SLON(L,3)) - GN(IJ5)=GN(IJ5)+2*(F(LR,1,1)*CLON(L,5) - & -F(LI,1,1)*SLON(L,5)) - GN(IJ7)=GN(IJ7)+2*(F(LR,1,1)*CLON(L,7) - & -F(LI,1,1)*SLON(L,7)) - GS(IJ1)=GS(IJ1)+2*(F(LR,2,1)*CLON(L,5) - & -F(LI,2,1)*SLON(L,5)) - GS(IJ3)=GS(IJ3)+2*(F(LR,2,1)*CLON(L,3) - & -F(LI,2,1)*SLON(L,3)) - GS(IJ5)=GS(IJ5)+2*(F(LR,2,1)*CLON(L,1) - & -F(LI,2,1)*SLON(L,1)) - GS(IJ7)=GS(IJ7)+2*(F(LR,2,1)*CLON(L,7) - & -F(LI,2,1)*SLON(L,7)) - ENDDO - ELSE - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - GN(IJK1)=GN(IJK1)+2*(F(LR,1,K)*CLON(L,1) - & -F(LI,1,K)*SLON(L,1)) - GN(IJK3)=GN(IJK3)+2*(F(LR,1,K)*CLON(L,3) - & -F(LI,1,K)*SLON(L,3)) - GN(IJK5)=GN(IJK5)+2*(F(LR,1,K)*CLON(L,5) - & -F(LI,1,K)*SLON(L,5)) - GN(IJK7)=GN(IJK7)+2*(F(LR,1,K)*CLON(L,7) - & -F(LI,1,K)*SLON(L,7)) - GS(IJK1)=GS(IJK1)+2*(F(LR,2,K)*CLON(L,5) - & -F(LI,2,K)*SLON(L,5)) - GS(IJK3)=GS(IJK3)+2*(F(LR,2,K)*CLON(L,3) - & -F(LI,2,K)*SLON(L,3)) - GS(IJK5)=GS(IJK5)+2*(F(LR,2,K)*CLON(L,1) - & -F(LI,2,K)*SLON(L,1)) - GS(IJK7)=GS(IJK7)+2*(F(LR,2,K)*CLON(L,7) - & -F(LI,2,K)*SLON(L,7)) - ENDDO - ENDDO - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE POINTS ON THE MAIN DIAGONALS THROUGH THE POLE, -C STARTING CLOCKWISE OF THE ORIENTATION LONGITUDE AND GOING CLOCKWISE. -C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8) -C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8) -C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8) -C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,LR,LI) - DO J1=1,NPH - I1=J1 - RADLON=(ORIENT-45)/DPR - J3=NPS+1-I1 - I3=J1 - J5=NPS+1-J1 - I5=NPS+1-I1 - J7=I1 - I7=NPS+1-J1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - IJ3=(I3-1)*NI+(J3-1)*NJ+1 - IJ5=(I5-1)*NI+(J5-1)*NJ+1 - IJ7=(I7-1)*NI+(J7-1)*NJ+1 - DI1=I1-NPH-1 - DJ1=J1-NPH-1 - RQ=DI1**2+DJ1**2 - SLAT1=(GQ-RQ)/(GQ+RQ) - CLAT1=SQRT(1.-SLAT1**2) - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX, - & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F) - DO L=1,MAXWV - SLON(L,1)=SIN(L*RADLON) - CLON(L,1)=COS(L*RADLON) - SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4)) - & -CLON(L,1)*SROT(MOD(1*L,4)) - CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4)) - & +SLON(L,1)*SROT(MOD(1*L,4)) - SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4)) - & -CLON(L,1)*SROT(MOD(2*L,4)) - CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4)) - & +SLON(L,1)*SROT(MOD(2*L,4)) - SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4)) - & -CLON(L,1)*SROT(MOD(3*L,4)) - CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4)) - & +SLON(L,1)*SROT(MOD(3*L,4)) - ENDDO -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - GN(IJK1)=F(1,1,K) - GN(IJK3)=F(1,1,K) - GN(IJK5)=F(1,1,K) - GN(IJK7)=F(1,1,K) - GS(IJK1)=F(1,2,K) - GS(IJK3)=F(1,2,K) - GS(IJK5)=F(1,2,K) - GS(IJK7)=F(1,2,K) - ENDDO - IF(KMAX.EQ.1) THEN - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 - GN(IJ1)=GN(IJ1)+2*(F(LR,1,1)*CLON(L,1) - & -F(LI,1,1)*SLON(L,1)) - GN(IJ3)=GN(IJ3)+2*(F(LR,1,1)*CLON(L,3) - & -F(LI,1,1)*SLON(L,3)) - GN(IJ5)=GN(IJ5)+2*(F(LR,1,1)*CLON(L,5) - & -F(LI,1,1)*SLON(L,5)) - GN(IJ7)=GN(IJ7)+2*(F(LR,1,1)*CLON(L,7) - & -F(LI,1,1)*SLON(L,7)) - GS(IJ1)=GS(IJ1)+2*(F(LR,2,1)*CLON(L,3) - & -F(LI,2,1)*SLON(L,3)) - GS(IJ3)=GS(IJ3)+2*(F(LR,2,1)*CLON(L,1) - & -F(LI,2,1)*SLON(L,1)) - GS(IJ5)=GS(IJ5)+2*(F(LR,2,1)*CLON(L,7) - & -F(LI,2,1)*SLON(L,7)) - GS(IJ7)=GS(IJ7)+2*(F(LR,2,1)*CLON(L,5) - & -F(LI,2,1)*SLON(L,5)) - ENDDO - ELSE - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - GN(IJK1)=GN(IJK1)+2*(F(LR,1,K)*CLON(L,1) - & -F(LI,1,K)*SLON(L,1)) - GN(IJK3)=GN(IJK3)+2*(F(LR,1,K)*CLON(L,3) - & -F(LI,1,K)*SLON(L,3)) - GN(IJK5)=GN(IJK5)+2*(F(LR,1,K)*CLON(L,5) - & -F(LI,1,K)*SLON(L,5)) - GN(IJK7)=GN(IJK7)+2*(F(LR,1,K)*CLON(L,7) - & -F(LI,1,K)*SLON(L,7)) - GS(IJK1)=GS(IJK1)+2*(F(LR,2,K)*CLON(L,3) - & -F(LI,2,K)*SLON(L,3)) - GS(IJK3)=GS(IJK3)+2*(F(LR,2,K)*CLON(L,1) - & -F(LI,2,K)*SLON(L,1)) - GS(IJK5)=GS(IJK5)+2*(F(LR,2,K)*CLON(L,7) - & -F(LI,2,K)*SLON(L,7)) - GS(IJK7)=GS(IJK7)+2*(F(LR,2,K)*CLON(L,5) - & -F(LI,2,K)*SLON(L,5)) - ENDDO - ENDDO - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE THE REMAINDER OF THE POLAR STEREOGRAPHIC DOMAIN, -C STARTING AT THE SECTOR JUST CLOCKWISE OF THE ORIENTATION LONGITUDE -C AND GOING CLOCKWISE UNTIL ALL EIGHT SECTORS ARE DONE. -C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8) -C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8) -C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8) -C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,LR,LI) - DO J1=1,NPH-1 - DO I1=J1+1,NPH - J2=I1 - I2=J1 - J3=NPS+1-I1 - I3=J1 - J4=NPS+1-J1 - I4=I1 - J5=NPS+1-J1 - I5=NPS+1-I1 - J6=NPS+1-I1 - I6=NPS+1-J1 - J7=I1 - I7=NPS+1-J1 - J8=J1 - I8=NPS+1-I1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - IJ2=(I2-1)*NI+(J2-1)*NJ+1 - IJ3=(I3-1)*NI+(J3-1)*NJ+1 - IJ4=(I4-1)*NI+(J4-1)*NJ+1 - IJ5=(I5-1)*NI+(J5-1)*NJ+1 - IJ6=(I6-1)*NI+(J6-1)*NJ+1 - IJ7=(I7-1)*NI+(J7-1)*NJ+1 - IJ8=(I8-1)*NI+(J8-1)*NJ+1 - DI1=I1-NPH-1 - DJ1=J1-NPH-1 - RQ=DI1**2+DJ1**2 - SLAT1=(GQ-RQ)/(GQ+RQ) - CLAT1=SQRT(1.-SLAT1**2) - RADLON1=ORIENT/DPR+ATAN(-DI1/DJ1) - RADLON2=(ORIENT-45)/DPR*2-RADLON1 - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX, - & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F) - DO L=1,MAXWV - SLON(L,1)=SIN(L*RADLON1) - CLON(L,1)=COS(L*RADLON1) - SLON(L,2)=SIN(L*RADLON2) - CLON(L,2)=COS(L*RADLON2) - SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4)) - & -CLON(L,1)*SROT(MOD(1*L,4)) - CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4)) - & +SLON(L,1)*SROT(MOD(1*L,4)) - SLON(L,4)=SLON(L,2)*CROT(MOD(1*L,4)) - & -CLON(L,2)*SROT(MOD(1*L,4)) - CLON(L,4)=CLON(L,2)*CROT(MOD(1*L,4)) - & +SLON(L,2)*SROT(MOD(1*L,4)) - SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4)) - & -CLON(L,1)*SROT(MOD(2*L,4)) - CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4)) - & +SLON(L,1)*SROT(MOD(2*L,4)) - SLON(L,6)=SLON(L,2)*CROT(MOD(2*L,4)) - & -CLON(L,2)*SROT(MOD(2*L,4)) - CLON(L,6)=CLON(L,2)*CROT(MOD(2*L,4)) - & +SLON(L,2)*SROT(MOD(2*L,4)) - SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4)) - & -CLON(L,1)*SROT(MOD(3*L,4)) - CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4)) - & +SLON(L,1)*SROT(MOD(3*L,4)) - SLON(L,8)=SLON(L,2)*CROT(MOD(3*L,4)) - & -CLON(L,2)*SROT(MOD(3*L,4)) - CLON(L,8)=CLON(L,2)*CROT(MOD(3*L,4)) - & +SLON(L,2)*SROT(MOD(3*L,4)) - ENDDO -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - IJK2=IJ2+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK4=IJ4+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK6=IJ6+(K-1)*KG - IJK7=IJ7+(K-1)*KG - IJK8=IJ8+(K-1)*KG - GN(IJK1)=F(1,1,K) - GN(IJK2)=F(1,1,K) - GN(IJK3)=F(1,1,K) - GN(IJK4)=F(1,1,K) - GN(IJK5)=F(1,1,K) - GN(IJK6)=F(1,1,K) - GN(IJK7)=F(1,1,K) - GN(IJK8)=F(1,1,K) - GS(IJK1)=F(1,2,K) - GS(IJK2)=F(1,2,K) - GS(IJK3)=F(1,2,K) - GS(IJK4)=F(1,2,K) - GS(IJK5)=F(1,2,K) - GS(IJK6)=F(1,2,K) - GS(IJK7)=F(1,2,K) - GS(IJK8)=F(1,2,K) - ENDDO - IF(KMAX.EQ.1) THEN - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 - GN(IJ1)=GN(IJ1)+2*(F(LR,1,1)*CLON(L,1) - & -F(LI,1,1)*SLON(L,1)) - GN(IJ2)=GN(IJ2)+2*(F(LR,1,1)*CLON(L,2) - & -F(LI,1,1)*SLON(L,2)) - GN(IJ3)=GN(IJ3)+2*(F(LR,1,1)*CLON(L,3) - & -F(LI,1,1)*SLON(L,3)) - GN(IJ4)=GN(IJ4)+2*(F(LR,1,1)*CLON(L,4) - & -F(LI,1,1)*SLON(L,4)) - GN(IJ5)=GN(IJ5)+2*(F(LR,1,1)*CLON(L,5) - & -F(LI,1,1)*SLON(L,5)) - GN(IJ6)=GN(IJ6)+2*(F(LR,1,1)*CLON(L,6) - & -F(LI,1,1)*SLON(L,6)) - GN(IJ7)=GN(IJ7)+2*(F(LR,1,1)*CLON(L,7) - & -F(LI,1,1)*SLON(L,7)) - GN(IJ8)=GN(IJ8)+2*(F(LR,1,1)*CLON(L,8) - & -F(LI,1,1)*SLON(L,8)) - GS(IJ1)=GS(IJ1)+2*(F(LR,2,1)*CLON(L,4) - & -F(LI,2,1)*SLON(L,4)) - GS(IJ2)=GS(IJ2)+2*(F(LR,2,1)*CLON(L,3) - & -F(LI,2,1)*SLON(L,3)) - GS(IJ3)=GS(IJ3)+2*(F(LR,2,1)*CLON(L,2) - & -F(LI,2,1)*SLON(L,2)) - GS(IJ4)=GS(IJ4)+2*(F(LR,2,1)*CLON(L,1) - & -F(LI,2,1)*SLON(L,1)) - GS(IJ5)=GS(IJ5)+2*(F(LR,2,1)*CLON(L,8) - & -F(LI,2,1)*SLON(L,8)) - GS(IJ6)=GS(IJ6)+2*(F(LR,2,1)*CLON(L,7) - & -F(LI,2,1)*SLON(L,7)) - GS(IJ7)=GS(IJ7)+2*(F(LR,2,1)*CLON(L,6) - & -F(LI,2,1)*SLON(L,6)) - GS(IJ8)=GS(IJ8)+2*(F(LR,2,1)*CLON(L,5) - & -F(LI,2,1)*SLON(L,5)) - ENDDO - ELSE - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 -CDIR$ IVDEP - DO K=1,KMAX - IJK1=IJ1+(K-1)*KG - IJK2=IJ2+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK4=IJ4+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK6=IJ6+(K-1)*KG - IJK7=IJ7+(K-1)*KG - IJK8=IJ8+(K-1)*KG - GN(IJK1)=GN(IJK1)+2*(F(LR,1,K)*CLON(L,1) - & -F(LI,1,K)*SLON(L,1)) - GN(IJK2)=GN(IJK2)+2*(F(LR,1,K)*CLON(L,2) - & -F(LI,1,K)*SLON(L,2)) - GN(IJK3)=GN(IJK3)+2*(F(LR,1,K)*CLON(L,3) - & -F(LI,1,K)*SLON(L,3)) - GN(IJK4)=GN(IJK4)+2*(F(LR,1,K)*CLON(L,4) - & -F(LI,1,K)*SLON(L,4)) - GN(IJK5)=GN(IJK5)+2*(F(LR,1,K)*CLON(L,5) - & -F(LI,1,K)*SLON(L,5)) - GN(IJK6)=GN(IJK6)+2*(F(LR,1,K)*CLON(L,6) - & -F(LI,1,K)*SLON(L,6)) - GN(IJK7)=GN(IJK7)+2*(F(LR,1,K)*CLON(L,7) - & -F(LI,1,K)*SLON(L,7)) - GN(IJK8)=GN(IJK8)+2*(F(LR,1,K)*CLON(L,8) - & -F(LI,1,K)*SLON(L,8)) - GS(IJK1)=GS(IJK1)+2*(F(LR,2,K)*CLON(L,4) - & -F(LI,2,K)*SLON(L,4)) - GS(IJK2)=GS(IJK2)+2*(F(LR,2,K)*CLON(L,3) - & -F(LI,2,K)*SLON(L,3)) - GS(IJK3)=GS(IJK3)+2*(F(LR,2,K)*CLON(L,2) - & -F(LI,2,K)*SLON(L,2)) - GS(IJK4)=GS(IJK4)+2*(F(LR,2,K)*CLON(L,1) - & -F(LI,2,K)*SLON(L,1)) - GS(IJK5)=GS(IJK5)+2*(F(LR,2,K)*CLON(L,8) - & -F(LI,2,K)*SLON(L,8)) - GS(IJK6)=GS(IJK6)+2*(F(LR,2,K)*CLON(L,7) - & -F(LI,2,K)*SLON(L,7)) - GS(IJK7)=GS(IJK7)+2*(F(LR,2,K)*CLON(L,6) - & -F(LI,2,K)*SLON(L,6)) - GS(IJK8)=GS(IJK8)+2*(F(LR,2,K)*CLON(L,5) - & -F(LI,2,K)*SLON(L,5)) - ENDDO - ENDDO - ENDIF - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptgpsd.f b/external/sp/v2.0.2/src/sptgpsd.f deleted file mode 100644 index 25a9eccc..00000000 --- a/external/sp/v2.0.2/src/sptgpsd.f +++ /dev/null @@ -1,104 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPSD(IROMB,MAXWV,KMAX,NPS, - & KWSKIP,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WAVE,XN,YN,XS,YS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPSD TRANSFORM SPECTRAL TO POLAR STEREO. GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C TO GRADIENT FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED -C ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. -C THE VECTORS ARE AUTOMATICALLY ROTATED TO BE RESOLVED -C RELATIVE TO THE RESPECTIVE POLAR STEREOGRAPHIC GRIDS. -C -C THE TRANSFORM IS MADE EFFICIENT \ 4 | 5 / -C BY COMBINING POINTS IN EIGHT SECTORS \ | / -C OF EACH POLAR STEREOGRAPHIC GRID, 3 \ | / 6 -C NUMBERED AS IN THE DIAGRAM AT RIGHT. \|/ -C THE POLE AND THE SECTOR BOUNDARIES ----+---- -C ARE TREATED SPECIALLY IN THE CODE. /|\ -C UNFORTUNATELY, THIS APPROACH INDUCES 2 / | \ 7 -C SOME HAIRY INDEXING AND CODE LOQUACITY, / | \ -C FOR WHICH THE DEVELOPER APOLOGIZES. / 1 | 8 \ -C -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPSD(IROMB,MAXWV,KMAX,NPS, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & TRUE,XMESH,ORIENT,WAVE,XP,YP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C XN - REAL (*) NORTHERN POLAR STEREOGRAPHIC X-GRADIENTS -C YN - REAL (*) NORTHERN POLAR STEREOGRAPHIC Y-GRADIENTS -C XS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC X-GRADIENTS -C YS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC Y-GRADIENTS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),XN(*),YN(*),XS(*),YS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - KW=KWSKIP - IF(KW.EQ.0) KW=2*MX -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE GRADIENTS -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),1) - WZ(1:2*MX,K)=0. - ENDDO - CALL SPTGPSV(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WD,WZ,XN,YN,XS,YS) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptgpsv.f b/external/sp/v2.0.2/src/sptgpsv.f deleted file mode 100644 index 0ac11601..00000000 --- a/external/sp/v2.0.2/src/sptgpsv.f +++ /dev/null @@ -1,931 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPSV(IROMB,MAXWV,KMAX,NPS, - & KWSKIP,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WAVED,WAVEZ,UN,VN,US,VS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO. -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO VECTOR FIELDS ON A PAIR OF POLAR STEREOGRAPHIC GRIDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TWO SQUARE POLAR STEREOGRAPHIC GRIDS ARE CENTERED -C ON THE RESPECTIVE POLES, WITH THE ORIENTATION LONGITUDE -C OF THE SOUTHERN HEMISPHERE GRID 180 DEGREES OPPOSITE -C THAT OF THE NORTHERN HEMISPHERE GRID. -C THE VECTORS ARE AUTOMATICALLY ROTATED TO BE RESOLVED -C RELATIVE TO THE RESPECTIVE POLAR STEREOGRAPHIC GRIDS. -C -C THE TRANSFORM IS MADE EFFICIENT \ 4 | 5 / -C BY COMBINING POINTS IN EIGHT SECTORS \ | / -C OF EACH POLAR STEREOGRAPHIC GRID, 3 \ | / 6 -C NUMBERED AS IN THE DIAGRAM AT RIGHT. \|/ -C THE POLE AND THE SECTOR BOUNDARIES ----+---- -C ARE TREATED SPECIALLY IN THE CODE. /|\ -C UNFORTUNATELY, THIS APPROACH INDUCES 2 / | \ 7 -C SOME HAIRY INDEXING AND CODE LOQUACITY, / | \ -C FOR WHICH THE DEVELOPER APOLOGIZES. / 1 | 8 \ -C -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER SECTOR POINTS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPSV(IROMB,MAXWV,KMAX,NPS, -C & KWSKIP,KGSKIP,NISKIP,NJSKIP, -C & TRUE,XMESH,ORIENT,WAVED,WAVEZ,UN,VN,US,VS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C UN - REAL (*) NORTHERN POLAR STEREOGRAPHIC U-WINDS -C VN - REAL (*) NORTHERN POLAR STEREOGRAPHIC V-WINDS -C US - REAL (*) SOUTHERN POLAR STEREOGRAPHIC U-WINDS -C VS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC V-WINDS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVED(*),WAVEZ(*),UN(*),VN(*),US(*),VS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(2*KMAX) - REAL SLON(MAXWV,8),CLON(MAXWV,8),SROT(0:3),CROT(0:3) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,2*KMAX) - REAL WTOP(2*(MAXWV+1),2*KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+3,2,2*KMAX) - DATA SROT/0.,1.,0.,-1./,CROT/1.,0.,-1.,0./ - PARAMETER(RERTH=6.3712E6) - PARAMETER(PI=3.14159265358979,DPR=180./PI) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - MDIM=2*MX+1 - IDIM=2*MAXWV+3 - KW=KWSKIP - KG=KGSKIP - NI=NISKIP - NJ=NJSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=NPS*NPS - IF(NI.EQ.0) NI=1 - IF(NJ.EQ.0) NJ=NPS - MP=1 - NPH=(NPS-1)/2 - GQ=((1.+SIN(TRUE/DPR))*RERTH/XMESH)**2 - SRH=SQRT(0.5) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE SPECTRAL WINDS -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP, - & WAVED(KWS+1),WAVEZ(KWS+1), - & W(1,K),W(1,KMAX+K),WTOP(1,K),WTOP(1,KMAX+K)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE POLE POINT - I1=NPH+1 - J1=NPH+1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - SLAT1=1. - CLAT1=0. - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - COSO=COS(ORIENT/DPR) - SINO=SIN(ORIENT/DPR) -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - UN(IJK1)=2*( COSO*F(3,1,KU)+SINO*F(3,1,KV)) - VN(IJK1)=2*(-SINO*F(3,1,KU)+COSO*F(3,1,KV)) - US(IJK1)=2*( COSO*F(3,2,KU)-SINO*F(3,2,KV)) - VS(IJK1)=2*( SINO*F(3,2,KU)+COSO*F(3,2,KV)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE POINTS ALONG THE ROW AND COLUMN OF THE POLE, -C STARTING AT THE ORIENTATION LONGITUDE AND GOING CLOCKWISE. -C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8) -C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8) -C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8) -C$OMP& PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI) - DO J1=1,NPH - I1=NPH+1 - RADLON=ORIENT/DPR - J3=NPS+1-I1 - I3=J1 - J5=NPS+1-J1 - I5=NPS+1-I1 - J7=I1 - I7=NPS+1-J1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - IJ3=(I3-1)*NI+(J3-1)*NJ+1 - IJ5=(I5-1)*NI+(J5-1)*NJ+1 - IJ7=(I7-1)*NI+(J7-1)*NJ+1 - DI1=I1-NPH-1 - DJ1=J1-NPH-1 - RQ=DI1**2+DJ1**2 - SLAT1=(GQ-RQ)/(GQ+RQ) - CLAT1=SQRT(1.-SLAT1**2) - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - DO L=1,MAXWV - SLON(L,1)=SIN(L*RADLON) - CLON(L,1)=COS(L*RADLON) - SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4)) - & -CLON(L,1)*SROT(MOD(1*L,4)) - CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4)) - & +SLON(L,1)*SROT(MOD(1*L,4)) - SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4)) - & -CLON(L,1)*SROT(MOD(2*L,4)) - CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4)) - & +SLON(L,1)*SROT(MOD(2*L,4)) - SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4)) - & -CLON(L,1)*SROT(MOD(3*L,4)) - CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4)) - & +SLON(L,1)*SROT(MOD(3*L,4)) - ENDDO -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - UN(IJK1)= F(1,1,KU) - VN(IJK1)= F(1,1,KV) - UN(IJK3)= F(1,1,KV) - VN(IJK3)=-F(1,1,KU) - UN(IJK5)=-F(1,1,KU) - VN(IJK5)=-F(1,1,KV) - UN(IJK7)=-F(1,1,KV) - VN(IJK7)= F(1,1,KU) - US(IJK1)=-F(1,2,KU) - VS(IJK1)=-F(1,2,KV) - US(IJK3)=-F(1,2,KV) - VS(IJK3)= F(1,2,KU) - US(IJK5)= F(1,2,KU) - VS(IJK5)= F(1,2,KV) - US(IJK7)= F(1,2,KV) - VS(IJK7)=-F(1,2,KU) - ENDDO - IF(KMAX.EQ.1) THEN - KU=1 - KV=2 - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 - UN(IJ1)=UN(IJ1)+2*(F(LR,1,KU)*CLON(L,1) - & -F(LI,1,KU)*SLON(L,1)) - VN(IJ1)=VN(IJ1)+2*(F(LR,1,KV)*CLON(L,1) - & -F(LI,1,KV)*SLON(L,1)) - UN(IJ3)=UN(IJ3)+2*(F(LR,1,KV)*CLON(L,3) - & -F(LI,1,KV)*SLON(L,3)) - VN(IJ3)=VN(IJ3)-2*(F(LR,1,KU)*CLON(L,3) - & -F(LI,1,KU)*SLON(L,3)) - UN(IJ5)=UN(IJ5)-2*(F(LR,1,KU)*CLON(L,5) - & -F(LI,1,KU)*SLON(L,5)) - VN(IJ5)=VN(IJ5)-2*(F(LR,1,KV)*CLON(L,5) - & -F(LI,1,KV)*SLON(L,5)) - UN(IJ7)=UN(IJ7)-2*(F(LR,1,KV)*CLON(L,7) - & -F(LI,1,KV)*SLON(L,7)) - VN(IJ7)=VN(IJ7)+2*(F(LR,1,KU)*CLON(L,7) - & -F(LI,1,KU)*SLON(L,7)) - US(IJ1)=US(IJ1)-2*(F(LR,2,KU)*CLON(L,5) - & -F(LI,2,KU)*SLON(L,5)) - VS(IJ1)=VS(IJ1)-2*(F(LR,2,KV)*CLON(L,5) - & -F(LI,2,KV)*SLON(L,5)) - US(IJ3)=US(IJ3)-2*(F(LR,2,KV)*CLON(L,3) - & -F(LI,2,KV)*SLON(L,3)) - VS(IJ3)=VS(IJ3)+2*(F(LR,2,KU)*CLON(L,3) - & -F(LI,2,KU)*SLON(L,3)) - US(IJ5)=US(IJ5)+2*(F(LR,2,KU)*CLON(L,1) - & -F(LI,2,KU)*SLON(L,1)) - VS(IJ5)=VS(IJ5)+2*(F(LR,2,KV)*CLON(L,1) - & -F(LI,2,KV)*SLON(L,1)) - US(IJ7)=US(IJ7)+2*(F(LR,2,KV)*CLON(L,7) - & -F(LI,2,KV)*SLON(L,7)) - VS(IJ7)=VS(IJ7)-2*(F(LR,2,KU)*CLON(L,7) - & -F(LI,2,KU)*SLON(L,7)) - ENDDO - ELSE - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - UN(IJK1)=UN(IJK1)+2*(F(LR,1,KU)*CLON(L,1) - & -F(LI,1,KU)*SLON(L,1)) - VN(IJK1)=VN(IJK1)+2*(F(LR,1,KV)*CLON(L,1) - & -F(LI,1,KV)*SLON(L,1)) - UN(IJK3)=UN(IJK3)+2*(F(LR,1,KV)*CLON(L,3) - & -F(LI,1,KV)*SLON(L,3)) - VN(IJK3)=VN(IJK3)-2*(F(LR,1,KU)*CLON(L,3) - & -F(LI,1,KU)*SLON(L,3)) - UN(IJK5)=UN(IJK5)-2*(F(LR,1,KU)*CLON(L,5) - & -F(LI,1,KU)*SLON(L,5)) - VN(IJK5)=VN(IJK5)-2*(F(LR,1,KV)*CLON(L,5) - & -F(LI,1,KV)*SLON(L,5)) - UN(IJK7)=UN(IJK7)-2*(F(LR,1,KV)*CLON(L,7) - & -F(LI,1,KV)*SLON(L,7)) - VN(IJK7)=VN(IJK7)+2*(F(LR,1,KU)*CLON(L,7) - & -F(LI,1,KU)*SLON(L,7)) - US(IJK1)=US(IJK1)-2*(F(LR,2,KU)*CLON(L,5) - & -F(LI,2,KU)*SLON(L,5)) - VS(IJK1)=VS(IJK1)-2*(F(LR,2,KV)*CLON(L,5) - & -F(LI,2,KV)*SLON(L,5)) - US(IJK3)=US(IJK3)-2*(F(LR,2,KV)*CLON(L,3) - & -F(LI,2,KV)*SLON(L,3)) - VS(IJK3)=VS(IJK3)+2*(F(LR,2,KU)*CLON(L,3) - & -F(LI,2,KU)*SLON(L,3)) - US(IJK5)=US(IJK5)+2*(F(LR,2,KU)*CLON(L,1) - & -F(LI,2,KU)*SLON(L,1)) - VS(IJK5)=VS(IJK5)+2*(F(LR,2,KV)*CLON(L,1) - & -F(LI,2,KV)*SLON(L,1)) - US(IJK7)=US(IJK7)+2*(F(LR,2,KV)*CLON(L,7) - & -F(LI,2,KV)*SLON(L,7)) - VS(IJK7)=VS(IJK7)-2*(F(LR,2,KU)*CLON(L,7) - & -F(LI,2,KU)*SLON(L,7)) - ENDDO - ENDDO - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE POINTS ON THE MAIN DIAGONALS THROUGH THE POLE, -C STARTING CLOCKWISE OF THE ORIENTATION LONGITUDE AND GOING CLOCKWISE. -C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8) -C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8) -C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8) -C$OMP& PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI) - DO J1=1,NPH - I1=J1 - RADLON=(ORIENT-45)/DPR - J3=NPS+1-I1 - I3=J1 - J5=NPS+1-J1 - I5=NPS+1-I1 - J7=I1 - I7=NPS+1-J1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - IJ3=(I3-1)*NI+(J3-1)*NJ+1 - IJ5=(I5-1)*NI+(J5-1)*NJ+1 - IJ7=(I7-1)*NI+(J7-1)*NJ+1 - DI1=I1-NPH-1 - DJ1=J1-NPH-1 - RQ=DI1**2+DJ1**2 - SLAT1=(GQ-RQ)/(GQ+RQ) - CLAT1=SQRT(1.-SLAT1**2) - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - DO L=1,MAXWV - SLON(L,1)=SIN(L*RADLON) - CLON(L,1)=COS(L*RADLON) - SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4)) - & -CLON(L,1)*SROT(MOD(1*L,4)) - CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4)) - & +SLON(L,1)*SROT(MOD(1*L,4)) - SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4)) - & -CLON(L,1)*SROT(MOD(2*L,4)) - CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4)) - & +SLON(L,1)*SROT(MOD(2*L,4)) - SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4)) - & -CLON(L,1)*SROT(MOD(3*L,4)) - CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4)) - & +SLON(L,1)*SROT(MOD(3*L,4)) - ENDDO -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - UN(IJK1)=SRH*( F(1,1,KU)+F(1,1,KV)) - VN(IJK1)=SRH*(-F(1,1,KU)+F(1,1,KV)) - UN(IJK3)=SRH*(-F(1,1,KU)+F(1,1,KV)) - VN(IJK3)=SRH*(-F(1,1,KU)-F(1,1,KV)) - UN(IJK5)=SRH*(-F(1,1,KU)-F(1,1,KV)) - VN(IJK5)=SRH*( F(1,1,KU)-F(1,1,KV)) - UN(IJK7)=SRH*( F(1,1,KU)-F(1,1,KV)) - VN(IJK7)=SRH*( F(1,1,KU)+F(1,1,KV)) - US(IJK1)=SRH*(-F(1,2,KU)-F(1,2,KV)) - VS(IJK1)=SRH*( F(1,2,KU)-F(1,2,KV)) - US(IJK3)=SRH*( F(1,2,KU)-F(1,2,KV)) - VS(IJK3)=SRH*( F(1,2,KU)+F(1,2,KV)) - US(IJK5)=SRH*( F(1,2,KU)+F(1,2,KV)) - VS(IJK5)=SRH*(-F(1,2,KU)+F(1,2,KV)) - US(IJK7)=SRH*(-F(1,2,KU)+F(1,2,KV)) - VS(IJK7)=SRH*(-F(1,2,KU)-F(1,2,KV)) - ENDDO - IF(KMAX.EQ.1) THEN - KU=1 - KV=2 - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 - UN(IJ1)=UN(IJ1)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,1) - & -( F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,1)) - VN(IJ1)=VN(IJ1)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,1) - & -(-F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,1)) - UN(IJ3)=UN(IJ3)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,3) - & -(-F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,3)) - VN(IJ3)=VN(IJ3)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,3) - & -(-F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,3)) - UN(IJ5)=UN(IJ5)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,5) - & -(-F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,5)) - VN(IJ5)=VN(IJ5)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,5) - & -( F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,5)) - UN(IJ7)=UN(IJ7)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,7) - & -( F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,7)) - VN(IJ7)=VN(IJ7)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,7) - & -( F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,7)) - US(IJ1)=US(IJ1)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,3) - & -(-F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,3)) - VS(IJ1)=VS(IJ1)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,3) - & -( F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,3)) - US(IJ3)=US(IJ3)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,1) - & -( F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,1)) - VS(IJ3)=VS(IJ3)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,1) - & -( F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,1)) - US(IJ5)=US(IJ5)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,7) - & -( F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,7)) - VS(IJ5)=VS(IJ5)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,7) - & -(-F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,7)) - US(IJ7)=US(IJ7)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,5) - & -(-F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,5)) - VS(IJ7)=VS(IJ7)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,5) - & -(-F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,5)) - ENDDO - ELSE - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK7=IJ7+(K-1)*KG - UN(IJK1)=UN(IJK1)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,1) - & -( F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,1)) - VN(IJK1)=VN(IJK1)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,1) - & -(-F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,1)) - UN(IJK3)=UN(IJK3)+2*SRH*((-F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,3) - & -(-F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,3)) - VN(IJK3)=VN(IJK3)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,3) - & -(-F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,3)) - UN(IJK5)=UN(IJK5)+2*SRH*((-F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,5) - & -(-F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,5)) - VN(IJK5)=VN(IJK5)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,5) - & -( F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,5)) - UN(IJK7)=UN(IJK7)+2*SRH*(( F(LR,1,KU)-F(LR,1,KV)) - & *CLON(L,7) - & -( F(LI,1,KU)-F(LI,1,KV)) - & *SLON(L,7)) - VN(IJK7)=VN(IJK7)+2*SRH*(( F(LR,1,KU)+F(LR,1,KV)) - & *CLON(L,7) - & -( F(LI,1,KU)+F(LI,1,KV)) - & *SLON(L,7)) - US(IJK1)=US(IJK1)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,3) - & -(-F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,3)) - VS(IJK1)=VS(IJK1)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,3) - & -( F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,3)) - US(IJK3)=US(IJK3)+2*SRH*(( F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,1) - & -( F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,1)) - VS(IJK3)=VS(IJK3)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,1) - & -( F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,1)) - US(IJK5)=US(IJK5)+2*SRH*(( F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,7) - & -( F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,7)) - VS(IJK5)=VS(IJK5)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,7) - & -(-F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,7)) - US(IJK7)=US(IJK7)+2*SRH*((-F(LR,2,KU)+F(LR,2,KV)) - & *CLON(L,5) - & -(-F(LI,2,KU)+F(LI,2,KV)) - & *SLON(L,5)) - VS(IJK7)=VS(IJK7)+2*SRH*((-F(LR,2,KU)-F(LR,2,KV)) - & *CLON(L,5) - & -(-F(LI,2,KU)-F(LI,2,KV)) - & *SLON(L,5)) - ENDDO - ENDDO - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE THE REMAINDER OF THE POLAR STEREOGRAPHIC DOMAIN, -C STARTING AT THE SECTOR JUST CLOCKWISE OF THE ORIENTATION LONGITUDE -C AND GOING CLOCKWISE UNTIL ALL EIGHT SECTORS ARE DONE. -C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8) -C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8) -C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8) -C$OMP& PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI) - DO J1=1,NPH-1 - DO I1=J1+1,NPH - J2=I1 - I2=J1 - J3=NPS+1-I1 - I3=J1 - J4=NPS+1-J1 - I4=I1 - J5=NPS+1-J1 - I5=NPS+1-I1 - J6=NPS+1-I1 - I6=NPS+1-J1 - J7=I1 - I7=NPS+1-J1 - J8=J1 - I8=NPS+1-I1 - IJ1=(I1-1)*NI+(J1-1)*NJ+1 - IJ2=(I2-1)*NI+(J2-1)*NJ+1 - IJ3=(I3-1)*NI+(J3-1)*NJ+1 - IJ4=(I4-1)*NI+(J4-1)*NJ+1 - IJ5=(I5-1)*NI+(J5-1)*NJ+1 - IJ6=(I6-1)*NI+(J6-1)*NJ+1 - IJ7=(I7-1)*NI+(J7-1)*NJ+1 - IJ8=(I8-1)*NI+(J8-1)*NJ+1 - DI1=I1-NPH-1 - DJ1=J1-NPH-1 - RQ=DI1**2+DJ1**2 - RR=SQRT(1/RQ) - SLAT1=(GQ-RQ)/(GQ+RQ) - CLAT1=SQRT(1.-SLAT1**2) - RADLON1=ORIENT/DPR+ATAN(-DI1/DJ1) - RADLON2=(ORIENT-45)/DPR*2-RADLON1 - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - DO L=1,MAXWV - SLON(L,1)=SIN(L*RADLON1) - CLON(L,1)=COS(L*RADLON1) - SLON(L,2)=SIN(L*RADLON2) - CLON(L,2)=COS(L*RADLON2) - SLON(L,3)=SLON(L,1)*CROT(MOD(1*L,4)) - & -CLON(L,1)*SROT(MOD(1*L,4)) - CLON(L,3)=CLON(L,1)*CROT(MOD(1*L,4)) - & +SLON(L,1)*SROT(MOD(1*L,4)) - SLON(L,4)=SLON(L,2)*CROT(MOD(1*L,4)) - & -CLON(L,2)*SROT(MOD(1*L,4)) - CLON(L,4)=CLON(L,2)*CROT(MOD(1*L,4)) - & +SLON(L,2)*SROT(MOD(1*L,4)) - SLON(L,5)=SLON(L,1)*CROT(MOD(2*L,4)) - & -CLON(L,1)*SROT(MOD(2*L,4)) - CLON(L,5)=CLON(L,1)*CROT(MOD(2*L,4)) - & +SLON(L,1)*SROT(MOD(2*L,4)) - SLON(L,6)=SLON(L,2)*CROT(MOD(2*L,4)) - & -CLON(L,2)*SROT(MOD(2*L,4)) - CLON(L,6)=CLON(L,2)*CROT(MOD(2*L,4)) - & +SLON(L,2)*SROT(MOD(2*L,4)) - SLON(L,7)=SLON(L,1)*CROT(MOD(3*L,4)) - & -CLON(L,1)*SROT(MOD(3*L,4)) - CLON(L,7)=CLON(L,1)*CROT(MOD(3*L,4)) - & +SLON(L,1)*SROT(MOD(3*L,4)) - SLON(L,8)=SLON(L,2)*CROT(MOD(3*L,4)) - & -CLON(L,2)*SROT(MOD(3*L,4)) - CLON(L,8)=CLON(L,2)*CROT(MOD(3*L,4)) - & +SLON(L,2)*SROT(MOD(3*L,4)) - ENDDO -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - IJK2=IJ2+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK4=IJ4+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK6=IJ6+(K-1)*KG - IJK7=IJ7+(K-1)*KG - IJK8=IJ8+(K-1)*KG - UN(IJK1)=RR*(-DJ1*F(1,1,KU)-DI1*F(1,1,KV)) - VN(IJK1)=RR*( DI1*F(1,1,KU)-DJ1*F(1,1,KV)) - UN(IJK2)=RR*(-DI1*F(1,1,KU)-DJ1*F(1,1,KV)) - VN(IJK2)=RR*( DJ1*F(1,1,KU)-DI1*F(1,1,KV)) - UN(IJK3)=RR*( DI1*F(1,1,KU)-DJ1*F(1,1,KV)) - VN(IJK3)=RR*( DJ1*F(1,1,KU)+DI1*F(1,1,KV)) - UN(IJK4)=RR*( DJ1*F(1,1,KU)-DI1*F(1,1,KV)) - VN(IJK4)=RR*( DI1*F(1,1,KU)+DJ1*F(1,1,KV)) - UN(IJK5)=RR*( DJ1*F(1,1,KU)+DI1*F(1,1,KV)) - VN(IJK5)=RR*(-DI1*F(1,1,KU)+DJ1*F(1,1,KV)) - UN(IJK6)=RR*( DI1*F(1,1,KU)+DJ1*F(1,1,KV)) - VN(IJK6)=RR*(-DJ1*F(1,1,KU)+DI1*F(1,1,KV)) - UN(IJK7)=RR*(-DI1*F(1,1,KU)+DJ1*F(1,1,KV)) - VN(IJK7)=RR*(-DJ1*F(1,1,KU)-DI1*F(1,1,KV)) - UN(IJK8)=RR*(-DJ1*F(1,1,KU)+DI1*F(1,1,KV)) - VN(IJK8)=RR*(-DI1*F(1,1,KU)-DJ1*F(1,1,KV)) - US(IJK1)=RR*( DJ1*F(1,2,KU)+DI1*F(1,2,KV)) - VS(IJK1)=RR*(-DI1*F(1,2,KU)+DJ1*F(1,2,KV)) - US(IJK2)=RR*( DI1*F(1,2,KU)+DJ1*F(1,2,KV)) - VS(IJK2)=RR*(-DJ1*F(1,2,KU)+DI1*F(1,2,KV)) - US(IJK3)=RR*(-DI1*F(1,2,KU)+DJ1*F(1,2,KV)) - VS(IJK3)=RR*(-DJ1*F(1,2,KU)-DI1*F(1,2,KV)) - US(IJK4)=RR*(-DJ1*F(1,2,KU)+DI1*F(1,2,KV)) - VS(IJK4)=RR*(-DI1*F(1,2,KU)-DJ1*F(1,2,KV)) - US(IJK5)=RR*(-DJ1*F(1,2,KU)-DI1*F(1,2,KV)) - VS(IJK5)=RR*( DI1*F(1,2,KU)-DJ1*F(1,2,KV)) - US(IJK6)=RR*(-DI1*F(1,2,KU)-DJ1*F(1,2,KV)) - VS(IJK6)=RR*( DJ1*F(1,2,KU)-DI1*F(1,2,KV)) - US(IJK7)=RR*( DI1*F(1,2,KU)-DJ1*F(1,2,KV)) - VS(IJK7)=RR*( DJ1*F(1,2,KU)+DI1*F(1,2,KV)) - US(IJK8)=RR*( DJ1*F(1,2,KU)-DI1*F(1,2,KV)) - VS(IJK8)=RR*( DI1*F(1,2,KU)+DJ1*F(1,2,KV)) - ENDDO - IF(KMAX.EQ.1) THEN - KU=1 - KV=2 - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 - UN(IJ1)=UN(IJ1)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,1) - & -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,1)) - VN(IJ1)=VN(IJ1)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,1) - & -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,1)) - UN(IJ2)=UN(IJ2)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,2) - & -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,2)) - VN(IJ2)=VN(IJ2)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,2) - & -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,2)) - UN(IJ3)=UN(IJ3)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,3) - & -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,3)) - VN(IJ3)=VN(IJ3)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,3) - & -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,3)) - UN(IJ4)=UN(IJ4)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,4) - & -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,4)) - VN(IJ4)=VN(IJ4)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,4) - & -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,4)) - UN(IJ5)=UN(IJ5)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,5) - & -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,5)) - VN(IJ5)=VN(IJ5)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,5) - & -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,5)) - UN(IJ6)=UN(IJ6)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,6) - & -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,6)) - VN(IJ6)=VN(IJ6)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,6) - & -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,6)) - UN(IJ7)=UN(IJ7)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,7) - & -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,7)) - VN(IJ7)=VN(IJ7)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,7) - & -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,7)) - UN(IJ8)=UN(IJ8)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,8) - & -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,8)) - VN(IJ8)=VN(IJ8)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,8) - & -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,8)) - US(IJ1)=US(IJ1)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,4) - & -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,4)) - VS(IJ1)=VS(IJ1)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,4) - & -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,4)) - US(IJ2)=US(IJ2)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,3) - & -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,3)) - VS(IJ2)=VS(IJ2)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,3) - & -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,3)) - US(IJ3)=US(IJ3)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,2) - & -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,2)) - VS(IJ3)=VS(IJ3)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,2) - & -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,2)) - US(IJ4)=US(IJ4)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,1) - & -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,1)) - VS(IJ4)=VS(IJ4)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,1) - & -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,1)) - US(IJ5)=US(IJ5)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,8) - & -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,8)) - VS(IJ5)=VS(IJ5)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,8) - & -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,8)) - US(IJ6)=US(IJ6)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,7) - & -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,7)) - VS(IJ6)=VS(IJ6)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,7) - & -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,7)) - US(IJ7)=US(IJ7)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,6) - & -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,6)) - VS(IJ7)=VS(IJ7)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,6) - & -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,6)) - US(IJ8)=US(IJ8)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,5) - & -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,5)) - VS(IJ8)=VS(IJ8)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,5) - & -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,5)) - ENDDO - ELSE - DO L=1,MAXWV - LR=2*L+1 - LI=2*L+2 -CDIR$ IVDEP - DO K=1,KMAX - KU=K - KV=K+KMAX - IJK1=IJ1+(K-1)*KG - IJK2=IJ2+(K-1)*KG - IJK3=IJ3+(K-1)*KG - IJK4=IJ4+(K-1)*KG - IJK5=IJ5+(K-1)*KG - IJK6=IJ6+(K-1)*KG - IJK7=IJ7+(K-1)*KG - IJK8=IJ8+(K-1)*KG - UN(IJK1)=UN(IJK1)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,1) - & -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,1)) - VN(IJK1)=VN(IJK1)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,1) - & -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,1)) - UN(IJK2)=UN(IJK2)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,2) - & -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,2)) - VN(IJK2)=VN(IJK2)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,2) - & -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,2)) - UN(IJK3)=UN(IJK3)+2*RR*(( DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,3) - & -( DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,3)) - VN(IJK3)=VN(IJK3)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,3) - & -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,3)) - UN(IJK4)=UN(IJK4)+2*RR*(( DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,4) - & -( DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,4)) - VN(IJK4)=VN(IJK4)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,4) - & -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,4)) - UN(IJK5)=UN(IJK5)+2*RR*(( DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,5) - & -( DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,5)) - VN(IJK5)=VN(IJK5)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,5) - & -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,5)) - UN(IJK6)=UN(IJK6)+2*RR*(( DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,6) - & -( DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,6)) - VN(IJK6)=VN(IJK6)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,6) - & -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,6)) - UN(IJK7)=UN(IJK7)+2*RR*((-DI1*F(LR,1,KU)+DJ1*F(LR,1,KV)) - & *CLON(L,7) - & -(-DI1*F(LI,1,KU)+DJ1*F(LI,1,KV)) - & *SLON(L,7)) - VN(IJK7)=VN(IJK7)+2*RR*((-DJ1*F(LR,1,KU)-DI1*F(LR,1,KV)) - & *CLON(L,7) - & -(-DJ1*F(LI,1,KU)-DI1*F(LI,1,KV)) - & *SLON(L,7)) - UN(IJK8)=UN(IJK8)+2*RR*((-DJ1*F(LR,1,KU)+DI1*F(LR,1,KV)) - & *CLON(L,8) - & -(-DJ1*F(LI,1,KU)+DI1*F(LI,1,KV)) - & *SLON(L,8)) - VN(IJK8)=VN(IJK8)+2*RR*((-DI1*F(LR,1,KU)-DJ1*F(LR,1,KV)) - & *CLON(L,8) - & -(-DI1*F(LI,1,KU)-DJ1*F(LI,1,KV)) - & *SLON(L,8)) - US(IJK1)=US(IJK1)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,4) - & -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,4)) - VS(IJK1)=VS(IJK1)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,4) - & -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,4)) - US(IJK2)=US(IJK2)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,3) - & -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,3)) - VS(IJK2)=VS(IJK2)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,3) - & -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,3)) - US(IJK3)=US(IJK3)+2*RR*((-DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,2) - & -(-DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,2)) - VS(IJK3)=VS(IJK3)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,2) - & -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,2)) - US(IJK4)=US(IJK4)+2*RR*((-DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,1) - & -(-DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,1)) - VS(IJK4)=VS(IJK4)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,1) - & -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,1)) - US(IJK5)=US(IJK5)+2*RR*((-DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,8) - & -(-DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,8)) - VS(IJK5)=VS(IJK5)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,8) - & -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,8)) - US(IJK6)=US(IJK6)+2*RR*((-DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,7) - & -(-DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,7)) - VS(IJK6)=VS(IJK6)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,7) - & -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,7)) - US(IJK7)=US(IJK7)+2*RR*(( DI1*F(LR,2,KU)-DJ1*F(LR,2,KV)) - & *CLON(L,6) - & -( DI1*F(LI,2,KU)-DJ1*F(LI,2,KV)) - & *SLON(L,6)) - VS(IJK7)=VS(IJK7)+2*RR*(( DJ1*F(LR,2,KU)+DI1*F(LR,2,KV)) - & *CLON(L,6) - & -( DJ1*F(LI,2,KU)+DI1*F(LI,2,KV)) - & *SLON(L,6)) - US(IJK8)=US(IJK8)+2*RR*(( DJ1*F(LR,2,KU)-DI1*F(LR,2,KV)) - & *CLON(L,5) - & -( DJ1*F(LI,2,KU)-DI1*F(LI,2,KV)) - & *SLON(L,5)) - VS(IJK8)=VS(IJK8)+2*RR*(( DI1*F(LR,2,KU)+DJ1*F(LR,2,KV)) - & *CLON(L,5) - & -( DI1*F(LI,2,KU)+DJ1*F(LI,2,KV)) - & *SLON(L,5)) - ENDDO - ENDDO - ENDIF - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptgpt.f b/external/sp/v2.0.2/src/sptgpt.f deleted file mode 100644 index 56a74e0c..00000000 --- a/external/sp/v2.0.2/src/sptgpt.f +++ /dev/null @@ -1,112 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPT(IROMB,MAXWV,KMAX,NMAX, - & KWSKIP,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WAVE,GP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C 2003-06-30 IREDELL USE SPFFTPT -C -C USAGE: CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVE,GP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GP - REAL (*) STATION POINT SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPFFTPT POINTWISE FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL RLAT(*),RLON(*),WAVE(*),GP(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(KMAX) - REAL WTOP(2*(MAXWV+1),KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+3,2,KMAX) - PARAMETER(PI=3.14159265358979) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - IDIM=2*MAXWV+3 - KW=KWSKIP - KG=KGSKIP - NR=NRSKIP - NG=NGSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=NMAX - IF(NR.EQ.0) NR=1 - IF(NG.EQ.0) NG=1 - MP=0 -C$OMP PARALLEL DO - DO K=1,KMAX - WTOP(1:2*MXTOP,K)=0 - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE STATION FIELDS -C$OMP PARALLEL DO PRIVATE(RADLAT,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,NK) - DO N=1,NMAX - RADLAT=PI/180*RLAT((N-1)*NR+1) - IF(RLAT((N-1)*NR+1).GE.89.9995) THEN - SLAT1=1. - CLAT1=0. - ELSEIF(RLAT((N-1)*NR+1).LE.-89.9995) THEN - SLAT1=-1. - CLAT1=0. - ELSE - SLAT1=SIN(RADLAT) - CLAT1=COS(RADLAT) - ENDIF - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,KW,2*MXTOP,KMAX, - & CLAT1,PLN,PLNTOP,MP,WAVE,WTOP,F) - CALL SPFFTPT(MAXWV,1,2*MAXWV+3,KG,KMAX,RLON((N-1)*NR+1), - & F,GP((N-1)*NG+1)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptgptd.f b/external/sp/v2.0.2/src/sptgptd.f deleted file mode 100644 index d8c85868..00000000 --- a/external/sp/v2.0.2/src/sptgptd.f +++ /dev/null @@ -1,83 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPTD(IROMB,MAXWV,KMAX,NMAX, - & KWSKIP,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WAVE,XP,YP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPTD TRANSFORM SPECTRAL TO STATION POINT GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C TO SPECIFIED SETS OF STATION POINT GRADIENTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTGPTD(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVE,XP,YP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C XP - REAL (*) STATION POINT X-GRADIENT SETS -C YP - REAL (*) STATION POINT Y-GRADIENT SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL RLAT(*),RLON(*),WAVE(*),XP(*),YP(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - KW=KWSKIP - IF(KW.EQ.0) KW=2*MX -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE STATION FIELDS -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),1) - WZ(1:2*MX,K)=0. - ENDDO - CALL SPTGPTV(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WD,WZ,XP,YP) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptgptsd.f b/external/sp/v2.0.2/src/sptgptsd.f deleted file mode 100644 index a25bbe5e..00000000 --- a/external/sp/v2.0.2/src/sptgptsd.f +++ /dev/null @@ -1,138 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPTSD(IROMB,MAXWV,KMAX,NMAX, - & KWSKIP,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WAVE,GP,XP,YP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPTSD TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C TO SPECIFIED SETS OF STATION POINT VALUES -C AND THEIR GRADIENTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C 1999-08-18 IREDELL OPENMP DIRECTIVE TYPO FIXED -C -C USAGE: CALL SPTGPTSD(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVE,GP,XP,YP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVE - REAL (*) WAVE FIELDS -C OUTPUT ARGUMENTS: -C GP - REAL (*) STATION POINT SETS -C XP - REAL (*) STATION POINT X-GRADIENT SETS -C YP - REAL (*) STATION POINT Y-GRADIENT SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPGRADY COMPUTE Y-GRADIENT IN SPECTRAL SPACE -C SPGRADX COMPUTE X-GRADIENT IN FOURIER SPACE -C SPFFTPT COMPUTE FOURIER TRANSFORM TO GRIDPOINTS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL RLAT(*),RLON(*),WAVE(*) - REAL GP(*),XP(*),YP(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(2*KMAX) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,2*KMAX) - REAL WTOP(2*(MAXWV+1),2*KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+2,2,3*KMAX),G(3*KMAX) - PARAMETER(PI=3.14159265358979) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - MDIM=2*MX - IDIM=2*MAXWV+2 - KW=KWSKIP - KG=KGSKIP - NR=NRSKIP - NG=NGSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=NMAX - IF(NR.EQ.0) NR=1 - IF(NG.EQ.0) NG=1 - MP(1:KMAX)=10 - MP(KMAX+1:2*KMAX)=1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE SPECTRAL WINDS -C$OMP PARALLEL DO PRIVATE(KWS,KS,KY) - DO K=1,KMAX - KWS=(K-1)*KW - KS=0*KMAX+K - KY=1*KMAX+K - DO I=1,2*MX - W(I,KS)=WAVE(KWS+I) - ENDDO - DO I=1,2*MXTOP - WTOP(I,KS)=0 - ENDDO - CALL SPGRADY(IROMB,MAXWV,ENN1,EON,EONTOP, - & WAVE(KWS+1),W(1,KY),WTOP(1,KY)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE STATION FIELDS -C$OMP PARALLEL DO PRIVATE(KS,KY,KX,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,G,NK) - DO N=1,NMAX - IF(ABS(RLAT((N-1)*NR+1)).GE.89.9995) THEN - SLAT1=SIGN(1.,RLAT((N-1)*NR+1)) - CLAT1=0. - ELSE - SLAT1=SIN(PI/180*RLAT((N-1)*NR+1)) - CLAT1=COS(PI/180*RLAT((N-1)*NR+1)) - ENDIF - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - CALL SPGRADX(MAXWV,IDIM,KMAX,MP,CLAT1,F(1,1,1),F(1,1,2*KMAX+1)) - CALL SPFFTPT(MAXWV,1,IDIM,1,3*KMAX,RLON((N-1)*NR+1),F,G) - DO K=1,KMAX - KS=0*KMAX+K - KY=1*KMAX+K - KX=2*KMAX+K - NK=(N-1)*NG+(K-1)*KG+1 - GP(NK)=G(KS) - XP(NK)=G(KX) - YP(NK)=G(KY) - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptgptv.f b/external/sp/v2.0.2/src/sptgptv.f deleted file mode 100644 index db4ddbd6..00000000 --- a/external/sp/v2.0.2/src/sptgptv.f +++ /dev/null @@ -1,130 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPTV(IROMB,MAXWV,KMAX,NMAX, - & KWSKIP,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WAVED,WAVEZ,UP,VP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO SPECIFIED SETS OF STATION POINT VECTORS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C 1999-08-18 IREDELL OPENMP DIRECTIVE TYPO FIXED -C 2003-06-30 IREDELL USE SPFFTPT -C -C USAGE: CALL SPTGPTV(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVED,WAVEZ,UP,VP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C UP - REAL (*) STATION POINT U-WIND SETS -C VP - REAL (*) STATION POINT V-WIND SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C SPFFTPT POINTWISE FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL RLAT(*),RLON(*),WAVED(*),WAVEZ(*),UP(*),VP(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(2*KMAX) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,2*KMAX) - REAL WTOP(2*(MAXWV+1),2*KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+3,2,2*KMAX) - REAL G(2*KMAX) - PARAMETER(PI=3.14159265358979) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - MDIM=2*MX+1 - IDIM=2*MAXWV+3 - KW=KWSKIP - KG=KGSKIP - NR=NRSKIP - NG=NGSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=NMAX - IF(NR.EQ.0) NR=1 - IF(NG.EQ.0) NG=1 - MP=1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE SPECTRAL WINDS -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP, - & WAVED(KWS+1),WAVEZ(KWS+1), - & W(1,K),W(1,KMAX+K),WTOP(1,K),WTOP(1,KMAX+K)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE STATION FIELDS -C$OMP PARALLEL DO PRIVATE(KU,KV,RADLAT,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,G,NK) - DO N=1,NMAX - RADLAT=PI/180*RLAT((N-1)*NR+1) - IF(RLAT((N-1)*NR+1).GE.89.9995) THEN - SLAT1=1. - CLAT1=0. - ELSEIF(RLAT((N-1)*NR+1).LE.-89.9995) THEN - SLAT1=-1. - CLAT1=0. - ELSE - SLAT1=SIN(RADLAT) - CLAT1=COS(RADLAT) - ENDIF - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,2*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - CALL SPFFTPT(MAXWV,1,2*MAXWV+3,1,2*KMAX,RLON((N-1)*NR+1),F,G) - DO K=1,KMAX - KU=K - KV=K+KMAX - NK=(N-1)*NG+(K-1)*KG+1 - UP(NK)=G(KU) - VP(NK)=G(KV) - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptgptvd.f b/external/sp/v2.0.2/src/sptgptvd.f deleted file mode 100644 index ec2326d9..00000000 --- a/external/sp/v2.0.2/src/sptgptvd.f +++ /dev/null @@ -1,168 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTGPTVD(IROMB,MAXWV,KMAX,NMAX, - & KWSKIP,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WAVED,WAVEZ, - & DP,ZP,UP,VP,UXP,VXP,UYP,VYP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTGPTVD TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C FROM SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C TO SPECIFIED SETS OF STATION POINT VECTORS AND THEIR -C GRADIENTS ON THE GLOBE. -C DP=(D(UP)/DLON+D(VP*CLAT)/DLAT)/(R*CLAT) -C ZP=(D(VP)/DLON-D(UP*CLAT)/DLAT)/(R*CLAT) -C UXP=D(UP*CLAT)/DLON/(R*CLAT) -C VXP=D(VP*CLAT)/DLON/(R*CLAT) -C UYP=D(UP*CLAT)/DLAT/R -C VYP=D(VP*CLAT)/DLAT/R -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE WAVE AND POINT FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER STATIONS. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C 1999-08-18 IREDELL OPENMP DIRECTIVE TYPO FIXED -C -C USAGE: CALL SPTGPTVD(IROMB,MAXWV,KMAX,NMAX, -C & KWSKIP,KGSKIP,NRSKIP,NGSKIP, -C & RLAT,RLON,WAVED,WAVEZ, -C & DP,ZP,UP,VP,UXP,VXP,UYP,VYP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS -C OUTPUT ARGUMENTS: -C DP - REAL (*) STATION POINT DIVERGENCE SETS -C ZP - REAL (*) STATION POINT VORTICITY SETS -C UP - REAL (*) STATION POINT U-WIND SETS -C VP - REAL (*) STATION POINT V-WIND SETS -C UXP - REAL (*) STATION POINT U-WIND X-GRADIENT SETS -C VXP - REAL (*) STATION POINT V-WIND X-GRADIENT SETS -C UYP - REAL (*) STATION POINT U-WIND Y-GRADIENT SETS -C VYP - REAL (*) STATION POINT V-WIND Y-GRADIENT SETS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C SPGRADX COMPUTE X-GRADIENT IN FOURIER SPACE -C SPFFTPT COMPUTE FOURIER TRANSFORM TO GRIDPOINTS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL RLAT(*),RLON(*),WAVED(*),WAVEZ(*) - REAL DP(*),ZP(*),UP(*),VP(*),UXP(*),VXP(*),UYP(*),VYP(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - INTEGER MP(4*KMAX) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,4*KMAX) - REAL WTOP(2*(MAXWV+1),4*KMAX) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1) - REAL F(2*MAXWV+2,2,6*KMAX),G(6*KMAX) - PARAMETER(PI=3.14159265358979) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE PRELIMINARY CONSTANTS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - MDIM=2*MX - IDIM=2*MAXWV+2 - KW=KWSKIP - KG=KGSKIP - NR=NRSKIP - NG=NGSKIP - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=NMAX - IF(NR.EQ.0) NR=1 - IF(NG.EQ.0) NG=1 - MP(1:2*KMAX)=0 - MP(2*KMAX+1:4*KMAX)=1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE SPECTRAL WINDS -C$OMP PARALLEL DO PRIVATE(KWS,KD,KZ,KU,KV) - DO K=1,KMAX - KWS=(K-1)*KW - KD=0*KMAX+K - KZ=1*KMAX+K - KU=2*KMAX+K - KV=3*KMAX+K - DO I=1,2*MX - W(I,KD)=WAVED(KWS+I) - W(I,KZ)=WAVEZ(KWS+I) - ENDDO - DO I=1,2*MXTOP - WTOP(I,KD)=0 - WTOP(I,KZ)=0 - ENDDO - CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP, - & WAVED(KWS+1),WAVEZ(KWS+1), - & W(1,KU),W(1,KV),WTOP(1,KU),WTOP(1,KV)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CALCULATE STATION FIELDS -C$OMP PARALLEL DO PRIVATE(KD,KZ,KU,KV,KUX,KVX,SLAT1,CLAT1) -C$OMP& PRIVATE(PLN,PLNTOP,F,G,NK) - DO N=1,NMAX - KU=2*KMAX+1 - KUX=4*KMAX+1 - IF(ABS(RLAT((N-1)*NR+1)).GE.89.9995) THEN - SLAT1=SIGN(1.,RLAT((N-1)*NR+1)) - CLAT1=0. - ELSE - SLAT1=SIN(PI/180*RLAT((N-1)*NR+1)) - CLAT1=COS(PI/180*RLAT((N-1)*NR+1)) - ENDIF - CALL SPLEGEND(IROMB,MAXWV,SLAT1,CLAT1,EPS,EPSTOP, - & PLN,PLNTOP) - CALL SPSYNTH(IROMB,MAXWV,2*MAXWV,IDIM,MDIM,2*MXTOP,4*KMAX, - & CLAT1,PLN,PLNTOP,MP,W,WTOP,F) - CALL SPGRADX(MAXWV,IDIM,2*KMAX,MP(2*KMAX+1),CLAT1, - & F(1,1,2*KMAX+1),F(1,1,4*KMAX+1)) - CALL SPFFTPT(MAXWV,1,IDIM,1,6*KMAX,RLON((N-1)*NR+1),F,G) - DO K=1,KMAX - KD=0*KMAX+K - KZ=1*KMAX+K - KU=2*KMAX+K - KV=3*KMAX+K - KUX=4*KMAX+K - KVX=5*KMAX+K - NK=(N-1)*NG+(K-1)*KG+1 - DP(NK)=G(KD) - ZP(NK)=G(KZ) - UP(NK)=G(KU) - VP(NK)=G(KV) - UXP(NK)=G(KUX) - VXP(NK)=G(KVX) - UYP(NK)=G(KVX)-CLAT1*G(KZ) - VYP(NK)=CLAT1*G(KD)-G(KUX) - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptran.f b/external/sp/v2.0.2/src/sptran.f deleted file mode 100644 index f447274f..00000000 --- a/external/sp/v2.0.2/src/sptran.f +++ /dev/null @@ -1,138 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRAN(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, - & JBEG,JEND,JCPU, - & WAVE,GRIDN,GRIDS,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C AND FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL GENERIC FFT USED -C OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRAN(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, -C & JBEG,JEND,JCPU, -C & WAVE,GRIDN,GRIDS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C ISKIP - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C (DEFAULTS TO 1 IF ISKIP=0) -C JNSKIP - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C (DEFAULTS TO IMAX IF JNSKIP=0) -C JSSKIP - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAX IF JSSKIP=0) -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO IMAX*JMAX IF KGSKIP=0) -C JBEG - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C (DEFAULTS TO 1 IF JBEG=0) -C (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM) -C JEND - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C (DEFAULTS TO (JMAX+1)/2 IF JEND=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVE - REAL (*) WAVE FIELDS IF IDIR>0 -C GRIDN - REAL (*) N.H. GRID FIELDS (STARTING AT JBEG) IF IDIR<0 -C GRIDS - REAL (*) S.H. GRID FIELDS (STARTING AT JBEG) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (*) WAVE FIELDS IF IDIR<0 -C GRIDN - REAL (*) N.H. GRID FIELDS (STARTING AT JBEG) IF IDIR>0 -C GRIDS - REAL (*) S.H. GRID FIELDS (STARTING AT JBEG) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANF PERFORM A SCALAR SPHERICAL TRANSFORM -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),GRIDN(*),GRIDS(*) -!==EM== integer JC, JCPU -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!==EM== -! print *, "jjjjjjjcccccccccc from SPTRAN- before NCPUS", JC - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - IP=IPRIME - IS=ISKIP - JN=JNSKIP - JS=JSSKIP - KW=KWSKIP - KG=KGSKIP - JB=JBEG - JE=JEND - JC=JCPU - IF(IP.EQ.0) IP=1 - IF(IS.EQ.0) IS=1 - IF(JN.EQ.0) JN=IMAX - IF(JS.EQ.0) JS=-JN - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=IMAX*JMAX - IF(JB.EQ.0) JB=1 - IF(JE.EQ.0) JE=(JMAX+1)/2 - IF(JC.EQ.0) JC=NCPUS() -! JC=NCPUS() -!==EM== -! print *, "jjjjjjjjjjjjjjjjjjjjcccccccccc from SPTRAN", JC -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(IDIR.LT.0.AND.JBEG.EQ.0) THEN - DO K=1,KMAX - KWS=(K-1)*KW - WAVE(KWS+1:KWS+2*MX)=0 - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!==EM== -! print *, "jjjjjjjcccccccccc from SPTRANF- before NCPUS", JC - CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVE,GRIDN,GRIDS,IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptrand.f b/external/sp/v2.0.2/src/sptrand.f deleted file mode 100644 index 323815b9..00000000 --- a/external/sp/v2.0.2/src/sptrand.f +++ /dev/null @@ -1,164 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, - & JBEG,JEND,JCPU, - & WAVE,GRIDMN,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR FIELDS -C AND THEIR MEANS AND GRADIENTS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRAND(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, -C & JBEG,JEND,JCPU, -C & WAVE,GRIDMN,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C ISKIP - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C (DEFAULTS TO 1 IF ISKIP=0) -C JNSKIP - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C (DEFAULTS TO IMAX IF JNSKIP=0) -C JSSKIP - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAX IF JSSKIP=0) -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO IMAX*JMAX IF KGSKIP=0) -C JBEG - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C (DEFAULTS TO 1 IF JBEG=0) -C (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM) -C JEND - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C (DEFAULTS TO (JMAX+1)/2 IF JEND=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVE - REAL (*) WAVE FIELDS IF IDIR>0 -C GRIDMN - REAL (KMAX) GLOBAL MEANS IF IDIR<0 -C GRIDXN - REAL (*) N.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C GRIDXS - REAL (*) S.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C GRIDYN - REAL (*) N.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C GRIDYS - REAL (*) S.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (*) WAVE FIELDS IF IDIR<0 -C GRIDMN - REAL (KMAX) GLOBAL MEANS IF IDIR>0 -C GRIDXN - REAL (*) N.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C GRIDXS - REAL (*) S.H. X-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C [GRIDX=(D(WAVE)/DLAM)/(CLAT*RERTH)] -C GRIDYN - REAL (*) N.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C GRIDYS - REAL (*) S.H. Y-GRADIENTS (STARTING AT JBEG) IF IDIR>0 -C [GRIDY=(D(WAVE)/DPHI)/RERTH] -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),GRIDMN(KMAX),GRIDXN(*),GRIDXS(*),GRIDYN(*),GRIDYS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SET PARAMETERS - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - KW=KWSKIP - IF(KW.EQ.0) KW=2*MX -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO GRID - IF(IDIR.GT.0) THEN -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - GRIDMN(K)=WAVE(KWS+1)/SQRT(2.) - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),1) - WZ(1:2*MX,K)=0. - ENDDO - CALL SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IPRIME,ISKIP,JNSKIP,JSSKIP,MDIM,KGSKIP, - & JBEG,JEND,JCPU, - & WD,WZ,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM GRID TO WAVE - ELSE -C$OMP PARALLEL DO - DO K=1,KMAX - WD(1:2*MX,K)=0. - WZ(1:2*MX,K)=0. - ENDDO - CALL SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IPRIME,ISKIP,JNSKIP,JSSKIP,MDIM,KGSKIP, - & JBEG,JEND,JCPU, - & WD,WZ,GRIDXN,GRIDXS,GRIDYN,GRIDYS,IDIR) - IF(JBEG.EQ.0) THEN -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WAVE(KWS+1),WD(1,K),-1) - WAVE(KWS+1)=GRIDMN(K)*SQRT(2.) - ENDDO - ELSE -C$OMP PARALLEL DO PRIVATE(KWS) - DO K=1,KMAX - KWS=(K-1)*KW - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WD(1,K),-1) - WAVE(KWS+1:KWS+2*MX)=WAVE(KWS+1:KWS+2*MX)+WZ(1:2*MX,K) - WAVE(KWS+1)=GRIDMN(K)*SQRT(2.) - ENDDO - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptranf.f b/external/sp/v2.0.2/src/sptranf.f deleted file mode 100644 index 46d84b1e..00000000 --- a/external/sp/v2.0.2/src/sptranf.f +++ /dev/null @@ -1,176 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVE,GRIDN,GRIDS,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF SCALAR QUANTITIES -C AND FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL GENERIC FFT USED -C OPENMP DIRECTIVES INSERTED -C 2013-01-16 IREDELL & -C MIRVIS :: -C FIXING AFFT NEGATIVE SHARING EFFECT DURING -C OMP LOOPS BY CREATING TMP AFFT COPY (AFFT_TMP) -C TO BE PRIVATE DURING OMP LOOP THREADING -C -C USAGE: CALL SPTRANF(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IP,IS,JN,JS,KW,KG,JB,JE,JC, -C & WAVE,GRIDN,GRIDS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IP - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN -C IS - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C JN - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C JS - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C KW - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C KG - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C JB - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C JE - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C JC - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVE - REAL (*) WAVE FIELDS IF IDIR>0 -C GRIDN - REAL (*) N.H. GRID FIELDS (STARTING AT JB) IF IDIR<0 -C GRIDS - REAL (*) S.H. GRID FIELDS (STARTING AT JB) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVE - REAL (*) WAVE FIELDS IF IDIR<0 -C GRIDN - REAL (*) N.H. GRID FIELDS (STARTING AT JB) IF IDIR>0 -C GRIDS - REAL (*) S.H. GRID FIELDS (STARTING AT JB) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANF0 SPTRANF SPECTRAL INITIALIZATION -C SPTRANF1 SPTRANF SPECTRAL TRANSFORM -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVE(*),GRIDN(*),GRIDS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL(8) AFFT(50000+4*IMAX), AFFT_TMP(50000+4*IMAX) - REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE) - REAL PLNTOP(MAXWV+1,JB:JE) - REAL WTOP(2*(MAXWV+1)) - REAL G(IMAX,2) -! write(0,*) 'sptranf top' -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SET PARAMETERS - MP=0 - CALL SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO GRID - IF(IDIR.GT.0) THEN -C$OMP PARALLEL DO PRIVATE(AFFT_TMP,KWS,WTOP,G,IJKN,IJKS) - DO K=1,KMAX - AFFT_TMP=AFFT - KWS=(K-1)*KW - WTOP=0 - DO J=JB,JE - CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT_TMP,CLAT(J),SLAT(J),WLAT(J), - & PLN(1,J),PLNTOP(1,J),MP, - & WAVE(KWS+1),WTOP,G,IDIR) - IF(IP.EQ.1.AND.IS.EQ.1) THEN - DO I=1,IMAX - IJKN=I+(J-JB)*JN+(K-1)*KG - IJKS=I+(J-JB)*JS+(K-1)*KG - GRIDN(IJKN)=G(I,1) - GRIDS(IJKS)=G(I,2) - ENDDO - ELSE - DO I=1,IMAX - IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1 - IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1 - GRIDN(IJKN)=G(I,1) - GRIDS(IJKS)=G(I,2) - ENDDO - ENDIF - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM GRID TO WAVE - ELSE -C$OMP PARALLEL DO PRIVATE(AFFT_TMP,KWS,WTOP,G,IJKN,IJKS) - DO K=1,KMAX - AFFT_TMP=AFFT - KWS=(K-1)*KW - WTOP=0 - DO J=JB,JE - IF(WLAT(J).GT.0.) THEN - IF(IP.EQ.1.AND.IS.EQ.1) THEN - DO I=1,IMAX - IJKN=I+(J-JB)*JN+(K-1)*KG - IJKS=I+(J-JB)*JS+(K-1)*KG - G(I,1)=GRIDN(IJKN) - G(I,2)=GRIDS(IJKS) - ENDDO - ELSE - DO I=1,IMAX - IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1 - IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1 - G(I,1)=GRIDN(IJKN) - G(I,2)=GRIDS(IJKS) - ENDDO - ENDIF - CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT_TMP,CLAT(J),SLAT(J),WLAT(J), - & PLN(1,J),PLNTOP(1,J),MP, - & WAVE(KWS+1),WTOP,G,IDIR) - ENDIF - ENDDO - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptranf0.f b/external/sp/v2.0.2/src/sptranf0.f deleted file mode 100644 index 037d819b..00000000 --- a/external/sp/v2.0.2/src/sptranf0.f +++ /dev/null @@ -1,83 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRANF0 SPTRANF SPECTRAL INITIALIZATION -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS AN INITIALIZATION FOR -C SUBPROGRAM SPTRANF. USE THIS SUBPROGRAM OUTSIDE -C THE SPTRANF FAMILY CONTEXT AT YOUR OWN RISK. -C -C PROGRAM HISTORY LOG: -C 1998-12-15 IREDELL -C -C USAGE: CALL SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, -C & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, -C & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES -C JMAX - INTEGER NUMBER OF LATITUDES -C JB - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C JE - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C OUTPUT ARGUMENTS: -C EPS - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EPSTOP - REAL (MAXWV+1) -C ENN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C ELONN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EON - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EONTOP - REAL (MAXWV+1) -C AFFT - REAL(8) (50000+4*IMAX) AUXILIARY ARRAY IF IDIR=0 -C CLAT - REAL (JB:JE) COSINES OF LATITUDE -C SLAT - REAL (JB:JE) SINES OF LATITUDE -C WLAT - REAL (JB:JE) GAUSSIAN WEIGHTS -C PLN - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE) -C LEGENDRE POLYNOMIALS -C PLNTOP - REAL (MAXWV+1,JB:JE) LEGENDRE POLYNOMIAL OVER TOP -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPFFTE PERFORM FAST FOURIER TRANSFORM -C SPLAT COMPUTE LATITUDE FUNCTIONS -C SPLEGEND COMPUTE LEGENDRE POLYNOMIALS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL(8) AFFT(50000+4*IMAX) - REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE) - REAL PLNTOP(MAXWV+1,JB:JE) - REAL SLATX(JMAX),WLATX(JMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,0.,0.,0,AFFT) - CALL SPLAT(IDRT,JMAX,SLATX,WLATX) - JHE=(JMAX+1)/2 - IF(JHE.GT.JMAX/2) WLATX(JHE)=WLATX(JHE)/2 - DO J=JB,JE - CLAT(J)=SQRT(1.-SLATX(J)**2) - SLAT(J)=SLATX(J) - WLAT(J)=WLATX(J) - ENDDO -C$OMP PARALLEL DO - DO J=JB,JE - CALL SPLEGEND(IROMB,MAXWV,SLAT(J),CLAT(J),EPS,EPSTOP, - & PLN(1,J),PLNTOP(1,J)) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptranf1.f b/external/sp/v2.0.2/src/sptranf1.f deleted file mode 100644 index 2c479ef0..00000000 --- a/external/sp/v2.0.2/src/sptranf1.f +++ /dev/null @@ -1,99 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP,MP, - & W,WTOP,G,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRANF1 SPTRANF SPECTRAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS AN SINGLE LATITUDE TRANSFORM FOR -C SUBPROGRAM SPTRANF. USE THIS SUBPROGRAM OUTSIDE -C THE SPTRANF FAMILY CONTEXT AT YOUR OWN RISK. -C -C PROGRAM HISTORY LOG: -C 1998-12-15 IREDELL -C -C USAGE: CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, -C & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, -C & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP,MP, -C & W,WTOP,G,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES -C JMAX - INTEGER NUMBER OF LATITUDES -C JB - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C JE - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C EPS - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EPSTOP - REAL (MAXWV+1) -C ENN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C ELONN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EON - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EONTOP - REAL (MAXWV+1) -C CLAT - REAL (JB:JE) COSINES OF LATITUDE -C SLAT - REAL (JB:JE) SINES OF LATITUDE -C WLAT - REAL (JB:JE) GAUSSIAN WEIGHTS -C AFFT - REAL(8) (50000+4*IMAX) AUXILIARY ARRAY IF IDIR=0 -C PLN - REAL ((M+1)*((I+1)*M+2)/2,JB:JE) LEGENDRE POLYNOMIALS -C PLNTOP - REAL (M+1,JB:JE) LEGENDRE POLYNOMIAL OVER TOP -C MP - INTEGER IDENTIFIER (0 FOR SCALAR, 1 FOR VECTOR) -C W - REAL (*) WAVE FIELD IF IDIR>0 -C WTOP - REAL (*) WAVE FIELD OVER TOP IF IDIR>0 -C G - REAL (IMAX,2,JB:JE) GRID FIELD IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C W - REAL (*) WAVE FIELD IF IDIR<0 -C WTOP - REAL (*) WAVE FIELD OVER TOP IF IDIR<0 -C G - REAL (IMAX,2,JB:JE) GRID FIELD IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPSYNTH SYNTHESIZE FOURIER FROM SPECTRAL -C SPANALY ANALYZE SPECTRAL FROM FOURIER -C SPFFTE PERFORM FAST FOURIER TRANSFORM -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL(8) AFFT(50000+4*IMAX) - REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE) - REAL PLNTOP(MAXWV+1,JB:JE) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)) - REAL WTOP(2*(MAXWV+1)) - REAL G(IMAX,2,JB:JE) - REAL F(IMAX+2,2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! write(0,*) 'sptranf1 top' - KW=(MAXWV+1)*((IROMB+1)*MAXWV+2) - KWTOP=2*(MAXWV+1) - IF(IDIR.GT.0) THEN - DO J=JB,JE - CALL SPSYNTH(IROMB,MAXWV,IMAX,IMAX+2,KW,KWTOP,1, - & CLAT(J),PLN(1,J),PLNTOP(1,J),MP, - & W,WTOP,F) - CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,F,G(1,1,J),+1,AFFT) - ENDDO - ELSE - DO J=JB,JE - CALL SPFFTE(IMAX,(IMAX+2)/2,IMAX,2,F,G(1,1,J),-1,AFFT) - CALL SPANALY(IROMB,MAXWV,IMAX,IMAX+2,KW,KWTOP,1, - & WLAT(J),CLAT(J),PLN(1,J),PLNTOP(1,J),MP, - & F,W,WTOP) - ENDDO -! write(0,*) 'sptranf1 end' - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptranfv.f b/external/sp/v2.0.2/src/sptranfv.f deleted file mode 100644 index 6bceb1b7..00000000 --- a/external/sp/v2.0.2/src/sptranfv.f +++ /dev/null @@ -1,215 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRANFV PERFORM A VECTOR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C AND VECTOR FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL GENERIC FFT USED -C OPENMP DIRECTIVES INSERTED -C 2013-01-16 IREDELL & -C MIRVIS :: -C FIXING AFFT NEGATIVE SHARING EFFECT DURING -C OMP LOOPS BY CREATING TMP AFFT COPY (AFFT_TMP) -C TO BE PRIVATE DURING OMP LOOP THREADING -C -C USAGE: CALL SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IP,IS,JN,JS,KW,KG,JB,JE,JC, -C & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IP - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN -C IS - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C JN - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C JS - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C KW - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C KG - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C JB - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C JE - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C JC - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR>0 -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS IF IDIR>0 -C GRIDUN - REAL (*) N.H. GRID U-WINDS (STARTING AT JB) IF IDIR<0 -C GRIDUS - REAL (*) S.H. GRID U-WINDS (STARTING AT JB) IF IDIR<0 -C GRIDVN - REAL (*) N.H. GRID V-WINDS (STARTING AT JB) IF IDIR<0 -C GRIDVS - REAL (*) S.H. GRID V-WINDS (STARTING AT JB) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR<0 -C [WAVED=(D(GRIDU)/DLAM+D(CLAT*GRIDV)/DPHI)/(CLAT*RERTH)] -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS IF IDIR<0 -C [WAVEZ=(D(GRIDV)/DLAM-D(CLAT*GRIDU)/DPHI)/(CLAT*RERTH)] -C GRIDUN - REAL (*) N.H. GRID U-WINDS (STARTING AT JB) IF IDIR>0 -C GRIDUS - REAL (*) S.H. GRID U-WINDS (STARTING AT JB) IF IDIR>0 -C GRIDVN - REAL (*) N.H. GRID V-WINDS (STARTING AT JB) IF IDIR>0 -C GRIDVS - REAL (*) S.H. GRID V-WINDS (STARTING AT JB) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANF0 SPTRANF SPECTRAL INITIALIZATION -C SPTRANF1 SPTRANF SPECTRAL TRANSFORM -C SPDZ2UV COMPUTE WINDS FROM DIVERGENCE AND VORTICITY -C SPUV2DZ COMPUTE DIVERGENCE AND VORTICITY FROM WINDS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVED(*),WAVEZ(*),GRIDUN(*),GRIDUS(*),GRIDVN(*),GRIDVS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL(8) AFFT(50000+4*IMAX), AFFT_TMP(50000+4*IMAX) - REAL CLAT(JB:JE),SLAT(JB:JE),WLAT(JB:JE) - REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2,JB:JE) - REAL PLNTOP(MAXWV+1,JB:JE) - INTEGER MP(2) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,2) - REAL WTOP(2*(MAXWV+1),2) - REAL G(IMAX,2,2) - REAL WINC((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2,2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SET PARAMETERS - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MP=1 - CALL SPTRANF0(IROMB,MAXWV,IDRT,IMAX,JMAX,JB,JE, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT,CLAT,SLAT,WLAT,PLN,PLNTOP) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO GRID - IF(IDIR.GT.0) THEN -C$OMP PARALLEL DO PRIVATE(AFFT_TMP,KWS,W,WTOP,G,IJKN,IJKS) - DO K=1,KMAX - AFFT_TMP=AFFT - KWS=(K-1)*KW - CALL SPDZ2UV(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP, - & WAVED(KWS+1),WAVEZ(KWS+1), - & W(1,1),W(1,2),WTOP(1,1),WTOP(1,2)) - DO J=JB,JE - CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT_TMP,CLAT(J),SLAT(J),WLAT(J), - & PLN(1,J),PLNTOP(1,J),MP, - & W(1,1),WTOP(1,1),G(1,1,1),IDIR) - CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT_TMP,CLAT(J),SLAT(J),WLAT(J), - & PLN(1,J),PLNTOP(1,J),MP, - & W(1,2),WTOP(1,2),G(1,1,2),IDIR) - IF(IP.EQ.1.AND.IS.EQ.1) THEN - DO I=1,IMAX - IJKN=I+(J-JB)*JN+(K-1)*KG - IJKS=I+(J-JB)*JS+(K-1)*KG - GRIDUN(IJKN)=G(I,1,1) - GRIDUS(IJKS)=G(I,2,1) - GRIDVN(IJKN)=G(I,1,2) - GRIDVS(IJKS)=G(I,2,2) - ENDDO - ELSE - DO I=1,IMAX - IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1 - IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1 - GRIDUN(IJKN)=G(I,1,1) - GRIDUS(IJKS)=G(I,2,1) - GRIDVN(IJKN)=G(I,1,2) - GRIDVS(IJKS)=G(I,2,2) - ENDDO - ENDIF - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM GRID TO WAVE - ELSE -C$OMP PARALLEL DO PRIVATE(AFFT_TMP,KWS,W,WTOP,G,IJKN,IJKS,WINC) - DO K=1,KMAX - AFFT_TMP=AFFT - KWS=(K-1)*KW - W=0 - WTOP=0 - DO J=JB,JE - IF(WLAT(J).GT.0.) THEN - IF(IP.EQ.1.AND.IS.EQ.1) THEN - DO I=1,IMAX - IJKN=I+(J-JB)*JN+(K-1)*KG - IJKS=I+(J-JB)*JS+(K-1)*KG - G(I,1,1)=GRIDUN(IJKN)/CLAT(J)**2 - G(I,2,1)=GRIDUS(IJKS)/CLAT(J)**2 - G(I,1,2)=GRIDVN(IJKN)/CLAT(J)**2 - G(I,2,2)=GRIDVS(IJKS)/CLAT(J)**2 - ENDDO - ELSE - DO I=1,IMAX - IJKN=MOD(I+IP-2,IMAX)*IS+(J-JB)*JN+(K-1)*KG+1 - IJKS=MOD(I+IP-2,IMAX)*IS+(J-JB)*JS+(K-1)*KG+1 - G(I,1,1)=GRIDUN(IJKN)/CLAT(J)**2 - G(I,2,1)=GRIDUS(IJKS)/CLAT(J)**2 - G(I,1,2)=GRIDVN(IJKN)/CLAT(J)**2 - G(I,2,2)=GRIDVS(IJKS)/CLAT(J)**2 - ENDDO - ENDIF - CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT_TMP,CLAT(J),SLAT(J),WLAT(J), - & PLN(1,J),PLNTOP(1,J),MP, - & W(1,1),WTOP(1,1),G(1,1,1),IDIR) - CALL SPTRANF1(IROMB,MAXWV,IDRT,IMAX,JMAX,J,J, - & EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP, - & AFFT_TMP,CLAT(J),SLAT(J),WLAT(J), - & PLN(1,J),PLNTOP(1,J),MP, - & W(1,2),WTOP(1,2),G(1,1,2),IDIR) - ENDIF - ENDDO - CALL SPUV2DZ(IROMB,MAXWV,ENN1,ELONN1,EON,EONTOP, - & W(1,1),W(1,2),WTOP(1,1),WTOP(1,2), - & WINC(1,1),WINC(1,2)) - WAVED(KWS+1:KWS+2*MX)=WAVED(KWS+1:KWS+2*MX)+WINC(1:2*MX,1) - WAVEZ(KWS+1:KWS+2*MX)=WAVEZ(KWS+1:KWS+2*MX)+WINC(1:2*MX,2) - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptranv.f b/external/sp/v2.0.2/src/sptranv.f deleted file mode 100644 index f4cd073c..00000000 --- a/external/sp/v2.0.2/src/sptranv.f +++ /dev/null @@ -1,139 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, - & JBEG,JEND,JCPU, - & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM PERFORMS A SPHERICAL TRANSFORM -C BETWEEN SPECTRAL COEFFICIENTS OF DIVERGENCES AND CURLS -C AND VECTOR FIELDS ON A GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE WAVE AND GRID FIELDS MAY HAVE GENERAL INDEXING, -C BUT EACH WAVE FIELD IS IN SEQUENTIAL 'IBM ORDER', -C I.E. WITH ZONAL WAVENUMBER AS THE SLOWER INDEX. -C TRANSFORMS ARE DONE IN LATITUDE PAIRS FOR EFFICIENCY; -C THUS GRID ARRAYS FOR EACH HEMISPHERE MUST BE PASSED. -C IF SO REQUESTED, JUST A SUBSET OF THE LATITUDE PAIRS -C MAY BE TRANSFORMED IN EACH INVOCATION OF THE SUBPROGRAM. -C THE TRANSFORMS ARE ALL MULTIPROCESSED OVER LATITUDE EXCEPT -C THE TRANSFORM FROM FOURIER TO SPECTRAL IS MULTIPROCESSED -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL GENERIC FFT USED -C OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRANV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, -C & IPRIME,ISKIP,JNSKIP,JSSKIP,KWSKIP,KGSKIP, -C & JBEG,JEND,JCPU, -C & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRT - INTEGER GRID IDENTIFIER -C (IDRT=4 FOR GAUSSIAN GRID, -C IDRT=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRT=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAX - INTEGER EVEN NUMBER OF LONGITUDES. -C JMAX - INTEGER NUMBER OF LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C ISKIP - INTEGER SKIP NUMBER BETWEEN LONGITUDES -C (DEFAULTS TO 1 IF ISKIP=0) -C JNSKIP - INTEGER SKIP NUMBER BETWEEN N.H. LATITUDES FROM NORTH -C (DEFAULTS TO IMAX IF JNSKIP=0) -C JSSKIP - INTEGER SKIP NUMBER BETWEEN S.H. LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAX IF JSSKIP=0) -C KWSKIP - INTEGER SKIP NUMBER BETWEEN WAVE FIELDS -C (DEFAULTS TO (MAXWV+1)*((IROMB+1)*MAXWV+2) IF KWSKIP=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO IMAX*JMAX IF KGSKIP=0) -C JBEG - INTEGER LATITUDE INDEX (FROM POLE) TO BEGIN TRANSFORM -C (DEFAULTS TO 1 IF JBEG=0) -C (IF JBEG=0 AND IDIR<0, WAVE IS ZEROED BEFORE TRANSFORM) -C JEND - INTEGER LATITUDE INDEX (FROM POLE) TO END TRANSFORM -C (DEFAULTS TO (JMAX+1)/2 IF JEND=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR>0 -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS IF IDIR>0 -C GRIDUN - REAL (*) N.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR<0 -C GRIDUS - REAL (*) S.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR<0 -C GRIDVN - REAL (*) N.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR<0 -C GRIDVS - REAL (*) S.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR<0 -C IDIR - INTEGER TRANSFORM FLAG -C (IDIR>0 FOR WAVE TO GRID, IDIR<0 FOR GRID TO WAVE) -C OUTPUT ARGUMENTS: -C WAVED - REAL (*) WAVE DIVERGENCE FIELDS IF IDIR<0 -C [WAVED=(D(GRIDU)/DLAM+D(CLAT*GRIDV)/DPHI)/(CLAT*RERTH)] -C WAVEZ - REAL (*) WAVE VORTICITY FIELDS IF IDIR<0 -C [WAVEZ=(D(GRIDV)/DLAM-D(CLAT*GRIDU)/DPHI)/(CLAT*RERTH)] -C GRIDUN - REAL (*) N.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR>0 -C GRIDUS - REAL (*) S.H. GRID U-WINDS (STARTING AT JBEG) IF IDIR>0 -C GRIDVN - REAL (*) N.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR>0 -C GRIDVS - REAL (*) S.H. GRID V-WINDS (STARTING AT JBEG) IF IDIR>0 -C -C SUBPROGRAMS CALLED: -C SPTRANFV PERFORM A VECTOR SPHERICAL TRANSFORM -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL WAVED(*),WAVEZ(*),GRIDUN(*),GRIDUS(*),GRIDVN(*),GRIDVS(*) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - IP=IPRIME - IS=ISKIP - JN=JNSKIP - JS=JSSKIP - KW=KWSKIP - KG=KGSKIP - JB=JBEG - JE=JEND - JC=JCPU - IF(IP.EQ.0) IP=1 - IF(IS.EQ.0) IS=1 - IF(JN.EQ.0) JN=IMAX - IF(JS.EQ.0) JS=-JN - IF(KW.EQ.0) KW=2*MX - IF(KG.EQ.0) KG=IMAX*JMAX - IF(JB.EQ.0) JB=1 - IF(JE.EQ.0) JE=(JMAX+1)/2 - IF(JC.EQ.0) JC=NCPUS() -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(IDIR.LT.0.AND.JBEG.EQ.0) THEN - DO K=1,KMAX - KWS=(K-1)*KW - WAVED(KWS+1:KWS+2*MX)=0 - WAVEZ(KWS+1:KWS+2*MX)=0 - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL SPTRANFV(IROMB,MAXWV,IDRT,IMAX,JMAX,KMAX, - & IP,IS,JN,JS,KW,KG,JB,JE,JC, - & WAVED,WAVEZ,GRIDUN,GRIDUS,GRIDVN,GRIDVS,IDIR) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptrun.f b/external/sp/v2.0.2/src/sptrun.f deleted file mode 100644 index a3b47306..00000000 --- a/external/sp/v2.0.2/src/sptrun.f +++ /dev/null @@ -1,113 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,IDRTO,IMAXO,JMAXO, - & KMAX,IPRIME,ISKIPI,JSKIPI,KSKIPI, - & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDI,GRIDO) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUN SPECTRALLY TRUNCATE GRIDDED SCALAR FIELDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,IDRTO,IMAXO,JMAXO, -C & KMAX,IPRIME,ISKIPI,JSKIPI,KSKIPI, -C & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDI,GRIDO) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C IDRTO - INTEGER OUTPUT GRID IDENTIFIER -C (IDRTO=4 FOR GAUSSIAN GRID, -C IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES. -C JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPO=0) -C JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXO IF JSKIPO=0) -C KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS -C (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GRIDO - REAL (*) OUTPUT GRID FIELDS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL GRIDI(*),GRIDO(*) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & W,GRIDI(INP),GRIDI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT - JN=-JSKIPO - IF(JN.EQ.0) JN=IMAXO - JS=-JN - INP=(JMAXO-1)*MAX(0,-JN)+1 - ISP=(JMAXO-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & W,GRIDO(INP),GRIDO(ISP),1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptrund.f b/external/sp/v2.0.2/src/sptrund.f deleted file mode 100644 index 68e1981b..00000000 --- a/external/sp/v2.0.2/src/sptrund.f +++ /dev/null @@ -1,121 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUND(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, - & IDRTO,IMAXO,JMAXO,KMAX, - & IPRIME,ISKIPI,JSKIPI,KSKIPI, - & ISKIPO,JSKIPO,KSKIPO,JCPU,GRID, - & GRIDMN,GRIDX,GRIDY) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUND SPECTRALLY TRUNCATE TO GRADIENTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THEIR MEANS AND -C GRADIENTS TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUND(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, -C & IDRTO,IMAXO,JMAXO,KMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI, -C & ISKIPO,JSKIPO,KSKIPO,JCPU,GRID, -C & GRIDMN,GRIDX,GRIDY) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C IDRTO - INTEGER OUTPUT GRID IDENTIFIER -C (IDRTO=4 FOR GAUSSIAN GRID, -C IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES. -C JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPO=0) -C JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXO IF JSKIPO=0) -C KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS -C (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRID - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GRIDMN - REAL (KMAX) OUTPUT GLOBAL MEANS -C GRIDX - REAL (*) OUTPUT X-GRADIENTS -C GRIDY - REAL (*) OUTPUT Y-GRADIENTS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTRAND PERFORM A GRADIENT SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL GRID(*),GRIDX(*),GRIDY(*) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & W,GRID(INP),GRID(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT GRADIENTS - JN=-JSKIPO - IF(JN.EQ.0) JN=IMAXO - JS=-JN - INP=(JMAXO-1)*MAX(0,-JN)+1 - ISP=(JMAXO-1)*MAX(0,-JS)+1 - CALL SPTRAND(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & W,GRIDMN, - & GRIDX(INP),GRIDX(ISP),GRIDY(INP),GRIDY(ISP),1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptrung.f b/external/sp/v2.0.2/src/sptrung.f deleted file mode 100644 index b31d9e8b..00000000 --- a/external/sp/v2.0.2/src/sptrung.f +++ /dev/null @@ -1,104 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNG(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX, - & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, - & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDI,GP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNG SPECTRALLY INTERPOLATE SCALARS TO STATIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID AND POINT FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNG(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDI,GP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GP - REAL (*) STATION POINT SETS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL RLAT(*),RLON(*),GRIDI(*),GP(*) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & W,GRIDI(INP),GRIDI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT - CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,W,GP) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptrungv.f b/external/sp/v2.0.2/src/sptrungv.f deleted file mode 100644 index ba8f01be..00000000 --- a/external/sp/v2.0.2/src/sptrungv.f +++ /dev/null @@ -1,153 +0,0 @@ -C------------------------------------------------------------------------- - SUBROUTINE SPTRUNGV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX, - & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, - & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDUI,GRIDVI, - & LUV,UP,VP,LDZ,DP,ZP,LPS,PP,SP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNGV SPECTRALLY INTERPOLATE VECTORS TO STATIONS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTORS FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIED SETS OF STATION POINTS ON THE GLOBE. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID AND POINT FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRUNGV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NRSKIP,NGSKIP,JCPU,RLAT,RLON,GRIDUI,GRIDVI, -C & LUV,UP,VP,LDZ,DP,ZP,LPS,PP,SP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NMAX - INTEGER NUMBER OF STATION POINTS TO RETURN -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINT SETS -C (DEFAULTS TO NMAX IF KGSKIP=0) -C NRSKIP - INTEGER SKIP NUMBER BETWEEN STATION LATS AND LONS -C (DEFAULTS TO 1 IF NRSKIP=0) -C NGSKIP - INTEGER SKIP NUMBER BETWEEN STATION POINTS -C (DEFAULTS TO 1 IF NGSKIP=0) -C RLAT - REAL (*) STATION LATITUDES IN DEGREES -C RLON - REAL (*) STATION LONGITUDES IN DEGREES -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C UP - REAL (*) STATION U-WINDS IF LUV -C VP - REAL (*) STATION V-WINDS IF LUV -C DP - REAL (*) STATION DIVERGENCES IF LDZ -C ZP - REAL (*) STATION VORTICITIES IF LDZ -C PP - REAL (*) STATION POTENTIALS IF LPS -C SP - REAL (*) STATION STREAMFCNS IF LPS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C SPTGPT TRANSFORM SPECTRAL SCALAR TO STATION POINTS -C SPTGPTV TRANSFORM SPECTRAL VECTOR TO STATION POINTS -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - LOGICAL LUV,LDZ,LPS - REAL RLAT(*),RLON(*),GRIDUI(*),GRIDVI(*) - REAL UP(*),VP(*),DP(*),ZP(*),PP(*),SP(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & WD,WZ, - & GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT WINDS - IF(LUV) THEN - CALL SPTGPTV(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WD,WZ,UP,VP) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY - IF(LDZ) THEN - CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WD,DP) - CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WZ,ZP) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION - IF(LPS) THEN - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$OMP PARALLEL DO - DO K=1,KMAX - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1) - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1) - WD(1:2,K)=0. - WZ(1:2,K)=0. - ENDDO - CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WD,PP) - CALL SPTGPT(IROMB,MAXWV,KMAX,NMAX,MDIM,KGSKIP,NRSKIP,NGSKIP, - & RLAT,RLON,WZ,SP) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptrunl.f b/external/sp/v2.0.2/src/sptrunl.f deleted file mode 100644 index e150de18..00000000 --- a/external/sp/v2.0.2/src/sptrunl.f +++ /dev/null @@ -1,127 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNL(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, - & IDRTO,IMAXO,JMAXO,KMAX, - & IPRIME,ISKIPI,JSKIPI,KSKIPI, - & ISKIPO,JSKIPO,KSKIPO,JCPU,IDIR,GRIDI,GRIDO) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNL SPECTRALLY TRUNCATE TO LAPLACIAN -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THEIR LAPLACIAN -C OR INVERSE TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRUNL(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, -C & IDRTO,IMAXO,JMAXO,KMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI, -C & ISKIPO,JSKIPO,KSKIPO,JCPU,IDIR,GRIDI,GRIDO) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C IDRTO - INTEGER OUTPUT GRID IDENTIFIER -C (IDRTO=4 FOR GAUSSIAN GRID, -C IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES. -C JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPO=0) -C JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXO IF JSKIPO=0) -C KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS -C (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C IDIR - INTEGER FLAG -C IDIR > 0 TO TAKE LAPLACIAN -C IDIR < 0 TO TAKE INVERSE LAPLACIAN -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GRIDO - REAL (*) OUTPUT GRID FIELDS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL GRIDI(*),GRIDO(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & W,GRIDI(INP),GRIDI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TAKE LAPLACIAN AND TRANSFORM WAVE TO OUTPUT GRID - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$OMP PARALLEL DO - DO K=1,KMAX - CALL SPLAPLAC(IROMB,MAXWV,ENN1,W(1,K),W(1,K),IDIR) - W(1:2,K)=0. - ENDDO - CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & W,GRIDO(INP),GRIDO(ISP),1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptrunm.f b/external/sp/v2.0.2/src/sptrunm.f deleted file mode 100644 index c9497974..00000000 --- a/external/sp/v2.0.2/src/sptrunm.f +++ /dev/null @@ -1,117 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNM(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ, - & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, - & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON, - & GRIDI,GM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNM SPECTRALLY INTERPOLATE SCALARS TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNM(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON, -C & GRIDI,GM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GM - REAL (*) MERCATOR FIELDS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL GRIDI(*),GM(*) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & W,GRIDI(INP),GRIDI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT - CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,W,GM) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptrunmv.f b/external/sp/v2.0.2/src/sptrunmv.f deleted file mode 100644 index e32a7389..00000000 --- a/external/sp/v2.0.2/src/sptrunmv.f +++ /dev/null @@ -1,165 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNMV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ, - & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, - & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON, - & GRIDUI,GRIDVI,LUV,UM,VM,LDZ,DM,ZM,LPS,PM,SM) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNMV SPECTRALLY INTERPOLATE VECTORS TO MERCATOR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A MERCATOR GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRUNMV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,MI,MJ, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,RLAT1,RLON1,DLAT,DLON, -C & GRIDUI,GRIDVI,LUV,UM,VM,LDZ,DM,ZM,LPS,PM,SM) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C MI - INTEGER NUMBER OF POINTS IN THE FASTER ZONAL DIRECTION -C MJ - INTEGER NUMBER OF POINTS IN THE SLOWER MERID DIRECTION -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO MI*MJ IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO MI IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C RLAT1 - REAL LATITUDE OF THE FIRST GRID POINT IN DEGREES -C RLON1 - REAL LONGITUDE OF THE FIRST GRID POINT IN DEGREES -C DLAT - REAL LATITUDE INCREMENT IN DEGREES SUCH THAT -C D(PHI)/D(J)=DLAT*COS(PHI) WHERE J IS MERIDIONAL INDEX. -C DLAT IS NEGATIVE FOR GRIDS INDEXED SOUTHWARD. -C (IN TERMS OF GRID INCREMENT DY VALID AT LATITUDE RLATI, -C THE LATITUDE INCREMENT DLAT IS DETERMINED AS -C DLAT=DPR*DY/(RERTH*COS(RLATI/DPR)) -C WHERE DPR=180/PI AND RERTH IS EARTH'S RADIUS) -C DLON - REAL LONGITUDE INCREMENT IN DEGREES SUCH THAT -C D(LAMBDA)/D(I)=DLON WHERE I IS ZONAL INDEX. -C DLON IS NEGATIVE FOR GRIDS INDEXED WESTWARD. -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C UM - REAL (*) MERCATOR U-WINDS IF LUV -C VM - REAL (*) MERCATOR V-WINDS IF LUV -C DM - REAL (*) MERCATOR DIVERGENCES IF LDZ -C ZM - REAL (*) MERCATOR VORTICITIES IF LDZ -C PM - REAL (*) MERCATOR POTENTIALS IF LPS -C SM - REAL (*) MERCATOR STREAMFCNS IF LPS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C SPTGPM TRANSFORM SPECTRAL SCALAR TO MERCATOR -C SPTGPMV TRANSFORM SPECTRAL VECTOR TO MERCATOR -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - LOGICAL LUV,LDZ,LPS - REAL GRIDUI(*),GRIDVI(*) - REAL UM(*),VM(*),DM(*),ZM(*),PM(*),SM(*) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & WD,WZ, - & GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT WINDS - IF(LUV) THEN - CALL SPTGPMV(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WD,WZ,UM,VM) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY - IF(LDZ) THEN - CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WD,DM) - CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WZ,ZM) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION - IF(LPS) THEN - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$OMP PARALLEL DO - DO K=1,KMAX - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1) - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1) - WD(1:2,K)=0. - WZ(1:2,K)=0. - ENDDO - CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WD,PM) - CALL SPTGPM(IROMB,MAXWV,KMAX,MI,MJ,MDIM,KGSKIP,NISKIP,NJSKIP, - & RLAT1,RLON1,DLAT,DLON,WZ,SM) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptruns.f b/external/sp/v2.0.2/src/sptruns.f deleted file mode 100644 index a12bdc8c..00000000 --- a/external/sp/v2.0.2/src/sptruns.f +++ /dev/null @@ -1,109 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNS(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS, - & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, - & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT, - & GRIDI,GN,GS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNS SPECTRALLY INTERPOLATE SCALARS TO POLAR STEREO -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES SCALAR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIC PAIRS OF POLAR STEREOGRAPHIC SCALAR FIELDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPTRUNS(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT, -C & GRIDI,GN,GS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C GRIDI - REAL (*) INPUT GRID FIELDS -C OUTPUT ARGUMENTS: -C GN - REAL (*) NORTHERN POLAR STEREOGRAPHIC FIELDS -C GS - REAL (*) SOUTHERN POLAR STEREOGRAPHIC FIELDS -C -C SUBPROGRAMS CALLED: -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO. -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL GRIDI(*),GN(*),GS(*) - REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRAN(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & W,GRIDI(INP),GRIDI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT - CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,W,GN,GS) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptrunsv.f b/external/sp/v2.0.2/src/sptrunsv.f deleted file mode 100644 index cfdfe4a5..00000000 --- a/external/sp/v2.0.2/src/sptrunsv.f +++ /dev/null @@ -1,166 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNSV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS, - & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, - & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT, - & GRIDUI,GRIDVI, - & LUV,UN,VN,US,VS,LDZ,DN,ZN,DS,ZS, - & LPS,PN,SN,PS,SS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNSV SPECTRALLY INTERPOLATE VECTORS TO POLAR STEREO -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO SPECIFIC PAIRS OF POLAR STEREOGRAPHIC SCALAR FIELDS. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C THE GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRUNSV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX,NPS, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI,KGSKIP, -C & NISKIP,NJSKIP,JCPU,TRUE,XMESH,ORIENT, -C & GRIDUI,GRIDVI, -C & LUV,UN,VN,US,VS,LDZ,DN,ZN,DS,ZS, -C & LPS,PN,SN,PS,SS) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C NPS - INTEGER ODD ORDER OF THE POLAR STEREOGRAPHIC GRIDS -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C KGSKIP - INTEGER SKIP NUMBER BETWEEN GRID FIELDS -C (DEFAULTS TO NPS*NPS IF KGSKIP=0) -C NISKIP - INTEGER SKIP NUMBER BETWEEN GRID I-POINTS -C (DEFAULTS TO 1 IF NISKIP=0) -C NJSKIP - INTEGER SKIP NUMBER BETWEEN GRID J-POINTS -C (DEFAULTS TO NPS IF NJSKIP=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C TRUE - REAL LATITUDE AT WHICH PS GRID IS TRUE (USUALLY 60.) -C XMESH - REAL GRID LENGTH AT TRUE LATITUDE (M) -C ORIENT - REAL LONGITUDE AT BOTTOM OF NORTHERN PS GRID -C (SOUTHERN PS GRID WILL HAVE OPPOSITE ORIENTATION.) -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C UN - REAL (*) NORTHERN PS U-WINDS IF LUV -C VN - REAL (*) NORTHERN PS V-WINDS IF LUV -C US - REAL (*) SOUTHERN PS U-WINDS IF LUV -C VS - REAL (*) SOUTHERN PS V-WINDS IF LUV -C DN - REAL (*) NORTHERN DIVERGENCES IF LDZ -C ZN - REAL (*) NORTHERN VORTICITIES IF LDZ -C DS - REAL (*) SOUTHERN DIVERGENCES IF LDZ -C ZS - REAL (*) SOUTHERN VORTICITIES IF LDZ -C PN - REAL (*) NORTHERN POTENTIALS IF LPS -C SN - REAL (*) NORTHERN STREAMFCNS IF LPS -C PS - REAL (*) SOUTHERN POTENTIALS IF LPS -C SS - REAL (*) SOUTHERN STREAMFCNS IF LPS -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C SPTGPS TRANSFORM SPECTRAL SCALAR TO POLAR STEREO. -C SPTGPSV TRANSFORM SPECTRAL VECTOR TO POLAR STEREO. -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - LOGICAL LUV,LDZ,LPS - REAL GRIDUI(*),GRIDVI(*) - REAL UN(*),VN(*),US(*),VS(*),DN(*),ZN(*),DS(*),ZS(*) - REAL PN(*),SN(*),PS(*),SS(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & WD,WZ, - & GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT WINDS - IF(LUV) THEN - CALL SPTGPSV(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WD,WZ,UN,VN,US,VS) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY - IF(LDZ) THEN - CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WD,DN,DS) - CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WZ,ZN,ZS) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION - IF(LPS) THEN - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$OMP PARALLEL DO - DO K=1,KMAX - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1) - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1) - WD(1:2,K)=0. - WZ(1:2,K)=0. - ENDDO - CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WD,PN,PS) - CALL SPTGPS(IROMB,MAXWV,KMAX,NPS,MDIM,KGSKIP,NISKIP,NJSKIP, - & TRUE,XMESH,ORIENT,WZ,SN,SS) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/sptrunv.f b/external/sp/v2.0.2/src/sptrunv.f deleted file mode 100644 index 95638687..00000000 --- a/external/sp/v2.0.2/src/sptrunv.f +++ /dev/null @@ -1,177 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPTRUNV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, - & IDRTO,IMAXO,JMAXO,KMAX, - & IPRIME,ISKIPI,JSKIPI,KSKIPI, - & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDUI,GRIDVI, - & LUV,GRIDUO,GRIDVO,LDZ,GRIDDO,GRIDZO, - & LPS,GRIDPO,GRIDSO) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPTRUNV SPECTRALLY TRUNCATE GRIDDED VECTOR FIELDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM SPECTRALLY TRUNCATES VECTOR FIELDS -C ON A GLOBAL CYLINDRICAL GRID, RETURNING THE FIELDS -C TO A POSSIBLY DIFFERENT GLOBAL CYLINDRICAL GRID. -C THE WAVE-SPACE CAN BE EITHER TRIANGULAR OR RHOMBOIDAL. -C EITHER GRID-SPACE CAN BE EITHER AN EQUALLY-SPACED GRID -C (WITH OR WITHOUT POLE POINTS) OR A GAUSSIAN GRID. -C THE GRID FIELDS MAY HAVE GENERAL INDEXING. -C THE TRANSFORMS ARE ALL MULTIPROCESSED. -C OVER ZONAL WAVENUMBER TO ENSURE REPRODUCIBILITY. -C TRANSFORM SEVERAL FIELDS AT A TIME TO IMPROVE VECTORIZATION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C 1998-12-15 IREDELL OPENMP DIRECTIVES INSERTED -C -C USAGE: CALL SPTRUNV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI, -C & IDRTO,IMAXO,JMAXO,KMAX, -C & IPRIME,ISKIPI,JSKIPI,KSKIPI, -C & ISKIPO,JSKIPO,KSKIPO,JCPU,GRIDUI,GRIDVI, -C & LUV,GRIDUO,GRIDVO,LDZ,GRIDDO,GRIDZO, -C & LPS,GRIDPO,GRIDSO) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C IDRTI - INTEGER INPUT GRID IDENTIFIER -C (IDRTI=4 FOR GAUSSIAN GRID, -C IDRTI=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTI=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXI - INTEGER EVEN NUMBER OF INPUT LONGITUDES. -C JMAXI - INTEGER NUMBER OF INPUT LATITUDES. -C IDRTO - INTEGER OUTPUT GRID IDENTIFIER -C (IDRTO=4 FOR GAUSSIAN GRID, -C IDRTO=0 FOR EQUALLY-SPACED GRID INCLUDING POLES, -C IDRTO=256 FOR EQUALLY-SPACED GRID EXCLUDING POLES) -C IMAXO - INTEGER EVEN NUMBER OF OUTPUT LONGITUDES. -C JMAXO - INTEGER NUMBER OF OUTPUT LATITUDES. -C KMAX - INTEGER NUMBER OF FIELDS TO TRANSFORM. -C IPRIME - INTEGER INPUT LONGITUDE INDEX FOR THE PRIME MERIDIAN. -C (DEFAULTS TO 1 IF IPRIME=0) -C (OUTPUT LONGITUDE INDEX FOR PRIME MERIDIAN ASSUMED 1.) -C ISKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPI=0) -C JSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXI IF JSKIPI=0) -C KSKIPI - INTEGER SKIP NUMBER BETWEEN INPUT GRID FIELDS -C (DEFAULTS TO IMAXI*JMAXI IF KSKIPI=0) -C ISKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LONGITUDES -C (DEFAULTS TO 1 IF ISKIPO=0) -C JSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT LATITUDES FROM SOUTH -C (DEFAULTS TO -IMAXO IF JSKIPO=0) -C KSKIPO - INTEGER SKIP NUMBER BETWEEN OUTPUT GRID FIELDS -C (DEFAULTS TO IMAXO*JMAXO IF KSKIPO=0) -C JCPU - INTEGER NUMBER OF CPUS OVER WHICH TO MULTIPROCESS -C (DEFAULTS TO ENVIRONMENT NCPUS IF JCPU=0) -C GRIDUI - REAL (*) INPUT GRID U-WINDS -C GRIDVI - REAL (*) INPUT GRID V-WINDS -C LUV - LOGICAL FLAG WHETHER TO RETURN WINDS -C LDZ - LOGICAL FLAG WHETHER TO RETURN DIVERGENCE AND VORTICITY -C LPS - LOGICAL FLAG WHETHER TO RETURN POTENTIAL AND STREAMFCN -C OUTPUT ARGUMENTS: -C GRIDUO - REAL (*) OUTPUT U-WINDS IF LUV -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDVO - REAL (*) OUTPUT V-WINDS IF LUV -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDDO - REAL (*) OUTPUT DIVERGENCES IF LDZ -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDZO - REAL (*) OUTPUT VORTICITIES IF LDZ -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDPO - REAL (*) OUTPUT POTENTIALS IF LPS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C GRIDSO - REAL (*) OUTPUT STREAMFCNS IF LPS -C (MAY OVERLAY INPUT FIELDS IF GRID SHAPE IS APPROPRIATE) -C -C SUBPROGRAMS CALLED: -C SPWGET GET WAVE-SPACE CONSTANTS -C SPLAPLAC COMPUTE LAPLACIAN IN SPECTRAL SPACE -C SPTRAN PERFORM A SCALAR SPHERICAL TRANSFORM -C SPTRANV PERFORM A VECTOR SPHERICAL TRANSFORM -C NCPUS GETS ENVIRONMENT NUMBER OF CPUS -C -C REMARKS: MINIMUM GRID DIMENSIONS FOR UNALIASED TRANSFORMS TO SPECTRAL: -C DIMENSION LINEAR QUADRATIC -C ----------------------- --------- ------------- -C IMAX 2*MAXWV+2 3*MAXWV/2*2+2 -C JMAX (IDRT=4,IROMB=0) 1*MAXWV+1 3*MAXWV/2+1 -C JMAX (IDRT=4,IROMB=1) 2*MAXWV+1 5*MAXWV/2+1 -C JMAX (IDRT=0,IROMB=0) 2*MAXWV+3 3*MAXWV/2*2+3 -C JMAX (IDRT=0,IROMB=1) 4*MAXWV+3 5*MAXWV/2*2+3 -C JMAX (IDRT=256,IROMB=0) 2*MAXWV+1 3*MAXWV/2*2+1 -C JMAX (IDRT=256,IROMB=1) 4*MAXWV+1 5*MAXWV/2*2+1 -C ----------------------- --------- ------------- -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - LOGICAL LUV,LDZ,LPS - REAL GRIDUI(*),GRIDVI(*) - REAL GRIDUO(*),GRIDVO(*),GRIDDO(*),GRIDZO(*),GRIDPO(*),GRIDSO(*) - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) - REAL WD((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) - REAL WZ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,KMAX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM INPUT GRID TO WAVE - JC=JCPU - IF(JC.EQ.0) JC=NCPUS() - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MDIM=2*MX+1 - JN=-JSKIPI - IF(JN.EQ.0) JN=IMAXI - JS=-JN - INP=(JMAXI-1)*MAX(0,-JN)+1 - ISP=(JMAXI-1)*MAX(0,-JS)+1 - CALL SPTRANV(IROMB,MAXWV,IDRTI,IMAXI,JMAXI,KMAX, - & IPRIME,ISKIPI,JN,JS,MDIM,KSKIPI,0,0,JC, - & WD,WZ, - & GRIDUI(INP),GRIDUI(ISP),GRIDVI(INP),GRIDVI(ISP),-1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT WINDS - JN=-JSKIPO - IF(JN.EQ.0) JN=IMAXO - JS=-JN - INP=(JMAXO-1)*MAX(0,-JN)+1 - ISP=(JMAXO-1)*MAX(0,-JS)+1 - IF(LUV) THEN - CALL SPTRANV(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & WD,WZ, - & GRIDUO(INP),GRIDUO(ISP),GRIDVO(INP),GRIDVO(ISP),1) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT DIVERGENCE AND VORTICITY - IF(LDZ) THEN - CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & WD,GRIDDO(INP),GRIDDO(ISP),1) - CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & WZ,GRIDZO(INP),GRIDZO(ISP),1) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C TRANSFORM WAVE TO OUTPUT POTENTIAL AND STREAMFUNCTION - IF(LPS) THEN - CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$OMP PARALLEL DO - DO K=1,KMAX - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WD(1,K),WD(1,K),-1) - CALL SPLAPLAC(IROMB,MAXWV,ENN1,WZ(1,K),WZ(1,K),-1) - WD(1:2,K)=0. - WZ(1:2,K)=0. - ENDDO - CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & WD,GRIDPO(INP),GRIDPO(ISP),1) - CALL SPTRAN(IROMB,MAXWV,IDRTO,IMAXO,JMAXO,KMAX, - & 0,ISKIPO,JN,JS,MDIM,KSKIPO,0,0,JC, - & WZ,GRIDSO(INP),GRIDSO(ISP),1) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/sp/v2.0.2/src/spuv2dz.f b/external/sp/v2.0.2/src/spuv2dz.f deleted file mode 100644 index 573a2377..00000000 --- a/external/sp/v2.0.2/src/spuv2dz.f +++ /dev/null @@ -1,94 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPUV2DZ(I,M,ENN1,ELONN1,EON,EONTOP,U,V,UTOP,VTOP,D,Z) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPUV2DZ COMPUTE DIVERGENCE AND VORTICITY FROM WINDS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE DIVERGENCE AND VORTICITY FROM WIND COMPONENTS -C IN SPECTRAL SPACE. -C SUBPROGRAM SPEPS SHOULD BE CALLED ALREADY. -C IF L IS THE ZONAL WAVENUMBER, N IS THE TOTAL WAVENUMBER, -C EPS(L,N)=SQRT((N**2-L**2)/(4*N**2-1)) AND A IS EARTH RADIUS, -C THEN THE DIVERGENCE D IS COMPUTED AS -C D(L,N)=I*L*A*U(L,N) -C +EPS(L,N+1)*N*A*V(L,N+1)-EPS(L,N)*(N+1)*A*V(L,N-1) -C AND THE VORTICITY Z IS COMPUTED AS -C Z(L,N)=I*L*A*V(L,N) -C -EPS(L,N+1)*N*A*U(L,N+1)+EPS(L,N)*(N+1)*A*U(L,N-1) -C WHERE U IS THE ZONAL WIND AND V IS THE MERIDIONAL WIND. -C U AND V ARE WEIGHTED BY THE SECANT OF LATITUDE. -C EXTRA TERMS ARE USED OVER TOP OF THE SPECTRAL DOMAIN. -C ADVANTAGE IS TAKEN OF THE FACT THAT EPS(L,L)=0 -C IN ORDER TO VECTORIZE OVER THE ENTIRE SPECTRAL DOMAIN. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPUV2DZ(I,M,ENN1,ELONN1,EON,EONTOP,U,V,UTOP,VTOP,D,Z) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C ENN1 - REAL ((M+1)*((I+1)*M+2)/2) N*(N+1)/A**2 -C ELONN1 - REAL ((M+1)*((I+1)*M+2)/2) L/(N*(N+1))*A -C EON - REAL ((M+1)*((I+1)*M+2)/2) EPSILON/N*A -C EONTOP - REAL (M+1) EPSILON/N*A OVER TOP -C U - REAL ((M+1)*((I+1)*M+2)) ZONAL WIND (OVER COSLAT) -C V - REAL ((M+1)*((I+1)*M+2)) MERID WIND (OVER COSLAT) -C UTOP - REAL (2*(M+1)) ZONAL WIND (OVER COSLAT) OVER TOP -C VTOP - REAL (2*(M+1)) MERID WIND (OVER COSLAT) OVER TOP -C -C OUTPUT ARGUMENT LIST: -C D - REAL ((M+1)*((I+1)*M+2)) DIVERGENCE -C Z - REAL ((M+1)*((I+1)*M+2)) VORTICITY -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL ENN1((M+1)*((I+1)*M+2)/2),ELONN1((M+1)*((I+1)*M+2)/2) - REAL EON((M+1)*((I+1)*M+2)/2),EONTOP(M+1) - REAL U((M+1)*((I+1)*M+2)),V((M+1)*((I+1)*M+2)) - REAL UTOP(2*(M+1)),VTOP(2*(M+1)) - REAL D((M+1)*((I+1)*M+2)),Z((M+1)*((I+1)*M+2)) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE TERMS FROM THE SPECTRAL DOMAIN - K=1 - D(2*K-1)=0. - D(2*K)=0. - Z(2*K-1)=0. - Z(2*K)=0. - DO K=2,(M+1)*((I+1)*M+2)/2-1 - D(2*K-1)=-ELONN1(K)*U(2*K)+EON(K+1)*V(2*K+1)-EON(K)*V(2*K-3) - D(2*K)=ELONN1(K)*U(2*K-1)+EON(K+1)*V(2*K+2)-EON(K)*V(2*K-2) - Z(2*K-1)=-ELONN1(K)*V(2*K)-EON(K+1)*U(2*K+1)+EON(K)*U(2*K-3) - Z(2*K)=ELONN1(K)*V(2*K-1)-EON(K+1)*U(2*K+2)+EON(K)*U(2*K-2) - ENDDO - K=(M+1)*((I+1)*M+2)/2 - D(2*K-1)=-ELONN1(K)*U(2*K)-EON(K)*V(2*K-3) - D(2*K)=ELONN1(K)*U(2*K-1)-EON(K)*V(2*K-2) - Z(2*K-1)=-ELONN1(K)*V(2*K)+EON(K)*U(2*K-3) - Z(2*K)=ELONN1(K)*V(2*K-1)+EON(K)*U(2*K-2) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE TERMS FROM OVER TOP OF THE SPECTRAL DOMAIN -CDIR$ IVDEP - DO L=0,M - K=L*(2*M+(I-1)*(L-1))/2+I*L+M+1 - D(2*K-1)=D(2*K-1)+EONTOP(L+1)*VTOP(2*L+1) - D(2*K)=D(2*K)+EONTOP(L+1)*VTOP(2*L+2) - Z(2*K-1)=Z(2*K-1)-EONTOP(L+1)*UTOP(2*L+1) - Z(2*K)=Z(2*K)-EONTOP(L+1)*UTOP(2*L+2) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C MULTIPLY BY LAPLACIAN TERM - DO K=2,(M+1)*((I+1)*M+2)/2 - D(2*K-1)=D(2*K-1)*ENN1(K) - D(2*K)=D(2*K)*ENN1(K) - Z(2*K-1)=Z(2*K-1)*ENN1(K) - Z(2*K)=Z(2*K)*ENN1(K) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/sp/v2.0.2/src/spvar.f b/external/sp/v2.0.2/src/spvar.f deleted file mode 100644 index 87187e97..00000000 --- a/external/sp/v2.0.2/src/spvar.f +++ /dev/null @@ -1,48 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPVAR(I,M,Q,QVAR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPVAR COMPUTE VARIANCE BY TOTAL WAVENUMBER -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: COMPUTES THE VARIANCES BY TOTAL WAVENUMBER -C OF A SCALAR FIELD IN SPECTRAL SPACE. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C -C USAGE: CALL SPVAR(I,M,Q,QVAR) -C -C INPUT ARGUMENT LIST: -C I - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C M - INTEGER SPECTRAL TRUNCATION -C Q - REAL ((M+1)*((I+1)*M+2)) SCALAR FIELD -C -C OUTPUT ARGUMENT LIST: -C QVAR - REAL (0:(I+1)*M) VARIANCES -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - REAL Q((M+1)*((I+1)*M+2)) - REAL QVAR(0:(I+1)*M) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - L=0 - DO N=0,M - KS=L*(2*M+(I-1)*(L-1))+2*N - QVAR(N)=0.5*Q(KS+1)**2 - ENDDO - DO N=M+1,(I+1)*M - QVAR(N)=0. - ENDDO - DO N=0,(I+1)*M - DO L=MAX(1,N-M),MIN(N,M) - KS=L*(2*M+(I-1)*(L-1))+2*N - QVAR(N)=QVAR(N)+Q(KS+1)**2+Q(KS+2)**2 - ENDDO - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/sp/v2.0.2/src/spwget.f b/external/sp/v2.0.2/src/spwget.f deleted file mode 100644 index 171a8b4f..00000000 --- a/external/sp/v2.0.2/src/spwget.f +++ /dev/null @@ -1,41 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SPWGET GET WAVE-SPACE CONSTANTS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-02-29 -C -C ABSTRACT: THIS SUBPROGRAM GETS WAVE-SPACE CONSTANTS. -C -C PROGRAM HISTORY LOG: -C 96-02-29 IREDELL -C -C USAGE: CALL SPWGET(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) -C INPUT ARGUMENTS: -C IROMB - INTEGER SPECTRAL DOMAIN SHAPE -C (0 FOR TRIANGULAR, 1 FOR RHOMBOIDAL) -C MAXWV - INTEGER SPECTRAL TRUNCATION -C OUTPUT ARGUMENTS: -C EPS - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EPSTOP - REAL (MAXWV+1) -C ENN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C ELONN1 - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EON - REAL ((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) -C EONTOP - REAL (MAXWV+1) -C -C SUBPROGRAMS CALLED: -C SPEPS COMPUTE UTILITY SPECTRAL FIELDS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C -C$$$ - REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1) - REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2) - REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MX=(MAXWV+1)*((IROMB+1)*MAXWV+2)/2 - MXTOP=MAXWV+1 - CALL SPEPS(IROMB,MAXWV,EPS,EPSTOP,ENN1,ELONN1,EON,EONTOP) - END diff --git a/external/w3nco/v2.0.6/src/CMakeLists.txt b/external/w3nco/v2.0.6/src/CMakeLists.txt deleted file mode 100644 index 186bbc6e..00000000 --- a/external/w3nco/v2.0.6/src/CMakeLists.txt +++ /dev/null @@ -1,155 +0,0 @@ -SET(W3_source_code ${W3LIB_SRC}/aea.f - ${W3LIB_SRC}/errexit.f - ${W3LIB_SRC}/errmsg.f - ${W3LIB_SRC}/fparsei.f - ${W3LIB_SRC}/fparser.f - ${W3LIB_SRC}/gbyte.f - ${W3LIB_SRC}/gbytec.f - ${W3LIB_SRC}/gbytes.f - ${W3LIB_SRC}/gbytesc.f - ${W3LIB_SRC}/getbit.f - ${W3LIB_SRC}/getgb.f - ${W3LIB_SRC}/getgb1.f - ${W3LIB_SRC}/getgb1r.f - ${W3LIB_SRC}/getgb1re.f - ${W3LIB_SRC}/getgb1s.f - ${W3LIB_SRC}/getgbe.f - ${W3LIB_SRC}/getgbeh.f - ${W3LIB_SRC}/getgbem.f - ${W3LIB_SRC}/getgbemh.f - ${W3LIB_SRC}/getgbemn.f - ${W3LIB_SRC}/getgbemp.f - ${W3LIB_SRC}/getgbep.f - ${W3LIB_SRC}/getgbex.f - ${W3LIB_SRC}/getgbexm.f - ${W3LIB_SRC}/getgbh.f - ${W3LIB_SRC}/getgbm.f - ${W3LIB_SRC}/getgbmh.f - ${W3LIB_SRC}/getgbmp.f - ${W3LIB_SRC}/getgbp.f - ${W3LIB_SRC}/getgi.f - ${W3LIB_SRC}/getgir.f - ${W3LIB_SRC}/gtbits.f - ${W3LIB_SRC}/idsdef.f - ${W3LIB_SRC}/instrument.f - ${W3LIB_SRC}/iw3jdn.f - ${W3LIB_SRC}/iw3pds.f - ${W3LIB_SRC}/iw3unp29.f - ${W3LIB_SRC}/ixgb.f - ${W3LIB_SRC}/lengds.f - ${W3LIB_SRC}/makwmo.f - ${W3LIB_SRC}/mkfldsep.f - ${W3LIB_SRC}/mova2i.c - ${W3LIB_SRC}/pdsens.f - ${W3LIB_SRC}/pdseup.f - ${W3LIB_SRC}/putgb.f - ${W3LIB_SRC}/putgbe.f - ${W3LIB_SRC}/putgben.f - ${W3LIB_SRC}/putgbex.f - ${W3LIB_SRC}/putgbn.f - ${W3LIB_SRC}/q9ie32.f - ${W3LIB_SRC}/r63w72.f - ${W3LIB_SRC}/sbyte.f - ${W3LIB_SRC}/sbytec.f - ${W3LIB_SRC}/sbytes.f - ${W3LIB_SRC}/sbytesc.f - ${W3LIB_SRC}/skgb.f - #${W3LIB_SRC}/summary.c - ${W3LIB_SRC}/w3ai00.f - ${W3LIB_SRC}/w3ai01.f - ${W3LIB_SRC}/w3ai08.f - ${W3LIB_SRC}/w3ai15.f - ${W3LIB_SRC}/w3ai18.f - ${W3LIB_SRC}/w3ai19.f - ${W3LIB_SRC}/w3ai24.f - ${W3LIB_SRC}/w3ai38.f - ${W3LIB_SRC}/w3ai39.f - ${W3LIB_SRC}/w3aq15.f - ${W3LIB_SRC}/w3as00.f - ${W3LIB_SRC}/w3difdat.f - ${W3LIB_SRC}/w3doxdat.f - ${W3LIB_SRC}/w3fi01.f - ${W3LIB_SRC}/w3fi04.f - ${W3LIB_SRC}/w3fi58.f - ${W3LIB_SRC}/w3fi59.f - ${W3LIB_SRC}/w3fi62.f - ${W3LIB_SRC}/w3fi63.f - ${W3LIB_SRC}/w3fi64.f - ${W3LIB_SRC}/w3fi68.f - ${W3LIB_SRC}/w3fi69.f - ${W3LIB_SRC}/w3fi71.f - ${W3LIB_SRC}/w3fi72.f - ${W3LIB_SRC}/w3fi73.f - ${W3LIB_SRC}/w3fi74.f - ${W3LIB_SRC}/w3fi75.f - ${W3LIB_SRC}/w3fi76.f - ${W3LIB_SRC}/w3fi82.f - ${W3LIB_SRC}/w3fi83.f - ${W3LIB_SRC}/w3fi88.f - ${W3LIB_SRC}/w3fi92.f - ${W3LIB_SRC}/w3fp11.f - ${W3LIB_SRC}/w3fp12.f - ${W3LIB_SRC}/w3fp13.f - ${W3LIB_SRC}/w3fs13.f - ${W3LIB_SRC}/w3fs15.f - ${W3LIB_SRC}/w3fs21.f - ${W3LIB_SRC}/w3fs26.f - ${W3LIB_SRC}/w3ft32.f - ${W3LIB_SRC}/w3kind.f - ${W3LIB_SRC}/w3locdat.f - ${W3LIB_SRC}/w3movdat.f - ${W3LIB_SRC}/w3nogds.f - ${W3LIB_SRC}/w3pradat.f - ${W3LIB_SRC}/w3reddat.f - ${W3LIB_SRC}/w3tagb.f - ${W3LIB_SRC}/w3trnarg.f - ${W3LIB_SRC}/w3unpk77.f - ${W3LIB_SRC}/w3utcdat.f - ${W3LIB_SRC}/w3valdat.f - ${W3LIB_SRC}/w3ymdh4.f - ${W3LIB_SRC}/xmovex.f - ${W3LIB_SRC}/xstore.f -) - -#set Fortran compiler flags -if (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") - #set(f_flags -fno-range-check -O3 -DLINUX) - set(f_flags -O0 -g -fdefault-real-8 -fno-range-check -ffixed-form -fPIC) -elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "Intel") - set(f_flags -O0 -g -r8 -fixed -fPIC) -elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "PGI") - set(f_flags -O0 -g -r8 -Mfixed -fPIC) -else (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") - message ("CMAKE_Fortran_COMPILER full path: " ${CMAKE_Fortran_COMPILER}) - message ("Fortran compiler: " ${CMAKE_Fortran_COMPILER_ID}) - message (FATAL_ERROR "This library has only been compiled with gfortran, pgf90 and ifort. If another compiler is needed, the appropriate flags must be added in ${W3LIB_SRC}/CMakeLists.txt") -endif (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") - -#set C compiler flags -set(c_flags -O3 -fPIC) - -#add OpenMP -set(c_flags ${c_flags} ${OpenMP_C_FLAGS}) -set(f_flags ${f_flags} ${OpenMP_Fortran_FLAGS}) - -if (${CMAKE_SYSTEM_NAME} MATCHES "Darwin") - set(c_flags ${c_flags} -DMACOSX) -elseif (${CMAKE_SYSTEM_NAME} MATCHES "Linux") - set(c_flags ${c_flags} -DLINUX) -else (${CMAKE_SYSTEM_NAME} MATCHES "Darwin") - message (FATAL_ERROR "This library has only been compiled on Linux and Darwin platforms. If another platform is needed, the appropriate flags must be added in ${W3LIB_SRC}/CMakeLists.txt") -endif (${CMAKE_SYSTEM_NAME} MATCHES "Darwin") - -if(${CMAKE_VERSION} LESS 3.3) - file(GLOB f_files *.f) - string (REPLACE ";" " " f_flags_str "${f_flags}") - set(CMAKE_Fortran_FLAGS "${f_flags_str}") - file(GLOB c_files *.c) - string (REPLACE ";" " " c_flags_str "${c_flags}") - set(CMAKE_C_FLAGS "${c_flags_str}") -else(${CMAKE_VERSION} LESS 3.3) - add_compile_options("$<$:${f_flags}>") - add_compile_options("$<$:${c_flags}>") -endif (${CMAKE_VERSION} LESS 3.3) - -ADD_LIBRARY(w3 STATIC ${W3_source_code}) diff --git a/external/w3nco/v2.0.6/src/Makefile b/external/w3nco/v2.0.6/src/Makefile deleted file mode 100644 index 276308cb..00000000 --- a/external/w3nco/v2.0.6/src/Makefile +++ /dev/null @@ -1,27 +0,0 @@ -# libsrc/w3nco makefile template -# -# Build Double Precision (Size of Real 8-byte and default Integer) version -# of libw3nco_d.a -# -# -include ../../../../macros.make - -FC = $(FCserial) -LIB = ../../../../libw3nco_d.a -FFLAGS = $(W3NCO_FFLAGS) -AFLAGS = $(W3NCO_ARFLAGS) -CFLAGS = $(W3NCO_CFLAGS) -SRCS = $(wildcard *.f *.c) -OBJS = $(addsuffix .o, $(basename $(SRCS))) - -%.o: %.f - $(FC) -c $(FFLAGS) $< - -%.o: %.c - $(CC) -c $(CFLAGS) $< - -$(LIB): $(OBJS) - ar $(AFLAGS) $@ $^ - -clean: - $(RM) *.o *.mod $(LIB) diff --git a/external/w3nco/v2.0.6/src/aea.f b/external/w3nco/v2.0.6/src/aea.f deleted file mode 100644 index f0361fdd..00000000 --- a/external/w3nco/v2.0.6/src/aea.f +++ /dev/null @@ -1,117 +0,0 @@ - SUBROUTINE AEA (IA, IE, NC ) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AEA ASCII TO EBCDIC, OR EBCDIC TO ASCII -C PRGMMR: DESMARAIS ORG: W342 DATE: 82-11-29 -C -C ABSTRACT: CONVERT ASCII TO EBCDIC, OR EBCDIC TO ASCII BY CHARACTER. -C THIS SUBROUTINE CAN BE REPLACED BY CRAY UTILITY SUBROUTINES -C USCCTC AND USCCTT. SEE MANUAL SR-2079 PAGE 3-15. CRAY UTILITY TR -C CAN ALSO BE USED FOR ASCII, EBCDIC CONVERSION. SEE MANUAL SR-2079 -C PAGE 9-35. -C -C PROGRAM HISTORY LOG: -C 82-11-29 DESMARAIS -C 88-03-31 R.E.JONES CHANGE LOGIC SO IT WORKS LIKE A -C IBM370 TRANSLATE INSTRUCTION. -C 88-08-22 R.E.JONES CHANGES FOR MICROSOFT FORTRAN 4.10 -C 88-09-04 R.E.JONES CHANGE TABLES TO 128 CHARACTER SET -C 90-01-31 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C CRAY DOES NOT ALLOW CHAR*1 TO BE SET TO HEX -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C -C USAGE: CALL AEA (IA, IE, NC) -C INPUT ARGUMENT LIST: -C IA - CHARACTER*1 ARRAY OF ASCII DATA IF NC < 0 -C IE - CHARACTER*1 ARRAY OF EBCDIC DATA IF NC > 0 -C NC - INTEGER, CONTAINS CHARACTER COUNT TO CONVERT.... -C IF NC .LT. 0, CONVERT ASCII TO EBCDIC -C IF NC .GT. 0, CONVERT EBCDIC TO ASCII -C -C OUTPUT ARGUMENT LIST: -C IA - CHARACTER*1 ARRAY OF ASCII DATA IF NC > 0 -C IE - CHARACTER*1 ARRAY OF EBCDIC DATA IF NC < 0 -C -C REMARKS: SOFTWARE VERSION OF IBM370 TRANSLATE INSTRUCTION, BY -C CHANGING THE TWO TABLES WE COULD DO A 64, 96, 128 ASCII -C CHARACTER SET, CHANGE LOWER CASE TO UPPER, ETC. -C AEA CONVERTS DATA AT A RATE OF 1.5 MILLION CHARACTERS PER SEC. -C CRAY UTILITY USCCTI CONVERT IBM EBCDIC TO ASCII -C CRAY UTILITY USCCTC CONVERT ASCII TO IBM EBCDIC -C THEY CONVERT DATA AT A RATE OF 2.1 MILLION CHARACTERS PER SEC. -C CRAY UTILITY TR WILL ALSO DO A ASCII, EBCDIC CONVERSION. -C TR CONVERT DATA AT A RATE OF 5.4 MILLION CHARACTERS PER SEC. -C TR IS IN LIBRARY /USR/LIB/LIBCOS.A ADD TO SEGLDR CARD. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM SP -C -C$$$ -C*** ASCII CONTAINS ASCII CHARACTERS, AS PUNCHED ON IBM029 -C - INTEGER(8) IASCII(32) - INTEGER(8) IEBCDC(32) -C - CHARACTER*1 IA(*) - CHARACTER*1 IE(*) - CHARACTER*1 ASCII(0:255) - CHARACTER*1 EBCDIC(0:255) -C - EQUIVALENCE (IASCII(1),ASCII(0)) - EQUIVALENCE (IEBCDC(1),EBCDIC(0)) -C - DATA IASCII/ - & X'000102030009007F',X'0000000B0C0D0E0F', - & X'1011120000000000',X'1819000000000000', - & X'00001C000A001700',X'0000000000050607', - & X'00001600001E0004',X'000000001415001A', - & X'2000600000000000',X'0000602E3C282B00', - & X'2600000000000000',X'000021242A293B5E', - & X'2D2F000000000000',X'00007C2C255F3E3F', - & X'0000000000000000',X'00603A2340273D22', - & X'2061626364656667',X'6869202020202020', - & X'206A6B6C6D6E6F70',X'7172202020202020', - & X'207E737475767778',X'797A2020205B2020', - & X'0000000000000000',X'00000000005D0000', - & X'7B41424344454647',X'4849202020202020', - & X'7D4A4B4C4D4E4F50',X'5152202020202020', - & X'5C20535455565758',X'595A202020202020', - & X'3031323334353637',X'3839202020202020'/ -C -C*** EBCDIC CONTAINS HEX. REPRESENTATION OF EBCDIC CHARACTERS -C - DATA IEBCDC/ - & X'00010203372D2E2F',X'1605250B0C0D0E0F', - & X'101112003C3D3226',X'18193F2722003500', - & X'405A7F7B5B6C507D',X'4D5D5C4E6B604B61', - & X'F0F1F2F3F4F5F6F7',X'F8F97A5E4C7E6E6F', - & X'7CC1C2C3C4C5C6C7',X'C8C9D1D2D3D4D5D6', - & X'D7D8D9E2E3E4E5E6',X'E7E8E9ADE0BD5F6D', - & X'7981828384858687',X'8889919293949596', - & X'979899A2A3A4A5A6',X'A7A8A9C06AD0A107', - & 16*X'4040404040404040'/ -C - NUM = IABS(NC) -C - IF (NC .EQ. 0) RETURN -C - IF (NC .GT. 0) THEN -C -C*** CONVERT STRING ... EBCDIC TO ASCII, NUM CHARACTERS -C - DO 10 J = 1, NUM - IA(J) = ASCII(mova2i(IE(J))) - 10 CONTINUE -C - ELSE -C -C*** CONVERT STRING ... ASCII TO EBCDIC, NUM CHARACTERS -C - DO 20 J = 1, NUM - IE(J) = EBCDIC(mova2i(IA(J))) - 20 CONTINUE - END IF -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/errexit.f b/external/w3nco/v2.0.6/src/errexit.f deleted file mode 100644 index bc482fcb..00000000 --- a/external/w3nco/v2.0.6/src/errexit.f +++ /dev/null @@ -1,33 +0,0 @@ - SUBROUTINE ERREXIT(IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: ERREXIT EXIT WITH A RETURN CODE -C PRGMMR: IREDELL ORG: NP23 DATE:1998-06-04 -C -C ABSTRACT: EXIT WITH A RETURN CODE -C -C PROGRAM HISTORY LOG: -C 1998-06-04 IREDELL -C 1999-01-26 Gilbert - changed to use XLF utility routine exit_(n) -C instead of exit(n). exit_(n) will return -C the proper value ( n must be 4 byte int ) -C to the sh/ksh shell status variable $? -C ( $status for csh ) on the IBM SP. -C -C USAGE: CALL ERREXIT(IRET) -C INPUT ARGUMENT LIST: -C IRET - INTEGER RETURN CODE -C -C SUBPROGRAMS CALLED: -C EXIT_ - EXITS FROM A FORTRAN PROGRAM -C -C ATTRIBUTES: -C LANGUAGE: XLF FORTRAN 90 -C MACHINE: IBM SP -C -C$$$ - INTEGER IRET - INTEGER(4) JRET - JRET=IRET - CALL exit(JRET) - END diff --git a/external/w3nco/v2.0.6/src/errmsg.f b/external/w3nco/v2.0.6/src/errmsg.f deleted file mode 100644 index c15a541e..00000000 --- a/external/w3nco/v2.0.6/src/errmsg.f +++ /dev/null @@ -1,29 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE ERRMSG(CMSG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: ERRMSG WRITE A MESSAGE TO STDERR -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: WRITE A MESSAGE TO STDERR. -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C -C USAGE: CALL ERRMSG(CMSG) -C INPUT ARGUMENTS: -C CMSG CHARACTER*(*) MESSAGE TO WRITE -C -C REMARKS: THIS IS A MACHINE-DEPENDENT SUBPROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN -C MACHINE: CRAY -C -C$$$ - CHARACTER*(*) CMSG -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - WRITE(0,'(A)') CMSG -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/fparsei.f b/external/w3nco/v2.0.6/src/fparsei.f deleted file mode 100644 index dccf3aa1..00000000 --- a/external/w3nco/v2.0.6/src/fparsei.f +++ /dev/null @@ -1,39 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE FPARSEI(CARG,MARG,KARG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FPARSER PARSE INTEGERS FROM A CHARACTER STRING -C PRGMMR: IREDELL ORG: NP23 DATE:1998-09-03 -C -C ABSTRACT: THIS SUBPROGRAM EXTRACTS INTEGERS FROM A FREE-FORMAT -C CHARACTER STRING. IT IS USEFUL FOR PARSING COMMAND ARGUMENTS. -C -C PROGRAM HISTORY LOG: -C 1998-09-03 IREDELL -C -C USAGE: CALL FPARSEI(CARG,MARG,KARG) -C -C INPUT ARGUMENT LIST: -C CARG - CHARACTER*(*) STRING OF ASCII DIGITS TO PARSE. -C INTEGERS MAY BE SEPARATED BY A COMMA OR BY BLANKS. -C MARG - INTEGER MAXIMUM NUMBER OF INTEGERS TO PARSE. -C -C OUTPUT ARGUMENT LIST: -C KARG - INTEGER (MARG) NUMBERS PARSED. -C (FROM 0 TO MARG VALUES MAY BE RETURNED.) -C -C REMARKS: -C TO DETERMINE THE ACTUAL NUMBER OF INTEGERS FOUND IN THE STRING, -C KARG SHOULD BE SET TO FILL VALUES BEFORE THE CALL TO FPARSEI AND -C THE NUMBER OF NON-FILL VALUES SHOULD BE COUNTED AFTER THE CALL. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - CHARACTER*(*) CARG - INTEGER KARG(MARG) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - READ(CARG,*,IOSTAT=IOS) KARG -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/w3nco/v2.0.6/src/fparser.f b/external/w3nco/v2.0.6/src/fparser.f deleted file mode 100644 index 85370ccf..00000000 --- a/external/w3nco/v2.0.6/src/fparser.f +++ /dev/null @@ -1,39 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE FPARSER(CARG,MARG,RARG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FPARSER PARSE REAL NUMBERS FROM A CHARACTER STRING -C PRGMMR: IREDELL ORG: NP23 DATE:1998-09-03 -C -C ABSTRACT: THIS SUBPROGRAM EXTRACTS REAL NUMBERS FROM A FREE-FORMAT -C CHARACTER STRING. IT IS USEFUL FOR PARSING COMMAND ARGUMENTS. -C -C PROGRAM HISTORY LOG: -C 1998-09-03 IREDELL -C -C USAGE: CALL FPARSER(CARG,MARG,RARG) -C -C INPUT ARGUMENT LIST: -C CARG - CHARACTER*(*) STRING OF ASCII DIGITS TO PARSE. -C REAL NUMBERS MAY BE SEPARATED BY A COMMA OR BY BLANKS. -C MARG - INTEGER MAXIMUM NUMBER OF REAL NUMBERS TO PARSE. -C -C OUTPUT ARGUMENT LIST: -C RARG - REAL (MARG) NUMBERS PARSED. -C (FROM 0 TO MARG VALUES MAY BE RETURNED.) -C -C REMARKS: -C TO DETERMINE THE ACTUAL NUMBER OF REAL NUMBERS FOUND IN THE STRING, -C RARG SHOULD BE SET TO FILL VALUES BEFORE THE CALL TO FPARSER AND -C THE NUMBER OF NON-FILL VALUES SHOULD BE COUNTED AFTER THE CALL. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ - CHARACTER*(*) CARG - REAL RARG(MARG) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - READ(CARG,*,IOSTAT=IOS) RARG -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/w3nco/v2.0.6/src/gbyte.f b/external/w3nco/v2.0.6/src/gbyte.f deleted file mode 100644 index 4e0e60db..00000000 --- a/external/w3nco/v2.0.6/src/gbyte.f +++ /dev/null @@ -1,108 +0,0 @@ - SUBROUTINE GBYTE(IPACKD,IUNPKD,NOFF,NBITS) -C -C THIS PROGRAM WRITTEN BY..... -C DR. ROBERT C. GAMMILL, CONSULTANT -C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH -C MAY 1972 -C -C CHANGES FOR SiliconGraphics IRIS-4D/25 -C SiliconGraphics 3.3 FORTRAN 77 -C March 1991, RUSSELL E. JONES -C NATIONAL WEATHER SERVICE -C -C THIS IS THE FORTRAN VERSION OF GBYTE -C -C*********************************************************************** -C -C SUBROUTINE GBYTE (IPACKD,IUNPKD,NOFF,NBITS) -C -C PURPOSE TO UNPACK A BYTE INTO A TARGET WORD. THE -C UNPACKED BYTE IS RIGHT-JUSTIFIED IN THE -C TARGET WORD, AND THE REMAINDER OF THE -C WORD IS ZERO-FILLED. -C -C USAGE CALL GBYTE(IPACKD,IUNPKD,NOFF,NBITS) -C -C ARGUMENTS -C -C ON INPUT IPACKD -C THE WORD OR ARRAY CONTAINING THE BYTE TO BE -C UNPACKED. -C -C IUNPKD -C THE WORD WHICH WILL CONTAIN THE UNPACKED -C BYTE. -C -C NOFF -C THE NUMBER OF BITS TO SKIP, LEFT TO RIGHT, -C IN 'IPACKD' IN ORDER TO LOCATE THE BYTE -C TO BE UNPACKED. -C -C NBITS -C NUMBER OF BITS IN THE BYTE TO BE UNPACKED. -C MAXIMUM OF 64 BITS ON 64 BIT MACHINE, 32 -C BITS ON 32 BIT MACHINE. -C -C ON OUTPUT IUNPKD -C CONTAINS THE REQUESTED UNPACKED BYTE. -C*********************************************************************** - - INTEGER IPACKD(*) - INTEGER IUNPKD - INTEGER MASKS(64) -C - SAVE -C - DATA IFIRST/1/ - IF(IFIRST.EQ.1) THEN - CALL W3FI01(LW) - NBITSW = 8 * LW - JSHIFT = -1 * NINT(ALOG(FLOAT(NBITSW)) / ALOG(2.0)) - MASKS(1) = 1 - DO I=2,NBITSW-1 - MASKS(I) = 2 * MASKS(I-1) + 1 - ENDDO - MASKS(NBITSW) = -1 - IFIRST = 0 - ENDIF -C -C NBITS MUST BE LESS THAN OR EQUAL TO NBITSW -C - ICON = NBITSW - NBITS - IF (ICON.LT.0) RETURN - MASK = MASKS(NBITS) -C -C INDEX TELLS HOW MANY WORDS INTO THE ARRAY 'IPACKD' THE NEXT BYTE -C APPEARS. -C - INDEX = ISHFT(NOFF,JSHIFT) -C -C II TELLS HOW MANY BITS THE BYTE IS FROM THE LEFT SIDE OF THE WORD. -C - II = MOD(NOFF,NBITSW) -C -C MOVER SPECIFIES HOW FAR TO THE RIGHT NBITS MUST BE MOVED IN ORDER -C -C TO BE RIGHT ADJUSTED. -C - MOVER = ICON - II -C - IF (MOVER.GT.0) THEN - IUNPKD = IAND(ISHFT(IPACKD(INDEX+1),-MOVER),MASK) -C -C THE BYTE IS SPLIT ACROSS A WORD BREAK. -C - ELSE IF (MOVER.LT.0) THEN - MOVEL = - MOVER - MOVER = NBITSW - MOVEL - IUNPKD = IAND(IOR(ISHFT(IPACKD(INDEX+1),MOVEL), - & ISHFT(IPACKD(INDEX+2),-MOVER)),MASK) -C -C THE BYTE IS ALREADY RIGHT ADJUSTED. -C - ELSE - IUNPKD = IAND(IPACKD(INDEX+1),MASK) - ENDIF -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/gbytec.f b/external/w3nco/v2.0.6/src/gbytec.f deleted file mode 100644 index 222b0e50..00000000 --- a/external/w3nco/v2.0.6/src/gbytec.f +++ /dev/null @@ -1,6 +0,0 @@ - SUBROUTINE GBYTEC(IN,IOUT,ISKIP,NBYTE) - character*1 in(*) - integer iout(*) - CALL GBYTESC(IN,IOUT,ISKIP,NBYTE,0,1) - RETURN - END diff --git a/external/w3nco/v2.0.6/src/gbytes.f b/external/w3nco/v2.0.6/src/gbytes.f deleted file mode 100644 index 1551117d..00000000 --- a/external/w3nco/v2.0.6/src/gbytes.f +++ /dev/null @@ -1,144 +0,0 @@ - SUBROUTINE GBYTES(IPACKD,IUNPKD,NOFF,NBITS,ISKIP,ITER) -C -C THIS PROGRAM WRITTEN BY..... -C DR. ROBERT C. GAMMILL, CONSULTANT -C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH -C MAY 1972 -C -C CHANGES FOR SiliconGraphics IRIS-4D/25 -C SiliconGraphics 3.3 FORTRAN 77 -C MARCH 1991, RUSSELL E. JONES -C NATIONAL WEATHER SERVICE -C -C THIS IS THE FORTRAN VERSION OF GBYTES. -C -C*********************************************************************** -C -C SUBROUTINE GBYTES (IPACKD,IUNPKD,NOFF,NBITS,ISKIP,ITER) -C -C PURPOSE TO UNPACK A SERIES OF BYTES INTO A TARGET -C ARRAY. EACH UNPACKED BYTE IS RIGHT-JUSTIFIED -C IN ITS TARGET WORD, AND THE REMAINDER OF THE -C WORD IS ZERO-FILLED. -C -C USAGE CALL GBYTES (IPACKD,IUNPKD,NOFF,NBITS,NSKIP, -C ITER) -C -C ARGUMENTS -C ON INPUT IPACKD -C THE WORD OR ARRAY CONTAINING THE PACKED -C BYTES. -C -C IUNPKD -C THE ARRAY WHICH WILL CONTAIN THE UNPACKED -C BYTES. -C -C NOFF -C THE INITIAL NUMBER OF BITS TO SKIP, LEFT -C TO RIGHT, IN 'IPACKD' IN ORDER TO LOCATE -C THE FIRST BYTE TO UNPACK. -C -C NBITS -C NUMBER OF BITS IN THE BYTE TO BE UNPACKED. -C MAXIMUM OF 64 BITS ON 64 BIT MACHINE, 32 -C BITS ON 32 BIT MACHINE. -C -C ISKIP -C THE NUMBER OF BITS TO SKIP BETWEEN EACH BYTE -C IN 'IPACKD' IN ORDER TO LOCATE THE NEXT BYTE -C TO BE UNPACKED. -C -C ITER -C THE NUMBER OF BYTES TO BE UNPACKED. -C -C ARGUMENTS -C ON OUTPUT IUNPKD -C CONTAINS THE REQUESTED UNPACKED BYTES. -C*********************************************************************** - - INTEGER IPACKD(*) - - INTEGER IUNPKD(*) - INTEGER MASKS(64) -C - SAVE -C - DATA IFIRST/1/ - IF(IFIRST.EQ.1) THEN - CALL W3FI01(LW) - NBITSW = 8 * LW - JSHIFT = -1 * NINT(ALOG(FLOAT(NBITSW)) / ALOG(2.0)) - MASKS(1) = 1 - DO I=2,NBITSW-1 - MASKS(I) = 2 * MASKS(I-1) + 1 - ENDDO - MASKS(NBITSW) = -1 - IFIRST = 0 - ENDIF -C -C NBITS MUST BE LESS THAN OR EQUAL TO NBITSW -C - ICON = NBITSW - NBITS - IF (ICON.LT.0) RETURN - MASK = MASKS(NBITS) -C -C INDEX TELLS HOW MANY WORDS INTO THE ARRAY 'IPACKD' THE NEXT BYTE -C APPEARS. -C - INDEX = ISHFT(NOFF,JSHIFT) -C -C II TELLS HOW MANY BITS THE BYTE IS FROM THE LEFT SIDE OF THE WORD. -C - II = MOD(NOFF,NBITSW) -C -C ISTEP IS THE DISTANCE IN BITS FROM THE START OF ONE BYTE TO THE NEXT. -C - ISTEP = NBITS + ISKIP -C -C IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT. -C - IWORDS = ISTEP / NBITSW -C -C IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS. -C - IBITS = MOD(ISTEP,NBITSW) -C - DO 10 I = 1,ITER -C -C MOVER SPECIFIES HOW FAR TO THE RIGHT A BYTE MUST BE MOVED IN ORDER -C -C TO BE RIGHT ADJUSTED. -C - MOVER = ICON - II -C -C THE BYTE IS SPLIT ACROSS A WORD BREAK. -C - IF (MOVER.LT.0) THEN - MOVEL = - MOVER - MOVER = NBITSW - MOVEL - IUNPKD(I) = IAND(IOR(ISHFT(IPACKD(INDEX+1),MOVEL), - & ISHFT(IPACKD(INDEX+2),-MOVER)),MASK) -C -C RIGHT ADJUST THE BYTE. -C - ELSE IF (MOVER.GT.0) THEN - IUNPKD(I) = IAND(ISHFT(IPACKD(INDEX+1),-MOVER),MASK) -C -C THE BYTE IS ALREADY RIGHT ADJUSTED. -C - ELSE - IUNPKD(I) = IAND(IPACKD(INDEX+1),MASK) - ENDIF -C -C INCREMENT II AND INDEX. -C - II = II + IBITS - INDEX = INDEX + IWORDS - IF (II.GE.NBITSW) THEN - II = II - NBITSW - INDEX = INDEX + 1 - ENDIF -C - 10 CONTINUE - RETURN - END diff --git a/external/w3nco/v2.0.6/src/gbytesc.f b/external/w3nco/v2.0.6/src/gbytesc.f deleted file mode 100644 index 589b4da8..00000000 --- a/external/w3nco/v2.0.6/src/gbytesc.f +++ /dev/null @@ -1,51 +0,0 @@ - SUBROUTINE GBYTESC(IN,IOUT,ISKIP,NBYTE,NSKIP,N) -C Get bytes - unpack bits: Extract arbitrary size values from a -C packed bit string, right justifying each value in the unpacked -C array. -C IN = character*1 array input -C IOUT = unpacked array output -C ISKIP = initial number of bits to skip -C NBYTE = number of bits to take -C NSKIP = additional number of bits to skip on each iteration -C N = number of iterations -C v1.1 -C - character*1 in(*) - integer iout(*) - integer ones(8), tbit, bitcnt - save ones - data ones/1,3,7,15,31,63,127,255/ - -c nbit is the start position of the field in bits - nbit = iskip - do i = 1, n - bitcnt = nbyte - index=nbit/8+1 - ibit=mod(nbit,8) - nbit = nbit + nbyte + nskip - -c first byte - tbit = min(bitcnt,8-ibit) - itmp = iand(mova2i(in(index)),ones(8-ibit)) - if (tbit.ne.8-ibit) itmp = ishft(itmp,tbit-8+ibit) - index = index + 1 - bitcnt = bitcnt - tbit - -c now transfer whole bytes - do while (bitcnt.ge.8) - itmp = ior(ishft(itmp,8),mova2i(in(index))) - bitcnt = bitcnt - 8 - index = index + 1 - enddo - -c get data from last byte - if (bitcnt.gt.0) then - itmp = ior(ishft(itmp,bitcnt),iand(ishft(mova2i(in(index)), - 1 -(8-bitcnt)),ones(bitcnt))) - endif - - iout(i) = itmp - enddo - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getbit.f b/external/w3nco/v2.0.6/src/getbit.f deleted file mode 100644 index 3e4aea6f..00000000 --- a/external/w3nco/v2.0.6/src/getbit.f +++ /dev/null @@ -1,87 +0,0 @@ - SUBROUTINE GETBIT(IBM,IBS,IDS,LEN,MG,G,GROUND,GMIN,GMAX,NBIT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETBIT COMPUTE NUMBER OF BITS AND ROUND FIELD. -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: THE NUMBER OF BITS REQUIRED TO PACK A GIVEN FIELD -C FOR PARTICULAR BINARY AND DECIMAL SCALINGS IS COMPUTED. -C THE FIELD IS ROUNDED OFF TO THE DECIMAL SCALING FOR PACKING. -C THE MINIMUM AND MAXIMUM ROUNDED FIELD VALUES ARE ALSO RETURNED. -C GRIB BITMAP MASKING FOR VALID DATA IS OPTIONALLY USED. -C -C PROGRAM HISTORY LOG: -C 96-09-16 IREDELL -C -C USAGE: CALL GTBITS(IBM,IBS,IDS,LEN,MG,G,GMIN,GMAX,NBIT) -C INPUT ARGUMENT LIST: -C IBM - INTEGER BITMAP FLAG (=0 FOR NO BITMAP) -C IBS - INTEGER BINARY SCALING -C (E.G. IBS=3 TO ROUND FIELD TO NEAREST EIGHTH VALUE) -C IDS - INTEGER DECIMAL SCALING -C (E.G. IDS=3 TO ROUND FIELD TO NEAREST MILLI-VALUE) -C (NOTE THAT IDS AND IBS CAN BOTH BE NONZERO, -C E.G. IDS=1 AND IBS=1 ROUNDS TO THE NEAREST TWENTIETH) -C LEN - INTEGER LENGTH OF THE FIELD AND BITMAP -C MG - INTEGER (LEN) BITMAP IF IBM=1 (0 TO SKIP, 1 TO KEEP) -C G - REAL (LEN) FIELD -C -C OUTPUT ARGUMENT LIST: -C GROUND - REAL (LEN) FIELD ROUNDED TO DECIMAL AND BINARY SCALING -C (SET TO ZERO WHERE BITMAP IS 0 IF IBM=1) -C GMIN - REAL MINIMUM VALID ROUNDED FIELD VALUE -C GMAX - REAL MAXIMUM VALID ROUNDED FIELD VALUE -C NBIT - INTEGER NUMBER OF BITS TO PACK -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - DIMENSION MG(LEN),G(LEN),GROUND(LEN) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C ROUND FIELD AND DETERMINE EXTREMES WHERE BITMAP IS ON - S=2.**IBS*10.**IDS - IF(IBM.EQ.0) THEN - GROUND(1)=NINT(G(1)*S)/S - GMAX=GROUND(1) - GMIN=GROUND(1) - DO I=2,LEN - GROUND(I)=NINT(G(I)*S)/S - GMAX=MAX(GMAX,GROUND(I)) - GMIN=MIN(GMIN,GROUND(I)) - ENDDO - ELSE - I1=1 - DOWHILE(I1.LE.LEN.AND.MG(I1).EQ.0) - I1=I1+1 - ENDDO - IF(I1.LE.LEN) THEN - DO I=1,I1-1 - GROUND(I)=0. - ENDDO - GROUND(I1)=NINT(G(I1)*S)/S - GMAX=GROUND(I1) - GMIN=GROUND(I1) - DO I=I1+1,LEN - IF(MG(I).NE.0) THEN - GROUND(I)=NINT(G(I)*S)/S - GMAX=MAX(GMAX,GROUND(I)) - GMIN=MIN(GMIN,GROUND(I)) - ELSE - GROUND(I)=0. - ENDIF - ENDDO - ELSE - DO I=1,LEN - GROUND(I)=0. - ENDDO - GMAX=0. - GMIN=0. - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE NUMBER OF BITS - NBIT=LOG((GMAX-GMIN)*S+0.9)/LOG(2.)+1. -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgb.f b/external/w3nco/v2.0.6/src/getgb.f deleted file mode 100644 index fac9c3df..00000000 --- a/external/w3nco/v2.0.6/src/getgb.f +++ /dev/null @@ -1,213 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGB(LUGB,LUGI,JF,J,JPDS,JGDS, - & KF,K,KPDS,KGDS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGB FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGB(LUGB,LUGI,JF,J,JPDS,JGDS, -C & KF,K,KPDS,KGDS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C OUTPUT ARGUMENTS: -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGBM FIND AND UNPACK GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBM AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),KPDS(200),KGDS(200) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBM(LUGB,LUGI,JF,JJ,JPDS,JGDS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,LB,F,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgb1.f b/external/w3nco/v2.0.6/src/getgb1.f deleted file mode 100644 index 418a9846..00000000 --- a/external/w3nco/v2.0.6/src/getgb1.f +++ /dev/null @@ -1,199 +0,0 @@ - SUBROUTINE GETGB1(LUGB,LUGI,JF,J,JPDS,JGDS, - & GRIB,KF,K,KPDS,KGDS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGB1 FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ AN ASSOCIATED GRIB INDEX FILE (UNLESS IT ALREADY WAS READ). -C FIND IN THE INDEX FILE A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-05-10 R.E.JONES ADD ONE MORE PARAMETER TO GETGB AND -C CHANGE NAME TO GETGB1 -C -C USAGE: CALL GETGB1(LUGB,LUGI,JF,J,JPDS,JGDS, -C & GRIB,KF,K,KPDS,KGDS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB LOGICAL UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI LOGICAL UNIT OF THE UNBLOCKED GRIB INDEX FILE -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO REOPEN INDEX FILE AND SEARCH FROM BEGINNING) -C JPDS INTEGER (25) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C LOOK IN DOC BLOCK OF W3FI63 FOR ARRAY KPDS -C FOR LIST OF ORDER OF UNPACKED PDS VALUES. IN -C MOST CASES YOU ONLY NEED TO SET 4 OR 5 VALUES -C TO PICK UP RECORD. -C JGDS INTEGER (22) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C OUTPUT ARGUMENTS: -C GRIB GRIB DATA ARRAY BEFORE IT IS UNPACKED -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (25) UNPACKED PDS PARAMETERS -C KGDS INTEGER (22) UNPACKED GDS PARAMETERS -C LB LOGICAL (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C BAREAD BYTE-ADDRESSABLE READ -C GBYTE UNPACK BYTES -C FI632 UNPACK PDS -C FI633 UNPACK GDS -C W3FI63 UNPACK GRIB -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048 -C -C$$$ -C - PARAMETER (MBUF=8192*128) - PARAMETER (LPDS=23,LGDS=22) -C - INTEGER JPDS(25),JGDS(*),KPDS(25),KGDS(*) - INTEGER IPDSP(LPDS),JPDSP(LPDS),IGDSP(LGDS) - INTEGER JGDSP(LGDS) - INTEGER KPTR(20) -C - LOGICAL LB(*) -C - REAL F(*) -C - CHARACTER CBUF(MBUF) - CHARACTER*81 CHEAD(2) - CHARACTER*1 CPDS(28) - CHARACTER*1 CGDS(42) - CHARACTER*1 GRIB(*) -C -C SAVE LUX,NSKP,NLEN,NNUM,CBUF - SAVE -C - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ INDEX FILE - IF(J.LT.0.OR.LUGI.NE.LUX) THEN -C REWIND LUGI -C READ(LUGI,fmt='(2A81)',IOSTAT=IOS) CHEAD - CALL BAREAD(LUGI,0,162,ios,chead) - IF(IOS.EQ.162.AND.CHEAD(1)(42:47).EQ.'GB1IX1') THEN - LUX=0 - READ(CHEAD(2),'(8X,3I10,2X,A40)',IOSTAT=IOS) NSKP,NLEN,NNUM - IF(IOS.EQ.0) THEN - NBUF=NNUM*NLEN - IF(NBUF.GT.MBUF) THEN - PRINT *,'GETGB1: INCREASE BUFFER FROM ',MBUF,' TO ',NBUF - NNUM=MBUF/NLEN - NBUF=NNUM*NLEN - ENDIF - CALL BAREAD(LUGI,NSKP,NBUF,LBUF,CBUF) - IF(LBUF.EQ.NBUF) THEN - LUX=LUGI - J=MAX(J,0) - ENDIF - ENDIF - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH FOR REQUEST - LGRIB=0 - KJ=J - K=J - KF=0 - IF(J.GE.0.AND.LUGI.EQ.LUX) THEN - LPDSP=0 - DO I=1,LPDS - IF(JPDS(I).NE.-1) THEN - LPDSP=LPDSP+1 - IPDSP(LPDSP)=I - JPDSP(LPDSP)=JPDS(I) - ENDIF - ENDDO - LGDSP=0 - IF(JPDS(3).EQ.255) THEN - DO I=1,LGDS - IF(JGDS(I).NE.-1) THEN - LGDSP=LGDSP+1 - IGDSP(LGDSP)=I - JGDSP(LGDSP)=JGDS(I) - ENDIF - ENDDO - ENDIF - IRET=99 - DOWHILE(LGRIB.EQ.0.AND.KJ.LT.NNUM) - KJ=KJ+1 - LT=0 - IF(LPDSP.GT.0) THEN - CPDS=CBUF((KJ-1)*NLEN+26:(KJ-1)*NLEN+53) - KPTR=0 - CALL GBYTE(CBUF,KPTR(3),(KJ-1)*NLEN*8+25*8,3*8) - CALL FI632(CPDS,KPTR,KPDS,IRET) - DO I=1,LPDSP - IP=IPDSP(I) - LT=LT+ABS(JPDS(IP)-KPDS(IP)) - ENDDO - ENDIF - IF(LT.EQ.0.AND.LGDSP.GT.0) THEN - CGDS=CBUF((KJ-1)*NLEN+54:(KJ-1)*NLEN+95) - KPTR=0 - CALL FI633(CGDS,KPTR,KGDS,IRET) - DO I=1,LGDSP - IP=IGDSP(I) - LT=LT+ABS(JGDS(IP)-KGDS(IP)) - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND UNPACK GRIB DATA - IF(LT.EQ.0) THEN - CALL GBYTE(CBUF,LSKIP,(KJ-1)*NLEN*8,4*8) - CALL GBYTE(CBUF,LGRIB,(KJ-1)*NLEN*8+20*8,4*8) - CGDS=CBUF((KJ-1)*NLEN+54:(KJ-1)*NLEN+95) - KPTR=0 - CALL FI633(CGDS,KPTR,KGDS,IRET) -C BSM IF(LGRIB.LE.200+17*JF/8.AND.KGDS(2)*KGDS(3).LE.JF) THEN -C Change number of bits that can be handled to 25 - IF(LGRIB.LE.200+25*JF/8.AND.KGDS(2)*KGDS(3).LE.JF) THEN - CALL BAREAD(LUGB,LSKIP,LGRIB,LREAD,GRIB) - IF(LREAD.EQ.LGRIB) THEN - CALL W3FI63(GRIB,KPDS,KGDS,LB,F,KPTR,IRET) - IF(IRET.EQ.0) THEN - K=KJ - KF=KPTR(10) - ENDIF - ELSE - IRET=97 - ENDIF - ELSE - IRET=98 - ENDIF - ENDIF - ENDDO - ELSE - IRET=96 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgb1r.f b/external/w3nco/v2.0.6/src/getgb1r.f deleted file mode 100644 index fcf66cf9..00000000 --- a/external/w3nco/v2.0.6/src/getgb1r.f +++ /dev/null @@ -1,76 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,NBITSS - + ,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGB1R READS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: READ AND UNPACK A GRIB MESSAGE. -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C 04-07-22 CHUANG ADD PACKING BIT NUMBER NBITSS IN THE ARGUMENT -C LIST BECAUSE ETA GRIB FILES NEED IT TO REPACK GRIB FILE -C USAGE: CALL -C GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,,NBITSS,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LSKIP INTEGER NUMBER OF BYTES TO SKIP -C LGRIB INTEGER NUMBER OF BYTES TO READ -C OUTPUT ARGUMENTS: -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 97 ERROR READING GRIB FILE -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C BAREAD BYTE-ADDRESSABLE READ -C W3FI63 UNPACK GRIB -C PDSEUP UNPACK PDS EXTENSION -C -C REMARKS: THERE IS NO PROTECTION AGAINST UNPACKING TOO MUCH DATA. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB ROUTINES ONLY. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200),KENS(200) - LOGICAL*1 LB(*) - REAL F(*) - INTEGER KPTR(200) - CHARACTER GRIB(LGRIB)*1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ GRIB RECORD - CALL BAREAD(LUGB,LSKIP,LGRIB,LREAD,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C UNPACK GRIB RECORD - IF(LREAD.EQ.LGRIB) THEN - CALL W3FI63(GRIB,KPDS,KGDS,LB,F,KPTR,IRET) - IF(IRET.EQ.0.AND.KPDS(23).EQ.2) THEN - CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,45,GRIB(9)) - ENDIF - ELSE - IRET=97 - ENDIF - NBITSS=KPTR(20) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C RETURN NUMBER OF POINTS - IF(IRET.EQ.0) THEN - KF=KPTR(10) - ELSE - KF=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgb1re.f b/external/w3nco/v2.0.6/src/getgb1re.f deleted file mode 100644 index 46ad99e1..00000000 --- a/external/w3nco/v2.0.6/src/getgb1re.f +++ /dev/null @@ -1,81 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGB1RE(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS, - & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGB1RE READS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: READ AND UNPACK A GRIB MESSAGE. -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C 97-02-11 Y.ZHU INCLUDED PROBABILITY AND CLUSTER ARGUMENTS -C -C USAGE: CALL GETGB1RE(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS, -C & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LSKIP INTEGER NUMBER OF BYTES TO SKIP -C LGRIB INTEGER NUMBER OF BYTES TO READ -C OUTPUT ARGUMENTS: -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C KPROB INTEGER (2) PROBABILITY ENSEMBLE PARMS -C XPROB REAL (2) PROBABILITY ENSEMBLE PARMS -C KCLUST INTEGER (16) CLUSTER ENSEMBLE PARMS -C KMEMBR INTEGER (8) CLUSTER ENSEMBLE PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 97 ERROR READING GRIB FILE -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C BAREAD BYTE-ADDRESSABLE READ -C W3FI63 UNPACK GRIB -C PDSEUP UNPACK PDS EXTENSION -C -C REMARKS: THERE IS NO PROTECTION AGAINST UNPACKING TOO MUCH DATA. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB ROUTINES ONLY. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200),KENS(200) - INTEGER KPROB(2),KCLUST(16),KMEMBR(80) - REAL XPROB(2) - LOGICAL*1 LB(*) - REAL F(*) - INTEGER KPTR(200) - CHARACTER GRIB(LGRIB)*1 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ GRIB RECORD - CALL BAREAD(LUGB,LSKIP,LGRIB,LREAD,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C UNPACK GRIB RECORD - IF(LREAD.EQ.LGRIB) THEN - CALL W3FI63(GRIB,KPDS,KGDS,LB,F,KPTR,IRET) - IF(IRET.EQ.0.AND.KPDS(23).EQ.2) THEN - CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,86,GRIB(9)) - ENDIF - ELSE - IRET=97 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C RETURN NUMBER OF POINTS - IF(IRET.EQ.0) THEN - KF=KPTR(10) - ELSE - KF=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgb1s.f b/external/w3nco/v2.0.6/src/getgb1s.f deleted file mode 100644 index ec54d7e4..00000000 --- a/external/w3nco/v2.0.6/src/getgb1s.f +++ /dev/null @@ -1,185 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGB1S(CBUF,NLEN,NNUM,J,JPDS,JGDS,JENS, - & K,KPDS,KGDS,KENS,LSKIP,LGRIB,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGB1S FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C FIND IN THE INDEX FILE A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C 2001-06-05 IREDELL APPLY LINUX PORT BY EBISUZAKI -C -C USAGE: CALL GETGB1S(CBUF,NLEN,NNUM,J,JPDS,JGDS,JENS, -C & K,KPDS,KGDS,KENS,LSKIP,LGRIB,IRET) -C INPUT ARGUMENTS: -C CBUF CHARACTER*1 (NLEN*NNUM) BUFFER CONTAINING INDEX DATA -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C OUTPUT ARGUMENTS: -C K INTEGER MESSAGE NUMBER FOUND -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C LSKIP INTEGER NUMBER OF BYTES TO SKIP -C LGRIB INTEGER NUMBER OF BYTES TO READ -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 1 REQUEST NOT FOUND -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB ROUTINES ONLY. -C -C SUBPROGRAMS CALLED: -C GBYTEC UNPACK BYTES -C FI632 UNPACK PDS -C FI633 UNPACK GDS -C PDSEUP UNPACK PDS EXTENSION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - CHARACTER CBUF(NLEN*NNUM) - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - PARAMETER(LPDS=23,LGDS=22,LENS=5) ! ACTUAL SEARCH RANGES - CHARACTER CPDS(400)*1,CGDS(400)*1 - INTEGER KPTR(200) - INTEGER IPDSP(LPDS),JPDSP(LPDS) - INTEGER IGDSP(LGDS),JGDSP(LGDS) - INTEGER IENSP(LENS),JENSP(LENS) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPRESS REQUEST LISTS - K=J - LSKIP=0 - LGRIB=0 - IRET=1 -C COMPRESS PDS REQUEST - LPDSP=0 - DO I=1,LPDS - IF(JPDS(I).NE.-1) THEN - LPDSP=LPDSP+1 - IPDSP(LPDSP)=I - JPDSP(LPDSP)=JPDS(I) - ENDIF - ENDDO -C COMPRESS GDS REQUEST - LGDSP=0 - IF(JPDS(3).EQ.255) THEN - DO I=1,LGDS - IF(JGDS(I).NE.-1) THEN - LGDSP=LGDSP+1 - IGDSP(LGDSP)=I - JGDSP(LGDSP)=JGDS(I) - ENDIF - ENDDO - ENDIF -C COMPRESS ENS REQUEST - LENSP=0 - IF(JPDS(23).EQ.2) THEN - DO I=1,LENS - IF(JENS(I).NE.-1) THEN - LENSP=LENSP+1 - IENSP(LENSP)=I - JENSP(LENSP)=JENS(I) - ENDIF - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH FOR REQUEST - DOWHILE(IRET.NE.0.AND.K.LT.NNUM) - K=K+1 - LT=0 -C SEARCH FOR PDS REQUEST - IF(LPDSP.GT.0) THEN - CPDS=CHAR(0) - CPDS(1:28)=CBUF((K-1)*NLEN+26:(K-1)*NLEN+53) - NLESS=MAX(184-NLEN,0) - CPDS(29:40-NLESS)=CBUF((K-1)*NLEN+173:(K-1)*NLEN+184-NLESS) - KPTR=0 - CALL GBYTEC(CBUF,KPTR(3),(K-1)*NLEN*8+25*8,3*8) - KPDS(18)=1 - CALL GBYTEC(CPDS,KPDS(4),7*8,8) - CALL FI632(CPDS,KPTR,KPDS,KRET) - DO I=1,LPDSP - IP=IPDSP(I) - LT=LT+ABS(JPDS(IP)-KPDS(IP)) - ENDDO - ENDIF -C SEARCH FOR GDS REQUEST - IF(LT.EQ.0.AND.LGDSP.GT.0) THEN - CGDS=CHAR(0) - CGDS(1:42)=CBUF((K-1)*NLEN+54:(K-1)*NLEN+95) - NLESS=MAX(320-NLEN,0) - CGDS(43:178-NLESS)=CBUF((K-1)*NLEN+185:(K-1)*NLEN+320-NLESS) - KPTR=0 - CALL FI633(CGDS,KPTR,KGDS,KRET) - DO I=1,LGDSP - IP=IGDSP(I) - LT=LT+ABS(JGDS(IP)-KGDS(IP)) - ENDDO - ENDIF -C SEARCH FOR ENS REQUEST - IF(LT.EQ.0.AND.LENSP.GT.0) THEN - NLESS=MAX(172-NLEN,0) - CPDS(41:100-NLESS)=CBUF((K-1)*NLEN+113:(K-1)*NLEN+172-NLESS) - CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,45,CPDS) - DO I=1,LENSP - IP=IENSP(I) - LT=LT+ABS(JENS(IP)-KENS(IP)) - ENDDO - ENDIF -C RETURN IF REQUEST IS FOUND - IF(LT.EQ.0) THEN - CALL GBYTEC(CBUF,LSKIP,(K-1)*NLEN*8,4*8) - CALL GBYTEC(CBUF,LGRIB,(K-1)*NLEN*8+20*8,4*8) - IF(LPDSP.EQ.0) THEN - CPDS=CHAR(0) - CPDS(1:28)=CBUF((K-1)*NLEN+26:(K-1)*NLEN+53) - NLESS=MAX(184-NLEN,0) - CPDS(29:40-NLESS)=CBUF((K-1)*NLEN+173:(K-1)*NLEN+184-NLESS) - KPTR=0 - CALL GBYTEC(CBUF,KPTR(3),(K-1)*NLEN*8+25*8,3*8) - KPDS(18)=1 - CALL GBYTEC(CPDS,KPDS(4),7*8,8) - CALL FI632(CPDS,KPTR,KPDS,KRET) - ENDIF - IF(LGDSP.EQ.0) THEN - CGDS=CHAR(0) - CGDS(1:42)=CBUF((K-1)*NLEN+54:(K-1)*NLEN+95) - NLESS=MAX(320-NLEN,0) - CGDS(43:178-NLESS)=CBUF((K-1)*NLEN+185:(K-1)*NLEN+320-NLESS) - KPTR=0 - CALL FI633(CGDS,KPTR,KGDS,KRET) - ENDIF - IF(KPDS(23).EQ.2.AND.LENSP.EQ.0) THEN - NLESS=MAX(172-NLEN,0) - CPDS(41:100-NLESS)=CBUF((K-1)*NLEN+113:(K-1)*NLEN+172-NLESS) - CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,45,CPDS) - ENDIF - IRET=0 - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbe.f b/external/w3nco/v2.0.6/src/getgbe.f deleted file mode 100644 index 15695225..00000000 --- a/external/w3nco/v2.0.6/src/getgbe.f +++ /dev/null @@ -1,223 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBE(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, - & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBE FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBE(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, -C & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C OUTPUT ARGUMENTS: -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGBEM FIND AND UNPACK GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEM AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBEM(LUGB,LUGI,JF,JJ,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,KENS,LB,F,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbeh.f b/external/w3nco/v2.0.6/src/getgbeh.f deleted file mode 100644 index 030bed06..00000000 --- a/external/w3nco/v2.0.6/src/getgbeh.f +++ /dev/null @@ -1,215 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEH(LUGB,LUGI,J,JPDS,JGDS,JENS, - & KG,KF,K,KPDS,KGDS,KENS,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEH FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS -C RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS. IF THE -C GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBEH(LUGB,LUGI,J,JPDS,JGDS,JENS, -C & KG,KF,K,KPDS,KGDS,KENS,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C (ONLY USED IF LUGI=0) -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C OUTPUT ARGUMENTS: -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C KF INTEGER NUMBER OF DATA POINTS IN THE MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGBEMH FIND GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEMH AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBEMH(LUGB,LUGI,JJ,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,KF,K,KPDS,KGDS,KENS,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbem.f b/external/w3nco/v2.0.6/src/getgbem.f deleted file mode 100644 index 87655b84..00000000 --- a/external/w3nco/v2.0.6/src/getgbem.f +++ /dev/null @@ -1,275 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEM FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBEM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C GETGB1R READ AND UNPACK GRIB RECORD -C LENGDS RETURN THE LENGTH OF A GRID -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - CHARACTER CBUF(MBUF) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MSK1=32000,MSK2=4000) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND UNPACK GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSEIF(LENGDS(KGDS).GT.JF) THEN - IRET=98 - ELSE - CALL GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,NBITS, - & IRET) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbemh.f b/external/w3nco/v2.0.6/src/getgbemh.f deleted file mode 100644 index deb36ab8..00000000 --- a/external/w3nco/v2.0.6/src/getgbemh.f +++ /dev/null @@ -1,265 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEMH(LUGB,LUGI,J,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,KF,K,KPDS,KGDS,KENS,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEMH FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS -C RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS. IF THE -C GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBEMH(LUGB,LUGI,J,JPDS,JGDS,JENS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KG,KF,K,KPDS,KGDS,KENS,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C (ONLY USED IF LUGI=0) -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C KF INTEGER NUMBER OF DATA POINTS IN THE MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C LENGDS RETURN THE LENGTH OF A GRID -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - CHARACTER CBUF(MBUF) - PARAMETER(MSK1=32000,MSK2=4000) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSE - KG=LGRIB - KF=LENGDS(KGDS) - IRET=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbemn.f b/external/w3nco/v2.0.6/src/getgbemn.f deleted file mode 100644 index b3a4d440..00000000 --- a/external/w3nco/v2.0.6/src/getgbemn.f +++ /dev/null @@ -1,277 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEMN(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,KENS,LB,F,NBITSS,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEM FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C 04-07-22 CHUANG ADD PACKING BIT NUMBER NBITSS IN THE ARGUMENT -C LIST BECAUSE ETA GRIB FILES NEED IT TO REPACK GRIB FILE -C -C USAGE: CALL GETGBEM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KF,K,KPDS,KGDS,KENS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C GETGB1R READ AND UNPACK GRIB RECORD -C LENGDS RETURN THE LENGTH OF A GRID -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - CHARACTER CBUF(MBUF) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MSK1=32000,MSK2=4000) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND UNPACK GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSEIF(LENGDS(KGDS).GT.JF) THEN - IRET=98 - ELSE - CALL GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,NBITSS - & ,IRET) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbemp.f b/external/w3nco/v2.0.6/src/getgbemp.f deleted file mode 100644 index b21b83ce..00000000 --- a/external/w3nco/v2.0.6/src/getgbemp.f +++ /dev/null @@ -1,271 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEMP(LUGB,LUGI,JG,J,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,K,KPDS,KGDS,KENS,G,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEMP FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE. ITS MESSAGE NUMBER IS RETURNED ALONG WITH THE UNPACKED -C PDS AND GDS PARAMETERS AND THE PACKED GRIB MESSAGE. IF THE GRIB -C MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBEMP(LUGB,LUGI,JG,J,JPDS,JGDS,JENS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KG,K,KPDS,KGDS,KENS,G,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JG INTEGER MAXIMUM NUMBER OF BYTES IN THE GRIB MESSAGE -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C G CHARACTER*1 (KG) GRIB MESSAGE -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF BYTES GREATER THAN JG -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C BAREAD READ GRIB RECORD -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - CHARACTER CBUF(MBUF) - CHARACTER G(JG) - PARAMETER(MSK1=32000,MSK2=4000) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSEIF(LGRIB.GT.JG) THEN - IRET=98 - ELSE - IRET=97 - CALL BAREAD(LUGB,LSKIP,LGRIB,KG,G) - IF(KG.EQ.LGRIB) IRET=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbep.f b/external/w3nco/v2.0.6/src/getgbep.f deleted file mode 100644 index 19faea07..00000000 --- a/external/w3nco/v2.0.6/src/getgbep.f +++ /dev/null @@ -1,219 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEP(LUGB,LUGI,JG,J,JPDS,JGDS,JENS, - & KG,K,KPDS,KGDS,KENS,G,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEP FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE. ITS MESSAGE NUMBER IS RETURNED ALONG WITH THE UNPACKED -C PDS AND GDS PARAMETERS AND THE PACKED GRIB MESSAGE. IF THE GRIB -C MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBEP(LUGB,LUGI,JG,J,JPDS,JGDS,JENS, -C & KG,K,KPDS,KGDS,KENS,G,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JG INTEGER MAXIMUM NUMBER OF BYTES IN THE GRIB MESSAGE -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C OUTPUT ARGUMENTS: -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C G CHARACTER*1 (KG) GRIB MESSAGE -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF BYTES GREATER THAN JG -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGBEMP FIND GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEMP AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - CHARACTER G(JG) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBEMP(LUGB,LUGI,JG,JJ,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,K,KPDS,KGDS,KENS,G,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbex.f b/external/w3nco/v2.0.6/src/getgbex.f deleted file mode 100644 index 4698b0fa..00000000 --- a/external/w3nco/v2.0.6/src/getgbex.f +++ /dev/null @@ -1,233 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEX(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, - & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, - & LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEX FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C 97-02-11 Y.ZHU INCLUDED PROBABILITY AND CLUSTER ARGUMENTS -C -C USAGE: CALL GETGBEX(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, -C & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, -C & LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C OUTPUT ARGUMENTS: -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C KPROB INTEGER (2) PROBABILITY ENSEMBLE PARMS -C XPROB REAL (2) PROBABILITY ENSEMBLE PARMS -C KCLUST INTEGER (16) CLUSTER ENSEMBLE PARMS -C KMEMBR INTEGER (8) CLUSTER ENSEMBLE PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGBEXM FIND AND UNPACK GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEXM AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - INTEGER KPROB(2),KCLUST(16),KMEMBR(80) - REAL XPROB(2) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBEXM(LUGB,LUGI,JF,JJ,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, - & LB,F,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbexm.f b/external/w3nco/v2.0.6/src/getgbexm.f deleted file mode 100644 index 765c6d5a..00000000 --- a/external/w3nco/v2.0.6/src/getgbexm.f +++ /dev/null @@ -1,284 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBEXM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, - & LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBEXM FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C 97-02-11 Y.ZHU INCLUDED PROBABILITY AND CLUSTER ARGUMENTS -C -C USAGE: CALL GETGBEXM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, -C & LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(23)=2) -C (=-1 FOR WILDCARD) -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS -C KPROB INTEGER (2) PROBABILITY ENSEMBLE PARMS -C XPROB REAL (2) PROBABILITY ENSEMBLE PARMS -C KCLUST INTEGER (16) CLUSTER ENSEMBLE PARMS -C KMEMBR INTEGER (8) CLUSTER ENSEMBLE PARMS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C GETGB1RE READ AND UNPACK GRIB RECORD -C LENGDS RETURN THE LENGTH OF A GRID -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),JENS(200) - INTEGER KPDS(200),KGDS(200),KENS(200) - INTEGER KPROB(2),KCLUST(16),KMEMBR(80) - REAL XPROB(2) - CHARACTER CBUF(MBUF) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MSK1=32000,MSK2=4000) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND UNPACK GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSEIF(LENGDS(KGDS).GT.JF) THEN - IRET=98 - ELSE - CALL GETGB1RE(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS, - & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbh.f b/external/w3nco/v2.0.6/src/getgbh.f deleted file mode 100644 index 115dee4a..00000000 --- a/external/w3nco/v2.0.6/src/getgbh.f +++ /dev/null @@ -1,206 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBH(LUGB,LUGI,J,JPDS,JGDS, - & KG,KF,K,KPDS,KGDS,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBH FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS -C RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS. IF THE -C GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBH(LUGB,LUGI,J,JPDS,JGDS, -C & KG,KF,K,KPDS,KGDS,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C (ONLY USED IF LUGI=0) -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C OUTPUT ARGUMENTS: -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C KF INTEGER NUMBER OF DATA POINTS IN THE MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGBMH FIND GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBMH AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200) - INTEGER KPDS(200),KGDS(200) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBMH(LUGB,LUGI,JJ,JPDS,JGDS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,KF,K,KPDS,KGDS,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbm.f b/external/w3nco/v2.0.6/src/getgbm.f deleted file mode 100644 index 4c4e57f5..00000000 --- a/external/w3nco/v2.0.6/src/getgbm.f +++ /dev/null @@ -1,271 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBM(LUGB,LUGI,JF,J,JPDS,JGDS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KF,K,KPDS,KGDS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBM FINDS AND UNPACKS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH -C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), -C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE -C RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C 04-07-22 CHUANG ADD NBITSS TO THE ARGUMENT LIST OF GETGB1R THAT -C IS CALLED IN THIS SUBROUTINE -C 10-03-02 WANG INCREASE MSK1 TO 256000000 FOR NEMSIO FILES -C -C USAGE: CALL GETGBM(LUGB,LUGI,JF,J,JPDS,JGDS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KF,K,KPDS,KGDS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KF INTEGER NUMBER OF DATA POINTS UNPACKED -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT -C F REAL (KF) UNPACKED DATA -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF DATA POINTS GREATER THAN JF -C 99 REQUEST NOT FOUND -C OTHER W3FI63 GRIB UNPACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C GETGB1R READ AND UNPACK GRIB RECORD -C LENGDS RETURN THE LENGTH OF A GRID -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200) - INTEGER KPDS(200),KGDS(200) - CHARACTER CBUF(MBUF) - LOGICAL*1 LB(JF) - REAL F(JF) - PARAMETER(MSK1=256000000,MSK2=4000) - INTEGER JENS(200),KENS(200) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - JENS=-1 - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DO WHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND UNPACK GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSEIF(LENGDS(KGDS).GT.JF) THEN - IRET=98 - ELSE - CALL GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,NBITSS - & ,IRET) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbmh.f b/external/w3nco/v2.0.6/src/getgbmh.f deleted file mode 100644 index 6d7f78e8..00000000 --- a/external/w3nco/v2.0.6/src/getgbmh.f +++ /dev/null @@ -1,258 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBMH(LUGB,LUGI,J,JPDS,JGDS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,KF,K,KPDS,KGDS,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBMH FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS -C RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS. IF THE -C GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBMH(LUGB,LUGI,J,JPDS,JGDS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KG,KF,K,KPDS,KGDS,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C (ONLY USED IF LUGI=0) -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C KF INTEGER NUMBER OF DATA POINTS IN THE MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C LENGDS RETURN THE LENGTH OF A GRID -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200) - INTEGER KPDS(200),KGDS(200) - CHARACTER CBUF(MBUF) - PARAMETER(MSK1=32000,MSK2=4000) - INTEGER JENS(200),KENS(200) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - JENS=-1 - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSE - KG=LGRIB - KF=LENGDS(KGDS) - IRET=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbmp.f b/external/w3nco/v2.0.6/src/getgbmp.f deleted file mode 100644 index ca6e1ef1..00000000 --- a/external/w3nco/v2.0.6/src/getgbmp.f +++ /dev/null @@ -1,264 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBMP(LUGB,LUGI,JG,J,JPDS,JGDS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,K,KPDS,KGDS,G,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBMP FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE. ITS MESSAGE NUMBER IS RETURNED ALONG WITH THE UNPACKED -C PDS AND GDS PARAMETERS AND THE PACKED GRIB MESSAGE. IF THE GRIB -C MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBMP(LUGB,LUGI,JG,J,JPDS,JGDS, -C & MBUF,CBUF,NLEN,NNUM,MNUM, -C & KG,K,KPDS,KGDS,G,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JG INTEGER MAXIMUM NUMBER OF BYTES IN THE GRIB MESSAGE -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C (INITIALIZE BY SETTING J=-1) -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C (INITIALIZE BY SETTING J=-1) -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (INITIALIZE BY SETTING J=-1) -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C (INITIALIZE BY SETTING J=-1) -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) INDEX BUFFER -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C G CHARACTER*1 (KG) GRIB MESSAGE -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF BYTES GREATER THAN JG -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGI READ INDEX FILE -C GETGIR READ INDEX BUFFER FROM GRIB FILE -C GETGB1S SEARCH INDEX RECORDS -C BAREAD READ GRIB RECORD -C -C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200) - INTEGER KPDS(200),KGDS(200) - CHARACTER CBUF(MBUF) - CHARACTER G(JG) - PARAMETER(MSK1=32000,MSK2=4000) - INTEGER JENS(200),KENS(200) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE - JENS=-1 - IF(J.GE.0) THEN - IF(MNUM.GE.0) THEN - IRGI=0 - ELSE - MNUM=-1-MNUM - IRGI=1 - ENDIF - JR=J-MNUM - IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ELSE - MNUM=J - IRGI=1 - IRGS=1 - ENDIF - ELSE - MNUM=-1-J - IRGI=1 - IRGS=1 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ AND SEARCH NEXT INDEX BUFFER - JR=0 - DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) - IF(LUGI.GT.0) THEN - CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ELSE - CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) - ENDIF - IF(IRGI.LE.1) THEN - CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, - & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) - IF(IRGS.EQ.0) K=KR+MNUM - IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM - IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C READ GRIB RECORD - IF(IRGI.GT.1) THEN - IRET=96 - ELSEIF(IRGS.NE.0) THEN - IRET=99 - ELSEIF(LGRIB.GT.JG) THEN - IRET=98 - ELSE - IRET=97 - CALL BAREAD(LUGB,LSKIP,LGRIB,KG,G) - IF(KG.EQ.LGRIB) IRET=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgbp.f b/external/w3nco/v2.0.6/src/getgbp.f deleted file mode 100644 index fdfd486e..00000000 --- a/external/w3nco/v2.0.6/src/getgbp.f +++ /dev/null @@ -1,209 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGBP(LUGB,LUGI,JG,J,JPDS,JGDS, - & KG,K,KPDS,KGDS,G,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGBP FINDS A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: FIND A GRIB MESSAGE. -C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) -C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. -C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) -C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. -C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP -C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER -C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) -C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE -C GRIB FILE. ITS MESSAGE NUMBER IS RETURNED ALONG WITH THE UNPACKED -C PDS AND GDS PARAMETERS AND THE PACKED GRIB MESSAGE. IF THE GRIB -C MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS -C AND ALLOWED FOR UNSPECIFIED INDEX FILE -C -C USAGE: CALL GETGBP(LUGB,LUGI,JG,J,JPDS,JGDS, -C & KG,K,KPDS,KGDS,G,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) -C JG INTEGER MAXIMUM NUMBER OF BYTES IN THE GRIB MESSAGE -C J INTEGER NUMBER OF MESSAGES TO SKIP -C (=0 TO SEARCH FROM BEGINNING) -C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) -C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH -C (=-1 FOR WILDCARD) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH -C (ONLY SEARCHED IF JPDS(3)=255) -C (=-1 FOR WILDCARD) -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C OUTPUT ARGUMENTS: -C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE -C K INTEGER MESSAGE NUMBER UNPACKED -C (CAN BE SAME AS J IN CALLING PROGRAM -C IN ORDER TO FACILITATE MULTIPLE SEARCHES) -C KPDS INTEGER (200) UNPACKED PDS PARAMETERS -C KGDS INTEGER (200) UNPACKED GDS PARAMETERS -C G CHARACTER*1 (KG) GRIB MESSAGE -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 96 ERROR READING INDEX FILE -C 97 ERROR READING GRIB FILE -C 98 NUMBER OF BYTES GREATER THAN JG -C 99 REQUEST NOT FOUND -C -C SUBPROGRAMS CALLED: -C GETGBMP FIND GRIB MESSAGE -C -C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT -C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF -C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBMP AS BELOW, -C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER JPDS(200),JGDS(200),KPDS(200),KGDS(200) - CHARACTER G(JG) - PARAMETER(MBUF=256*1024) - CHARACTER CBUF(MBUF) - SAVE CBUF,NLEN,NNUM,MNUM - DATA LUX/0/ -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED - IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN - LUX=LUGI - JJ=MIN(J,-1-J) - ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN - LUX=LUGB - JJ=MIN(J,-1-J) - ELSE - JJ=J - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C FIND AND UNPACK GRIB MESSAGE - CALL GETGBMP(LUGB,LUGI,JG,JJ,JPDS,JGDS, - & MBUF,CBUF,NLEN,NNUM,MNUM, - & KG,K,KPDS,KGDS,G,IRET) - IF(IRET.EQ.96) LUX=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgi.f b/external/w3nco/v2.0.6/src/getgi.f deleted file mode 100644 index 0c47dd70..00000000 --- a/external/w3nco/v2.0.6/src/getgi.f +++ /dev/null @@ -1,88 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGI READS A GRIB INDEX FILE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: READ A GRIB INDEX FILE AND RETURN ITS CONTENTS. -C VERSION 1 OF THE INDEX FILE HAS THE FOLLOWING FORMAT: -C 81-BYTE S.LORD HEADER WITH 'GB1IX1' IN COLUMNS 42-47 FOLLOWED BY -C 81-BYTE HEADER WITH NUMBER OF BYTES TO SKIP BEFORE INDEX RECORDS, -C NUMBER OF BYTES IN EACH INDEX RECORD, NUMBER OF INDEX RECORDS, -C AND GRIB FILE BASENAME WRITTEN IN FORMAT ('IX1FORM:',3I10,2X,A40). -C EACH FOLLOWING INDEX RECORD CORRESPONDS TO A GRIB MESSAGE -C AND HAS THE INTERNAL FORMAT: -C BYTE 001-004: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE -C BYTE 005-008: BYTES TO SKIP IN MESSAGE BEFORE PDS -C BYTE 009-012: BYTES TO SKIP IN MESSAGE BEFORE GDS (0 IF NO GDS) -C BYTE 013-016: BYTES TO SKIP IN MESSAGE BEFORE BMS (0 IF NO BMS) -C BYTE 017-020: BYTES TO SKIP IN MESSAGE BEFORE BDS -C BYTE 021-024: BYTES TOTAL IN THE MESSAGE -C BYTE 025-025: GRIB VERSION NUMBER -C BYTE 026-053: PRODUCT DEFINITION SECTION (PDS) -C BYTE 054-095: GRID DEFINITION SECTION (GDS) (OR NULLS) -C BYTE 096-101: FIRST PART OF THE BIT MAP SECTION (BMS) (OR NULLS) -C BYTE 102-112: FIRST PART OF THE BINARY DATA SECTION (BDS) -C BYTE 113-172: (OPTIONAL) BYTES 41-100 OF THE PDS -C BYTE 173-184: (OPTIONAL) BYTES 29-40 OF THE PDS -C BYTE 185-320: (OPTIONAL) BYTES 43-178 OF THE GDS -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C 96-10-31 IREDELL AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320 -C -C USAGE: CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRET) -C INPUT ARGUMENTS: -C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE -C MNUM INTEGER NUMBER OF INDEX RECORDS TO SKIP (USUALLY 0) -C MBUF INTEGER LENGTH OF CBUF IN BYTES -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) BUFFER TO RECEIVE INDEX DATA -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 1 CBUF TOO SMALL TO HOLD INDEX BUFFER -C 2 ERROR READING INDEX FILE BUFFER -C 3 ERROR READING INDEX FILE HEADER -C -C SUBPROGRAMS CALLED: -C BAREAD BYTE-ADDRESSABLE READ -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - CHARACTER CBUF(MBUF) - CHARACTER CHEAD*162 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NLEN=0 - NNUM=0 - IRET=3 - CALL BAREAD(LUGI,0,162,LHEAD,CHEAD) - IF(LHEAD.EQ.162.AND.CHEAD(42:47).EQ.'GB1IX1') THEN - READ(CHEAD(82:162),'(8X,3I10,2X,A40)',IOSTAT=IOS) NSKP,NLEN,NNUM - IF(IOS.EQ.0) THEN - NSKP=NSKP+MNUM*NLEN - NNUM=NNUM-MNUM - NBUF=NNUM*NLEN - IRET=0 - IF(NBUF.GT.MBUF) THEN - NNUM=MBUF/NLEN - NBUF=NNUM*NLEN - IRET=1 - ENDIF - IF(NBUF.GT.0) THEN - CALL BAREAD(LUGI,NSKP,NBUF,LBUF,CBUF) - IF(LBUF.NE.NBUF) IRET=2 - ENDIF - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/getgir.f b/external/w3nco/v2.0.6/src/getgir.f deleted file mode 100644 index e23871ce..00000000 --- a/external/w3nco/v2.0.6/src/getgir.f +++ /dev/null @@ -1,90 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GETGIR READS A GRIB INDEX FILE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: READ A GRIB FILE AND RETURN ITS INDEX CONTENTS. -C THE INDEX BUFFER RETURNED CONTAINS INDEX RECORDS WITH THE INTERNAL FORMAT: -C BYTE 001-004: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE -C BYTE 005-008: BYTES TO SKIP IN MESSAGE BEFORE PDS -C BYTE 009-012: BYTES TO SKIP IN MESSAGE BEFORE GDS (0 IF NO GDS) -C BYTE 013-016: BYTES TO SKIP IN MESSAGE BEFORE BMS (0 IF NO BMS) -C BYTE 017-020: BYTES TO SKIP IN MESSAGE BEFORE BDS -C BYTE 021-024: BYTES TOTAL IN THE MESSAGE -C BYTE 025-025: GRIB VERSION NUMBER -C BYTE 026-053: PRODUCT DEFINITION SECTION (PDS) -C BYTE 054-095: GRID DEFINITION SECTION (GDS) (OR NULLS) -C BYTE 096-101: FIRST PART OF THE BIT MAP SECTION (BMS) (OR NULLS) -C BYTE 102-112: FIRST PART OF THE BINARY DATA SECTION (BDS) -C BYTE 113-172: (OPTIONAL) BYTES 41-100 OF THE PDS -C BYTE 173-184: (OPTIONAL) BYTES 29-40 OF THE PDS -C BYTE 185-320: (OPTIONAL) BYTES 43-178 OF THE GDS -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C 96-10-31 IREDELL AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320 -C -C USAGE: CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB FILE -C MSK1 INTEGER NUMBER OF BYTES TO SEARCH FOR FIRST MESSAGE -C MSK2 INTEGER NUMBER OF BYTES TO SEARCH FOR OTHER MESSAGES -C MNUM INTEGER NUMBER OF INDEX RECORDS TO SKIP (USUALLY 0) -C MBUF INTEGER LENGTH OF CBUF IN BYTES -C OUTPUT ARGUMENTS: -C CBUF CHARACTER*1 (MBUF) BUFFER TO RECEIVE INDEX DATA -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER NUMBER OF INDEX RECORDS -C (=0 IF NO GRIB MESSAGES ARE FOUND) -C IRET INTEGER RETURN CODE -C 0 ALL OK -C 1 CBUF TOO SMALL TO HOLD INDEX DATA -C -C SUBPROGRAMS CALLED: -C SKGB SEEK NEXT GRIB MESSAGE -C IXGB MAKE INDEX RECORD -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - CHARACTER CBUF(MBUF) - PARAMETER(MINDEX=320) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SEARCH FOR FIRST GRIB MESSAGE - ISEEK=0 - CALL SKGB(LUGB,ISEEK,MSK1,LSKIP,LGRIB) - IF(LGRIB.GT.0.AND.MINDEX.LE.MBUF) THEN - CALL IXGB(LUGB,LSKIP,LGRIB,MINDEX,1,NLEN,CBUF) - ELSE - NLEN=MINDEX - ENDIF - DO M=1,MNUM - IF(LGRIB.GT.0) THEN - ISEEK=LSKIP+LGRIB - CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB) - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C MAKE AN INDEX RECORD FOR EVERY GRIB RECORD FOUND - NNUM=0 - IRET=0 - DOWHILE(IRET.EQ.0.AND.LGRIB.GT.0) - IF(NLEN*(NNUM+1).LE.MBUF) THEN - NNUM=NNUM+1 - CALL IXGB(LUGB,LSKIP,LGRIB,NLEN,NNUM,MLEN,CBUF) - ISEEK=LSKIP+LGRIB - CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB) - ELSE - IRET=1 - ENDIF - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/gtbits.f b/external/w3nco/v2.0.6/src/gtbits.f deleted file mode 100644 index 8c46e9f4..00000000 --- a/external/w3nco/v2.0.6/src/gtbits.f +++ /dev/null @@ -1,83 +0,0 @@ - SUBROUTINE GTBITS(IBM,IDS,LEN,MG,G,GROUND,GMIN,GMAX,NBIT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: GTBITS COMPUTE NUMBER OF BITS AND ROUND FIELD. -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: THE NUMBER OF BITS REQUIRED TO PACK A GIVEN FIELD -C AT A PARTICULAR DECIMAL SCALING IS COMPUTED USING THE FIELD RANGE. -C THE FIELD IS ROUNDED OFF TO THE DECIMAL SCALING FOR PACKING. -C THE MINIMUM AND MAXIMUM ROUNDED FIELD VALUES ARE ALSO RETURNED. -C GRIB BITMAP MASKING FOR VALID DATA IS OPTIONALLY USED. -C -C PROGRAM HISTORY LOG: -C 92-10-31 IREDELL -C -C USAGE: CALL GTBITS(IBM,IDS,LEN,MG,G,GMIN,GMAX,NBIT) -C INPUT ARGUMENT LIST: -C IBM - INTEGER BITMAP FLAG (=0 FOR NO BITMAP) -C IDS - INTEGER DECIMAL SCALING -C (E.G. IDS=3 TO ROUND FIELD TO NEAREST MILLI-VALUE) -C LEN - INTEGER LENGTH OF THE FIELD AND BITMAP -C MG - INTEGER (LEN) BITMAP IF IBM=1 (0 TO SKIP, 1 TO KEEP) -C G - REAL (LEN) FIELD -C -C OUTPUT ARGUMENT LIST: -C GROUND - REAL (LEN) FIELD ROUNDED TO DECIMAL SCALING -C (SET TO ZERO WHERE BITMAP IS 0 IF IBM=1) -C GMIN - REAL MINIMUM VALID ROUNDED FIELD VALUE -C GMAX - REAL MAXIMUM VALID ROUNDED FIELD VALUE -C NBIT - INTEGER NUMBER OF BITS TO PACK -C -C SUBPROGRAMS CALLED: -C ISRCHNE - FIND FIRST VALUE IN AN ARRAY NOT EQUAL TO TARGET VALUE -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - DIMENSION MG(LEN),G(LEN),GROUND(LEN) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C ROUND FIELD AND DETERMINE EXTREMES WHERE BITMAP IS ON - DS=10.**IDS - IF(IBM.EQ.0) THEN - GROUND(1)=NINT(G(1)*DS)/DS - GMAX=GROUND(1) - GMIN=GROUND(1) - DO I=2,LEN - GROUND(I)=NINT(G(I)*DS)/DS - GMAX=MAX(GMAX,GROUND(I)) - GMIN=MIN(GMIN,GROUND(I)) - ENDDO - ELSE - I1=ISRCHNE(LEN,MG,1,0) - IF(I1.GT.0.AND.I1.LE.LEN) THEN - DO I=1,I1-1 - GROUND(I)=0. - ENDDO - GROUND(I1)=NINT(G(I1)*DS)/DS - GMAX=GROUND(I1) - GMIN=GROUND(I1) - DO I=I1+1,LEN - IF(MG(I).NE.0) THEN - GROUND(I)=NINT(G(I)*DS)/DS - GMAX=MAX(GMAX,GROUND(I)) - GMIN=MIN(GMIN,GROUND(I)) - ELSE - GROUND(I)=0. - ENDIF - ENDDO - ELSE - DO I=1,LEN - GROUND(I)=0. - ENDDO - GMAX=0. - GMIN=0. - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COMPUTE NUMBER OF BITS - NBIT=LOG((GMAX-GMIN)*DS+0.9)/LOG(2.)+1. -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/idsdef.f b/external/w3nco/v2.0.6/src/idsdef.f deleted file mode 100644 index ca8862c9..00000000 --- a/external/w3nco/v2.0.6/src/idsdef.f +++ /dev/null @@ -1,285 +0,0 @@ - SUBROUTINE IDSDEF(IPTV,IDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IDSDEF SETS DEFAULT DECIMAL SCALINGS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: SETS DECIMAL SCALINGS DEFAULTS FOR VARIOUS PARAMETERS. -C A DECIMAL SCALING OF -3 MEANS DATA IS PACKED IN KILO-SI UNITS. -C -C PROGRAM HISTORY LOG: -C 92-10-31 IREDELL -C -C USAGE: CALL IDSDEF(IPTV,IDS) -C INPUT ARGUMENTS: -C IPTV PARAMTER TABLE VERSION (ONLY 1 OR 2 IS RECOGNIZED) -C OUTPUT ARGUMENTS: -C IDS INTEGER (255) DECIMAL SCALINGS -C (UNKNOWN DECIMAL SCALINGS WILL NOT BE SET) -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - DIMENSION IDS(255) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - IF(IPTV.EQ.1.OR.IPTV.EQ.2) THEN - IDS(001)=-1 ! PRESSURE (PA) - IDS(002)=-1 ! SEA-LEVEL PRESSURE (PA) - IDS(003)=3 ! PRESSURE TENDENCY (PA/S) - ! - ! - IDS(006)=-1 ! GEOPOTENTIAL (M2/S2) - IDS(007)=0 ! GEOPOTENTIAL HEIGHT (M) - IDS(008)=0 ! GEOMETRIC HEIGHT (M) - IDS(009)=0 ! STANDARD DEVIATION OF HEIGHT (M) - ! - IDS(011)=1 ! TEMPERATURE (K) - IDS(012)=1 ! VIRTUAL TEMPERATURE (K) - IDS(013)=1 ! POTENTIAL TEMPERATURE (K) - IDS(014)=1 ! PSEUDO-ADIABATIC POTENTIAL TEMPERATURE (K) - IDS(015)=1 ! MAXIMUM TEMPERATURE (K) - IDS(016)=1 ! MINIMUM TEMPERATURE (K) - IDS(017)=1 ! DEWPOINT TEMPERATURE (K) - IDS(018)=1 ! DEWPOINT DEPRESSION (K) - IDS(019)=4 ! TEMPERATURE LAPSE RATE (K/M) - IDS(020)=0 ! VISIBILITY (M) - ! RADAR SPECTRA 1 () - ! RADAR SPECTRA 2 () - ! RADAR SPECTRA 3 () - ! - IDS(025)=1 ! TEMPERATURE ANOMALY (K) - IDS(026)=-1 ! PRESSURE ANOMALY (PA) - IDS(027)=0 ! GEOPOTENTIAL HEIGHT ANOMALY (M) - ! WAVE SPECTRA 1 () - ! WAVE SPECTRA 2 () - ! WAVE SPECTRA 3 () - IDS(031)=0 ! WIND DIRECTION (DEGREES) - IDS(032)=1 ! WIND SPEED (M/S) - IDS(033)=1 ! ZONAL WIND (M/S) - IDS(034)=1 ! MERIDIONAL WIND (M/S) - IDS(035)=-4 ! STREAMFUNCTION (M2/S) - IDS(036)=-4 ! VELOCITY POTENTIAL (M2/S) - IDS(037)=-1 ! MONTGOMERY STREAM FUNCTION (M2/S2) - IDS(038)=8 ! SIGMA VERTICAL VELOCITY (1/S) - IDS(039)=3 ! PRESSURE VERTICAL VELOCITY (PA/S) - IDS(040)=4 ! GEOMETRIC VERTICAL VELOCITY (M/S) - IDS(041)=6 ! ABSOLUTE VORTICITY (1/S) - IDS(042)=6 ! ABSOLUTE DIVERGENCE (1/S) - IDS(043)=6 ! RELATIVE VORTICITY (1/S) - IDS(044)=6 ! RELATIVE DIVERGENCE (1/S) - IDS(045)=4 ! VERTICAL U SHEAR (1/S) - IDS(046)=4 ! VERTICAL V SHEAR (1/S) - IDS(047)=0 ! DIRECTION OF CURRENT (DEGREES) - ! SPEED OF CURRENT (M/S) - ! U OF CURRENT (M/S) - ! V OF CURRENT (M/S) - IDS(051)=4 ! SPECIFIC HUMIDITY (KG/KG) - IDS(052)=0 ! RELATIVE HUMIDITY (PERCENT) - IDS(053)=4 ! HUMIDITY MIXING RATIO (KG/KG) - IDS(054)=1 ! PRECIPITABLE WATER (KG/M2) - IDS(055)=-1 ! VAPOR PRESSURE (PA) - IDS(056)=-1 ! SATURATION DEFICIT (PA) - IDS(057)=1 ! EVAPORATION (KG/M2) - IDS(058)=1 ! CLOUD ICE (KG/M2) - IDS(059)=6 ! PRECIPITATION RATE (KG/M2/S) - IDS(060)=0 ! THUNDERSTORM PROBABILITY (PERCENT) - IDS(061)=1 ! TOTAL PRECIPITATION (KG/M2) - IDS(062)=1 ! LARGE-SCALE PRECIPITATION (KG/M2) - IDS(063)=1 ! CONVECTIVE PRECIPITATION (KG/M2) - IDS(064)=6 ! WATER EQUIVALENT SNOWFALL RATE (KG/M2/S) - IDS(065)=0 ! WATER EQUIVALENT OF SNOW DEPTH (KG/M2) - IDS(066)=2 ! SNOW DEPTH (M) - ! MIXED-LAYER DEPTH (M) - ! TRANSIENT THERMOCLINE DEPTH (M) - ! MAIN THERMOCLINE DEPTH (M) - ! MAIN THERMOCLINE ANOMALY (M) - IDS(071)=0 ! TOTAL CLOUD COVER (PERCENT) - IDS(072)=0 ! CONVECTIVE CLOUD COVER (PERCENT) - IDS(073)=0 ! LOW CLOUD COVER (PERCENT) - IDS(074)=0 ! MIDDLE CLOUD COVER (PERCENT) - IDS(075)=0 ! HIGH CLOUD COVER (PERCENT) - IDS(076)=1 ! CLOUD WATER (KG/M2) - ! - IDS(078)=1 ! CONVECTIVE SNOW (KG/M2) - IDS(079)=1 ! LARGE SCALE SNOW (KG/M2) - IDS(080)=1 ! WATER TEMPERATURE (K) - IDS(081)=0 ! SEA-LAND MASK () - ! DEVIATION OF SEA LEVEL FROM MEAN (M) - IDS(083)=5 ! ROUGHNESS (M) - IDS(084)=1 ! ALBEDO (PERCENT) - IDS(085)=1 ! SOIL TEMPERATURE (K) - IDS(086)=0 ! SOIL WETNESS (KG/M2) - IDS(087)=0 ! VEGETATION (PERCENT) - ! SALINITY (KG/KG) - IDS(089)=4 ! DENSITY (KG/M3) - IDS(090)=1 ! RUNOFF (KG/M2) - IDS(091)=0 ! ICE CONCENTRATION () - ! ICE THICKNESS (M) - IDS(093)=0 ! DIRECTION OF ICE DRIFT (DEGREES) - ! SPEED OF ICE DRIFT (M/S) - ! U OF ICE DRIFT (M/S) - ! V OF ICE DRIFT (M/S) - ! ICE GROWTH (M) - ! ICE DIVERGENCE (1/S) - IDS(099)=1 ! SNOW MELT (KG/M2) - ! SIG HEIGHT OF WAVES AND SWELL (M) - IDS(101)=0 ! DIRECTION OF WIND WAVES (DEGREES) - ! SIG HEIGHT OF WIND WAVES (M) - ! MEAN PERIOD OF WIND WAVES (S) - IDS(104)=0 ! DIRECTION OF SWELL WAVES (DEGREES) - ! SIG HEIGHT OF SWELL WAVES (M) - ! MEAN PERIOD OF SWELL WAVES (S) - IDS(107)=0 ! PRIMARY WAVE DIRECTION (DEGREES) - ! PRIMARY WAVE MEAN PERIOD (S) - IDS(109)=0 ! SECONDARY WAVE DIRECTION (DEGREES) - ! SECONDARY WAVE MEAN PERIOD (S) - IDS(111)=0 ! NET SOLAR RADIATIVE FLUX AT SURFACE (W/M2) - IDS(112)=0 ! NET LONGWAVE RADIATIVE FLUX AT SURFACE (W/M2) - IDS(113)=0 ! NET SOLAR RADIATIVE FLUX AT TOP (W/M2) - IDS(114)=0 ! NET LONGWAVE RADIATIVE FLUX AT TOP (W/M2) - IDS(115)=0 ! NET LONGWAVE RADIATIVE FLUX (W/M2) - IDS(116)=0 ! NET SOLAR RADIATIVE FLUX (W/M2) - IDS(117)=0 ! TOTAL RADIATIVE FLUX (W/M2) - ! - ! - ! - IDS(121)=0 ! LATENT HEAT FLUX (W/M2) - IDS(122)=0 ! SENSIBLE HEAT FLUX (W/M2) - IDS(123)=0 ! BOUNDARY LAYER DISSIPATION (W/M2) - IDS(124)=3 ! U WIND STRESS (N/M2) - IDS(125)=3 ! V WIND STRESS (N/M2) - ! WIND MIXING ENERGY (J) - ! IMAGE DATA () - IDS(128)=-1 ! MEAN SEA-LEVEL PRESSURE (STDATM) (PA) - IDS(129)=-1 ! MEAN SEA-LEVEL PRESSURE (MAPS) (PA) - IDS(130)=-1 ! MEAN SEA-LEVEL PRESSURE (ETA) (PA) - IDS(131)=1 ! SURFACE LIFTED INDEX (K) - IDS(132)=1 ! BEST LIFTED INDEX (K) - IDS(133)=1 ! K INDEX (K) - IDS(134)=1 ! SWEAT INDEX (K) - IDS(135)=10 ! HORIZONTAL MOISTURE DIVERGENCE (KG/KG/S) - IDS(136)=4 ! SPEED SHEAR (1/S) - IDS(137)=3 ! 3-HR PRESSURE TENDENCY (PA/S) - IDS(138)=6 ! BRUNT-VAISALA FREQUENCY SQUARED (1/S2) - IDS(139)=11 ! POTENTIAL VORTICITY (MASS-WEIGHTED) (1/S/M) - IDS(140)=0 ! RAIN MASK () - IDS(141)=0 ! FREEZING RAIN MASK () - IDS(142)=0 ! ICE PELLETS MASK () - IDS(143)=0 ! SNOW MASK () - IDS(144)=3 ! VOLUMETRIC SOIL MOISTURE CONTENT (FRACTION) - IDS(145)=0 ! POTENTIAL EVAPORATION RATE (W/M2) - IDS(146)=0 ! CLOUD WORKFUNCTION (J/KG) - IDS(147)=3 ! U GRAVITY WAVE STRESS (N/M2) - IDS(148)=3 ! V GRAVITY WAVE STRESS (N/M2) - IDS(149)=10 ! POTENTIAL VORTICITY (M2/S/KG) - ! COVARIANCE BETWEEN V AND U (M2/S2) - ! COVARIANCE BETWEEN U AND T (K*M/S) - ! COVARIANCE BETWEEN V AND T (K*M/S) - ! - ! - IDS(155)=0 ! GROUND HEAT FLUX (W/M2) - IDS(156)=0 ! CONVECTIVE INHIBITION (W/M2) - IDS(157)=0 ! CONVECTIVE APE (J/KG) - IDS(158)=0 ! TURBULENT KE (J/KG) - IDS(159)=-1 ! CONDENSATION PRESSURE OF LIFTED PARCEL (PA) - IDS(160)=0 ! CLEAR SKY UPWARD SOLAR FLUX (W/M2) - IDS(161)=0 ! CLEAR SKY DOWNWARD SOLAR FLUX (W/M2) - IDS(162)=0 ! CLEAR SKY UPWARD LONGWAVE FLUX (W/M2) - IDS(163)=0 ! CLEAR SKY DOWNWARD LONGWAVE FLUX (W/M2) - IDS(164)=0 ! CLOUD FORCING NET SOLAR FLUX (W/M2) - IDS(165)=0 ! CLOUD FORCING NET LONGWAVE FLUX (W/M2) - IDS(166)=0 ! VISIBLE BEAM DOWNWARD SOLAR FLUX (W/M2) - IDS(167)=0 ! VISIBLE DIFFUSE DOWNWARD SOLAR FLUX (W/M2) - IDS(168)=0 ! NEAR IR BEAM DOWNWARD SOLAR FLUX (W/M2) - IDS(169)=0 ! NEAR IR DIFFUSE DOWNWARD SOLAR FLUX (W/M2) - ! - ! - IDS(172)=3 ! MOMENTUM FLUX (N/M2) - IDS(173)=0 ! MASS POINT MODEL SURFACE () - IDS(174)=0 ! VELOCITY POINT MODEL SURFACE () - IDS(175)=0 ! SIGMA LAYER NUMBER () - IDS(176)=2 ! LATITUDE (DEGREES) - IDS(177)=2 ! EAST LONGITUDE (DEGREES) - ! - ! - ! - IDS(181)=9 ! X-GRADIENT LOG PRESSURE (1/M) - IDS(182)=9 ! Y-GRADIENT LOG PRESSURE (1/M) - IDS(183)=5 ! X-GRADIENT HEIGHT (M/M) - IDS(184)=5 ! Y-GRADIENT HEIGHT (M/M) - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - ! - IDS(201)=0 ! ICE-FREE WATER SURCACE (PERCENT) - ! - ! - IDS(204)=0 ! DOWNWARD SOLAR RADIATIVE FLUX (W/M2) - IDS(205)=0 ! DOWNWARD LONGWAVE RADIATIVE FLUX (W/M2) - ! - IDS(207)=0 ! MOISTURE AVAILABILITY (PERCENT) - ! EXCHANGE COEFFICIENT (KG/M2/S) - IDS(209)=0 ! NUMBER OF MIXED LAYER NEXT TO SFC () - ! - IDS(211)=0 ! UPWARD SOLAR RADIATIVE FLUX (W/M2) - IDS(212)=0 ! UPWARD LONGWAVE RADIATIVE FLUX (W/M2) - IDS(213)=0 ! NON-CONVECTIVE CLOUD COVER (PERCENT) - IDS(214)=6 ! CONVECTIVE PRECIPITATION RATE (KG/M2/S) - IDS(215)=7 ! TOTAL DIABATIC HEATING RATE (K/S) - IDS(216)=7 ! TOTAL RADIATIVE HEATING RATE (K/S) - IDS(217)=7 ! TOTAL DIABATIC NONRADIATIVE HEATING RATE (K/S) - IDS(218)=2 ! PRECIPITATION INDEX (FRACTION) - IDS(219)=1 ! STD DEV OF IR T OVER 1X1 DEG AREA (K) - IDS(220)=4 ! NATURAL LOG OF SURFACE PRESSURE OVER 1 KPA () - ! - IDS(222)=0 ! 5-WAVE GEOPOTENTIAL HEIGHT (M) - IDS(223)=1 ! PLANT CANOPY SURFACE WATER (KG/M2) - ! - ! - ! BLACKADARS MIXING LENGTH (M) - ! ASYMPTOTIC MIXING LENGTH (M) - IDS(228)=1 ! POTENTIAL EVAPORATION (KG/M2) - IDS(229)=0 ! SNOW PHASE-CHANGE HEAT FLUX (W/M2) - ! - IDS(231)=3 ! CONVECTIVE CLOUD MASS FLUX (PA/S) - IDS(232)=0 ! DOWNWARD TOTAL RADIATION FLUX (W/M2) - IDS(233)=0 ! UPWARD TOTAL RADIATION FLUX (W/M2) - IDS(224)=1 ! BASEFLOW-GROUNDWATER RUNOFF (KG/M2) - IDS(225)=1 ! STORM SURFACE RUNOFF (KG/M2) - ! - ! - IDS(238)=0 ! SNOW COVER (PERCENT) - IDS(239)=1 ! SNOW TEMPERATURE (K) - ! - IDS(241)=7 ! LARGE SCALE CONDENSATION HEATING RATE (K/S) - IDS(242)=7 ! DEEP CONVECTIVE HEATING RATE (K/S) - IDS(243)=10 ! DEEP CONVECTIVE MOISTENING RATE (KG/KG/S) - IDS(244)=7 ! SHALLOW CONVECTIVE HEATING RATE (K/S) - IDS(245)=10 ! SHALLOW CONVECTIVE MOISTENING RATE (KG/KG/S) - IDS(246)=7 ! VERTICAL DIFFUSION HEATING RATE (KG/KG/S) - IDS(247)=7 ! VERTICAL DIFFUSION ZONAL ACCELERATION (M/S/S) - IDS(248)=7 ! VERTICAL DIFFUSION MERID ACCELERATION (M/S/S) - IDS(249)=10 ! VERTICAL DIFFUSION MOISTENING RATE (KG/KG/S) - IDS(250)=7 ! SOLAR RADIATIVE HEATING RATE (K/S) - IDS(251)=7 ! LONGWAVE RADIATIVE HEATING RATE (K/S) - ! DRAG COEFFICIENT () - ! FRICTION VELOCITY (M/S) - ! RICHARDSON NUMBER () - ! - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/instrument.f b/external/w3nco/v2.0.6/src/instrument.f deleted file mode 100644 index 0c936f99..00000000 --- a/external/w3nco/v2.0.6/src/instrument.f +++ /dev/null @@ -1,111 +0,0 @@ -!----------------------------------------------------------------------- - SUBROUTINE INSTRUMENT(K,KALL,TTOT,TMIN,TMAX) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . . -! SUBPROGRAM: INSTRUMENT MONITOR WALL-CLOCK TIMES, ETC. -! PRGMMR: IREDELL ORG: NP23 DATE:1998-07-16 -! -! ABSTRACT: THIS SUBPROGRAM IS USEFUL IN INSTRUMENTING A CODE -! BY MONITORING THE NUMBER OF TIMES EACH GIVEN SECTION -! OF A PROGRAM IS INVOKED AS WELL AS THE MINIMUM, MAXIMUM -! AND TOTAL WALL-CLOCK TIME SPENT IN THE GIVEN SECTION. -! -! PROGRAM HISTORY LOG: -! 1998-07-16 IREDELL -! -! USAGE: CALL INSTRUMENT(K,KALL,TTOT,TMIN,TMAX) -! INPUT ARGUMENT LIST: -! K - INTEGER POSITIVE SECTION NUMBER -! OR MAXIMUM SECTION NUMBER IN THE FIRST INVOCATION -! OR ZERO TO RESET ALL WALL-CLOCK STATISTICS -! OR NEGATIVE SECTION NUMBER TO SKIP MONITORING -! AND JUST RETURN STATISTICS. -! -! OUTPUT ARGUMENT LIST: -! KALL - INTEGER NUMBER OF TIMES SECTION IS CALLED -! TTOT - REAL TOTAL SECONDS SPENT IN SECTION -! TMIN - REAL MINIMUM SECONDS SPENT IN SECTION -! TMAX - REAL MAXIMUM SECONDS SPENT IN SECTION -! -! SUBPROGRAMS CALLED: -! W3UTCDAT RETURN THE UTC DATE AND TIME -! W3DIFDAT RETURN A TIME INTERVAL BETWEEN TWO DATES -! -! REMARKS: -! THIS SUBPROGRAM SHOULD NOT BE INVOKED FROM A MULTITASKING REGION. -! NORMALLY, TIME SPENT INSIDE THIS SUBPROGRAM IS NOT COUNTED. -! WALL-CLOCK TIMES ARE KEPT TO THE NEAREST MILLISECOND. -! -! EXAMPLE. -! CALL INSTRUMENT(2,KALL,TTOT,TMIN,TMAX) ! KEEP STATS FOR 2 SUBS -! DO K=1,N -! CALL SUB1 -! CALL INSTRUMENT(1,KALL,TTOT,TMIN,TMAX) ! ACCUM STATS FOR SUB1 -! CALL SUB2 -! CALL INSTRUMENT(2,KALL,TTOT,TMIN,TMAX) ! ACCUM STATS FOR SUB2 -! ENDDO -! PRINT *,'SUB2 STATS: ',KALL,TTOT,TMIN,TMAX -! CALL INSTRUMENT(-1,KALL,TTOT,TMIN,TMAX) ! RETURN STATS FOR SUB1 -! PRINT *,'SUB1 STATS: ',KALL,TTOT,TMIN,TMAX -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - IMPLICIT NONE - INTEGER,INTENT(IN):: K - INTEGER,INTENT(OUT):: KALL - REAL,INTENT(OUT):: TTOT,TMIN,TMAX - INTEGER,SAVE:: KMAX=0 - INTEGER,DIMENSION(:),ALLOCATABLE,SAVE:: KALLS - REAL,DIMENSION(:),ALLOCATABLE,SAVE:: TTOTS,TMINS,TMAXS - INTEGER,DIMENSION(8),SAVE:: IDAT - INTEGER,DIMENSION(8):: JDAT - REAL,DIMENSION(5):: RINC - INTEGER:: KA -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - KA=ABS(K) -! ALLOCATE MONITORING ARRAYS IF INITIAL INVOCATION - IF(KMAX.EQ.0) THEN - KMAX=K - ALLOCATE(KALLS(KMAX)) - ALLOCATE(TTOTS(KMAX)) - ALLOCATE(TMINS(KMAX)) - ALLOCATE(TMAXS(KMAX)) - KALLS=0 - KA=0 -! OR RESET ALL STATISTICS BACK TO ZERO - ELSEIF(K.EQ.0) THEN - KALLS=0 -! OR COUNT TIME SINCE LAST INVOCATION AGAINST THIS SECTION - ELSEIF(K.GT.0) THEN - CALL W3UTCDAT(JDAT) - CALL W3DIFDAT(JDAT,IDAT,4,RINC) - KALLS(K)=KALLS(K)+1 - IF(KALLS(K).EQ.1) THEN - TTOTS(K)=RINC(4) - TMINS(K)=RINC(4) - TMAXS(K)=RINC(4) - ELSE - TTOTS(K)=TTOTS(K)+RINC(4) - TMINS(K)=MIN(TMINS(K),RINC(4)) - TMAXS(K)=MAX(TMAXS(K),RINC(4)) - ENDIF - ENDIF -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! RETURN STATISTICS - IF(KA.GE.1.AND.KA.LE.KMAX.AND.KALLS(KA).GT.0) THEN - KALL=KALLS(KA) - TTOT=TTOTS(KA) - TMIN=TMINS(KA) - TMAX=TMAXS(KA) - ELSE - KALL=0 - TTOT=0 - TMIN=0 - TMAX=0 - ENDIF -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! KEEP CURRENT TIME FOR NEXT INVOCATION - IF(K.GE.0) CALL W3UTCDAT(IDAT) - END SUBROUTINE INSTRUMENT diff --git a/external/w3nco/v2.0.6/src/iw3jdn.f b/external/w3nco/v2.0.6/src/iw3jdn.f deleted file mode 100644 index 896d6211..00000000 --- a/external/w3nco/v2.0.6/src/iw3jdn.f +++ /dev/null @@ -1,62 +0,0 @@ - FUNCTION IW3JDN(IYEAR,MONTH,IDAY) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IW3JDN COMPUTE JULIAN DAY NUMBER -C AUTHOR: JONES,R.E. ORG: W342 DATE: 87-03-29 -C -C ABSTRACT: COMPUTES JULIAN DAY NUMBER FROM YEAR (4 DIGITS), MONTH, -C AND DAY. IW3JDN IS VALID FOR YEARS 1583 A.D. TO 3300 A.D. -C JULIAN DAY NUMBER CAN BE USED TO COMPUTE DAY OF WEEK, DAY OF -C YEAR, RECORD NUMBERS IN AN ARCHIVE, REPLACE DAY OF CENTURY, -C FIND THE NUMBER OF DAYS BETWEEN TWO DATES. -C -C PROGRAM HISTORY LOG: -C 87-03-29 R.E.JONES -C 89-10-25 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: II = IW3JDN(IYEAR,MONTH,IDAY) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IYEAR ARG LIST INTEGER YEAR ( 4 DIGITS) -C MONTH ARG LIST INTEGER MONTH OF YEAR (1 - 12) -C IDAY ARG LIST INTEGER DAY OF MONTH (1 - 31) -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IW3JDN FUNTION INTEGER JULIAN DAY NUMBER -C JAN. 1,1960 IS JULIAN DAY NUMBER 2436935 -C JAN. 1,1987 IS JULIAN DAY NUMBER 2446797 -C -C REMARKS: JULIAN PERIOD WAS DEVISED BY JOSEPH SCALIGER IN 1582. -C JULIAN DAY NUMBER #1 STARTED ON JAN. 1,4713 B.C. THREE MAJOR -C CHRONOLOGICAL CYCLES BEGIN ON THE SAME DAY. A 28-YEAR SOLAR -C CYCLE, A 19-YEAR LUNER CYCLE, A 15-YEAR INDICTION CYCLE, USED -C IN ANCIENT ROME TO REGULATE TAXES. IT WILL TAKE 7980 YEARS -C TO COMPLETE THE PERIOD, THE PRODUCT OF 28, 19, AND 15. -C SCALIGER NAMED THE PERIOD, DATE, AND NUMBER AFTER HIS FATHER -C JULIUS (NOT AFTER THE JULIAN CALENDAR). THIS SEEMS TO HAVE -C CAUSED A LOT OF CONFUSION IN TEXT BOOKS. SCALIGER NAME IS -C SPELLED THREE DIFFERENT WAYS. JULIAN DATE AND JULIAN DAY -C NUMBER ARE INTERCHANGED. A JULIAN DATE IS USED BY ASTRONOMERS -C TO COMPUTE ACCURATE TIME, IT HAS A FRACTION. WHEN TRUNCATED TO -C AN INTEGER IT IS CALLED AN JULIAN DAY NUMBER. THIS FUNCTION -C WAS IN A LETTER TO THE EDITOR OF THE COMMUNICATIONS OF THE ACM -C VOLUME 11 / NUMBER 10 / OCTOBER 1968. THE JULIAN DAY NUMBER -C CAN BE CONVERTED TO A YEAR, MONTH, DAY, DAY OF WEEK, DAY OF -C YEAR BY CALLING SUBROUTINE W3FS26. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - IW3JDN = IDAY - 32075 - & + 1461 * (IYEAR + 4800 + (MONTH - 14) / 12) / 4 - & + 367 * (MONTH - 2 - (MONTH -14) / 12 * 12) / 12 - & - 3 * ((IYEAR + 4900 + (MONTH - 14) / 12) / 100) / 4 - RETURN - END diff --git a/external/w3nco/v2.0.6/src/iw3pds.f b/external/w3nco/v2.0.6/src/iw3pds.f deleted file mode 100644 index 103beb68..00000000 --- a/external/w3nco/v2.0.6/src/iw3pds.f +++ /dev/null @@ -1,177 +0,0 @@ - LOGICAL FUNCTION IW3PDS(L1, L2, KEY) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C FUNCTION: IW3PDS TEST FOR MATCH OF TWO PDS -C AUTHOR: JONES, R.E. ORG: W342 DATE: 88-02-22 -C -C ABSTACT: TEST TWO PDS (GRIB PRODUCT DEFINITION SECTION) TO SEE -C IF ALL EQUAL; OTHERWISE .FALSE. IF KEY = 1, ALL 24 CHARACTERS -C ARE TESTED, IF KEY = 0 , THE DATE (CHARACTERS 13-17) ARE NOT -C TESTED. IF KEY = 2, 11 OF 1ST 12 BYTES ARE TESTED. BYTE 4 IS -C IS NOT TESTED, SO TABLE VERSION NUMBER CAN CHANGE AND YOUR -C PROGRAM WILL STILL WORK. IF KEY=3, TEST BYTES 1-3, 7-12. -C -C PROGRAM HISTORY LOG: -C 88-02-22 R.E.JONES -C 89-08-29 R.E.JONES ADD ENTRY IW3PDS, AN ALIAS NAME. -C 89-08-29 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN, MAKE IW3PDS -C THE FUNCTION NAME, IW3PDB THE ALIAS. -C 94-02-10 R.E.JONES ADD KEY=2, TEST ONLY 11 OF 1ST 12 BYTES. -C BYTE 4 (TABLE VERSION NO.) IS NOT TESTED -C 94-07-07 R.E.JONES ADD KEY=3, TEST BYTES 1-3, 7-12. -C -C USAGE: II = IW3PDS(L1,L2,KEY) -C II = IW3PDB(L1,L2,KEY) ALIAS -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C L1 ARG LIST CHARACTER ARRAY TO MATCH WITH L2, -C L1 CAN ALSO BE A 3 WORD INTEGER ARRAY -C L2 ARG LIST CHARACTER ARRAY TO MATCH WITH L1, -C L2 CAN ALSO BE A 3 WORD INTEGER ARRAY -C KEY ARG LIST 0, DO NOT INCLUDE THE DATE (BYTES 13-17) IN -C MATCH. -C 1, MATCH 24 BYTES OF PDS -C 2, MATCH BYTES 1-3, 5-12 OF PDS -C 3, MATCH BYTES 1-3, 7-12 OF PDS -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IW3PDB FUNCTION LOGICAL .TRUE. IF L1 AND L2 MATCH ON ALL CHAR., -C LOGICAL .FALSE. IF NOT MATCH ON ANY CHAR. -C -C EXAMPLE: SEARCH IDTBL FOR MATCH WITH GIVEN (PDS), USE RBA IN 7TH -C ID WORD TO READ RECORD BY RBA. -C -C INTEGER IDTBL(1794), IPDS(6), RBA -C LOGICAL IW3PDS -C -C KEY = 0 -C DO 400 I = 9,1793,7 -C IF (IDTBL(I).EQ.0) GO TO 500 -C IF (IW3PDS(IPDS,IDTBL(I),KEY)) THEN -C RBA = IDTBL(I+6) -C GO TO 600 -C END IF -C 400 CONTINUE -C -C 500 CONTINUE -C GO TO XXXX ... ERROR EXIT , CAN NOT FIND RECORD -C -C 600 .. READ RECORD WITH RBA -C -C REMARK: ALIAS ADDED BECAUSE OF NAME CHANGE IN GRIB WRITE UP. -C NAME OF PDB (PRODUCT DEFINITION BLOCK) WAS CHANGD TO PDS -C (PRODUCT DEFINITION SECTION). -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - CHARACTER*1 L1(24) - CHARACTER*1 L2(24) -C - LOGICAL IW3PDB -C - SAVE -C - IW3PDS = .TRUE. -C - IF (KEY.EQ.1) THEN - DO 10 I = 1,3 - IF (L1(I).NE.L2(I)) GO TO 70 - 10 CONTINUE -C - DO 20 I = 5,24 - IF (L1(I).NE.L2(I)) GO TO 70 - 20 CONTINUE -C - ELSE -C - DO 30 I = 1,3 - IF (L1(I).NE.L2(I)) GO TO 70 - 30 CONTINUE -C -C DO NOT TEST BYTE 4, 5, 6 PDS VER. NO., COUNTRY -C MODEL NUMBER. U.S., U.K., FNOC WAFS DATA WILL -C WORK. -C - IF (KEY.EQ.3) THEN - DO I = 7,12 - IF (L1(I).NE.L2(I)) GO TO 70 - END DO - GO TO 60 - END IF -C -C DO NOT TEST PDS VERSION NUMBER, IT MAY BE 1 O 2 -C - DO 40 I = 5,12 - IF (L1(I).NE.L2(I)) GO TO 70 - 40 CONTINUE - IF (KEY.EQ.2) GO TO 60 -C - DO 50 I = 18,24 - IF (L1(I).NE.L2(I)) GO TO 70 - 50 CONTINUE - ENDIF -C - 60 CONTINUE - RETURN -C - 70 CONTINUE - IW3PDS = .FALSE. - RETURN -C - ENTRY IW3PDB (L1, L2, KEY) -C - IW3PDB = .TRUE. -C - IF (KEY.EQ.1) THEN - DO 80 I = 1,3 - IF (L1(I).NE.L2(I)) GO TO 140 - 80 CONTINUE -C - DO 90 I = 5,24 - IF (L1(I).NE.L2(I)) GO TO 140 - 90 CONTINUE -C - ELSE -C - DO 100 I = 1,3 - IF (L1(I).NE.L2(I)) GO TO 140 - 100 CONTINUE -C -C DO NOT TEST BYTE 4, 5, 6 PDS VER. NO., COUNTRY -C MODEL NUMBER. U.S., U.K., FNOC WAFS DATA WILL -C WORK. -C - IF (KEY.EQ.3) THEN - DO I = 7,12 - IF (L1(I).NE.L2(I)) GO TO 140 - END DO - GO TO 130 - END IF -C -C DO NOT TEST PDS VERSION NUMBER, IT MAY BE 1 O 2 -C - DO 110 I = 5,12 - IF (L1(I).NE.L2(I)) GO TO 140 - 110 CONTINUE - IF (KEY.EQ.2) GO TO 130 -C - DO 120 I = 18,24 - IF (L1(I).NE.L2(I)) GO TO 140 - 120 CONTINUE - ENDIF -C - 130 CONTINUE - RETURN -C - 140 CONTINUE - IW3PDB = .FALSE. - RETURN - END diff --git a/external/w3nco/v2.0.6/src/iw3unp29.f b/external/w3nco/v2.0.6/src/iw3unp29.f deleted file mode 100644 index 352598aa..00000000 --- a/external/w3nco/v2.0.6/src/iw3unp29.f +++ /dev/null @@ -1,4656 +0,0 @@ -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IW3UNP29 -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2013-03-20 -C -C********************************************************************** -C********************************************************************** -C NOTICE: -C This routine has not been tested reading input data from any dump -C type in ON29/124 format on WCOSS. It likely will not work when -C attempting to read ON29/124 format dumps on WCOSS. It has also -C not been tested reading any dump file other than ADPUPA (BUFR -C input only) on WCOSS. It does work reading BUFR ADPUPA dump files -C on WCOSS. It will hopefully working reading other BUFR (only) -C dump files on WCOSS. -C -C Also, this routine is only known to work correctly when compiled -C using 8 byte machine words (real and integer). -C********************************************************************** -C********************************************************************** -C -C ABSTRACT: READS AND UNPACKS ONE REPORT INTO THE UNPACKED OFFICE NOTE -C 29/124 FORMAT. THE INPUT DATA MAY BE PACKED INTO EITHER BUFR OR -C TRUE ON29/124 FORMAT WITH A Y2K COMPLIANT PSEUDO-ON85 HEADER LABEL. -C (NOTE: AS A TEMPORARY MEASURE, THIS CODE WILL STILL OPERATE ON A -C TRUE ON29/124 FORMAT FILE WITH A NON-Y2K COMPLIANT ON85 HEADER -C LABEL. THE CODE WILL USE THE "WINDOWING" TECHNIQUE TO OBTAIN A -C 4-DIGIT YEAR.) THIS ROUTINE WILL DETERMINE THE FORMAT OF THE -C INPUT DATA AND TAKE THE APPROPRIATE ACTION. IT RETURNS THE -C UNPACKED REPORT TO THE CALLING PROGRAM IN THE ARRAY 'OBS'. -C VARIOUS CONTINGENCIES ARE COVERED BY RETURN VALUE OF THE FUNCTION -C AND PARAMETER 'IER' - FUNCTION AND IER HAVE SAME VALUE. REPEATED -C CALLS OF FUNCTION WILL RETURN A SEQUENCE OF UNPACKED ON29/124 -C REPORTS. THE CALLING PROGRAM MAY SWITCH TO A NEW 'NUNIT' AT ANY -C TIME, THAT DATASET WILL THEN BE READ IN SEQUENCE. IF USER -C SWITCHES BACK TO A PREVIOUS 'NUNIT', THAT DATA SET WILL BE READ -C FROM THE BEGINNING, NOT FROM WHERE THE USER LEFT OFF (THIS IS A -C 'SOFTWARE TOOL', NOT AN ENTIRE I/O SYSTEM). -C -C PROGRAM HISTORY LOG: -C 1996-12-13 J. S. WOOLLEN (GSC) -- ORIGINAL AUTHOR - NOTE THIS NEW -C VERSION OF IW3GAD INCORPORATES THE EARLIER VERSION WHICH -C WAS WRITTEN BY J. STACKPOLE AND DEALT ONLY WITH TRUE -C ON29/124 DATA AS INPUT - THIS OPTION IS STILL AVAILABLE -C BUT IS A SMALL PART OF THE NEW ROUTINE WHICH WAS WRITTEN -C FROM SCRATCH TO READ IN BUFR DATA. -C 1997-01-27 D. A. KEYSER -- CHANGES TO MORE CLOSELY DUPLICATE FORMAT -C OBTAINED WHEN READING FROM TRUE ON29/124 DATA SETS. -C 1997-02-04 D. A. KEYSER -- DROPS WITH MISSING STNID GET STNID SET TO -C "DRP88A"; SATWNDS WITH ZERO PRESSURE ARE TOSSED -C 1997-02-12 D. A. KEYSER -- TO GET AROUND THE 3-BIT LIMITATION TO -C THE ON29 PRESSURE Q.M. MNEMONIC "QMPR", AN SDMEDIT/QUIPS -C PURGE OR REJECT FLAG ON PRESSURE IS CHANGED FROM 12 OR 14 -C TO 6 IN ORDER TO FIT INTO 3-BITS, SEE FUNCTION E35O29; -C INTERPRETS SDMEDIT AND QUIPS PURGE/KEEP/CHANGE FLAGS -C PROPERLY FOR ALL DATA TYPES; CAN NOW PROCESS CAT. 6 AND -C CAT. 2/3 TYPE FLIGHT-LEVEL RECCOS (BEFORE SKIPPED THESE); -C TESTS FOR MISSING LAT, LON, OBTIME DECODED FROM BUFR AND -C RETAINS MISSING VALUE ON THESE IN UNPACKED ON29/124 -C FORMAT (BEFORE NO MISSING CHECK, LED TO POSSIBLE NON- -C MISSING BUT INCORRECT VALUES FOR THESE); THE CHECK FOR -C DROPS WITH MISSING STNID REMOVED SINCE DECODER FIXED FOR -C THIS -C 1997-05-01 D. A. KEYSER -- LOOKS FOR DUPLICATE LEVELS WHEN -C PROCESSING ON29 CAT. 2, 3, AND 4 (IN ALL DATA ON LEVEL) -C AND REMOVES DUPLICATE LEVEL; IN PROCESSING ON29 CAT. 3 -C LEVELS, REMOVES ALL LEVELS WHERE WIND IS MISSING; FIXED -C BUG IN AIRCRAFT (AIREP/PIREP/AMDAR) QUALITY MARK -C ASSIGNMENT (WAS NOT ASSIGNING KEEP FLAG TO REPORT IF -C PRESSURE HAD A KEEP Q.M. BUT TEMPERATURE Q.M. WAS -C MISSING) -C 1997-05-30 D. A. KEYSER -- FOR AIRCFT: (ONLY ACARS RIGHT NOW) - -C SECONDS ARE DECODED (IF AVAIL.) AND USED TO OBTAIN -C REPORT TIME; ONLY ASDAR/AMDAR - NEW CAT. 8 CODE FIGS. -C O-PUT 917 (CHAR. 1 & 2 OF ACTUAL STNID), 918 (CHAR. 3 & -C 4 OF ACTUAL STNID), 919 (CHAR. 5 & 6 OF ACTUAL STNID); -C ASDAR/AMDAR AND ACARS - NEW CAT. 8 CODE FIG. O-PUT 920 -C (CHAR. 7 & 8 OF ACTUAL STNID); ONLY ACARS - NEW CAT. 8 -C CODE FIG. O-PUT 921 (REPORT TIME TO NEAREST 1000'TH OF -C AN HOUR); ONLY SOME ACARS - NEW MNEMONIC "IALT" NOW -C EXISTS AND CAN (IF LINE NOT COMMENTED OUT) BE USED TO -C OBTAIN UNPACKED ON29 CAT. 6 -C 1997-07-02 D. A. KEYSER -- REMOVED FILTERING OF AIRCRAFT DATA AS -C FOLLOWS: AIR FRANCE AMDARS NO LONGER FILTERED, AMDAR/ -C ASDAR BELOW 7500 FT. NO LONGER FILTERED, AIREP/PIREP -C BELOW 100 METERS NO LONGER FILTERED, ALL AIRCRAFT WITH -C MISSING WIND BUT VALID TEMPERATURE ARE NO LONGER -C FILTERED; REPROCESSES U.S. SATWND STN. IDS TO CONFORM -C WITH PREVIOUS ON29 APPEARANCE EXCEPT NOW 8-CHAR (TAG -C CHAR. 1 & 6 NOT CHANGED FROM BUFR STN. ID) - NEVER ANY -C DUPL. IDS NOW FOR U.S. SATWNDS DECODED FROM A SINGLE -C BUFR FILE; STREAMLINED/ELIMINATED SOME DO LOOPS TO -C SPEED UP A BIT -C 1997-09-18 D. A. KEYSER -- CORRECTED ERRORS IN REFORMATTING SURFACE -C DATA INTO UNPACKED ON124, SPECIFICALLY-HEADER: INST. TYPE -C (SYNOPTIC FMT FLG, AUTO STN. TYPE, CONVERTED HRLY FLG), -C INDICATORS (PRECIP., WIND SPEED, WX/AUTO STN), CAT51: -C P-TEND, HORIZ. VIZ., PRESENT/PAST WX, CLOUD INFO, MAX/ -C MIN TEMP, CAT52: PRECIP., SNOW DPTH, WAVE INFO, SHIP -C COURSE/SPEED, CAT8: CODE FIGS. 81-85,98; CORRECTED -C PROBLEM WHICH CODED UPPER-AIR MANDATORY LEVEL WINDS -C AS CAT. 3 INSTEAD OF CAT. 1 WHEN MASS DATA (ONLY) WAS -C REPORTED ON SAME MANDATORY LEVEL IN A SEPARATE REPORTED -C LEVEL IN THE RAW BULLETIN -C 1997-10-06 D. A. KEYSER -- UPDATED LOGIC TO READ AND PROCESS NESDIS -C HI-DENSITY SATELLITE WINDS PROPERLY -C 1997-10-30 D. A. KEYSER -- ADDED GROSS CHECK ON U-AIR PRESSURE, ALL -C LEVELS WITH REPORTED PRESSURE .LE. ZERO NOW TOSSED; SFC -C CAT. 52 SEA-SFC TEMPERATURE NOW READ FROM HIERARCHY OF -C SST IN BUFR {1ST CHOICE - HI-RES SST ('SST2'), 2ND -C CHOICE - LO-RES SST ('SST1'), 3RD CHOICE - SEA TEMP -C ('STMP')}, BEFORE ONLY READ 'SST1' -C 1998-01-26 D. A. KEYSER -- CHANGED PQM PROCESSING FOR ADPUPA TYPES -C SUCH THAT SDMEDIT FLAGS ARE NOW HONORED (BEFORE, PQM -C WAS ALWAYS HARDWIRED TO 2 FOR ADPUPA TYPES); BUMPED -C LIMIT FOR NUMBER OF LEVELS THAT CAN BE PROCESSED FROM -C 100 TO 150 AND ADDED DIAGNOSTIC PRINT WHEN THE LIMIT -C IS EXCEEDED -C 1998-05-19 D. A. KEYSER -- Y2K COMPLIANT VERSION OF IW3GAD ROUTINE -C ACCOMPLISHED BY REDEFINING ORIGINAL 32-CHARACTER ON85 -C HEADER LABEL TO BE A 40-CHARACTER LABEL THAT CONTAINS A -C FULL 4-DIGIT YEAR, CAN STILL READ "TRUE" ON29/124 DATA -C SETS PROVIDED THEIR HEADER LABEL IS IN THIS MODIFIED -C FORM -C 1998-07-22 D. A. KEYSER -- MINOR MODIFICATIONS TO ACCOUNT FOR -C CORRECTIONS IN Y2K/F90 BUFRLIB (MAINLY RELATED TO -C BUFRLIB ROUTINE DUMPBF) -C 1998-08-04 D. A. KEYSER -- FIXED A BUG THAT RESULTED IN CODE BEING -C CLOBBERED IN CERTAIN SITUATIONS FOR RECCO REPORTS; MINOR -C MODIFICATIONS TO GIVE SAME ANSWERS ON CRAY AS ON SGI; -C ALLOWED CODE TO READ TRUE ON29/124 FILES WITH NON-Y2K -C COMPLIANT ON85 LABEL (A TEMPORARY MEASURE DURING -C TRANSITION OF MAIN PROGRAMS TO Y2K); ADDED CALL TO "AEA" -C WHICH CONVERTS EBCDIC CHARACTERS TO ASCII FOR INPUT -C TRUE ON29/124 DATA SET PROCESSING OF SGI (WHICH DOES -C NOT SUPPORT "-Cebcdic" IN ASSIGN STATEMENT) -C 1999-02-25 D. A. KEYSER -- ADDED ABILITY TO READ REPROCESSED SSM/I -C BUFR DATA SET (SPSSMI); ADDED ABILITY TO READ MEAN -C SEA-LEVEL PRESSURE BOGUS (PAOBS) DATA SET (SFCBOG) -C 1999-05-14 D. A. KEYSER -- MADE CHANGES NECESSARY TO PORT THIS -C ROUTINE TO THE IBM SP -C 1999-06-18 D. A. KEYSER -- CAN NOW PROCESS WATER VAPOR SATWNDS -C FROM FOREIGN PRODUCERS; STN. ID FOR FOREIGN SATWNDS -C NOW REPROCESSED IN SAME WAY AS FOR NESDIS/GOES SATWNDS, -C CHARACTER 1 OF STN. ID NOW DEFINES EVEN VS. ODD -C SATELLITE WHILE CHARACTER 6 OF STN. ID NOW DEFINES -C IR CLOUD-DRFT VS. VISIBLE CLOUD DRFT VS. WATER VAPOR -C 2002-03-05 D. A. KEYSER -- REMOVED ENTRY "E02O29", NOW PERFORMS -C HEIGHT TO PRESS. CONVERSION DIRECTLY IN CODE FOR CAT. 7; -C TEST FOR MISSING "RPID" CORRECTED FOR ADPUPA DATA (NOW -C CHECKS UFBINT RETURN CODE RATHER THAN VALUE=BMISS); -C ACCOUNTS FOR CHANGES IN INPUT ADPUPA, ADPSFC, AIRCFT -C AND AIRCAR BUFR DUMP FILES AFTER 3/2002: CAT. 7 AND CAT. -C 51 USE MNEMONIC "HBLCS" TO GET HEIGHT OF CLOUD BASE IF -C MNEMONIC "HOCB" NOT AVAILABLE (AND IT WILL NOT BE FOR ALL -C CAT. 7 AND SOME CAT. 51 REPORTS); MNEMONIC "TIWM" -C REPLACES "SUWS" IN HEADER FOR SURFACE DATA; MNEMONIC -C "BORG" REPLACES "ICLI" IN CAT. 8 FOR AIRCRAFT DATA (WILL -C STILL WORK PROPERLY FOR INPUT ADPUPA, ADPSFC, AIRCFT AND -C AIRCAR DUMP FILES PRIOR TO 3/2002) -C 2013-03-20 D. A. KEYSER -- CHANGES TO RUN ON WCOSS: OBTAIN VALUE OF -C BMISS SET IN CALLING PROGRAM VIA CALL TO BUFRLIB ROUTINE -C GETBMISS RATHER THAN HARDWIRING IT TO 10E08 (OR 10E10); -C USE FORMATTED PRINT STATEMENTS WHERE PREVIOUSLY -C UNFORMATTED PRINT WAS USED (WCOSS SPLITS UNFORMATTED -C PRINT AT 80 CHARACTERS) -C -C USAGE: II = IW3UNP29(NUNIT, OBS, IER) -C INPUT ARGUMENT LIST: -C NUNIT - FORTRAN UNIT NUMBER FOR SEQUENTIAL DATA SET CONTAINING -C - PACKED BUFR REPORTS OR PACKED AND BLOCKED OFFICE NOTE -C - 29/124 REPORTS -C -C OUTPUT ARGUMENT LIST: -C OBS - ARRAY CONTAINING ONE REPORT IN UNPACKED OFFICE NOTE -C - 29/124 FORMAT. FORMAT IS MIXED, USER MUST EQUIVALENCE -C - INTEGER AND CHARACTER ARRAYS TO THIS ARRAY (SEE -C - DOCBLOCK FOR W3FI64 IN /nwprod/lib/sorc/w3nco -C - OR WRITEUPS ON W3FI64, ON29, ON124 FOR HELP) -C - THE LENGTH OF THE ARRAY SHOULD BE AT LEAST 1608 -C IER - RETURN FLAG (EQUAL TO FUNCTION VALUE) - SEE REMARKS -C -C INPUT FILES: -C UNIT AA - SEQUENTIAL BUFR OR OFFICE NOTE 29/124 DATA SET ("AA" -C - IS UNIT NUMBER SPECIFIED BY INPUT ARGUMENT "NUNIT") -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C SUBPROGRAMS CALLED: -C UNIQUE: xxxxxx -C LIBRARY: -C UTILITY - xxxxxx -C W3NCO - xxxxxx -C W3EMC - xxxxxx -C BUFRLIB - xxxxxx -C -C REMARKS: -C IF INPUT DATA SET IS ON29/124, IT SHOULD BE ASSIGNED IN THIS WAY: -C Cray: -C assign -a ADPUPA -Fcos -Cebcdic fort.XX -C SGI: -C assign -a ADPUPA -Fcos fort.XX -C (Note: -Cebcdic is not possible on SGI, so call to W3NCO -C routine "AEA" takes care of the conversion as each -C ON29 record is read in) -C IF INPUT DATA SET IS BUFR, IT SHOULD BE ASSIGNED IN THIS WAY: -C Cray: -C assign -a ADPUPA fort.XX -C SGI: -C assign -a ADPUPA -F cos fort.XX -C -C NOTE: FOR INPUT ON29/124 DATA SETS, A CONTINGENCY HAS BEEN BUILT -C INTO THIS SUBROUTINE TO PERFORM THE CONVERSION FROM EBCDIC TO -C ASCII IN THE EVENT THE assign DOES NOT PERFORM THE CONVERSION -C -C THE RETURN FLAGS IN IER (AND FUNCTION IW3UNP29 ITSELF) ARE: -C = 0 OBSERVATION READ AND UNPACKED INTO LOCATION 'OBS'. -C SEE WRITEUP OF W3FI64 FOR CONTENTS. (ALL CHARACTER -C WORDS ARE LEFT-JUSTIFIED.) NEXT CALL TO IW3UNP29 -C WILL RETURN NEXT OBSERVATION IN DATA SET. -C = 1 A 40 BYTE HEADER IN THE FORMAT DESCRIBED HERE -C (Y2K COMPLIANT PSEUDO-OFFICE NOTE 85) IS RETURNED -C IN THE FIRST 10 WORDS OF 'OBS' ON a 4-BYTE MACHINE -C (IBM) AND IN THE FIRST 5 WORDS OF 'OBS' ON AN -C 8-BYTE MACHINE (CRAY). NEXT CALL TO -C IW3UNP29 WILL RETURN FIRST OBS. IN THIS DATA SET. -C (NOTE: IF INPUT DATA SET IS A TRUE ON29/124 FILE -C WITH THE Y2K COMPLIANT PSEUDO-ON85 HEADER RECORD, -C THEN THE PSEUDO-ON85 HEADER RECORD IS ACTUALLY -C READ IN AND RETURNED; IF INPUT DATA SET IS A TRUE -C ON29/124 FILE WITH A NON-Y2K COMPLIANT ON85 HEADER -C RECORD, THEN A Y2K COMPLIANT PSEUDO-ON85 HEADER -C RECORD IS CONSTRUCTED FROM IT USING THE "WINDOWING" -C TECHNIQUE TO OBTAIN A 4-DIGIT YEAR FROM A 2-DIGIT -C YEAR.) -C FORMAT FOR Y2K COMPLIANT PSEUDO-ON85 HEADER RECORD -C RETURNED (40 BYTES IN CHARACTER): -C BYTES 1- 8 -- DATA SET NAME (AS DEFINED IN ON85 -C EXCEPT UP TO EIGHT ASCII CHAR., -C LEFT JUSTIFIED WITH BLANK FILL) -C BYTES 9-10 -- SET TYPE (AS DEFINED IN ON85) -C BYTES 11-20 -- CENTER (ANALYSIS) DATE FOR DATA -C SET (TEN ASCII CHARACTERS IN FORM -C "YYYYMMDDHH") -C BYTES 21-24 -- SET INITIALIZE (DUMP) TIME, AS -C DEDINED IN ON85) -C BYTES 25-34 -- ALWAYS "WASHINGTON" (AS IN ON85) -C BYTES 35-36 -- SOURCE MACHINE (AS DEFINED IN ON85) -C BYTES 37-40 -- BLANK FILL CHARACTERS -C -C = 2 END-OF-FILE (NEVER AN EMPTY OR NULL FILE): -C INPUT ON29/124 DATA SET: THE "ENDOF FILE" RECORD IS -C ENCOUNTERED - NO USEFUL INFORMATION IN 'OBS' ARRAY. -C NEXT CALL TO IW3UNP29 WILL RETURN PHYSICAL END OF -C FILE FOR DATA SET IN 'NUNIT' (SEE IER=3 BELOW). -C INPUT BUFR DATA SET: THE PHYSICAL END OF FILE IS -C ENCOUNTERED. -C = 3 END-OF-FILE: -C PHYSICAL END OF FILE ENCOUNTERED ON DATA SET - -C THIS CAN ONLY HAPPEN FOR AN EMPTY (NULL) DATA SET -C OR FOR A TRUE ON29/124 DATA SET. THERE ARE NO -C MORE REPORTS (OR NEVER WERE ANY IF NULL) ASSOCIATED -C WITH DATA SET IN THIS UNIT NUMBER - NO USEFUL -C INFORMATION IN 'OBS' ARRAY. EITHER ALL DONE (IF -C NO MORE UNIT NUMBERS ARE TO BE READ IN), OR RESET -C 'NUNIT' TO POINT TO A NEW DATA SET (IN WHICH CASE -C NEXT CALL TO IW3UNP29 SHOULD RETURN WITH IER=1). -C = 4 ONLY VALID FOR INPUT ON29/124 DATA SET - I/O ERROR -C READING THE NEXT RECORD OF REPORTS - NO USEFUL -C INFORMATION IN 'OBS' ARRAY. CALLING PROGRAM CAN -C CHOOSE TO STOP OR AGAIN CALL IW3UNP29 WHICH WILL -C ATTEMPT TO UNPACK THE FIRST OBSERVATION IN THE NEXT -C RECORD OF REPORTS. -C = 999 APPLIES ONLY TO NON-EMPTY DATA SETS: -C INPUT ON29/124 DATA SET: FIRST CHOICE Y2K COMPLIANT -C PSEUDO-ON85 FILE HEADER LABEL NOT ENCOUNTERED WHERE -C EXPECTED, AND SECOND CHOICE NON-Y2K COMPLIANT ON85 -C FILE HEADER LABEL ALSO NOT ENCOUNTERED. -C INPUT BUFR DATA SET: EITHER HEADER LABEL IN -C FORMAT OF PSEUDO-ON85 COULD NOT BE RETURNED, OR AN -C ABNORMAL ERROR OCCURRED IN THE ATTEMPT TO DECODE AN -C OBSERVATION. FOR EITHER INPUT DATA SET TYPE, NO -C USEFUL INFORMATION IN 'OBS' ARRAY. CALLING PROGRAM -C CAN CHOOSE TO STOP WITH NON-ZERO CONDITION CODE OR -C RESET 'NUNIT' TO POINT TO A NEW DATA SET (IN WHICH -C CASE NEXT CALL TO IW3UNP29 SHOULD RETURN WITH -C IER=1). -C INPUT DATA SET NEITHER ON29/124 NOR BUFR: SPEAKS FOR -C ITSELF. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: NCEP WCOSS -C -C$$$ - FUNCTION IW3UNP29(LUNIT,OBS,IER) - - COMMON/IO29AA/JWFILE(100),LASTF - COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI - COMMON/IO29CC/SUBSET,IDAT10 - COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11) - COMMON/IO29EE/ROBS(255,11) - COMMON/IO29FF/QMS(255,9) - COMMON/IO29GG/SFO(34) - COMMON/IO29HH/SFQ(5) - COMMON/IO29II/PWMIN - COMMON/IO29JJ/ISET,MANLIN(1001) - COMMON/IO29KK/KOUNT(499,18) - COMMON/IO29LL/BMISS - - DIMENSION OBS(*) - REAL(8) BMISS,GETBMISS - - SAVE - - DATA ITIMES/0/ - - IF(ITIMES.EQ.0) THEN - -C THE FIRST TIME IN, INITIALIZE SOME DATA -C (NOTE: FORTRAN 77/90 STANDARD DOES NOT ALLOW COMMON BLOCK VARIABLES -C TO BE INITIALIZED VIA DATA STATEMENTS, AND, FOR SOME REASON, -C THE BLOCK DATA DOES NOT INITIALIZE DATA IN THE W3NCO LIBRARY -C AVOID BLOCK DATA IN W3NCO/W3EMC) -C -------------------------------------------------------------------- - - ITIMES = 1 - JWFILE = 0 - LASTF = 0 - KNDX = 0 - KSKACF = 0 - KSKUPA = 0 - KSKSFC = 0 - KSKSAT = 0 - KSKSMI = 0 - KOUNT = 0 - IKAT(1) = 1 - IKAT(2) = 2 - IKAT(3) = 3 - IKAT(4) = 4 - IKAT(5) = 5 - IKAT(6) = 6 - IKAT(7) = 7 - IKAT(8) = 8 - IKAT(9) = 51 - IKAT(10) = 52 - IKAT(11) = 9 - MCAT(1) = 6 - MCAT(2) = 4 - MCAT(3) = 4 - MCAT(4) = 4 - MCAT(5) = 6 - MCAT(6) = 6 - MCAT(7) = 3 - MCAT(8) = 3 - MCAT(9) = 21 - MCAT(10) = 15 - MCAT(11) = 3 - ISET = 0 - END IF - -C UNIT NUMBER OUT OF RANGE RETURNS A 999 -C -------------------------------------- - - IF(LUNIT.LT.1 .OR. LUNIT.GT.100) THEN - PRINT'(" ##IW3UNP29 - UNIT NUMBER ",I0," OUT OF RANGE -- ", - $ "IER = 999")', LUNIT - GO TO 9999 - END IF - IF(LASTF.NE.LUNIT .AND. LASTF.GT.0) THEN - CALL CLOSBF(LASTF) - JWFILE(LASTF) = 0 - END IF - LASTF = LUNIT - -C THE JWFILE INDICATOR: =0 IF UNOPENED; =1 IF ON29; =2 IF BUFR -C ------------------------------------------------------------ - - IF(JWFILE(LUNIT).EQ.0) THEN - PRINT'(" ===> IW3UNP29 - WCOSS VERSION: 03-20-2013")' - - BMISS = GETBMISS() - print'(1X)' - print'(" BUFRLIB value for missing passed into IW3UNP29 is: ", - $ G0)', bmiss - print'(1X)' - - IF(I03O29(LUNIT,OBS,IER).EQ.1) THEN - PRINT'(" IW3UNP29 - OPENED A TRUE OFFICE NOTE 29 FILE IN ", - $ "UNIT ",I0)', LUNIT - JWFILE(LUNIT) = 1 - IER = 1 - IW3UNP29 = 1 - ELSEIF(I03O29(LUNIT,OBS,IER).EQ.3) THEN - PRINT 107, LUNIT - 107 FORMAT(/,' ##IW3UNP29 - FILE IN UNIT',I3,' IS EMPTY OR NULL -- ', - $ 'IER = 3'/) - IER = 3 - IW3UNP29 = 3 - ELSEIF(I02O29(LUNIT,OBS,IER).EQ.1) THEN - PRINT'(" IW3UNP29 - OPENED A BUFR FILE IN UNIT ",I0)', LUNIT - - JWFILE(LUNIT) = 2 - KNDX = 0 - KSKACF = 0 - KSKUPA = 0 - KSKSFC = 0 - KSKSAT = 0 - KSKSMI = 0 - IER = 1 - IW3UNP29 = 1 - ELSEIF(I03O29(LUNIT,OBS,IER).EQ.999) THEN - PRINT'(" IW3UNP29 - OPENED A TRUE OFFICE NOTE 29 FILE IN ", - $ "UNIT ",I0)', LUNIT - PRINT 88 - 88 FORMAT(/' ##IW3UNP29/I03O29 - NEITHER EXPECTED Y2K COMPLIANT ', - $ 'PSEUDO-ON85 LABEL NOR SECOND CHOICE NON-Y2K COMPLIANT ON85 ', - $ 'LABEL FOUND IN'/21X,'FIRST RECORD OF FILE -- IER = 999'/) - GO TO 9999 - ELSE - PRINT 108, LUNIT - 108 FORMAT(/,' ##IW3UNP29 - FILE IN UNIT',I3,' IS NEITHER BUFR NOR ', - $ 'TRUE OFFICE NOTE 29 -- IER = 999'/) - GO TO 9999 - END IF - ELSEIF(JWFILE(LUNIT).EQ.1) THEN - IF(I03O29(LUNIT,OBS,IER).NE.0) JWFILE(LUNIT) = 0 - IF(IER.GT.0) CLOSE (LUNIT) - IW3UNP29 = IER - ELSEIF(JWFILE(LUNIT).EQ.2) THEN - IF(I02O29(LUNIT,OBS,IER).NE.0) JWFILE(LUNIT) = 0 - IF(IER.GT.0) CALL CLOSBF(LUNIT) - IF(IER.EQ.2.OR.IER.EQ.3) THEN - IF(KSKACF(1).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT/", - $ "AIRCAR REPORTS TOSSED DUE TO ZERO CAT. 6 LVLS = ",I0)', - $ KSKACF(1) - IF(KSKACF(2).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT ", - $ "REPORTS TOSSED DUE TO BEING ""LFPW"" AMDAR = ",I0)', - $ KSKACF(2) - IF(KSKACF(8).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT ", - $ "REPORTS TOSSED DUE TO BEING ""PHWR"" AIREP = ",I0)', - $ KSKACF(8) - IF(KSKACF(3).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT ", - $ "REPORTS TOSSED DUE TO BEING CARSWELL AMDAR = ",I0)', - $ KSKACF(3) - IF(KSKACF(4).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT ", - $ "REPORTS TOSSED DUE TO BEING CARSWELL ACARS = ",I0)', - $ KSKACF(4) - IF(KSKACF(5).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT/", - $ "AIRCAR REPORTS TOSSED DUE TO HAVING MISSING WIND = ",I0)', - $ KSKACF(5) - IF(KSKACF(6).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT ", - $ "REPORTS TOSSED DUE TO BEING AMDAR < 2286 M = ",I0)', - $ KSKACF(6) - IF(KSKACF(7).GT.0) PRINT'(" IW3UNP29 - NO. OF AIRCFT ", - $ "REPORTS TOSSED DUE TO BEING AIREP < 100 M = ",I0)', - $ KSKACF(7) - IF(KSKACF(1)+KSKACF(2)+KSKACF(3)+KSKACF(4)+KSKACF(5)+ - $ KSKACF(6)+KSKACF(7)+KSKACF(8).GT.0) - $ PRINT'(" IW3UNP29 - TOTAL NO. OF AIRCFT/AIRCAR REPORTS ", - $ "TOSSED = ",I0)', - $ KSKACF(1)+KSKACF(2)+KSKACF(3)+KSKACF(4)+ - $ KSKACF(5)+KSKACF(6)+KSKACF(7)+KSKACF(8) - IF(KSKUPA.GT.0) PRINT'(" IW3UNP29 - TOTAL NO. OF ADPUPA ", - $ "REPORTS TOSSED = ",I0)', KSKUPA - IF(KSKSFC.GT.0) PRINT'(" IW3UNP29 - TOTAL NO. OF ADPSFC/", - $ "SFCSHP/SFCBOG REPORTS TOSSED = ",I0)', KSKSFC - IF(KSKSAT.GT.0) PRINT'(" IW3UNP29 - TOTAL NO. OF SATWND ", - $ "REPORTS TOSSED = ",I0)', KSKSAT - IF(KSKSMI.GT.0) PRINT'(" IW3UNP29 - TOTAL NO. OF SPSSMI ", - $ "REPORTS TOSSED = ",I0)', KSKSMI - KNDX = 0 - KSKACF = 0 - KSKUPA = 0 - KSKSFC = 0 - KSKSAT = 0 - KSKSMI = 0 - END IF - IW3UNP29 = IER - END IF - - RETURN - - 9999 CONTINUE - IER = 999 - IW3UNP29 = 999 - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** -C----------------------------------------------------------------------- -C I01O29 RETURNS LOOK ALIKE Y2K COMPL. PSEUDO-ON85 HDR FROM A DATA FILE -C----------------------------------------------------------------------- - FUNCTION I01O29(LUNIT,HDR,IER) -C ---> formerly FUNCTION IW3HDR - - COMMON/IO29AA/JWFILE(100),LASTF - - DIMENSION HDR(*) - - SAVE - -C UNIT NUMBER OUT OF RANGE RETURNS A 999 -C -------------------------------------- - - IF(LUNIT.LT.1 .OR. LUNIT.GT.100) THEN - PRINT'(" ##IW3UNP29/I01O29 - UNIT NUMBER ",I0," OUT OF RANGE ", - $ "-- IER = 999")', LUNIT - GO TO 9999 - END IF - -C THE JWFILE INDICATOR: =0 IF UNOPENED; =1 IF ON29; =2 IF BUFR -C ------------------------------------------------------------ - - IF(JWFILE(LUNIT).EQ.0) THEN - IF(I03O29(LUNIT,HDR,IER).EQ.1) THEN - I01O29 = I03O29(0,HDR,IER) - I01O29 = 1 - RETURN - ELSEIF(I02O29(LUNIT,HDR,IER).EQ.1) THEN - CALL CLOSBF(LUNIT) - I01O29 = 1 - RETURN - ELSE - -C CAN'T READ FILE HEADER RETURNS A 999 -C ------------------------------------ - - PRINT'(" ##IW3UNP29/I01O29 - CAN""T READ FILE HEADER -- ", - $ "IER = 999")' - GO TO 9999 - END IF - ELSE - -C FILE ALREADY OPEN RETURNS A 999 -C ------------------------------- - - PRINT'(" ##IW3UNP29/I01O29 - FILE ALREADY OPEN -- IER = 999")' - GO TO 9999 - END IF - - RETURN - - 9999 CONTINUE - IER = 999 - I01O29 = 999 - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION I02O29(LUNIT,OBS,IER) -C ---> formerly FUNCTION JW3O29 - - COMMON/IO29CC/SUBSET,IDAT10 - - CHARACTER*40 ON85 - CHARACTER*10 CDATE - CHARACTER*8 SUBSET,CBUFR - CHARACTER*6 C01O29 - CHARACTER*4 CDUMP - DIMENSION OBS(1608),RON85(16),JDATE(5),JDUMP(5) - EQUIVALENCE (RON85(1),ON85) - - SAVE - - DATA ON85/' '/ - - JDATE = -1 - JDUMP = -1 - -C IF FILE IS CLOSED TRY TO OPEN IT AND RETURN A Y2K COMPLIANT -C PSEUDO-ON85 LABEL -C ----------------------------------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - - IF(IL.EQ.0) THEN - IRET = -1 - I02O29 = 2 - REWIND LUNIT - READ(LUNIT,END=10,ERR=10,FMT='(A8)') CBUFR - IF(CBUFR(1:4).EQ.'BUFR') THEN - PRINT'(" IW3UNP29/I02O29 - INPUT FILE ON UNIT ",I0, " IS", - $ " UNBLOCKED NCEP BUFR"/)', LUNIT - ELSE IF(CBUFR(5:8).EQ.'BUFR') THEN - PRINT'(" IW3UNP29/I02O29 - INPUT FILE ON UNIT ",I0, " IS", - $ " BLOCKED NCEP BUFR"/)', LUNIT - ELSE - REWIND LUNIT - GO TO 10 - END IF - call datelen(10) - CALL DUMPBF(LUNIT,JDATE,JDUMP) -cppppp - print'(" CENTER DATE (JDATE) = ",I4,4I3.2/" DUMP DATE (JDUMP)", - $ " (year not used anywhere) = "I4,4I3.2)',jdate,jdump -cppppp - IF(JDATE(1).GT.999) THEN - WRITE(CDATE,'(I4.4,3I2.2)') (JDATE(I),I=1,4) - ELSE IF(JDATE(1).GT.0) THEN - -C If 2-digit year returned in JDATE(1), must use "windowing" technique -C 2 create a 4-digit year - - PRINT'(" ##IW3UNP29/I02O29 - 2-DIGIT YEAR IN JDATE(1) ", - $ "RETURNED FROM DUMPBF (JDATE IS: ",I4.4,3I2.2,") - USE ", - $ "WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR")', JDATE - IF(JDATE(1).GT.20) THEN - WRITE(CDATE,'("19",4I2.2)') (JDATE(I),I=1,4) - ELSE - WRITE(CDATE,'("20",4I2.2)') (JDATE(I),I=1,4) - ENDIF - PRINT'(" ##IW3UNP29/I02O29 - CORRECTED JDATE(1) WITH ", - $ "4-DIGIT YEAR, JDATE NOW IS: ",I4.4,3I2.2)', JDATE - ELSE - GO TO 10 - ENDIF - - CALL OPENBF(LUNIT,'IN',LUNIT) - -C This next call, I believe, is needed only because SUBSET is not -C returned in DUMPBF ... - call readmg(lunit,subset,idat10,iret) - - WRITE(CDUMP,'(2I2.2)') JDUMP(4),100*JDUMP(5)/60 - IF(JDUMP(1).LT.0) CDUMP = '9999' - ON85=C01O29(SUBSET)//' C2'//CDATE//CDUMP//'WASHINGTONCR ' - OBS(1:16) = RON85 - I02O29 = 1 - 10 CONTINUE - IER = I02O29 - RETURN - END IF - -C IF THE FILE IS ALREADY OPENED FOR INPUT TRY TO READ THE NEXT SUBSET -C ------------------------------------------------------------------- - - IF(IL.LT.0) THEN - 7822 CONTINUE - CALL READNS(LUNIT,SUBSET,IDAT10,IRET) - IF(IRET.EQ.0) I02O29 = R01O29(SUBSET,LUNIT,OBS) - IF(IRET.NE.0) I02O29 = 2 - IF(I02O29.EQ.-9999) GO TO 7822 - IER = I02O29 - RETURN - END IF - -C FILE MUST BE OPEN FOR INPUT! -C ---------------------------- - - PRINT'(" ##IW3UNP29/I02O29 - FILE ON UNIT ",I0," IS OPENED FOR ", - $ "OUTPUT -- IER = 999")', LUNIT - I02O29 = 999 - IER = 999 - RETURN - - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: I03O29 -C PRGMMR: KEYSER ORG: NP22 DATE: 2013-03-20 -C -C ABSTRACT: READS A TRUE (SEE *) ON29/124 DATA SET AND UNPACKS ONE -C REPORT INTO THE UNPACKED OFFICE NOTE 29/124 FORMAT. THE INPUT AND -C OUTPUT ARGUMENTS HERE HAVE THE SAME MEANING AS FOR IW3UNP29. -C REPEATED CALLS OF FUNCTION WILL RETURN A SEQUENCE OF UNPACKED -C ON29/124 REPORTS. * - UNLIKE ORIGINAL "TRUE" ON29/124 DATA SETS, -C THE "EXPECTED" FILE HEADER LABEL IS A Y2K COMPLIANT 40-BYTE -C PSEUDO-ON85 VERSION - IF THIS IS NOT ENCOUNTERED THIS CODE, AS A -C TEMPORARY MEASURE DURING THE Y2K TRANSITION PERIOD, WILL LOOK FOR -C THE ORIGINAL NON-Y2K COMPLIANT 32-BYTE ON85 HEADER LABEL AND USE -C THE "WINDOWING" TECHNIQUE TO CONVERT THE 2-DIGIT YEAR TO A 4-DIGIT -C YEAR IN PREPARATION FOR RETURNING A 40-BYTE PSEUDO-ON85 LABEL IN -C THE FIRST C CALL. (SEE IW3UNP29 DOCBLOCK FOR FORMAT OF 40-BYTE -C PSEUDO-ON85 HEADER LABEL.) -C -C PROGRAM HISTORY LOG: -C 1980-12-01 J.STACKPOLE -- ORIGINAL W3LIB ROUTINE IW3GAD -C 1984-06-26 R.E.JONES -- CONVERT TO VS FORTRAN -C 1991-07-23 D.A.KEYSER -- NOW CALLS W3FI64 (F77); INTERNAL READ ERROR -C NO LONGER CAUSES CALLING PROGRAM TO FAIL BUT WILL MOVE -C TO NEXT RECORD IF CAN'T RECOVER TO NEXT REPORT -C 1993-10-07 D.A.KEYSER -- ADAPTED FOR USE ON CRAY (ADDED SAVE -C STATEMENT, REMOVED IBM-SPECIFIC CODE, ETC.) -C 1993-10-15 R.E.JONES -- ADDED CODE SO IF FILE IS EBCDIC IT CONVERTS -C IT TO ASCII -C 1996-10-04 J.S.WOOLLEN -- CHANGED NAME TO I03GAD AND INCORPORATED -C INTO NEW W3LIB ROUTINE IW3GAD -C 2013-03-20 D. A. KEYSER -- CHANGES TO RUN ON WCOSS -C -C USAGE: II = I03O29(NUNIT, OBS, IER) -C INPUT ARGUMENT LIST: -C NUNIT - FORTRAN UNIT NUMBER FOR SEQUENTIAL DATA SET CONTAINING -C - PACKED AND BLOCKED OFFICE NOTE 29/124 REPORTS -C -C OUTPUT ARGUMENT LIST: -C OBS - ARRAY CONTAINING ONE REPORT IN UNPACKED OFFICE NOTE -C - 29/124 FORMAT. FORMAT IS MIXED, USER MUST EQUIVALENCE -C - INTEGER AND CHARACTER ARRAYS TO THIS ARRAY (SEE -C - DOCBLOCK FOR W3FI64 IN /nwprod/lib/sorc/w3nco -C - OR WRITEUPS ON W3FI64, ON29, ON124 FOR HELP) -C - THE LENGTH OF THE ARRAY SHOULD BE AT LEAST 1608 -C IER - RETURN FLAG (EQUAL TO FUNCTION VALUE) - SEE REMARKS -C - IN IW3UNP29 DOCBLOCK -C -C INPUT FILES: -C UNIT AA - SEQUENTIAL OFFICE NOTE 29/124 DATA SET ("AA" IS UNIT -C - NUMBER SPECIFIED BY INPUT ARGUMENT "NUNIT") -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBPROGRAM IW3UNP29. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: NCEP WCOSS -C -C$$$ - FUNCTION I03O29(NUNIT, OBS, IER) -C ---> formerly FUNCTION KW3O29 - - CHARACTER*1 CBUFF(6432),CON85L(32) - CHARACTER*2 CBF910 - CHARACTER*4 CYR4D - CHARACTER*8 CBUFR - INTEGER IBUFF(5),OBS(*) - - EQUIVALENCE (IBUFF,CBUFF) - - SAVE - - DATA IOLDUN/0/ - -C TEST FOR NEW (OR PREVIOUSLY USED) NUNIT AND ADJUST 'NEXT' -C (THIS ALLOWS USER TO SWITCH TO NEW NUNIT PRIOR TO READING TO -C THE 'END OF FILE' ON AN OLD UNIT. ANY SWITCH TO A NEW UNIT WILL -C START THE READ AT THE BEGINNING) -C ---------------------------------------------------------------- - - if(nunit.eq.0) then - if(ioldun.gt.0) rewind ioldun - I03O29 = 0 - ioldun = 0 - return - end if - - IF(NUNIT.NE.IOLDUN) THEN - -C THIS IS A NEW UNIT NUMBER, SET 'NEXT' TO 0 AND REWIND THIS UNIT -C --------------------------------------------------------------- - -CDAKCDAK PRINT 87, NUNIT NOW REDUNDANT TO PRINT THIS - 87 FORMAT(//' IW3UNP29/I03O29 - PREPARING TO READ ON29 DATA SET IN ', - $ 'UNIT ',I3/) - IOLDUN = NUNIT - NEXT = 0 - NFILE = 0 - REWIND NUNIT - ISWT = 0 - END IF - - 10 CONTINUE - - IF(NEXT.NE.0) GO TO 70 - -C COME HERE TO READ IN A NEW RECORD (EITHER REPORTS, Y2K COMPLIANT 40- -C BYTE PSEUDO-ON85 LBL, NON-Y2K 32-BYTE COMPLIANT ON85 LBL, OR E-O-F) -C -------------------------------------------------------------------- - - READ(NUNIT,END=9997,ERR=9998,FMT='(A8)') CBUFR - IF(CBUFR(1:4).EQ.'BUFR' .OR. CBUFR(5:8).EQ.'BUFR') THEN - -C INPUT DATASET IS BUFR - EXIT IMMEDIATELY -C ---------------------------------------- - - IOLDUN = 0 - NEXT = 0 - IER = 999 - GO TO 90 - END IF - - REWIND NUNIT - - READ(NUNIT,ERR=9998,END=9997,FMT='(6432A1)') CBUFF - -C IF ISWT=1, CHARACTER DATA IN RECORD ARE EBCDIC - CONVERT TO ASCII -C ----------------------------------------------------------------- - - IF(ISWT.EQ.1) CALL AEA(CBUFF,CBUFF,6432) - - IF(NFILE.EQ.0) THEN - -C TEST FOR EXPECTED HEADER LABEL -C ------------------------------ - - NFILE = 1 - - IF(CBUFF(25)//CBUFF(26)//CBUFF(27)//CBUFF(28).EQ.'WASH') THEN - ELSEIF(CBUFF(21)//CBUFF(22)//CBUFF(23)//CBUFF(24).EQ.'WASH')THEN - ELSE - -C QUICK CHECK SHOWS SOMETHING OTHER THAN EITHER Y2K COMPLIANT PSEUDO- -C ON85 LBL OR NON-Y2K COMPLIANT ON85 LBL FOUND -- COULD MEAN CHARACTER -C DATA ARE IN EBCDIC, SO SEE IF CONVERSION TO ASCII RECTIFIES THIS -C --------------------------------------------------------------------- - - PRINT 78 - 78 FORMAT(/' ##IW3UNP29 - NEITHER EXPECTED Y2K COMPLIANT PSEUDO-', - $ 'ON85 LABEL NOR SECOND CHOICE NON-Y2K COMPLIANT ON85 LABEL ', - $ 'FOUND IN'/14X,'FIRST RECORD OF FILE -- TRY EBCDIC TO ASCII ', - $ 'CONVERSION'/) - CALL AEA(CBUFF,CBUFF,6432) - ISWT = 1 - END IF - - IF(CBUFF(25)//CBUFF(26)//CBUFF(27)//CBUFF(28).EQ.'WASH') THEN - -C THIS IS Y2K COMPLIANT 40-BYTE PSEUDO-ON85 LBL; RESET 'NEXT', SET -C 'IER', FILL 'OBS(1)-(4)', AND QUIT -C --------------------------------------------------------------- - NEXT = 0 - IER = 1 - OBS(1:5) = IBUFF(1:5) - GO TO 90 - ELSE IF(CBUFF(21)//CBUFF(22)//CBUFF(23)//CBUFF(24).EQ.'WASH') - $ THEN - -C THIS IS NON-Y2K COMPLIANT 32-BYTE ON85 LBL; RESET 'NEXT', SET -C 'IER', USE "WINDOWING" TECHNIQUE TO CONTRUCT 4-DIGIT YEAR, -C CONSTRUCT A 40-BYTE PSEUDO-ON85 LABE, FILL 'OBS(1)-(4)', AND QUIT -C ------------------------------------------------------------------ - PRINT'(" ==> THIS IS A TRUE OFFICE NOTE 29 FILE!! <==")' - PRINT 88 - 88 FORMAT(/' ##IW3UNP29/I03O29 - WARNING: ORIGINAL NON-Y2K ', - $ 'COMPLIANT ON85 LABEL FOUND IN FIRST RECORD OF FILE INSTEAD OF ', - $ 'EXPECTED'/30X,'Y2K COMPLIANT PSEUDO-ON85 LABEL -- THIS ', - $ 'ROUTINE IS FORCED TO USE "WINDOWING" TECHNIQUE TO CONTRUCT'/30X, - $'A Y2K COMPLIANT PSEUDO-ON85 LABEL TO RETURN TO CALLING PROGRAM'/) - - NEXT = 0 - IER = 1 - - CBF910 = CBUFF(9)//CBUFF(10) - READ(CBF910,'(I2)') IYR2D - PRINT'(" ##IW3UNP29/I03O29 - 2-DIGIT YEAR FOUND IN ON85 ", - $ "LBL (",A,") IS: ",I0/19X," USE WINDOWING TECHNIQUE TO ", - $ "OBTAIN 4-DIGIT YEAR")', CBUFF(1:32),IYR2D - IF(IYR2D.GT.20) THEN - IYR4D = 1900 + IYR2D - ELSE - IYR4D = 2000 + IYR2D - ENDIF - PRINT'(" ##IW3UNP29/I03O29 - 4-DIGIT YEAR OBTAINED VIA ", - $ "WINDOWING TECHNIQUE IS: ",I0/)', IYR4D - CON85L = CBUFF(1:32) - CBUFF(7:40) = ' ' - CBUFF(9:10) = CON85L(7:8) - WRITE(CYR4D,'(I4.4)') IYR4D - DO I=1,4 - CBUFF(10+I) = CYR4D(I:I) - ENDDO - CBUFF(15:36) = CON85L(11:32) - OBS(1:5) = IBUFF(1:5) - GO TO 90 - ELSE - -C SOMETHING OTHER THAN EITHER Y2K COMPLIANT PSEUDO-ON85 LBL OR -C NON-Y2K COMPLIANT ON85 LBL FOUND; RESET 'NEXT', SET 'IER' AND QUIT -C ------------------------------------------------------------------ -CDAKCDAK PRINT 88 CAN'T PRINT THIS ANYMORE -CDA88 FORMAT(/' ##IW3UNP29/I03O29 - EXPECTED ON85 LABEL NOT FOUND IN ', -CDAK $ 'FIRST RECORD OF NEW LOGICAL FILE -- IER = 999'/) - IOLDUN = 0 - NEXT = 0 - IER = 999 - GO TO 90 - END IF - - END IF - - IF(CBUFF(1)//CBUFF(2)//CBUFF(3)//CBUFF(4).EQ.'ENDO') THEN - -C LOGICAL "ENDOF FILE" READ; RESET NEXT, SET IER, AND QUIT -C -------------------------------------------------------- - - NEXT = 0 - IER = 2 - NFILE = 0 - GO TO 90 - END IF - GO TO 70 - - 9997 CONTINUE - -C PHYSICAL END OF FILE; RESET 'NEXT', SET 'IER' AND QUIT -C ------------------------------------------------------ - - NEXT = 0 - IER = 3 - GO TO 90 - - 9998 CONTINUE - -C I/O ERROR; RESET 'NEXT', SET 'IER' AND QUIT -C ------------------------------------------- - -cppppp - print'(" ##IW3UNP29/I03O29 - ERROR READING DATA RECORD")' -cppppp - NEXT = 0 - IER = 4 - GO TO 90 - - 70 CONTINUE - -C WORKING WITHIN ACTUAL DATA REC. READ, CALL W3FI64 TO READ IN NEXT RPT -C --------------------------------------------------------------------- - - CALL W3FI64(CBUFF,OBS,NEXT) - - IF(NEXT.GE.0) THEN - -C REPORT SUCCESSFULLY RETURNED IN ARRAY 'OBS' -C ------------------------------------------- - - IER = 0 - - ELSE - -C HIT END-OF-RECORD, OR INTERNAL READ ERROR ENCOUNTERED & CAN'T RECOVER -C -- READ IN NEXT RECORD OF REPORTS -C --------------------------------------------------------------------- - - NEXT = 0 - GO TO 10 - END IF - - 90 CONTINUE - - I03O29 = IER - - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION C01O29(SUBSET) -C ---> formerly FUNCTION ADP - - CHARACTER*(*) SUBSET - CHARACTER*6 C01O29 - - SAVE - - C01O29 = 'NONE' - - IF(SUBSET(1:5).EQ.'NC000') C01O29 = 'ADPSFC' - IF(SUBSET(1:5).EQ.'NC001') THEN - IF(SUBSET(6:8).NE.'006') THEN - C01O29 = 'SFCSHP' - ELSE - C01O29 = 'SFCBOG' - END IF - END IF - IF(SUBSET(1:5).EQ.'NC002') C01O29 = 'ADPUPA' - IF(SUBSET(1:5).EQ.'NC004') C01O29 = 'AIRCFT' - IF(SUBSET(1:5).EQ.'NC005') C01O29 = 'SATWND' - IF(SUBSET(1:5).EQ.'NC012') C01O29 = 'SPSSMI' - - IF(SUBSET .EQ. 'NC003101') C01O29 = 'SATEMP' - IF(SUBSET .EQ. 'NC004004') C01O29 = 'AIRCAR' - IF(SUBSET .EQ. 'NC004005') C01O29 = 'ADPUPA' - - IF(SUBSET .EQ. 'ADPSFC') C01O29 = 'ADPSFC' - IF(SUBSET .EQ. 'SFCSHP') C01O29 = 'SFCSHP' - IF(SUBSET .EQ. 'SFCBOG') C01O29 = 'SFCBOG' - IF(SUBSET .EQ. 'ADPUPA') C01O29 = 'ADPUPA' - IF(SUBSET .EQ. 'AIRCFT') C01O29 = 'AIRCFT' - IF(SUBSET .EQ. 'SATWND') C01O29 = 'SATWND' - IF(SUBSET .EQ. 'SATEMP') C01O29 = 'SATEMP' - IF(SUBSET .EQ. 'AIRCAR') C01O29 = 'AIRCAR' - IF(SUBSET .EQ. 'SPSSMI') C01O29 = 'SPSSMI' - - IF(C01O29.EQ.'NONE') PRINT'(" ##IW3UNP29/C01O29 - UNKNOWN SUBSET", - $ " (=",A,") -- CONTINUE~~")', SUBSET - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R01O29(SUBSET,LUNIT,OBS) -C ---> formerly FUNCTION ADC - - CHARACTER*(*) SUBSET - CHARACTER*6 C01O29,ADPSUB - DIMENSION OBS(*) - - SAVE - -C FIND AN ON29/124 DATA TYPE AND CALL A TRANSLATOR -C ------------------------------------------------ - - R01O29 = 4 - ADPSUB = C01O29(SUBSET) - IF(ADPSUB .EQ. 'ADPSFC') R01O29 = R04O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'SFCSHP') R01O29 = R04O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'SFCBOG') R01O29 = R04O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'ADPUPA') R01O29 = R03O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'AIRCFT') R01O29 = R05O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'AIRCAR') R01O29 = R05O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'SATWND') R01O29 = R06O29(LUNIT,OBS) - IF(ADPSUB .EQ. 'SPSSMI') R01O29 = R07O29(LUNIT,OBS) - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - SUBROUTINE S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP) -C ---> Formerly SUBROUTINE O29HDR - - COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11) - COMMON/IO29LL/BMISS - - CHARACTER*(*) RSV,RSV2 - CHARACTER*8 COB,SID,RCT - DIMENSION IHDR(12),RHDR(12),ICATS(50,150,11) - REAL(8) BMISS - EQUIVALENCE (IHDR(1),RHDR(1)),(COB,IOB),(ICATS,RCATS) - - SAVE - - DATA OMISS/99999/ - -C INITIALIZE THE UNPACK ARRAY TO MISSINGS -C --------------------------------------- - - NCAT = 0 - RCATS = OMISS - COB = ' ' - ICATS(6,1:149,1) = IOB - ICATS(4,1:149,2) = IOB - ICATS(4,1:149,3) = IOB - ICATS(4,1:149,4) = IOB - ICATS(6,1:149,5) = IOB - ICATS(6,1:149,6) = IOB - ICATS(3,1:149,7) = IOB - ICATS(3,1:149,8) = IOB - -C WRITE THE RECEIPT TIME IN CHARACTERS -C ------------------------------------ - - RCT = '9999 ' - IF(RCH*100.LT.2401.AND.RCH*100.GT.-1) - $ WRITE(RCT,'(I4.4)') NINT(RCH*100.) - -C STORE THE ON29 HEADER INFORMATION INTO UNP FORMAT -C ------------------------------------------------- - - RHDR( 1) = OMISS - IF(YOB.LT.BMISS) RHDR( 1) = NINT(100.*YOB) -cppppp - IF(YOB.GE.BMISS) print'(" ~~IW3UNP29/S01O29: ID ",A," has a ", - $ "missing LATITUDE - on29 hdr, word 1 is set to ",G0)', - $ sid,RHDR(1) -cppppp - RHDR( 2) = OMISS - IF(XOB.LT.BMISS) RHDR( 2) = NINT(100.*MOD(720.-XOB,360.)) -cppppp - IF(XOB.GE.BMISS) print'(" ~~IW3UNP29/S01O29: ID ",A," has a ", - $ "missing LONGITUDE - on29 hdr, word 2 is set to ",G0)', - $ sid,RHDR(2) -cppppp - RHDR( 3) = OMISS - RHDR( 4) = OMISS - IF(RHR.LT.BMISS) RHDR( 4) = NINT((100.*RHR)+0.0001) -cppppp - IF(RHR.GE.BMISS) print'(" ~~IW3UNP29/S01O29: ID ",A," has a ", - $ "missing OB TIME - on29 hdr, word 4 is set to ",G0)', sid,RHDR(4) -cppppp - IF(RSV2.EQ.' ') THEN - COB = ' ' - COB(1:4) = RCT(3:4)//RSV(1:2) - IHDR(5) = IOB - COB = ' ' - COB(1:3) = RCT(1:2)//RSV(3:3) - IHDR(6) = IOB - ELSE - COB = ' ' - COB(1:4) = RSV2(3:4)//RSV(1:2) - IHDR(5) = IOB - COB = ' ' - COB(1:3) = RSV2(1:2)//RSV(3:3) - IHDR(6) = IOB - END IF - RHDR( 7) = NINT(ELV) - IHDR( 8) = ITP - IHDR( 9) = RTP - RHDR(10) = OMISS - COB = ' ' - COB(1:4) = SID(1:4) - IHDR(11) = IOB - COB = ' ' - COB(1:4) = SID(5:6)//' ' - IHDR(12) = IOB - -C STORE THE HEADER INTO A HOLDING ARRAY -C ------------------------------------- - - HDR = RHDR - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - SUBROUTINE S02O29(ICAT,N,*) -C ---> Formerly SUBROUTINE O29CAT - - COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11) - COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), - $ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255), - $ CF8(255) - COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255), - $ QCP(255),QCA(255),Q81(255),Q82(255) - COMMON/IO29GG/PSL,STP,SDR,SSP,STM,DPD,TMX,TMI,HVZ,PRW,PW1,CCN,CHN, - $ CTL,CTM,CTH,HCB,CPT,APT,PC6,SND,P24,DOP,POW,HOW,SWD, - $ SWP,SWH,SST,SPG,SPD,SHC,SAS,WES - COMMON/IO29HH/PSQ,SPQ,SWQ,STQ,DDQ - COMMON/IO29II/PWMIN - COMMON/IO29LL/BMISS - - CHARACTER*8 COB,C11,C12 - CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,PSQ,SPQ,SWQ,STQ, - $ DDQ - DIMENSION RCAT(50),JCAT(50) - REAL(8) BMISS - EQUIVALENCE (RCAT(1),JCAT(1)),(C11,HDR(11)),(C12,HDR(12)), - $ (COB,IOB) - LOGICAL SURF - - SAVE - -cppppp-ID - iprint = 0 -c if(C11(1:4)//C12(1:2).eq.'59758 ') iprint = 1 -c if(C11(1:4)//C12(1:2).eq.'59362 ') iprint = 1 -c if(C11(1:4)//C12(1:2).eq.'57957 ') iprint = 1 -c if(C11(1:4)//C12(1:2).eq.'74794 ') iprint = 1 -c if(C11(1:4)//C12(1:2).eq.'74389 ') iprint = 1 -c if(C11(1:4)//C12(1:2).eq.'96801A') iprint = 1 -cppppp-ID - - SURF = .FALSE. - GOTO 1 - -C ENTRY POINT SE01O29 FORCES DATA INTO THE SURFACE (FIRST) LEVEL -C -------------------------------------------------------------- - - ENTRY SE01O29(ICAT,N) -C ---> formerly ENTRY O29SFC - SURF = .TRUE. - -C CHECK THE PARAMETERS COMING IN -C ------------------------------ - -1 KCAT = 0 - DO I = 1,11 - IF(ICAT.EQ.IKAT(I)) THEN - KCAT = I - GO TO 991 - END IF - ENDDO - - 991 CONTINUE - -C PARAMETER ICAT (ON29 CATEGORY) OUT OF BOUNDS RETURNS A 999 -C ---------------------------------------------------------- - - IF(KCAT.EQ.0) THEN - PRINT'(" ##IW3UNP29/S02O29 - ON29 CATEGORY ",I0," OUT OF ", - $ "BOUNDS -- IER = 999")', ICAT - RETURN 1 - END IF - -C PARAMETER N (LEVEL INDEX) OUT OF BOUNDS RETURNS A 999 -C ----------------------------------------------------- - - IF(N.GT.255) THEN - PRINT'(" ##IW3UNP29/S02O29 - LEVEL INDEX ",I0," EXCEEDS 255 ", - $ "-- IER = 999")', N - RETURN 1 - END IF - -C MAKE A MISSING LEVEL AND RETURN WHEN N=0 (NOT ALLOWED FOR CAT 01) -C ----------------------------------------------------------------- - - IF(N.EQ.0) THEN - IF(KCAT.EQ.1) RETURN - NCAT(KCAT) = MIN(149,NCAT(KCAT)+1) -cppppp - if(iprint.eq.1) - $ print'(" To prepare for sfc. data, write all missings on ", - $ "lvl ",I0," for cat ",I0)', ncat(kcat),kcat -cppppp - RETURN - END IF - -C FIGURE OUT WHICH LEVEL TO UPDATE AND RESET THE LEVEL COUNTER -C ------------------------------------------------------------ - - IF(KCAT.EQ.1) THEN - L = I04O29(POB(N)*.1) - IF(L.EQ.999999) GO TO 9999 - -C BAD MANDATORY LEVEL RETURNS A 999 -C --------------------------------- - - IF(L.LE.0) THEN - PRINT'(" ##IW3UNP29/S02O29 - BAD MANDATORY LEVEL (P = ", - $ G0,") -- IER = 999")', POB(N) - RETURN 1 - END IF - NCAT(KCAT) = MAX(NCAT(KCAT),L) -cppppp - if(iprint.eq.1) - $ print'(" Will write cat. 1 data on lvl ",I0," for cat ",I0, - $ ", - total no. cat. 1 lvls processed so far = ",I0)', - $ L,kcat,ncat(kcat) -cppppp - ELSEIF(SURF) THEN - L = 1 - NCAT(KCAT) = MAX(NCAT(KCAT),1) -cppppp - if(iprint.eq.1) - $ print'(" Will write cat. ",I0," SURFACE data on lvl ",I0, - $ ", - total no. cat. ",I0," lvls processed so far = ",I0)', - $ kcat,L,kcat,ncat(kcat) -cppppp - ELSE - L = MIN(149,NCAT(KCAT)+1) - IF(L.EQ.149) THEN -cppppp - print'(" ~~IW3UNP29/S02O29: ID ",A," - This cat. ",I0, - $ " level cannot be processed because the limit has already", - $ " been reached")', c11(1:4)//c12(1:2),kcat -cppppp - RETURN - END IF - NCAT(KCAT) = L -cppppp - if(iprint.eq.1) - $ print'(" Will write cat. ",I0," NON-SFC data on lvl ",I0, - $ ", - total no. cat. ",I0," lvls processed so far = ",I0)', - $ kcat,L,kcat,ncat(kcat) -cppppp - END IF - -C EACH CATEGORY NEEDS A SPECIFIC DATA ARRANGEMENT -C ----------------------------------------------- - - COB = ' ' - IF(ICAT.EQ.1) THEN - RCAT(1) = MIN(NINT(ZOB(N)),NINT(RCATS(1,L,KCAT))) - RCAT(2) = MIN(NINT(TOB(N)),NINT(RCATS(2,L,KCAT))) - RCAT(3) = MIN(NINT(QOB(N)),NINT(RCATS(3,L,KCAT))) - RCAT(4) = MIN(NINT(DOB(N)),NINT(RCATS(4,L,KCAT))) - RCAT(5) = MIN(NINT(SOB(N)),NINT(RCATS(5,L,KCAT))) - COB(1:4) = ZQM(N)//TQM(N)//QQM(N)//WQM(N) - JCAT(6) = IOB - ELSEIF(ICAT.EQ.2) THEN - RCAT(1) = MIN(NINT(POB(N)),99999) - RCAT(2) = MIN(NINT(TOB(N)),99999) - RCAT(3) = MIN(NINT(QOB(N)),99999) - COB(1:3) = PQM(N)//TQM(N)//QQM(N) - JCAT(4) = IOB - ELSEIF(ICAT.EQ.3) THEN - RCAT(1) = MIN(NINT(POB(N)),99999) - RCAT(2) = MIN(NINT(DOB(N)),99999) - RCAT(3) = MIN(NINT(SOB(N)),99999) - -C MARK THE TROPOPAUSE LEVEL IN CAT. 3 - - IF(NINT(VSG(N)).EQ.16) PQM(N) = 'T' - -C MARK THE MAXIMUM WIND LEVEL IN CAT. 3 - - IF(NINT(VSG(N)).EQ. 8) THEN - PQM(N) = 'W' - IF(POB(N).EQ.PWMIN) PQM(N) = 'X' - END IF - COB(1:2) = PQM(N)//WQM(N) - JCAT(4) = IOB - ELSEIF(ICAT.EQ.4) THEN - RCAT(1) = MIN(NINT(ZOB(N)),99999) - RCAT(2) = MIN(NINT(DOB(N)),99999) - RCAT(3) = MIN(NINT(SOB(N)),99999) - COB(1:2) = ZQM(N)//WQM(N) - JCAT(4) = IOB - ELSEIF(ICAT.EQ.5) THEN - RCAT(1) = MIN(NINT(POB(N)),99999) - RCAT(2) = MIN(NINT(TOB(N)),99999) - RCAT(3) = MIN(NINT(QOB(N)),99999) - RCAT(4) = MIN(NINT(DOB(N)),99999) - RCAT(5) = MIN(NINT(SOB(N)),99999) - COB(1:4) = PQM(N)//TQM(N)//QQM(N)//WQM(N) - JCAT(6) = IOB - ELSEIF(ICAT.EQ.6) THEN - RCAT(1) = MIN(NINT(ZOB(N)),99999) - RCAT(2) = MIN(NINT(TOB(N)),99999) - RCAT(3) = MIN(NINT(QOB(N)),99999) - RCAT(4) = MIN(NINT(DOB(N)),99999) - RCAT(5) = MIN(NINT(SOB(N)),99999) - COB(1:4) = ZQM(N)//TQM(N)//QQM(N)//WQM(N) - JCAT(6) = IOB - ELSEIF(ICAT.EQ.7) THEN - RCAT(1) = MIN(NINT(CLP(N)),99999) - RCAT(2) = MIN(NINT(CLA(N)),99999) - COB(1:2) = QCP(N)//QCA(N) - JCAT(3) = IOB - ELSEIF(ICAT.EQ.8) THEN - RCAT(1) = MIN(NINT(OB8(N)),99999) - RCAT(2) = MIN(NINT(CF8(N)),99999) - COB(1:2) = Q81(N)//Q82(N) - JCAT(3) = IOB - ELSEIF(ICAT.EQ.51) THEN - RCAT( 1) = MIN(NINT(PSL),99999) - RCAT( 2) = MIN(NINT(STP),99999) - RCAT( 3) = MIN(NINT(SDR),99999) - RCAT( 4) = MIN(NINT(SSP),99999) - RCAT( 5) = MIN(NINT(STM),99999) - RCAT( 6) = MIN(NINT(DPD),99999) - RCAT( 7) = MIN(NINT(TMX),99999) - RCAT( 8) = MIN(NINT(TMI),99999) - COB(1:4) = PSQ//SPQ//SWQ//STQ - JCAT(9) = IOB - COB = ' ' - COB(1:1) = DDQ - JCAT(10) = IOB - JCAT(11) = MIN(NINT(HVZ),99999) - JCAT(12) = MIN(NINT(PRW),99999) - JCAT(13) = MIN(NINT(PW1),99999) - JCAT(14) = MIN(NINT(CCN),99999) - JCAT(15) = MIN(NINT(CHN),99999) - JCAT(16) = MIN(NINT(CTL),99999) - JCAT(17) = MIN(NINT(HCB),99999) - JCAT(18) = MIN(NINT(CTM),99999) - JCAT(19) = MIN(NINT(CTH),99999) - JCAT(20) = MIN(NINT(CPT),99999) - RCAT(21) = MIN(ABS(NINT(APT)),99999) - IF(CPT.GE.BMISS.AND.APT.LT.0.) - $ RCAT(21) = MIN(ABS(NINT(APT))+500,99999) - ELSEIF(ICAT.EQ.52) THEN - JCAT( 1) = MIN(NINT(PC6),99999) - JCAT( 2) = MIN(NINT(SND),99999) - JCAT( 3) = MIN(NINT(P24),99999) - JCAT( 4) = MIN(NINT(DOP),99999) - JCAT( 5) = MIN(NINT(POW),99999) - JCAT( 6) = MIN(NINT(HOW),99999) - JCAT( 7) = MIN(NINT(SWD),99999) - JCAT( 8) = MIN(NINT(SWP),99999) - JCAT( 9) = MIN(NINT(SWH),99999) - JCAT(10) = MIN(NINT(SST),99999) - JCAT(11) = MIN(NINT(SPG),99999) - JCAT(12) = MIN(NINT(SPD),99999) - JCAT(13) = MIN(NINT(SHC),99999) - JCAT(14) = MIN(NINT(SAS),99999) - JCAT(15) = MIN(NINT(WES),99999) - ELSE - -C UNSUPPORTED CATEGORY RETURNS A 999 -C ---------------------------------- - - PRINT'(" ##IW3UNP29/S02O29 - CATEGORY ",I0," NOT SUPPORTED ", - $ "-- IER = 999")', ICAT - RETURN 1 - END IF - -C TRANSFER THE LEVEL DATA INTO THE HOLDING ARRAY AND EXIT -C ------------------------------------------------------- - - DO I = 1,MCAT(KCAT) - RCATS(I,L,KCAT) = RCAT(I) - ENDDO - - RETURN - 9999 CONTINUE - RETURN 1 - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - SUBROUTINE S03O29(UNP,SUBSET,*,*) -C ---> Formerly SUBROUTINE O29UNP - - COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11) - - DIMENSION RCAT(50),JCAT(50),UNP(*) - CHARACTER*8 SUBSET - EQUIVALENCE (RCAT(1),JCAT(1)) - - SAVE - -C CALL TO SORT CATEGORIES 02, 03, 04, AND 08 LEVELS -C ------------------------------------------------- - - CALL S04O29 - -C TRANSFER DATA FROM ALL CATEGORIES INTO UNP ARRAY & SET POINTERS -C --------------------------------------------------------------- - - INDX = 43 - JCAT = 0 - NLEVTO = 0 - NLEVC8 = 0 - - DO K = 1,11 - JCAT(2*K+11) = NCAT(K) - IF(K.NE.7.AND.K.NE.8.AND.K.NE.11) THEN - NLEVTO = NLEVTO + NCAT(K) - ELSE IF(K.EQ.8) THEN - NLEVC8 = NLEVC8 + NCAT(K) - END IF - IF(NCAT(K).GT.0) JCAT(2*K+12) = INDX - IF(NCAT(K).EQ.0) JCAT(2*K+12) = 0 - DO J = 1,NCAT(K) - DO I = 1,MCAT(K) - -C UNPACKED ON29 REPORT CONTAINS MORE THAN 1608 WORDS - RETURNS A 999 -C ------------------------------------------------------------------ - - IF(INDX.GT.1608) THEN - PRINT'(" ##IW3UNP29/S03O29 - UNPKED ON29 RPT CONTAINS ", - $ I0," WORDS, > LIMIT OF 1608 -- IER = 999")', INDX - RETURN 1 - END IF - UNP(INDX) = RCATS(I,J,K) - INDX = INDX+1 - ENDDO - ENDDO - ENDDO - -C RETURN WITHOUT PROCESSING THIS REPORT IF NO DATA IN CAT. 1-6, 51, 52 -C (UNLESS SSM/I REPORT, THEN DO NOT RETURN UNLESS ALSO NO CAT. 8 DATA) -C -------------------------------------------------------------------- - - IF(NLEVTO.EQ.0) THEN - IF(SUBSET(1:5).NE.'NC012') THEN - RETURN 2 - ELSE - IF(NLEVC8.EQ.0) RETURN 2 - END IF - END IF - -C TRANSFER THE HEADER AND POINTER ARRAYS INTO UNP -C ----------------------------------------------- - - UNP(1:12) = HDR - UNP(13:42) = RCAT(13:42) - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - SUBROUTINE S04O29 -C ---> Formerly SUBROUTINE O29SRT - - COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11) -cppppp - character*8 c11,c12,sid -cppppp - - DIMENSION RCAT(50,150),IORD(150),IWORK(65536),SCAT(50,150),RCTL(3) -cppppp - EQUIVALENCE (C11,HDR(11)),(C12,HDR(12)) -cppppp - - SAVE - -cppppp - sid = c11(1:4)//c12(1:4) -cppppp - -C SORT CATEGORIES 2, 3, AND 4 - LEAVE THE FIRST LEVEL IN EACH INTACT -C ------------------------------------------------------------------ - - DO K=2,4 - IF(NCAT(K).GT.1) THEN - DO J=1,NCAT(K)-1 - DO I=1,MCAT(K) - SCAT(I,J) = RCATS(I,J+1,K) - ENDDO - ENDDO - CALL ORDERS(2,IWORK,SCAT(1,1),IORD,NCAT(K)-1,50,8,2) - RCTL = 10E9 - DO J=1,NCAT(K)-1 - IF(K.LT.4) JJ = IORD((NCAT(K)-1)-J+1) - IF(K.EQ.4) JJ = IORD(J) - DO I=1,MCAT(K) - RCAT(I,J) = SCAT(I,JJ) - ENDDO - IDUP = 0 - IF(NINT(RCAT(1,J)).EQ.NINT(RCTL(1))) THEN - IF(NINT(RCAT(2,J)).EQ.NINT(RCTL(2)).AND. - $ NINT(RCAT(3,J)).EQ.NINT(RCTL(3))) THEN -cppppp - if(k.ne.4) then - print'(" ~~@@IW3UNP29/S04O29: ID ",A," has a ", - $ "dupl. cat. ",I0," lvl (all data) at ",G0," mb -- lvl will be ", - $ "excluded from processing")', sid,k,rcat(1,j)*.1 - else - print'(" ~~@@IW3UNP29/S04O29: ID ",A," has a ", - $ "dupl. cat. ",I0," lvl (all data) at ",G0," m -- lvl will be ", - $ "excluded from processing")', sid,k,rcat(1,j) - end if -cppppp - IDUP = 1 - ELSE -cppppp - if(k.ne.4) then - print'(" ~~@@#IW3UNP29/S04O29: ID ",A," has a ", - $ "dupl. cat. ",I0," press. lvl (data differ) at ",G0," mb -- lvl", - $ " will NOT be excluded")', sid,k,rcat(1,j)*.1 - else - print'(" ~~@@#IW3UNP29/S04O29: ID ",A," has a ", - $ "dupl. cat. ",I0," height lvl (data differ) at ",G0," m -- lvl ", - $ "will NOT be excluded")', sid,k,rcat(1,j) - end if -cppppp - END IF - END IF - RCTL = RCAT(1:3,J) - IF(IDUP.EQ.1) RCAT(1,J) = 10E8 - ENDDO - JJJ = 1 - DO J=2,NCAT(K) - IF(RCAT(1,J-1).GE.10E8) GO TO 887 - JJJ = JJJ + 1 - DO I=1,MCAT(K) - RCATS(I,JJJ,K) = RCAT(I,J-1) - ENDDO - 887 CONTINUE - ENDDO -cppppp - if(jjj.ne.NCAT(K)) - $ print'(" ~~@@IW3UNP29/S04O29: ID ",A," has had ",I0, - $ " lvls removed due to their being duplicates")', - $ sid,NCAT(K)-jjj -cppppp - ncat(k) = jjj - end if - IF(NCAT(K).EQ.1) THEN - IF(MIN(RCATS(1,1,K),RCATS(2,1,K),RCATS(3,1,K)).GT.99998.8) - $ NCAT(K) = 0 - END IF - ENDDO - -C SORT CATEGORY 08 BY CODE FIGURE -C ------------------------------- - - DO K=8,8 - IF(NCAT(K).GT.1) THEN - CALL ORDERS(2,IWORK,RCATS(2,1,K),IORD,NCAT(K),50,8,2) - DO J=1,NCAT(K) - DO I=1,MCAT(K) - RCAT(I,J) = RCATS(I,IORD(J),K) - ENDDO - ENDDO - DO J=1,NCAT(K) - DO I=1,MCAT(K) - RCATS(I,J,K) = RCAT(I,J) - ENDDO - ENDDO - END IF - ENDDO - -C NORMAL EXIT -C ----------- - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - SUBROUTINE S05O29 -C ---> Formerly SUBROUTINE O29INX - - COMMON/IO29EE/OBS(255,11) - COMMON/IO29FF/QMS(255,9) - COMMON/IO29GG/SFO(34) - COMMON/IO29HH/SFQ(5) - COMMON/IO29LL/BMISS - - CHARACTER*1 QMS,SFQ - - REAL(8) BMISS - - SAVE - -C SET THE INPUT DATA ARRAYS TO MISSING OR BLANK -C --------------------------------------------- - - OBS = BMISS - QMS = ' ' - SFO = BMISS - SFQ = ' ' - - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION I04O29(P) -C ---> formerly FUNCTION MANO29 - - COMMON/IO29JJ/ISET,MANLIN(1001) - - SAVE - - IF(ISET.EQ.0) THEN - MANLIN = 0 - - MANLIN(1000) = 1 - MANLIN(850) = 2 - MANLIN(700) = 3 - MANLIN(500) = 4 - MANLIN(400) = 5 - MANLIN(300) = 6 - MANLIN(250) = 7 - MANLIN(200) = 8 - MANLIN(150) = 9 - MANLIN(100) = 10 - MANLIN(70) = 11 - MANLIN(50) = 12 - MANLIN(30) = 13 - MANLIN(20) = 14 - MANLIN(10) = 15 - MANLIN(7) = 16 - MANLIN(5) = 17 - MANLIN(3) = 18 - MANLIN(2) = 19 - MANLIN(1) = 20 - - ISET = 1 - END IF - - IP = NINT(P*10.) - - IF(IP.GT.10000 .OR. IP.LT.10 .OR. MOD(IP,10).NE.0) THEN - I04O29 = 0 - ELSE - I04O29 = MANLIN(IP/10) - END IF - - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R02O29() -C ---> formerly FUNCTION ONFUN - - COMMON/IO29LL/BMISS - - CHARACTER*8 SUBSET,RPID - LOGICAL L02O29,L03O29 - INTEGER KKK(0:99),KKKK(49) - REAL(8) BMISS - - SAVE - - DATA GRAV/9.8/,CM2K/1.94/,TZRO/273.15/ - DATA KKK /5*90,16*91,30*92,49*93/ - DATA KKKK/94,2*95,6*96,10*97,30*98/ - - PRS1(Z) = 1013.25 * (((288.15 - (.0065 * Z))/288.15)**5.256) - PRS2(Z) = 226.3 * EXP(1.576106E-4 * (11000. - Z)) - PRS3(PMND,TEMP,Z,ZMND) - $ = PMND * (((TEMP - (.0065 * (Z - ZMND)))/TEMP)**5.256) - ES(T) = 6.1078 * EXP((17.269 * (T-273.16))/((T-273.16)+237.3)) - QFRMTP(T,PPPP) = (0.622 * ES(T))/(PPPP-(0.378 * ES(T))) - HGTF(P) = (1.-(P/1013.25)**(1./5.256))*(288.15/.0065) - - R02O29 = 0 - - RETURN - - ENTRY E01O29(PRS) -C ---> formerly ENTRY ONPRS - IF(PRS.LT.BMISS) E01O29 = NINT(PRS*.1) - IF(PRS.GE.BMISS) E01O29 = BMISS - RETURN - ENTRY E37O29(PMND,TEMP,HGT,ZMND,TQM) -C ---> formerly ENTRY ONPFHT - IF(HGT.GE.BMISS) THEN - E37O29 = BMISS - ELSE - IF(HGT.LE.11000) THEN - P = PRS1(HGT) - ELSE - P = PRS2(HGT) - END IF - IF(MAX(PMND,ZMND).GE.BMISS) THEN - E37O29 = P - RETURN - END IF - IF(TEMP.GE.9999.) TEMP = BMISS - IF(TQM.GE.BMISS) TQM = 2 - IF(TEMP.GE.BMISS.OR.TQM.GE.4) CALL W3FA03(P,D1,TEMP,D2) - Q = QFRMTP(TEMP,P) - TVIRT = TEMP * (1.0 + (0.61 * Q)) - E37O29 = PRS3(PMND,TVIRT,HGT,ZMND) - END IF - RETURN - ENTRY E03O29(PRS) -C ---> formerly ENTRY ONHFP - IF(PRS.LT.BMISS) E03O29 = HGTF(PRS) - IF(PRS.GE.BMISS) E03O29 = BMISS - RETURN - ENTRY E04O29(WDR,WSP) -C ---> formerly ENTRY ONWDR - E04O29 = WDR - RETURN - ENTRY E05O29(WDR,WSP) -C ---> formerly ENTRY ONWSP - IF(WSP.LT.BMISS) THEN - E05O29 = (WSP*CM2K) - E05O29 = E05O29 + 0.0000001 - ELSE - E05O29 = BMISS - END IF - RETURN - ENTRY E06O29(TMP) -C ---> formerly ENTRY ONTMP - ITMP = NINT(TMP*100.) - ITZRO = NINT(TZRO*100.) - IF(TMP.LT.BMISS) E06O29 = NINT((ITMP - ITZRO)*0.1) - IF(TMP.GE.BMISS) E06O29 = BMISS - RETURN - ENTRY E07O29(DPD,TMP) -C ---> formerly ENTRY ONDPD - IF(DPD.LT.BMISS .AND. TMP.LT.BMISS) E07O29 = (TMP-DPD)*10. - IF(DPD.GE.BMISS .OR. TMP.GE.BMISS) E07O29 = BMISS - RETURN - ENTRY E08O29(HGT) -C ---> formerly ENTRY ONHGT - E08O29 = HGT - IF(HGT.LT.BMISS) E08O29 = (HGT/GRAV) - RETURN - ENTRY E09O29(HVZ) -C ---> formerly ENTRY ONHVZ - IF(HVZ.GE.BMISS.OR.HVZ.LT.0.) THEN - E09O29 = BMISS - ELSE IF(NINT(HVZ).LT.6000) THEN - E09O29 = MIN(INT(NINT(HVZ)/100),50) - ELSE IF(NINT(HVZ).LT.30000) THEN - E09O29 = INT(NINT(HVZ)/1000) + 50 - ELSE IF(NINT(HVZ).LE.70000) THEN - E09O29 = INT(NINT(HVZ)/5000) + 74 - ELSE - E09O29 = 89 - END IF - RETURN - ENTRY E10O29(PRW) -C ---> formerly ENTRY ONPRW - E10O29 = BMISS - IF(PRW.LT.BMISS) E10O29 = NINT(MOD(PRW,100.)) - RETURN - ENTRY E11O29(PAW) -C ---> formerly ENTRY ONPAW - E11O29 = BMISS - IF(PAW.LT.BMISS) E11O29 = NINT(MOD(PAW,10.)) - RETURN - ENTRY E12O29(CCN) -C ---> formerly ENTRY ONCCN - IF(NINT(CCN).EQ.0) THEN - E12O29 = 0 - ELSE IF(CCN.LT. 15) THEN - E12O29 = 1 - ELSE IF(CCN.LT. 35) THEN - E12O29 = 2 - ELSE IF(CCN.LT. 45) THEN - E12O29 = 3 - ELSE IF(CCN.LT. 55) THEN - E12O29 = 4 - ELSE IF(CCN.LT. 65) THEN - E12O29 = 5 - ELSE IF(CCN.LT. 85) THEN - E12O29 = 6 - ELSE IF(CCN.LT.100) THEN - E12O29 = 7 - ELSE IF(NINT(CCN).EQ.100) THEN - E12O29 = 8 - ELSE - E12O29 = BMISS - END IF - RETURN - ENTRY E13O29(CLA) -C ---> formerly ENTRY ONCLA - E13O29 = BMISS - IF(CLA.EQ.0) E13O29 = 0 - IF(CLA.EQ.1) E13O29 = 5 - IF(CLA.EQ.2) E13O29 = 25 - IF(CLA.EQ.3) E13O29 = 40 - IF(CLA.EQ.4) E13O29 = 50 - IF(CLA.EQ.5) E13O29 = 60 - IF(CLA.EQ.6) E13O29 = 75 - IF(CLA.EQ.7) E13O29 = 95 - IF(CLA.EQ.8) E13O29 = 100 - RETURN - ENTRY E14O29(CCL,CCM) -C ---> formerly ENTRY ONCHN - E14O29 = CCL - IF(NINT(E14O29).EQ.0) E14O29 = CCM - IF(NINT(E14O29).LT.10) RETURN - IF(NINT(E14O29).EQ.10) THEN - E14O29 = 9. - ELSE IF(NINT(E14O29).EQ.15) THEN - E14O29 = 10. - ELSE - E14O29 = BMISS - END IF - RETURN - ENTRY E15O29(CTLMH) -C ---> formerly ENTRY ONCTL, ONCTM, ONCTH - E15O29 = CTLMH - RETURN - ENTRY E18O29(CHL,CHM,CHH,CTL,CTM,CTH) -C ---> formerly ENTRY ONHCB - IF(NINT(MAX(CTL,CTM,CTH)).EQ.0) THEN - E18O29 = 9 - RETURN - END IF - E18O29 = BMISS - IF(CHH.LT.BMISS) E18O29 = CHH - IF(CHM.LT.BMISS) E18O29 = CHM - IF(CHL.LT.BMISS) E18O29 = CHL - IF(E18O29.GE.BMISS.OR.E18O29.LT.0) RETURN - IF(E18O29.LT. 150) THEN - E18O29 = 0 - ELSE IF(E18O29.LT. 350) THEN - E18O29 = 1 - ELSE IF(E18O29.LT. 650) THEN - E18O29 = 2 - ELSE IF(E18O29.LT. 950) THEN - E18O29 = 3 - ELSE IF(E18O29.LT.1950) THEN - E18O29 = 4 - ELSE IF(E18O29.LT.3250) THEN - E18O29 = 5 - ELSE IF(E18O29.LT.4950) THEN - E18O29 = 6 - ELSE IF(E18O29.LT.6750) THEN - E18O29 = 7 - ELSE IF(E18O29.LT.8250) THEN - E18O29 = 8 - ELSE - E18O29 = 9 - END IF - RETURN - ENTRY E19O29(CPT) -C ---> formerly ENTRY ONCPT - E19O29 = BMISS - IF(NINT(CPT).GT.-1.AND.NINT(CPT).LT.9) E19O29 = CPT - RETURN - ENTRY E20O29(PRC) -C ---> formerly ENTRY ONPRC - E20O29 = PRC - IF(PRC.LT.0.) THEN - E20O29 = 9998 - ELSE IF(PRC.LT.BMISS) THEN - E20O29 = NINT(PRC*3.937) - END IF - RETURN - ENTRY E21O29(SND) -C ---> formerly ENTRY ONSND - E21O29 = SND - IF(SND.LT.0.) THEN - E21O29 = 998 - ELSE IF(SND.LT.BMISS) THEN - E21O29 = NINT(SND*39.37) - END IF - RETURN - ENTRY E22O29(PC6) -C ---> formerly ENTRY ONDOP - E22O29 = BMISS - IF(PC6.LT.BMISS) E22O29 = 1 - RETURN - ENTRY E23O29(PER) -C ---> formerly ENTRY ONPOW, ONSWP - E23O29 = NINT(PER) - RETURN - ENTRY E24O29(HGT) -C ---> formerly ENTRY ONHOW, ONSWH - E24O29 = HGT - IF(HGT.LT.BMISS) E24O29 = NINT(2.*HGT) - RETURN - ENTRY E25O29(SWD) -C ---> formerly ENTRY ONSWD - E25O29 = SWD - IF(SWD.EQ.0) THEN - E25O29 = 0 - ELSE IF(SWD.LT.5) THEN - E25O29 = 36 - ELSE IF(SWD.LT.BMISS) THEN - E25O29 = NINT((SWD+.001)*.1) - END IF - RETURN - ENTRY E28O29(SPG) -C ---> formerly ENTRY ONSPG - E28O29 = SPG - RETURN - ENTRY E29O29(SPD) -C ---> formerly ENTRY ONSPD - E29O29 = SPD - RETURN - ENTRY E30O29(SHC) -C ---> formerly ENTRY ONSHC - E30O29 = BMISS - IF(NINT(SHC).GT.-1.AND.NINT(SHC).LT.9) E30O29 = NINT(SHC) - RETURN - ENTRY E31O29(SAS) -C ---> formerly ENTRY ONSAS - E31O29 = BMISS - IF(NINT(SAS).GT.-1.AND.NINT(SAS).LT.10) E31O29 = NINT(SAS) - RETURN - ENTRY E32O29(WES) -C ---> formerly ENTRY ONWES - E32O29 = WES - RETURN - ENTRY E33O29(SUBSET,RPID) -C ---> formerly ENTRY ONRTP - E33O29 = BMISS - IF(SUBSET(1:5).EQ.'NC000'.AND.L02O29(RPID) ) E33O29 = 511 - IF(SUBSET(1:5).EQ.'NC000'.AND.L03O29(RPID) ) E33O29 = 512 - IF(SUBSET.EQ.'NC001001'.AND.RPID.NE.'SHIP') E33O29 = 522 - IF(SUBSET.EQ.'NC001001'.AND.RPID.EQ.'SHIP') E33O29 = 523 - IF(SUBSET.EQ.'NC001002') E33O29 = 562 - IF(SUBSET.EQ.'NC001003') E33O29 = 561 - IF(SUBSET.EQ.'NC001004') E33O29 = 531 - IF(SUBSET.EQ.'NC001006') E33O29 = 551 - IF(SUBSET.EQ.'NC002001') THEN - -C LAND RADIOSONDE - FIXED -C ----------------------- - - E33O29 = 011 - IF(L03O29(RPID)) E33O29 = 012 - IF(RPID(1:4).EQ.'CLAS') E33O29 = 013 - END IF - IF(SUBSET.EQ.'NC002002') THEN - -C LAND RADIOSONDE - MOBILE -C ------------------------ - - E33O29 = 013 - END IF - IF(SUBSET.EQ.'NC002003') THEN - -C SHIP RADIOSONDE -C --------------- - - E33O29 = 022 - IF(RPID(1:4).EQ.'SHIP') E33O29 = 023 - END IF - IF(SUBSET.EQ.'NC002004') THEN - -C DROPWINSONDE -C ------------- - - E33O29 = 031 - END IF - IF(SUBSET.EQ.'NC002005') THEN - -C PIBAL -C ----- - - E33O29 = 011 - IF(L03O29(RPID)) E33O29 = 012 - END IF - - IF(SUBSET.EQ.'NC004001') E33O29 = 041 - IF(SUBSET.EQ.'NC004002') E33O29 = 041 - IF(SUBSET.EQ.'NC004003') E33O29 = 041 - IF(SUBSET.EQ.'NC004004') E33O29 = 041 - IF(SUBSET.EQ.'NC004005') E33O29 = 031 - IF(SUBSET(1:5).EQ.'NC005') E33O29 = 063 - RETURN - ENTRY E34O29(HGT,Z100) -C ---> formerly ENTRY ONFIX -C - With Jeff Ator's fix on 1/30/97, don't need this anymore -cdak HGT0 = HGT -cdak IF(MOD(NINT(HGT),300).EQ.0.OR.MOD(NINT(HGT),500).EQ.0) -cdak $ HGT = HGT * 1.016 - -C ALL WINDS-BY-HEIGHT HEIGHTS ARE TRUNCATED DOWN TO THE NEXT -C 10 METER LEVEL IF PART DD (ABOVE 100 MB LEVEL) (ON29 CONVENTION) -C ----------------------------------------------------------------- - - IF(HGT.GT.Z100) THEN - IF(MOD(NINT(HGT),10).NE.0) HGT = INT(HGT/10.) * 10 - E34O29 = NINT(HGT) - ELSE -C - With Jeff Ator's fix on 1/30/97, don't need this anymore -cdak IF(HGT.NE.HGT0) THEN -cdak IF(MOD(NINT(HGT0),1500).EQ.0) HGT = HGT - 1.0 -cdak ELSE - IF(MOD(NINT(HGT/1.016),1500).EQ.0) HGT = NINT(HGT - 1.0) -cdak END IF - E34O29 = INT(HGT) - END IF - RETURN - ENTRY E38O29(HVZ) - IF(HVZ.GE.BMISS.OR.HVZ.LT.0.) THEN - E38O29 = BMISS - ELSE IF(NINT(HVZ).LT.1000) THEN - KK = MIN(INT(NINT(HVZ)/10),99) - E38O29 = KKK(KK) - ELSE IF(NINT(HVZ).LT.50000) THEN - KK = MIN(INT(NINT(HVZ)/1000),49) - E38O29 = KKKK(KK) - ELSE - E38O29 = 99 - END IF - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION C02O29() -C ---> formerly FUNCTION ONCHR - CHARACTER*8 C02O29,E35O29,E36O29 - CHARACTER*1 CPRT(0:11),CMR29(0:15) - - SAVE - -C (NOTE: Prior to mid-March 1999, a purge or reject flag on pressure -C was set to 6 (instead of 14 or 12, resp.) to get around the -C 3-bit limit to ON29 pressure q.m. mnemonic "QMPR". The 3-bit -C limit on "QMPR" was changed to 4-bits with a decoder change -C in February 1999. However, the codes that write the q.m.'s -C out (EDTBUFR and QUIPC) were not changed to write out 14 or -C 12 for purge or reject until mid-March 1999. In order to -C allow old runs to work properly, a q.m. of 6 will continue -C to be interpreted as a "P". This would have to change if -C q.m.=6 ever has a defined meaning.) - -C Code Table Value: 0 1 2 3 4 5 6 7 - - DATA CMR29 /'H','A',' ','Q','C','F','P','F', - -C Code Table Value: 8 9 10 11 12 13 14 15 - - . 'F','F','O','B','R','F','P','F'/ - - DATA CPRT /' ',' ',' ',' ','A','B','C','D','I','J','K','L'/ - - C02O29 = ' ' - RETURN - ENTRY E35O29(QMK) -C ---> formerly ENTRY ONQMK - IF(QMK.GE.0 .AND. QMK.LE.15) E35O29 = CMR29(NINT(QMK)) - IF(QMK.LT.0 .OR. QMK.GT.15) E35O29 = ' ' - RETURN - ENTRY E36O29(NPRT) -C ---> formerly ENTRY ONPRT - E36O29 = ' ' - IF(NPRT.LT.12) E36O29 = CPRT(NPRT)//' ' - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION L01O29() -C ---> formerly FUNCTION ONLOG - CHARACTER*8 RPID - LOGICAL L01O29,L02O29,L03O29 - - SAVE - - L01O29 = .TRUE. - - RETURN - - ENTRY L02O29(RPID) -C ---> formerly ENTRY ONBKS - L02O29 = .FALSE. - READ(RPID,'(I5)',ERR=1) IBKS - L02O29 = .TRUE. -1 RETURN - ENTRY L03O29(RPID) -C ---> formerly ENTRY ONCAL - L03O29 = .TRUE. - READ(RPID,'(I5)',ERR=2) IBKS - L03O29 = .FALSE. -2 RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R03O29(LUNIT,OBS) -C ---> formerly FUNCTION ADPUPA - - COMMON/IO29DD/HDR(12),RCATS(50,150,11),IKAT(11),MCAT(11),NCAT(11) - COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), - $ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255), - $ CF8(255) - COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255), - $ QCP(255),QCA(255),Q81(255),Q82(255) - COMMON/IO29CC/SUBSET,IDAT10 - COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI - COMMON/IO29II/PWMIN - COMMON/IO29LL/BMISS - - CHARACTER*80 HDSTR,LVSTR,QMSTR,RCSTR - CHARACTER*8 SUBSET,SID,E35O29,E36O29,RSV,RSV2 - CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,PQML - REAL(8) RID_8,HDR_8(12),VSG_8(255) - REAL(8) RCT_8(5,255),ARR_8(10,255) - REAL(8) RAT_8(255),RMORE_8(4),RGP10_8(255),RPMSL_8,RPSAL_8 - REAL(8) BMISS - INTEGER IHBLCS(0:9) - DIMENSION OBS(*),RCT(5,255),ARR(10,255) - DIMENSION RAT(255),RMORE(4),RGP10(255) - DIMENSION P2(255),P8(255),P16(255) - - EQUIVALENCE (RID_8,SID) - LOGICAL L02O29 - - SAVE - - DATA HDSTR/'NULL CLON CLAT HOUR MINU SELV '/ - DATA LVSTR/'PRLC TMDP TMDB GP07 GP10 WDIR WSPD '/ - DATA QMSTR/'QMPR QMAT QMDD QMGP QMWN '/ - DATA RCSTR/'RCHR RCMI RCTS '/ - - DATA IHBLCS/25,75,150,250,450,800,1250,1750,2250,2500/ - - PRS1(Z) = 1013.25 * (((288.15 - (.0065 * Z))/288.15)**5.256) - PRS2(Z) = 226.3 * EXP(1.576106E-4 * (11000. - Z)) - -C CHECK IF THIS IS A PREPBUFR FILE -C -------------------------------- - - R03O29 = 99 -c#V#V#dak - future -cdak IF(SUBSET.EQ.'ADPUPA') R03O29 = PRPUPA(LUNIT,OBS) -caaaaadak - future - IF(R03O29.NE.99) RETURN - R03O29 = 0 - - CALL S05O29 - -C VERTICAL SIGNIFICANCE DESCRIPTOR TO ASSIGN ON29 CATEGORY -C -------------------------------------------------------- - -C NOTE: MNEMONIC "VSIG" 008001 IS DEFINED AS VERTICAL SOUNDING -C SIGNIFICANCE -- CODE TABLE FOLLOWS: -C 64 Surface -C processed as ON29 category 2 and/or 3 and/or 4 -C 32 Standard (mandatory) level -C processed as ON29 category 1 -C 16 Tropopause level -C processed as ON29 category 5 -C 8 Maximum wind level -C processed as ON29 category 3 or 4 -C 4 Significant level, temperature -C processed as ON29 category 2 -C 2 Significant level, wind -C processed as ON29 category 3 or 4 -C 1 ??????????????????????? -C processed as ON29 category 6 -C -C anything else - the level is not processed - - CALL UFBINT(LUNIT,VSG_8,1,255,NLEV,'VSIG');VSG=VSG_8 - -C PUT THE HEADER INFORMATION INTO ON29 FORMAT -C ------------------------------------------- - - CALL UFBINT(LUNIT,HDR_8,12, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) - IF(HDR(5).GE.BMISS) HDR(5) = 0 - CALL UFBINT(LUNIT,RID_8,1,1,IRET,'RPID') - IF(IRET.NE.1) SID = 'MISSING ' -cppppp-ID - iprint = 0 -c if(sid.eq.'59758 ') iprint = 1 -c if(sid.eq.'61094 ') iprint = 1 -c if(sid.eq.'62414 ') iprint = 1 -c if(sid.eq.'59362 ') iprint = 1 -c if(sid.eq.'57957 ') iprint = 1 -c if(sid.eq.'74794 ') iprint = 1 -c if(sid.eq.'74389 ') iprint = 1 -c if(sid.eq.'96801A ') iprint = 1 - if(iprint.eq.1) - $ print'(" @@@ START DIAGNOSTIC PRINTOUT FOR ID ",A)', sid -cppppp-ID - - IRECCO = 0 - CALL UFBINT(LUNIT,RPMSL_8,1, 1,IRET,'PMSL');RPMSL=RPMSL_8 - IF(SUBSET.EQ.'NC004005') THEN - CALL UFBINT(LUNIT,RGP10_8,1,255,NLEV,'GP10');RGP10=RGP10_8 - CALL UFBINT(LUNIT,RPSAL_8,1,1,IRET,'PSAL');RPSAL=RPSAL_8 - IF(NINT(VSG(1)).EQ.32.AND.RPMSL.GE.BMISS.AND. - $ MAX(RGP10(1),RPSAL).LT.BMISS) THEN -cppppp -cdak print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 1 type ", -cdak $ "Flight-level RECCO")', sid -cppppp - IRECCO = 1 - ELSE IF(MIN(VSG(1),RPMSL,RGP10(1)).GE.BMISS.AND.RPSAL.LT. - $ BMISS) - $ THEN -cppppp -cdak print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 6 type ", -cdak $ "Flight-level RECCO (but reformatted into cat. 2/3)")', sid -cppppp - IRECCO = 6 - ELSE IF(MIN(VSG(1),RGP10(1)).GE.BMISS.AND.MAX(RPMSL,RPSAL) - $ .LT.BMISS) THEN -cppppp -cdak print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 2/3 type ", -cdak $ "Flight-level RECCO with valid PMSL")', sid -cppppp - IRECCO = 23 - ELSE -cppppp - print'(" ~~IW3UNP29/R03O29: ID ",A," is currently an ", - $ "unknown type of Flight-level RECCO - VSIG =",G0, - $ "; PMSL =",G0,"; GP10 =",G0," -- SKIP IT for now")', - $ sid,VSG(1),RPMSL,RGP10(1) - R03O29 = -9999 - KSKUPA =KSKUPA + 1 - RETURN -cppppp - END IF - END IF - - XOB = HDR(2) - YOB = HDR(3) - RHR = BMISS - IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4))+NINT(HDR(5))/60. - RCH = BMISS - RSV = '999 ' - ELV = HDR(6) - IF(IRECCO.GT.0) THEN - RPSAL = RPSAL + SIGN(0.0000001,RPSAL) - ELV = RPSAL - END IF - - CALL UFBINT(LUNIT,RAT_8, 1,255,NLEV,'RATP');RAT=RAT_8 - ITP = MIN(99,NINT(RAT(1))) - RTP = E33O29(SUBSET,SID) - IF(ELV.GE.BMISS) THEN -cppppp - print'(" IW3UNP29/R03O29: ID ",A," has a missing elev, so ", - $ "elevation set to ZERO")', sid -cppppp - IF((RTP.GT.20.AND.RTP.LT.24).OR.SUBSET.EQ.'NC002004') ELV = 0 - END IF -cdak if(sid(5:5).eq.' ') print'(A)', sid - IF(L02O29(SID).AND.SID(5:5).EQ.' ') SID = '0'//SID - RSV2 = ' ' - CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP) - -C PUT THE LEVEL DATA INTO ON29 UNITS -C ---------------------------------- - - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8 - - PWMIN = 999999. - JLV = 2 - IF(IRECCO.EQ.6) JLV = 1 - IF(IRECCO.GT.0.AND.NLEV.EQ.1) THEN - VSG(JLV) = 4 - VSG(JLV+1) = 2 - QOB(JLV) = E07O29(ARR(2,1),ARR(3,1)) - TOB(JLV) = E06O29(ARR(3,1)) - ARR(2,1) = BMISS - ARR(3,1) = BMISS - DOB(JLV+1) = E04O29(ARR(6,1),ARR(7,1)) - SOB(JLV+1) = E05O29(ARR(6,1),ARR(7,1)) - IF(NINT(DOB(JLV+1)).EQ.0.AND.NINT(SOB(JLV+1)).GT.0) - $ DOB(JLV+1) = 360. - IF(NINT(DOB(JLV+1)).EQ.360.AND.NINT(SOB(JLV+1)).EQ.0) - $ DOB(JLV+1) = 0. - ARR(6,1) = BMISS - ARR(7,1) = BMISS - IF(IRECCO.EQ.23) THEN - VSG(1) = 64 - ARR(1,1) = RPMSL - END IF - END IF - - IF(IRECCO.EQ.6) GO TO 4523 - - DO L=1,NLEV - POB(L) = E01O29(ARR(1,L)) - IF(NINT(ARR(1,L)).LE.0) THEN - POB(L) = BMISS -cppppp - print'(" ~~@@IW3UNP29/R03O29: ID ",A," has a ZERO or ", - $ "negative reported pressure that is reset to missing")', - $ sid -cppppp - END IF - QOB(L) = E07O29(ARR(2,L),ARR(3,L)) - TOB(L) = E06O29(ARR(3,L)) - ZOB(L) = MIN(E08O29(ARR(4,L)),E08O29(ARR(5,L))) -cppppp - if(iprint.eq.1) then - if(irecco.gt.0) print'(" At lvl=",I0,"; orig. ZOB = ",G0)', - $ L,zob(L) - end if -cppppp - IF(IRECCO.EQ.1) THEN - IF(MOD(NINT(ZOB(L)),10).NE.0) ZOB(L) = INT(ZOB(L)/10.) * 10 - ZOB(L) = NINT(ZOB(L)) - ELSEIF(IRECCO.EQ.23) THEN - ZOB(L) = 0 - END IF - DOB(L) = E04O29(ARR(6,L),ARR(7,L)) - SOB(L) = E05O29(ARR(6,L),ARR(7,L)) - IF(NINT(DOB(L)).EQ.0.AND.NINT(SOB(L)).GT.0) DOB(L) = 360. - IF(NINT(DOB(L)).EQ.360.AND.NINT(SOB(L)).EQ.0) DOB(L) = 0. -cppppp - if(iprint.eq.1) then - print'(" At lvl=",I0,"; VSG=",G0,"; POB = ",G0,"; QOB = ",G0, - $ "; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,"; final SOB ", - $ "(kts) = ",G0,"; origl SOB (mps) = ",G0)', - $ L,vsg(L),pob(L),qob(L),tob(L),zob(L),dob(L),sob(L),arr(7,L) - end if -cppppp - IF(IRECCO.EQ.0.AND.MAX(POB(L),DOB(L),SOB(L)).LT.BMISS) - $ PWMIN=MIN(PWMIN,POB(L)) - ENDDO - - 4523 CONTINUE - - MLEV = NLEV - - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8 - - IF(IRECCO.GT.0.AND.MLEV.EQ.1) THEN - POB1 = BMISS - IF(POB(1).LT.BMISS) POB1 = POB(1) * 0.1 - TOB1 = BMISS - IF(TOB(JLV).LT.BMISS) TOB1 = (TOB(JLV) * 0.1) + 273.15 - RPS1 = RPSAL - ZOB1 = ZOB(1) - TQM1 = ARR(3,1) - POB(JLV)=NINT(E37O29(POB1,TOB1,RPS1,ZOB1,TQM1)) * 10 - POB(JLV+1) = POB(JLV) -cppppp - if(iprint.eq.1) then - do L=JLV,JLV+1 - print'(" At lvl=",I0,"; VSG=",G0,"; POB = ",G0,"; QOB = ", - $ G0,"; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,"; SOB = ", - $ G0)', L,vsg(L),pob(L),qob(L),tob(L),zob(L),dob(L),sob(L) - enddo - end if -cppppp - END IF - - IF(IRECCO.GT.0.AND.NLEV.EQ.1) THEN - PQM(JLV) = 'E' - PQM(JLV+1) = 'E' - TQM(JLV) = E35O29(ARR(2,1)) - ARR(2,1) = BMISS - QQM(JLV) = E35O29(ARR(3,1)) - ARR(3,1) = BMISS - ARR(4,1) = 3 - WQM(JLV+1) = E35O29(ARR(5,1)) - ARR(5,1) = BMISS - END IF - - IF(IRECCO.EQ.6) GO TO 4524 - - DO L=1,NLEV - PQM(L) = E35O29(ARR(1,L)) - TQM(L) = E35O29(ARR(2,L)) - QQM(L) = E35O29(ARR(3,L)) - ZQM(L) = E35O29(ARR(4,L)) - WQM(L) = E35O29(ARR(5,L)) - ENDDO - - 4524 CONTINUE - - IF(IRECCO.GT.0.AND.NLEV.EQ.1) NLEV = JLV + 1 - -C SURFACE DATA MUST GO FIRST -C -------------------------- - - CALL S02O29(2,0,*9999) - CALL S02O29(3,0,*9999) - CALL S02O29(4,0,*9999) - - INDX2 = 0 - INDX8 = 0 - INDX16 = 0 - P2 = BMISS - P8 = BMISS - P16 = BMISS - - DO L=1,NLEV - IF(NINT(VSG(L)).EQ.64) THEN -cppppp - if(iprint.eq.1) then - print'(" Lvl=",L," is a surface level")' - end if - if(iprint.eq.1.and.POB(L).LT.BMISS.AND.(TOB(L).LT.BMISS.OR.IRECCO - $ .EQ.23)) then - print'(" --> valid cat. 2 sfc. lvl ")' - end if -cppppp - IF(POB(L).LT.BMISS.AND.(TOB(L).LT.BMISS.OR.IRECCO.EQ.23)) - $ CALL SE01O29(2,L) -cppppp - if(iprint.eq.1.and.POB(L).LT.BMISS.AND.(DOB(L).LT.BMISS.OR.IRECCO - $ .EQ.23)) then - print'(" --> valid cat. 3 sfc. lvl ")' - end if -cppppp - IF(POB(L).LT.BMISS.AND.(DOB(L).LT.BMISS.OR.IRECCO.EQ.23)) - $ CALL SE01O29(3,L) - IF(ZOB(L).LT.BMISS.AND.DOB(L).LT.BMISS) THEN -cppppp - if(iprint.eq.1) print'(" --> valid cat. 4 sfc. lvl ")' -cppppp - -C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M. -C ----------------------------------------------------------------- - - ZQM(L) = ' ' - CALL SE01O29(4,L) - END IF - VSG(L) = 0 - ELSE IF(NINT(VSG(L)).EQ.2) THEN - P2(L) = POB(L) - INDX2 = L - IF(INDX8.GT.0) THEN - DO II = 1,INDX8 - IF(POB(L).EQ.P8(II).AND.POB(L).LT.BMISS) THEN -cppppp - if(iprint.eq.1) then - print'(" ## This cat. 3 level, on lvl ",I0, - $ " will have already been processed as a cat. 3 ", - $ "MAX wind lvl (on lvl ",I0,") - skip this Cat. ", - $ "3 lvl")', L,II - end if -cppppp - IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN - SOB(II) = SOB(L) - DOB(II) = DOB(L) -cppppp - if(iprint.eq.1) then - print'(" ...... also on lvl ",I0," - transfer", - $ " wind data to dupl. MAX wind lvl because its ", - $ "missing there")', L - end if -cppppp - END IF - VSG(L) = 0 - GO TO 7732 - END IF - ENDDO - END IF - ELSE IF(NINT(VSG(L)).EQ.8) THEN - P8(L) = POB(L) - INDX8 = L - IF(INDX2.GT.0) THEN - DO II = 1,INDX2 - IF(POB(L).EQ.P2(II).AND.POB(L).LT.BMISS) THEN -cppppp - if(iprint.eq.1) then - print'(" ## This MAX wind level, on lvl ",I0, - $ " will have already been processed as a cat. 3 ", - $ "lvl (on lvl ",I0,") - skip this MAX wind lvl ", - $ "but set"/6X,"cat. 3 lvl PQM to ""W""")', L,II - end if -cppppp - PQM(II) = 'W' - IF(POB(L).EQ.PWMIN) PQM(II) = 'X' - IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN - SOB(II) = SOB(L) - DOB(II) = DOB(L) -cppppp - if(iprint.eq.1) then - print'(" ...... also on lvl ",I0," - transfer", - $ " wind data to dupl. cat. 3 lvl because its ", - $ "missing there")', L - end if -cppppp - END IF - VSG(L) = 0 - GO TO 7732 - END IF - ENDDO - END IF - IF(INDX8-1.GT.0) THEN - DO II = 1,INDX8-1 - IF(POB(L).EQ.P8(II).AND.POB(L).LT.BMISS) THEN -cppppp - if(iprint.eq.1) then - print'(" ## This cat. 3 MAX wind lvl, on lvl ",I0, - $ " will have already been processed as a cat. 3 ", - $ "MAX wind lvl (on lvl ",I0,") - skip this Cat. ", - $ "3 MAX wind lvl")', L,II - end if -cppppp - IF(MAX(SOB(II),DOB(II)).GE.BMISS) THEN - SOB(II) = SOB(L) - DOB(II) = DOB(L) -cppppp - if(iprint.eq.1) then - print'(" ...... also on lvl ",I0," - transfer", - $ " wind data to dupl. MAX wind lvl because its ", - $ "missing there")', L - end if -cppppp - END IF - VSG(L) = 0 - GO TO 7732 - END IF - ENDDO - END IF - ELSE IF(NINT(VSG(L)).EQ.16) THEN - INDX16 = INDX16 + 1 - P16(INDX16) = POB(L) - END IF - 7732 CONTINUE - ENDDO - -C TAKE CARE OF 925 MB NEXT -C ------------------------ - - DO L=1,NLEV - IF(NINT(VSG(L)).EQ.32 .AND. NINT(POB(L)).EQ.9250) THEN - CF8(L) = 925 - OB8(L) = ZOB(L) - Q81(L) = ' ' - Q82(L) = ' ' - IF(TOB(L).LT.BMISS) CALL S02O29(2,L,*9999) - IF(DOB(L).LT.BMISS) CALL S02O29(3,L,*9999) - IF(OB8(L).LT.BMISS) CALL S02O29(8,L,*9999) - VSG(L) = 0 - END IF - ENDDO - -C REST OF THE DATA -C ---------------- - - Z100 = 16000 - DO L=1,NLEV - IF(NINT(VSG(L)).EQ.32) THEN - IF(MIN(DOB(L),ZOB(L),TOB(L)).GE.BMISS) THEN -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG=32 & DOB,ZOB,TOB all ", - $ "missing --> this level not processed")', L - end if - VSG(L) = 0 - ELSE IF(MIN(ZOB(L),TOB(L)).LT.BMISS) THEN -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG=32 & one or both of ", - $ "ZOB,TOB non-missing --> valid cat. 1 lvl")', L - end if -cppppp - CALL S02O29(1,L,*9999) - IF(NINT(POB(L)).EQ.1000.AND.ZOB(L).LT.BMISS) Z100 = ZOB(L) - VSG(L) = 0 - END IF - END IF - ENDDO - DO L=1,NLEV - IF(NINT(VSG(L)).EQ.32) THEN - IF(DOB(L).LT.BMISS.AND.MIN(ZOB(L),TOB(L)).GE.BMISS) THEN - LL = I04O29(POB(L)*.1) - IF(LL.EQ.999999) THEN -cppppp - print'(" ~~IW3UNP29/R03O29: ID ",A," has VSG=32 for ", - $ "lvl ",I0," but pressure not mand.!! --> this level ", - $ "not processed")', sid,L -cppppp - ELSE IF(MIN(RCATS(1,LL,1),RCATS(2,LL,1)).LT.99999.) THEN - IF(RCATS(4,LL,1).GE.99998.) THEN -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG=32 & ZOB,TOB ", - $ "both missing while DOB non-missing BUT one or ", - $ "both of Z, T non-missing while wind missing ", - $ "in"/7X,"earlier cat. 1 processing of this ",G0, - $ "mb level --> valid cat. 1 lvl")', L,POB(L)*.1 - end if -cppppp - CALL S02O29(1,L,*9999) - ELSE -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG=32 & ZOB,TOB ", - $ "both missing while DOB non-missing BUT one or ", - $ "both of Z, T non-missing while wind non-missing", - $ " in"/6X,"earlier cat. 1 processing of this ",G0, - $ "mb level --> valid cat. 3 lvl")', L,POB(L)*.1 - end if -cppppp - CALL S02O29(3,L,*9999) - END IF - ELSE -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG=32 & ZOB,TOB both ", - $ "missing while DOB non-missing AND both Z, T ", - $ "missing on"/7X,"this ",G0,"mb level in cat. 1 --> ", - $ "valid cat. 3 lvl")', L,POB(L)*.1 - end if -cppppp - CALL S02O29(3,L,*9999) - END IF - ELSE -cppppp - print'(" ~~IW3UNP29/R03O29: ID ",A," has VSG=32 for lvl ", - $ I0," & should never come here!! - by default output", - $ " as cat. 1 lvl")', sid,L -cppppp - CALL S02O29(1,L,*9999) - END IF - VSG(L) = 0 - END IF - ENDDO - - DO L=1,NLEV - IF(NINT(VSG(L)).EQ. 4) THEN -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG= 4 --> valid cat. 2 ", - $ "lvl")', L - end if -cppppp - IF(INDX16.GT.0) THEN - DO II = 1,INDX16 - IF(POB(L).EQ.P16(II).AND.POB(L).LT.BMISS) THEN -cppppp - if(iprint.eq.1) then - print'(" ## This cat. 2 level, on lvl ",I0," is", - $ " also the tropopause level, as its pressure ", - $ "matches that of trop. lvl no. ",I0," - ", - $ "set this cat. 2"/5X,"lvl PQM to ""T""")', L,II - end if -cppppp - PQM(L) = 'T' - GO TO 7738 - END IF - ENDDO - END IF - 7738 CONTINUE - CALL S02O29(2,L,*9999) - VSG(L) = 0 - ELSEIF(NINT(VSG(L)).EQ.16) THEN -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG=16 --> valid cat. 3/5 ", - $ "lvl")', L - end if -cppppp - PQML = PQM(L) - IF(MIN(SOB(L),DOB(L)).LT.BMISS) CALL S02O29(3,L,*9999) - PQM(L) = PQML - CALL S02O29(5,L,*9999) - VSG(L) = 0 - ELSEIF(NINT(VSG(L)).EQ. 1) THEN -cppppp - print'(" ~~IW3UNP29/R03O29: HERE IS A VSG =1, SET TO CAT.6, ", - $ "AT ID ",A,"; SHOULD NEVER HAPPEN!!")', SID -cppppp - CALL S02O29(6,L,*9999) - VSG(L) = 0 - ELSEIF(NINT(VSG(L)).EQ. 2 .AND. POB(L).LT.BMISS) THEN - IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG= 2 & POB .ne. missing ", - $ "--> valid cat. 3 lvl (expect that ZOB is missing)")', L - end if -cppppp - CALL S02O29(3,L,*9999) - ELSE -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG= 2 & POB .ne. missing ", - $ "--> Cat. 3 level not processed - wind is missing")', L - end if -cppppp - END IF - VSG(L) = 0 - ELSEIF(NINT(VSG(L)).EQ. 2 .AND. ZOB(L).LT.BMISS) THEN - IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN - -C CERTAIN U.S. WINDS-BY-HEIGHT ARE CORRECTED TO ON29 CONVENTION -C ------------------------------------------------------------- - - IF(SID(1:2).EQ.'70'.OR.SID(1:2).EQ.'71'.OR.SID(1:2).EQ.'72' - $ .OR.SID(1:2).EQ.'74') ZOB(L) = E34O29(ZOB(L),Z100) -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG= 2 & ZOB .ne. missing ", - $ "--> valid cat. 4 lvl (POB must always be missing)")', L - if(sid(1:2).eq.'70'.or.sid(1:2).eq.'71'.or.sid(1:2).eq.'72' - $ .or.sid(1:2).eq.'74') print'(" .... ZOB at this ", - $ "U.S. site adjusted to ",G0)', zob(L) - end if -cppppp - -C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M. -C ----------------------------------------------------------------- - - ZQM(L) = ' ' - - CALL S02O29(4,L,*9999) - ELSE -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG= 2 & ZOB .ne. missing ", - $ "--> Cat. 4 level not processed - wind is missing")', L - end if -cppppp - END IF - VSG(L) = 0 - ELSEIF(NINT(VSG(L)).EQ. 8 .AND. POB(L).LT.BMISS) THEN -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG= 8 & POB .ne. missing ", - $ "--> valid cat. 3 lvl (expect that ZOB is missing)")', L - end if -cppppp - CALL S02O29(3,L,*9999) - VSG(L) = 0 - ELSEIF(NINT(VSG(L)).EQ. 8 .AND. ZOB(L).LT.BMISS) THEN - IF(MAX(SOB(L),DOB(L)).LT.BMISS) THEN - -C CERTAIN U.S. WINDS-BY-HEIGHT ARE CORRECTED TO ON29 CONVENTION -C ------------------------------------------------------------- - - IF(SID(1:2).EQ.'70'.OR.SID(1:2).EQ.'71'.OR.SID(1:2).EQ.'72' - $ .OR.SID(1:2).EQ.'74') ZOB(L) = E34O29(ZOB(L),Z100) -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG= 8 & ZOB .ne. missing ", - $ "--> valid cat. 4 lvl (POB must always be missing)")', L - if(sid(1:2).eq.'70'.or.sid(1:2).eq.'71'.or.sid(1:2).eq.'72' - $ .or.sid(1:2).eq.'74') print'(" .... ZOB at this ", - $ "U.S. site adjusted to ",G0)', zob(L) - end if -cppppp - -C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M. -C ----------------------------------------------------------------- - - ZQM(L) = ' ' - - CALL S02O29(4,L,*9999) - ELSE -cppppp - if(iprint.eq.1) then - print'(" ==> For lvl ",I0,"; VSG= 8 & ZOB .ne. missing ", - $ "--> Cat. 4 level not processed - wind is missing")', L - end if -cppppp - END IF - VSG(L) = 0 - END IF - ENDDO - -C CHECK FOR LEVELS WHICH GOT LEFT OUT -C ----------------------------------- - - DO L=1,NLEV - IF(NINT(VSG(L)).GT.0) THEN - PRINT 887, L,SID,NINT(VSG(L)) - 887 FORMAT(' ##IW3UNP29/R03O29 - ~~ON LVL',I4,' OF ID ',A8,', A ', - $ 'VERTICAL SIGNIFICANCE OF',I3,' WAS NOT SUPPORTED - LEAVE ', - $ 'THIS LEVEL OUT OF THE PROCESSING') - print'(" ..... at lvl=",I0,"; POB = ",G0,"; QOB = ",G0, - $ "; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,";"/19X,"SOB = ", - $ G0)', pob(L),qob(L),tob(L),zob(L),dob(L),sob(L) - END IF - ENDDO - -C CLOUD DATA GOES INTO CATEGORY 07 -C -------------------------------- - - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,'HOCB CLAM QMCA HBLCS') - ARR=ARR_8 - DO L=1,NLEV - IF(ARR(1,L).LT.BMISS/2.) THEN - ! Prior to 3/2002 HBLCS was not available, this will - ! always be tested first because it is more precise - ! in theory but will now be missing after 3/2002 - IF(ELV+ARR(1,L).GE.BMISS/2.) THEN - CLP(L) = BMISS - ELSE IF(ELV+ARR(1,L).LE.11000) THEN - CLP(L) = (PRS1(ELV+ARR(1,L))*10.) + 0.001 - ELSE - CLP(L) = (PRS2(ELV+ARR(1,L))*10.) + 0.001 - END IF - ELSE - ! Effective 3/2002 only this will be available - IF(NINT(ARR(4,L)).GE.10) THEN - CLP(L) = BMISS - ELSE - IF(ELV+IHBLCS(NINT(ARR(4,L))).GE.BMISS/2.) THEN - CLP(L) = BMISS - ELSE IF(ELV+IHBLCS(NINT(ARR(4,L))).LE.11000) THEN - CLP(L) = (PRS1(ELV+IHBLCS(NINT(ARR(4,L))))*10.) +0.001 - ELSE - CLP(L) = (PRS2(ELV+IHBLCS(NINT(ARR(4,L))))*10.) +0.001 - END IF - END IF - END IF - CLA(L) = E13O29(ARR(2,L)) - QCP(L) = ' ' - QCA(L) = E35O29(ARR(3,L)) - IF(CLP(L).LT.BMISS .OR. CLA(L).LT.BMISS) CALL S02O29(7,L,*9999) - ENDDO - -C ----------------------------------------------------- -C MISC DATA GOES INTO CATEGORY 08 -C ----------------------------------------------------- -C CODE FIGURE 104 - RELEASE TIME IN .01*HR -C CODE FIGURE 105 - RECEIPT TIME IN .01*HR -C CODE FIGURE 106 - RADIOSONDE INSTR. TYPE, -C SOLAR/IR CORRECTION INDICATOR, -C TRACKING TECH/STATUS OF SYSTEM USED -C CODE FIGURE 925 - HEIGHT OF 925 LEVEL -C ----------------------------------------------------- - - CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 - -C NOTE: MNEMONIC "RCTS" 008202 IS A LOCAL DESCRIPTOR DEFINED AS -C RECEIPT TIME SIGNIFICANCE -- CODE TABLE FOLLOWS: -C 0 General decoder receipt time -C 1 NCEP receipt time -C 2 OSO receipt time -C 3 ARINC ground station receipt time -C 4 Radiosonde TEMP AA part receipt time -C 5 Radiosonde TEMP BB part receipt time -C 6 Radiosonde TEMP CC part receipt time -C 7 Radiosonde TEMP DD part receipt time -C 8 Radiosonde PILOT AA part receipt time -C 9 Radiosonde PILOT BB part receipt time -C 10 Radiosonde PILOT CC part receipt time -C 11 Radiosonde PILOT DD part receipt time -C 12-62 Reserved for future use -C 63 Missing - - DO L=1,NRCT - CF8(L) = 105 - OB8(L) = NINT((NINT(RCT(1,L))+NINT(RCT(2,L))/60.) * 100.) - IF(IRECCO.GT.0.AND.NINT(RCT(3,L)).EQ.0) RCT(3,L) = 9 - Q81(L) = E36O29(NINT(RCT(3,L))) - Q82(L) = ' ' - CALL S02O29(8,L,*9999) - ENDDO - - CALL UFBINT(LUNIT,RMORE_8,4,1,NRMORE,'SIRC TTSS UALNHR UALNMN') - RMORE=RMORE_8 - IF(MAX(RMORE(3),RMORE(4)).LT.BMISS) THEN - CF8(1) = 104 - OB8(1) = NINT((RMORE(3)+RMORE(4)/60.) * 100.) - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - IF(NINT(RAT(1)).LT.100) THEN - CF8(1) = 106 - ISIR = 9 - IF(NINT(RMORE(1)).LT.9) ISIR = NINT(RMORE(1)) - ITEC = 99 - IF(NINT(RMORE(2)).LT.99) ITEC = NINT(RMORE(2)) - OB8(1) = (ISIR * 10000) + (NINT(RAT(1)) * 100) + ITEC - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - -C PUT THE UNPACKED ON29 REPORT INTO OBS -C ------------------------------------- - - CALL S03O29(OBS,SUBSET,*9999,*9998) - - RETURN - 9999 CONTINUE - R03O29 = 999 - RETURN - 9998 CONTINUE - print'(" IW3UNP29/R03O29: RPT with ID= ",A," TOSSED - ZERO ", - $ "CAT.1-6,51,52 LVLS")', SID - R03O29 = -9999 - KSKUPA =KSKUPA + 1 - RETURN - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R04O29(LUNIT,OBS) -C ---> formerly FUNCTION SURFCE - - COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), - $ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255), - $ CF8(255) - COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255), - $ QCP(255),QCA(255),Q81(255),Q82(255) - COMMON/IO29GG/PSL,STP,SDR,SSP,STM,DPD,TMX,TMI,HVZ,PRW,PW1,CCN,CHN, - $ CTL,CTM,CTH,HCB,CPT,APT,PC6,SND,P24,DOP,POW,HOW,SWD, - $ SWP,SWH,SST,SPG,SPD,SHC,SAS,WES - COMMON/IO29HH/PSQ,SPQ,SWQ,STQ,DDQ - COMMON/IO29CC/SUBSET,IDAT10 - COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI - COMMON/IO29LL/BMISS - - CHARACTER*80 HDSTR,RCSTR - CHARACTER*8 SUBSET,SID,E35O29,RSV,RSV2 - CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,PSQ,SPQ,SWQ,STQ, - $ DDQ - REAL(8) RID_8,UFBINT_8,BMISS - REAL(8) HDR_8(20),RCT_8(5,255),RRSV_8(3),CLDS_8(4,255), - $ TMXMNM_8(4,255) - INTEGER ITIWM(0:15),IHBLCS(0:9) - DIMENSION OBS(*),HDR(20),RCT(5,255),RRSV(3),CLDS(4,255),JTH(0:9), - $ JTL(0:9),LTL(0:9),TMXMNM(4,255) - EQUIVALENCE (RID_8,SID) - - SAVE - - DATA HDSTR/'RPID CLON CLAT HOUR MINU SELV AUTO '/ - DATA RCSTR/'RCHR RCMI RCTS '/ - - DATA JTH/0,1,2,3,4,5,6,8,7,9/,JTL/0,1,5,8,7,2,3,4,6,9/ - DATA LTL/0,1,5,6,7,2,8,4,3,9/ - DATA ITIWM/0,3*7,3,3*7,1,3*7,4,3*7/ - DATA IHBLCS/25,75,150,250,450,800,1250,1750,2250,2500/ - -C CHECK IF THIS IS A PREPBUFR FILE -C -------------------------------- - - R04O29 = 99 -c#V#V#dak - future -cdak IF(SUBSET.EQ.'ADPSFC') R04O29 = PRPSFC(LUNIT,OBS) -cdak IF(SUBSET.EQ.'SFCSHP') R04O29 = PRPSFC(LUNIT,OBS) -cdak IF(SUBSET.EQ.'SFCBOG') R04O29 = PRPSFC(LUNIT,OBS) -caaaaadak - future - IF(R04O29.NE.99) RETURN - R04O29 = 0 - - CALL S05O29 - -C PUT THE HEADER INFORMATION INTO ON29 FORMAT -C ------------------------------------------- - - CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) - CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 - IF(HDR(5).GE.BMISS) HDR(5) = 0 - RCTIM = NINT(RCT(1,1))+NINT(RCT(2,1))/60. - RID_8 = HDR_8(1) - XOB = HDR(2) - YOB = HDR(3) - RHR = BMISS - IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4))+NINT(HDR(5))/60. - RCH = RCTIM - ELV = HDR(6) - -C I1 DEFINES SYNOPTIC FORMAT FLAG (SUBSET NC000001, NC000009) -C I1 DEFINES AUTOMATED STATION TYPE (SUBSET NC000003-NC000008,NC000010) -C I2 DEFINES CONVERTED HOURLY FLAG (SUBSET NC000xxx) -C I2 DEFINES SHIP LOCATION FLAG (SUBSET NC001xxx) (WHERE xxx != 006) - - I1 = 9 - I2 = 9 - IF(SUBSET(1:5).EQ.'NC000') THEN - IF(SUBSET(6:8).EQ.'001'.OR.SUBSET(6:8).EQ.'009') THEN - I1 = 1 - IF(SUBSET(6:8).EQ.'009') I2 = 1 - ELSE IF(SUBSET(6:8).NE.'002') THEN - IF(HDR(7).LT.15) THEN - IF(HDR(7).GT.0.AND.HDR(7).LT.5) THEN - I1 = 2 - ELSE IF(HDR(7).EQ.8) THEN - I1 = 3 - ELSE - I1 = 4 - END IF - END IF - END IF - END IF - ITP = (10 * I1) + I2 - RTP = E33O29(SUBSET,SID) - -C THE 25'TH (RESERVE) CHARACTER IS INDICATOR FOR PRECIP. (INCL./EXCL.) -C THE 26'TH (RESERVE) CHARACTER IS INDICATOR FOR W SPEED (SOURCE/UNITS) -C '0' - Wind speed estimated in m/s (uncertified instrument) -C '1' - Wind speed obtained from anemometer in m/s (certified -C instrument) -C '3' - Wind speed estimated in knots (uncertified instrument) -C '4' - Wind speed obtained from anemometer in knots (certified -C instrument) -C '7' - Missing -C THE 27'TH (RESERVE) CHARACTER IS INDICATOR FOR STN OPER./PAST WX DATA - - CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'INPC');RRSV(1)=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'TIWM');TIWM=UFBINT_8 - IF(TIWM.LT.BMISS) THEN ! Effective 3/2002 - RRSV(2) = 7 - IF(NINT(TIWM).LE.15) RRSV(2) = ITIWM(NINT(TIWM)) - ELSE ! Prior to 3/2002 - CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'SUWS');RRSV(2)=UFBINT_8 - END IF - CALL UFBINT(LUNIT,UFBINT_8,1,1,NRSV,'ITSO');RRSV(3)=UFBINT_8 - RSV = '999 ' - DO I=1,3 - IF(RRSV(I).LT.BMISS) WRITE(RSV(I:I),'(I1)') NINT(RRSV(I)) - ENDDO - -C READ THE CATEGORY 51 SURFACE DATA FROM BUFR -C ------------------------------------------- - - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PMSL');PSL=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PRES');STP=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WDIR');SDR=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WSPD');SSP=UFBINT_8 - WSPD1 = SSP - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMDB');STM=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMDP');DPD=UFBINT_8 - IF(SUBSET.NE.'NC000007') THEN - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'MXTM');TMX=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'MITM');TMI=UFBINT_8 - ELSE - TMX = BMISS - TMI = BMISS - END IF - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMPR');QSL=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMPR');QSP=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMWN');QMW=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMAT');QMT=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'QMDD');QMD=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOVI');HVZ=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PRWE');PRW=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PSW1');PW1=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PSW2');PW2=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOCC');CCN=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CHPT');CPT=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'3HPC');APT=UFBINT_8 - IF(MAX(APT,CPT).GE.BMISS) THEN - APT = BMISS - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'24PC');APT24=UFBINT_8 - IF(APT24.LT.BMISS) THEN - APT = APT24 - CPT = BMISS - END IF - END IF - - -C READ THE CATEGORY 52 SURFACE DATA FROM BUFR -C ------------------------------------------- - - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TP06');PC6=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOSD');SND=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TP24');P24=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOPC');PTO=UFBINT_8 - IF(PTO.LT.BMISS) THEN - IF(PC6.GE.BMISS.AND.NINT(DOP).EQ. 6) PC6 = PTO -cppppp - IF(PC6.GE.BMISS.AND.NINT(DOP).EQ. 6) - $ print'(" ~~IW3UNP29/R04O29: PTO used for PC6 since latter ", - $ "missing & 6-hr DOP")' -cppppp - IF(P24.GE.BMISS.AND.NINT(DOP).EQ.24) P24 = PTO -cppppp - IF(P24.GE.BMISS.AND.NINT(DOP).EQ.24) - $ print'(" ~~IW3UNP29/R04O29: PTO used for P24 since latter ", - $ "missing & 24-hr DOP")' -cppppp - END IF - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POWW');POW=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOWW');HOW=UFBINT_8 - IF(SUBSET(1:5).EQ.'NC001') THEN - IF(SUBSET(6:8).NE.'006') THEN - IF(MIN(POW,HOW).GE.BMISS) THEN - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POWV');POW=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOWV');HOW=UFBINT_8 - END IF - ELSE -C PAOBS always have a missing elev, but we know they are at sea level - ELV = 0 - END IF - END IF - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'DOSW');SWD=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POSW');SWP=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HOSW');SWH=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SST1');SST=UFBINT_8 - IF(SST.GE.BMISS) THEN - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'STMP');SST=UFBINT_8 - ENDIF - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'????');SPG=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'????');SPD=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TDMP');SHC=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'ASMP');SAS=UFBINT_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'????');WES=UFBINT_8 - I52FLG = 0 - IF(MIN(SND,P24,POW,HOW,SWD,SWP,SWH,SST,SPG,SPD,SHC,SAS,WES) - $ .GE.BMISS.AND.(PC6.EQ.0..OR.PC6.GE.BMISS)) I52FLG= 1 - -C SOME CLOUD DATA IS NEEDED FOR LOW, MIDDLE, AND HIGH CLOUDS IN CAT. 51 -C --------------------------------------------------------------------- - - CALL UFBINT(LUNIT,CLDS_8,4,255,NCLD,'VSSO CLAM CLTP HOCB') - CLDS=CLDS_8 - CTH = -9999. - CTM = -9999. - CTL = -9999. - CHH = BMISS - CHM = BMISS - CHL = BMISS - IF(NCLD.EQ.0) THEN - CCM = BMISS - CCL = BMISS - ELSE - CCM = 0. - CCL = 0. - DO L=1,NCLD - VSS = CLDS(1,L) - CAM = CLDS(2,L) - CTP = CLDS(3,L) - CHT = BMISS - IF(CLDS(4,L).LT.BMISS) THEN - ! Prior to 3/2002 HBLCS was not available, this will - ! always be tested first because it is more precise - ! and may still be available for some types after - ! 3/2002 - CHT = CLDS(4,L) - ELSE - ! Effective 3/2002 this will be available and can be - ! used for types where HOCB is not available - less - ! precise and only available on 1 level - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'HBLCS') - HBLCS=UFBINT_8 - IF(NINT(HBLCS).LT.10) CHT = IHBLCS(NINT(HBLCS)) - END IF - IF(CHT.LT.BMISS) CHT = CHT * 3.2808 - IF(NINT(VSS).EQ.0) THEN - IF(NINT(CTP).GT.9.AND.NINT(CTP).LT.20) THEN - ITH = MOD(NINT(CTP),10) - KTH = JTH(ITH) - CTH = MAX(KTH,NINT(CTH)) - CHH = MIN(CHT,CHH) - ELSE IF(NINT(CTP).LT.30) THEN - ITM = MOD(NINT(CTP),10) - CTM = MAX(ITM,NINT(CTM)) - IF(ITM.EQ.0) CAM = 0. - CCM = MAX(CAM,CCM) - CHM = MIN(CHT,CHM) - ELSE IF(NINT(CTP).LT.40) THEN - ITL = MOD(NINT(CTP),10) - KTL = JTL(ITL) - CTL = MAX(KTL,NINT(CTL)) - IF(ITL.EQ.0) CAM = 0. - CCL = MAX(CAM,CCL) - CHL = MIN(CHT,CHL) - ELSE IF(NINT(CTP).EQ.59) THEN - CTH = 10. - CTM = 10. - IF(CCM.EQ.0.) CCM = 15. - CTL = 10. - IF(CCL.EQ.0.) CCL = 15. - ELSE IF(NINT(CTP).EQ.60) THEN - CTH = 10. - ELSE IF(NINT(CTP).EQ.61) THEN - CTM = 10. - IF(CCM.EQ.0.) CCM = 15. - ELSE IF(NINT(CTP).EQ.62) THEN - CTL = 10. - IF(CCL.EQ.0.) CCL = 15. - END IF - END IF - ENDDO - END IF - IF(NINT(CTH).GT.-1.AND.NINT(CTH).LT.10) THEN - CTH = JTH(NINT(CTH)) - ELSE IF(NINT(CTH).NE.10) THEN - CTH = BMISS - END IF - IF(NINT(CTM).LT.0.OR.NINT(CTM).GT.10) THEN - CTM = BMISS - CCM = BMISS - END IF - IF(NINT(CTL).GT.-1.AND.NINT(CTL).LT.10) THEN - CTL = LTL(NINT(CTL)) - ELSE IF(NINT(CTL).NE.10) THEN - CTL = BMISS - CCL = BMISS - END IF - -C CALL FUNCTIONS TO TRANSFORM TO ON29/124 UNITS -C --------------------------------------------- - - PSL = E01O29(PSL) - STP = E01O29(STP) - SDR = E04O29(SDR,SSP) - SSP = E05O29(SDR,SSP) - IF(NINT(SDR).EQ.0) SDR = 360. - IF(SDR.GE.BMISS.AND.NINT(SSP).EQ.0) SDR = 360. - DPD = E07O29(DPD,STM) - STM = E06O29(STM) - TMX = E06O29(TMX) - TMI = E06O29(TMI) - - PSQ = E35O29(QSL) - SPQ = E35O29(QSP) - SWQ = E35O29(QMW) - STQ = E35O29(QMT) - DDQ = E35O29(QMD) - -C ADJUST QUIPS QUALITY MARKERS TO REFLECT UNPACKED ON29 CONVENTION - - IF(SUBSET(1:5).EQ.'NC001'.AND.PSQ.EQ.'C') STP = BMISS - IF(PSL.GE.BMISS) PSQ = ' ' - IF(STP.GE.BMISS) SPQ = ' ' - IF(MAX(SDR,SSP).GE.BMISS) SWQ = ' ' - IF(STM.GE.BMISS) STQ = ' ' - - IF(SUBSET(1:5).EQ.'NC000'.OR.SUBSET.EQ.'NC001004') THEN - HVZ = E09O29(HVZ) - ELSE - HVZ = E38O29(HVZ) - END IF - PRW = E10O29(PRW) - PW1 = E11O29(PW1) - PW2 = E11O29(PW2) - IF(DDQ.NE.'P'.AND.DDQ.NE.'H'.AND.DDQ.NE.'C') THEN - DDQ = ' ' - IPW2 = NINT(PW2) - IF(IPW2.GT.-1.AND.IPW2.LT.10) WRITE(DDQ,'(I1)') IPW2 - END IF - CCN = E12O29(CCN) - CHN = E14O29(CCL,CCM) - CTL = E15O29(CTL) - CTM = E15O29(CTM) - CTH = E15O29(CTH) - HCB = E18O29(CHL,CHM,CHH,CTL,CTM,CTH) - CPT = E19O29(CPT) - APT = E01O29(APT) - - PC6 = E20O29(PC6) - SND = E21O29(SND) - P24 = E20O29(P24) - DOP = E22O29(PC6) - POW = E23O29(POW) - HOW = E24O29(HOW) - SWD = E25O29(SWD) - SWP = E23O29(SWP) - SWH = E24O29(SWH) - SST = E06O29(SST) - SPG = E28O29(SPG) - SPD = E29O29(SPD) - SHC = E30O29(SHC) - SAS = E31O29(SAS) - WES = E32O29(WES) - -C MAKE THE UNPACKED ON29/124 REPORT INTO OBS -C ------------------------------------------ - - RSV2 = ' ' - CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP) - CALL S02O29(51,1,*9999) - IF(I52FLG.EQ.0) CALL S02O29(52,1,*9999) - -C ------------------------------------------------------------------ -C MISC DATA GOES INTO CATEGORY 08 -C ------------------------------------------------------------------ -C CODE FIGURE 020 - ALTIMETER SETTING IN 0.1*MB -C CODE FIGURE 081 - CALENDAR DAY MAXIMUM TEMPERATURE -C CODE FIGURE 082 - CALENDAR DAY MINIMUM TEMPERATURE -C CODE FIGURE 083 - SIX HOUR MAXIMUM TEMPERATURE -C CODE FIGURE 084 - SIX HOUR MINIMUM TEMPERATURE -C CODE FIGURE 085 - PRECIPITATION OVER PAST HOUR IN 0.01*INCHES -C CODE FIGURE 098 - DURATION OF SUNSHINE FOR CALENDAR DAY IN MINUTES -C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S -C ------------------------------------------------------------------ - - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'ALSE');ALS=UFBINT_8 - IF(ALS.LT.BMISS) THEN - OB8(1) = E01O29(ALS) - CF8(1) = 20 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - IF(SUBSET.EQ.'NC000007') THEN - CALL UFBINT(LUNIT,TMXMNM_8,4,255,NTXM, - $ '.DTHMXTM MXTM .DTHMITM MITM');TMXMNM=TMXMNM_8 - IF(NTXM.GT.0) THEN - DO I = 1,NTXM - DO J = 1,3,2 - IF(NINT(TMXMNM(J,I)).EQ.24) THEN - IF(TMXMNM(J+1,I).LT.BMISS) THEN - TMX = E06O29(TMXMNM(J+1,I)) - IF(TMX.LT.0) THEN - OB8(1) = 1000 + ABS(NINT(TMX)) - ELSE - OB8(1) = NINT(TMX) - END IF - CF8(1) = 81 + INT(J/2) - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - ELSE IF(NINT(TMXMNM(J,I)).EQ.6) THEN - IF(TMXMNM(J+1,I).LT.BMISS) THEN - TMX = E06O29(TMXMNM(J+1,I)) - IF(TMX.LT.0) THEN - OB8(1) = 1000 + ABS(NINT(TMX)) - ELSE - OB8(1) = NINT(TMX) - END IF - CF8(1) = 83 + INT(J/2) - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - END IF - ENDDO - ENDDO - END IF - END IF - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TP01');PC1=UFBINT_8 - IF(PC1.LT.10000) THEN - OB8(1) = E20O29(PC1) - CF8(1) = 85 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TOSS');DUS=UFBINT_8 - IF(NINT(DUS).LT.1000) THEN - OB8(1) = NINT(98000. + DUS) - CF8(1) = 98 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - IF(WSPD1.LT.BMISS) THEN - OB8(1) = NINT(WSPD1*10.) - CF8(1) = 924 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - - CALL S03O29(OBS,SUBSET,*9999,*9998) - - RETURN - - 9999 CONTINUE - R04O29 = 999 - RETURN - - 9998 CONTINUE - print'(" IW3UNP29/R04O29: RPT with ID= ",A," TOSSED - ZERO ", - $ "CAT.1-6,51,52 LVLS")', SID - R04O29 = -9999 - KSKSFC =KSKSFC + 1 - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R05O29(LUNIT,OBS) -C ---> formerly FUNCTION AIRCFT - - COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), - $ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255), - $ CF8(255) - COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255), - $ QCP(255),QCA(255),Q81(255),Q82(255) - COMMON/IO29CC/SUBSET,IDAT10 - COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI - COMMON/IO29LL/BMISS - - CHARACTER*80 HDSTR,LVSTR,QMSTR,RCSTR,CRAWR - CHARACTER*8 SUBSET,SID,SIDO,SIDMOD,E35O29,RSV,RSV2,CCL,CRAW(1,255) - CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,CTURB(0:14) - REAL(8) RID_8,RCL_8,UFBINT_8,RNS_8,BMISS - REAL(8) HDR_8(20),RCT_8(5,255),ARR_8(10,255),RAW_8(1,255) - DIMENSION OBS(*),HDR(20),RCT(5,255),ARR(10,255),RAW(1,255) - EQUIVALENCE (RID_8,SID),(RCL_8,CCL),(RAW_8,CRAW) - - SAVE - - DATA HDSTR/'RPID CLON CLAT HOUR MINU SECO '/ - DATA LVSTR/'PRLC TMDP TMDB WDIR WSPD '/ - DATA QMSTR/'QMPR QMAT QMDD QMGP QMWN '/ - DATA RCSTR/'RCHR RCMI RCTS '/ - - DATA CTURB/'0','1','2','3','0','1','2','3','0','1','2',4*'3'/ - -C CHECK IF THIS IS A PREPBUFR FILE -C -------------------------------- - - R05O29 = 99 -c#V#V#dak - future -cdak IF(SUBSET.EQ.'AIRCFT') R05O29 = PRPCFT(LUNIT,OBS) -cdak IF(SUBSET.EQ.'AIRCAR') R05O29 = PRPCFT(LUNIT,OBS) -caaaaadak - future - IF(R05O29.NE.99) RETURN - R05O29 = 0 - - CALL S05O29 - -C PUT THE HEADER INFORMATION INTO ON29 FORMAT -C ------------------------------------------- - - CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) - IF(IRET.EQ.0) SID = ' ' - CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 - IF(HDR(5).GE.BMISS) HDR(5) = 0 - IF(HDR(6).GE.BMISS) HDR(6) = 0 - RCTIM = NINT(RCT(1,1))+NINT(RCT(2,1))/60. - RID_8 = HDR_8(1) - XOB = HDR(2) - YOB = HDR(3) - RHR = BMISS - IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4)) + ((NINT(HDR(5)) * 60.) + - $ NINT(HDR(6)))/3600. - RCH = RCTIM - -C TRY TO FIND FIND THE FLIGHT LEVEL HEIGHT -C ---------------------------------------- - - CALL UFBINT(LUNIT,HDR_8,20,1,IRET,'PSAL FLVL IALT HMSL PRLC') - HDR=HDR_8 - ELEV = BMISS - IF(HDR(5).LT.BMISS) ELEV = E03O29(HDR(5)*.01) - IF(HDR(4).LT.BMISS) ELEV = HDR(4) -C FOR MDCARS ACARS DATA ONLY: -C UNCOMMENTING NEXT LINE WILL SET P-ALT TO REPORTED "IALT" VALUE -- -C IN THIS CASE, PREPDATA WILL LATER GET PRESS. VIA STD. ATMOS. FCN. -C COMMENTING NEXT LINE WILL USE REPORTED PRESSURE "PRLC" TO GET -C P-ALT VIA INVERSE STD. ATMOS. FCN. -- IN THIS CASE, PREPDATA WILL -C LATER RETURN THIS SAME PRESS. VIA STD. ATMOS. FCN. -cdak IF(HDR(3).LT.BMISS) ELEV = HDR(3) - IF(HDR(2).LT.BMISS) ELEV = HDR(2) + SIGN(0.0000001,HDR(2)) - IF(HDR(1).LT.BMISS) ELEV = HDR(1) + SIGN(0.0000001,HDR(1)) - ELV = ELEV - -C ACFT NAVIGATION SYSTEM STORED IN INSTR. TYPE LOCATION (AS WITH ON29) -C -------------------------------------------------------------------- - - ITP = 99 - CALL UFBINT(LUNIT,RNS_8,1,1,IRET,'ACNS');RNS=RNS_8 - IF(RNS.LT.BMISS) THEN - IF(NINT(RNS).EQ.0) THEN - ITP = 97 - ELSE IF(NINT(RNS).EQ.1) THEN - ITP = 98 - END IF - END IF - - RTP = E33O29(SUBSET,SID) - - CALL UFBINT(LUNIT,RCL_8,1,1,IRET,'BORG') ! Effective 3/2002 - IF(IRET.EQ.0) THEN - CCL = ' ' - CALL UFBINT(LUNIT,RCL_8,1,1,IRET,'ICLI') ! Prior to 3/2002 - IF(IRET.EQ.0) CCL = ' ' - END IF -cvvvvv temporary? - IF(CCL(1:4).EQ.'KAWN') THEN - -C This will toss all Carswell/Tinker Aircraft reports - until Jack -C fixes the dup-check to properly remove the duplicate Carswell -C reports, we are better off removing them all since they are -C often of less quality than the non-Carswell AIREP reports -C RIGHT NOW WE ARE HAPPY WITH DUP-CHECKER'S HANDLING OF THESE, -C SO COMMENT THIS OUT - -cdak R05O29 = -9999 -cdak KSKACF(?) = KSKACF(?) + 1 -cdak RETURN - END IF -caaaaa temporary? - IF(SUBSET.EQ.'NC004003') THEN - -C ------------------------------------ -C ASDAR/AMDAR AIRCRAFT TYPE COME HERE -C ------------------------------------ - -cvvvvv temporary? -C Currently, we throw out any ASDAR/AMDAR reports with header "LFPW" - -C simply because they never appeared in NAS9000 ON29 AIRCFT data set -C (NOTE: These should all have ACID's that begin with "IT") -C (NOTE: These will not be removed from the new decoders, because -C they are apparently unique reports of reasonable -C quality. EMC just needs to test them in a parallel run -C to make sure prepacqc and the analysis handle them okay.) - -C NOTE: NO, NO DON'T THROW THEM OUT ANY MORE !!!!!! -C Keyser -- 6/13/97 - -CDAKCDAK if(ccl(1:4).eq.'LFPW') then -cppppp -cdak print'(" IW3UNP29/R05O29: TOSS ""LFPW"" AMDAR with ID = ",A, -cdak $ "; CCL = ",A)', SID,CCL(1:4) -cppppp -CDAKCDAK R05O29 = -9999 -CDAKCDAK kskacf(2) = kskacf(2) + 1 -CDAKCDAK return -CDAKCDAK end if -caaaaa temporary? - -C MODIFY REPORT ID AS WAS DONE IN OLD ON29 AIRCRAFT PACKER -C -------------------------------------------------------- - - CALL S06O29(SID,SIDMOD) - SIDO = SID - SID = SIDMOD - -C THE 25'TH (RESERVE) CHARACTER INDICATES PHASE OF FLIGHT -C THE 26'TH (RESERVE) CHARACTER INDICATES TEMPERATURE PRECISION -C THE 27'TH (RESERVE) CHARACTER INDICATES CARSWELL (NEVER HAPPENS) -C (NOTE: NAS9000 ONLY ASSIGNED HEADER "KAWN" AS CARSWELL, ALTHOUGH -C "PHWR" AND "EGWR" ARE ALSO APPARENTLY ALSO CARSWELL) - - RSV = '71 ' - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'POAF');POF=UFBINT_8 - IF(POF.LT.BMISS) WRITE(RSV(1:1),'(I1)') NINT(POF) - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PCAT');PCT=UFBINT_8 - IF(NINT(PCT).GT.1) RSV(2:2) = '0' - IF(CCL(1:4).EQ.'KAWN') RSV(3:3) = 'C' - - ELSE IF(SUBSET.EQ.'NC004004') THEN - -C ------------------------------ -C ACARS AIRCRAFT TYPE COME HERE -C ------------------------------ - - CALL UFBINT(LUNIT,RID_8,1,1,IRET,'ACRN') - IF(IRET.EQ.0) SID = 'ACARS ' - KNDX = KNDX + 1 - RSV = '999 ' - - ELSE IF(SUBSET.EQ.'NC004001'.OR.SUBSET.EQ.'NC004002') THEN - -C ----------------------------------------- -C AIREP AND PIREP AIRCRAFT TYPES COME HERE -C ----------------------------------------- - -C MAY POSSIBLY NEED TO MODIFY THE RPID HERE -C ----------------------------------------- - - IF(SID(6:6).EQ.'Z') SID(6:6) = 'X' - IF(SID.EQ.'A '.OR.SID.EQ.' '.OR.SID(1:3).EQ.'ARP' - $ .OR.SID(1:3).EQ.'ARS') SID = 'AIRCFT ' - -cvvvvv temporary? -C Determined that Hickum AFB reports are much like Carswell - they have -C problems! They also are usually duplicates of either Carswell or -C non-Carswell reports. Apparently the front-end processing filters -C them out (according to B. Ballish). So, to make things match, -C we will do the same here. -C ACTUALLY, JEFF ATOR HAS REMOVED THESE FROM THE DECODER, SO WE -C SHOULD NEVER EVEN SEE THEM IN THE DATABASE, but it won't hurt -C anything to keep this in here. -C (NOTE: These all have headers of "PHWR") - - if(ccl(1:4).eq.'PHWR') then -cppppp -cdak print'(" IW3UNP29/R05O29: TOSS ""PHWR"" AIREP with ID = ",A, -cdak $ "; CCL = ",A)', SID,CCL(1:4) -cppppp - R05O29 = -9999 - kskacf(8) = kskacf(8) + 1 - return - end if -caaaaa temporary? - -cvvvvv temporary? -C 1) Carswell/Tinker AMDARS are processed as AIREP subtypes. -C Nearly all of them are duplicated as true non-Carswell AMDARS in -C the AMDAR subtype. The earlier version of the aircraft dup- -C checker could not remove such duplicates; the new verison now -C in operations can remove these. SO, WE HAVE COMMENTED THIS OUT. -C -C The Carswell AMDARS can be identified by the string " Sxyz" in -C the raw report (beyond byte 40), where y is 0,1, or 2. -C (NOTE: Apparently Carswell here applies to more headers than -C just "KAWN", so report header is not even checked.) - -C 2) Carswell/Tinker ACARS are processed as AIREP subtypes. -C These MAY duplicate true non-Carswell ACARS in the ACARS -C subtype. The NAS9000 decoder always excluded this type (no -C dup-checking was done). All of these will be removed here. -C The Carswell ACARS can be identified by the string " Sxyz" in -C the raw report (beyond byte 40), where y is 3 or greater. -C (NOTE: Apparently Carswell here applies to more headers than -C just "KAWN", so report header is not even checked.) - - call ufbint(lunit,raw_8,1,255,nlev,'RRSTG');raw=raw_8 - if(nlev.gt.5) then - ni = -7 - do mm = 6,nlev - ni = ni + 8 - crawr(ni:ni+7) = craw(1,mm) - if(ni+8.gt.80) go to 556 - enddo - 556 continue - do mm = 1,ni+7 - if(crawr(mm:mm+1).eq.' S') then - if((crawr(mm+2:mm+2).ge.'0'.and.crawr(mm+2:mm+2).le. - $ '9').or.crawr(mm+2:mm+2).eq.'/') then - if((crawr(mm+3:mm+3).ge.'0'.and.crawr(mm+3:mm+3) - $ .le.'9').or.crawr(mm+3:mm+3).eq.'/') then - if((crawr(mm+4:mm+4).ge.'0'.and. - $ crawr(mm+4:mm+4).le.'9').or.crawr(mm+4:mm+4) - $ .eq.'/') then -cppppp -cdak print'(" IW3UNP29/R05O29: For ",A,", raw_8(",I0,") = ",A)', -cdak $ SID,ni+7,crawr(1:ni+7) -cppppp - if(crawr(mm+3:mm+3).lt.'3') then - -C THIS IS A CARSWELL/TINKER AMDAR REPORT --> THROW OUT -C (NOT ANYMORE, DUP-CHECKER IS HANDLING THESE OKAY NOW) -C ---------------------------------------------------- - -cppppp -cdak print'(" IW3UNP29/R05O29: Found a Carswell AMDAR for ",A, -cdak $ "; CCL = ",A)', SID,CCL(1:4) -cppppp -cdak R05O29 = -9999 -cdak KSKACF(3) = KSKACF(3) + 1 -cdak RETURN - else - -C THIS IS A CARSWELL/TINKER ACARS REPORT --> THROW OUT -C ---------------------------------------------------- - -cppppp -cdak print'(" IW3UNP29/R05O29: Found a Carswell ACARS for ",A, -cdak $ "; CCL = ",A)', SID,CCL(1:4) -cppppp - R05O29 = -9999 - KSKACF(4) = KSKACF(4) + 1 - RETURN - - end if - end if - end if - end iF - end if - if(mm+5.gt.ni+7) go to 557 - enddo - 557 continue - END IF -caaaaa temporary? - -C THE 25'TH (RESERVE) CHARACTER INDICATES 8'TH CHARACTER OF STATION ID -C THE 26'TH (RESERVE) CHARACTER INDICATES 7'TH CHARACTER OF STATION ID -C THE 27'TH (RESERVE) CHARACTER INDICATES CARSWELL -C (NOTE: NAS9000 ONLY ASSIGNED HEADER "KAWN" AS CARSWELL, ALTHOUGH -C "PHWR" AND "EGWR" ARE ALSO APPARENTLY ALSO CARSWELL) - - RSV = SID(8:8)//SID(7:7)//' ' - IF(CCL(1:4).EQ.'KAWN') RSV(3:3) = 'C' - - END IF - -C ----------------------------- -C ALL AIRCRAFT TYPES COME HERE -C ----------------------------- - - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'DGOT');DGT=UFBINT_8 - -C PUT THE LEVEL DATA INTO ON29 UNITS -C ---------------------------------- - - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8 - DO L=1,NLEV - -Cvvvvv temporary? -C Even though PREPDATA filters out any aircraft reports with a missing -C wind, or AIREP/PIREP and AMDAR reports below 100 and 2286 meters, -C respectively, it will be done here for now in order to help in -C the comparison between counts coming from the Cray dumps and the -C NAS9000 ON29 dumps (the NAS9000 ON29 maker filters these out). - -C NO, NO LET'S NOT FILTER HERE ANY MORE - LEAVE IT UP TO PREPDATA -C SINCE WE AREN'T COMPARING NAS9000 AND CRAY COUNTS ANY MORE -C Keyser -- 6/13/97 - -CDAKCDAK if(arr(4,1).ge.bmiss.or.arr(5,1).ge.bmiss) then -CDAKCDAK R05O29 = -9999 -CDAKCDAK kskacf(5) = kskacf(5) + 1 -CDAKCDAK return -CDAKCDAK end if -CDAKCDAK if(subset.eq.'NC004003'.and.elev.lt.2286.) then -CDAKCDAK R05O29 = -9999 -CDAKCDAK kskacf(6) = kskacf(6) + 1 -CDAKCDAK return -CDAKCDAK else if(subset.ne.'NC004004'.and.elev.lt.100.) then -CDAKCDAK R05O29 = -9999 -CDAKCDAK kskacf(7) = kskacf(7) + 1 -CDAKCDAK return -CDAKCDAK end if -caaaaa temporary? - - POB(L) = E01O29(ARR(1,L)) - QOB(L) = E07O29(ARR(2,L),ARR(3,L)) - TOB(L) = E06O29(ARR(3,L)) - ZOB(L) = ELEV - DOB(L) = E04O29(ARR(4,L),ARR(5,L)) - SOB(L) = E05O29(ARR(4,L),ARR(5,L)) - ENDDO - WSPD1 = ARR(5,1) - - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8 - - IF(SUBSET.EQ.'NC004004') THEN - -C --------------------------------------------------------- -C ACARS AIRCRAFT TYPE COME HERE FOR QUALITY MARK ASSIGNMENT -C --------------------------------------------------------- - - DO L=1,NLEV - PQM(L) = E35O29(ARR(1,L)) - TQM(L) = E35O29(ARR(2,L)) - QQM(L) = E35O29(ARR(3,L)) - ZQM(L) = E35O29(ARR(4,L)) - WQM(L) = E35O29(ARR(5,L)) - ENDDO - -C DEFAULT Q.MARK FOR WIND: "A" -C ---------------------------- - - IF(NLEV.EQ.0.OR.ARR(5,1).GE.BMISS) WQM(1) = 'A' - - ELSE - -C -------------------------------------------------------------- -C ALL OTHER AIRCRAFT TYPES COME HERE FOR QUALITY MARK ASSIGNMENT -C -------------------------------------------------------------- - - DO L=1,NLEV - ARR(4,L) = 2 - -C IF KEEP FLAG ON WIND, ENTIRE REPORT GETS KEEP FLAG ('H' IN ZQM) -C -- unless.... -C IF PURGE FLAG ON WIND, ENTIRE REPORT GETS PURGE FLAG ('P' IN ZQM) -C IF PURGE FLAG ON TEMP, ENTIRE REPORT GETS PURGE FLAG ('P' IN ZQM) -C IF FAIL FLAG ON WIND, ENTIRE REPORT GETS FAIL FLAG ('F' IN ZQM) -C IF FAIL FLAG ON TEMP, ENTIRE REPORT GETS FAIL FLAG ('F' IN ZQM) -C ----------------------------------------------------------------- - - IF(ARR(5,L).EQ.0.AND.(ARR(2,L).LT.10.OR.ARR(2,L).GT.15))THEN - ARR(4,L) = 0 - ELSE IF(ARR(5,L).EQ.14.OR.ARR(2,L).EQ.14) THEN - ARR(4,L) = 14 - ELSE IF(ARR(5,L).EQ.13.OR.ARR(2,L).EQ.13) THEN - ARR(4,L) = 13 - END IF - PQM(L) = ' ' - TQM(L) = ' ' - QQM(L) = ' ' - ZQM(L) = E35O29(ARR(4,L)) - -C DEGREE OF TURBULENCE IS STORED IN MOISTURE Q.M. SLOT -C ---------------------------------------------------- - - IF(NINT(DGT).LT.15) QQM(L) = CTURB(NINT(DGT)) - ENDDO - -C DEFAULT Q.MARK FOR WIND: "C" -C ---------------------------- - - WQM(1) = 'C' - END IF - -C PUT THE UNPACKED ON29 REPORT INTO OBS -C ------------------------------------- - - RSV2 = ' ' - CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP) - CALL S02O29(6,1,*9999) - -C ------------------------------------------------------------------ -C MISC DATA GOES INTO CATEGORY 08 -C ------------------------------------------------------------------ -C CODE FIGURE 021 - REPORT SEQUENCE NUMBER -C CODE FIGURE 917 - CHARACTERS 1 AND 2 OF ACTUAL STATION IDENTIFICATION -C (CURRENTLY ONLY FOR ASDAR/AMDAR) -C CODE FIGURE 918 - CHARACTERS 3 AND 4 OF ACTUAL STATION IDENTIFICATION -C (CURRENTLY ONLY FOR ASDAR/AMDAR) -C CODE FIGURE 919 - CHARACTERS 5 AND 6 OF ACTUAL STATION IDENTIFICATION -C (CURRENTLY ONLY FOR ASDAR/AMDAR) -C CODE FIGURE 920 - CHARACTERS 7 AND 8 OF ACTUAL STATION IDENTIFICATION -C (CURRENTLY ONLY FOR ASDAR/AMDAR AND ACARS) -C CODE FIGURE 921 - OBSERVATION TIME TO NEAREST 1000'TH OF AN HOUR -C (CURRENTLY ONLY FOR ACARS) -C CODE FIGURE 922 - FIRST TWO CHARACTERS OF BULLETIN BEING MONITORED -C CODE FIGURE 923 - LAST TWO CHARACTERS OF BULLETIN BEING MONITORED -C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S -C ------------------------------------------------------------------ - - IF(SUBSET.EQ.'NC004004') THEN - OB8(1) = KNDX - CF8(1) = 21 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - OB8(1) = 99999. - Q81(1) = SID(7:7) - Q82(1) = SID(8:8) - CF8(1) = 920 - CALL S02O29(8,1,*9999) - IF(RHR.LT.BMISS) THEN - OB8(1) = NINT((RHR*1000.)+0.0000001) - CF8(1) = 921 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - ELSE IF(SUBSET.EQ.'NC004003') THEN - DO KKK = 1,4 - OB8(KKK) = 99999. - Q81(KKK) = SIDO(2*KKK-1:2*KKK-1) - Q82(KKK) = SIDO(2*KKK:2*KKK) - CF8(KKK) = 916 + KKK - CALL S02O29(8,KKK,*9999) - ENDDO - END IF - IF(CCL.NE.' ') THEN - OB8(2) = 99999. - Q81(2) = CCL(1:1) - Q82(2) = CCL(2:2) - CF8(2) = 922 - CALL S02O29(8,2,*9999) - OB8(3) = 99999. - Q81(3) = CCL(3:3) - Q82(3) = CCL(4:4) - CF8(3) = 923 - CALL S02O29(8,3,*9999) - END IF - IF(WSPD1.LT.BMISS) THEN - OB8(4) = NINT(WSPD1*10.) - CF8(4) = 924 - Q81(4) = ' ' - Q82(4) = ' ' - CALL S02O29(8,4,*9999) - END IF - - CALL S03O29(OBS,SUBSET,*9999,*9998) - - RETURN - - 9999 CONTINUE - R05O29 = 999 - RETURN - - 9998 CONTINUE - print'(" IW3UNP29/R05O29: RPT with ID= ",A," TOSSED - ZERO ", - $ "CAT.1-6,51,52 LVLS")', SID - R05O29 = -9999 - KSKACF(1) = KSKACF(1) + 1 - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R06O29(LUNIT,OBS) -C ---> formerly FUNCTION SATWND - - COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), - $ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255), - $ CF8(255) - COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255), - $ QCP(255),QCA(255),Q81(255),Q82(255) - COMMON/IO29CC/SUBSET,IDAT10 - COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI - COMMON/IO29KK/KOUNT(499,18) - COMMON/IO29LL/BMISS - - CHARACTER*80 HDSTR,LVSTR,QMSTR,RCSTR - CHARACTER*8 SUBSET,SID,E35O29,RSV,RSV2 - CHARACTER*3 CINDX3 - CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,CSAT(499), - $ CPRD(9),CINDX7,C7(26),CPROD(0:4),CPRDF(3) - INTEGER IPRDF(3) - REAL(8) RID_8,UFBINT_8,BMISS - REAL(8) HDR_8(20),RCT_8(5,255),ARR_8(10,255) - DIMENSION OBS(*),HDR(20),RCT(5,255),ARR(10,255) - EQUIVALENCE (RID_8,SID) - - SAVE - - DATA HDSTR/'RPID CLON CLAT HOUR MINU SAID '/ - DATA LVSTR/'PRLC TMDP TMDB WDIR WSPD '/ - DATA QMSTR/'QMPR QMAT QMDD QMGP SWQM '/ - DATA RCSTR/'RCHR RCMI RCTS '/ - - DATA CSAT /'A','B','C','D',45*'?','Z','W','X','Y','Z','W','X', - $ 'Y','Z','W',90*'?','R','O','P','Q','R','O','P','Q','R','O', - $ 339*'?','V'/ - DATA CPROD /'C','D','?','?','E'/ - DATA CPRDF /'C','B','V'/ - DATA IPRDF / 1 , 6 , 4 / - DATA CPRD /'C','V','I','W','P','T','L','Z','G'/ - DATA C7 /'A','B','C','D','E','F','G','H','I','J','K','L','M', - $ 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/ - -C CHECK IF THIS IS A PREPBUFR FILE -C -------------------------------- - - R06O29 = 99 -c#V#V#dak - future -cdak IF(SUBSET.EQ.'SATWND') R06O29 = PRPWND(LUNIT,OBS) -caaaaadak - future - IF(R06O29.NE.99) RETURN - R06O29 = 0 - - CALL S05O29 - -C TRY TO FIND FIND THE HEIGHT ASSIGNMENT -C -------------------------------------- - - CALL UFBINT(LUNIT,HDR_8,20,1,IRET,'HGHT PRLC');HDR=HDR_8 - ELEV = BMISS - IF(HDR(2).LT.BMISS) ELEV = E03O29(HDR(2)*.01) - IF(HDR(1).LT.BMISS) ELEV = HDR(1) - -C PUT THE HEADER INFORMATION INTO ON29 FORMAT -C ------------------------------------------- - - CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) - CALL UFBINT(LUNIT,RCT_8, 5,255,NRCT,RCSTR);RCT=RCT_8 - IF(HDR(5).GE.BMISS) HDR(5) = 0 - RCTIM = NINT(RCT(1,1))+NINT(RCT(2,1))/60. - RID_8 = HDR_8(1) - XOB = HDR(2) - YOB = HDR(3) - RHR = BMISS - IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4))+NINT(HDR(5))/60. - RCH = RCTIM - RSV = '990 ' - -C THE 25'TH (RESERVE) CHARACTER IS THE CLOUD MASK/DEEP LAYER INDICATOR -C {=2 - CLOUD TOP (NORMAL CLOUD DRIFT), =1 - DEEP LAYER, -C =9 - INDICATOR MISSING, THUS REVERTS TO DEFAULT CLOUD TOP} -C (=9 FOR ALL BUT U.S. HIGH-DENSITY SATWND TYPES) -C -------------------------------------------------------------------- - -C THE 27'TH (RESERVE) CHARACTER INDICATES THE PRODUCER OF THE SATWND -C ------------------------------------------------------------------ - -C THE INSTRUMENT TYPE INDICATES THE PRODUCT TYPE -C ---------------------------------------------- - - ITP = 99 - -C REPROCESS THE STN. ID -C --------------------- - -C REPROCESSED CHAR 1 -----> GOES: BUFR CHAR 1 -C -----> METEOSAT: SAT. NO. 52, 56 GET 'X' -C SAT. NO. 53, 57 GET 'Y' -C SAT. NO. 50, 54, 58 GET 'Z' -C SAT. NO. 51, 55, 59 GET 'W' -C -----> GMS(JA): SAT. NO. 152,156 GET 'P' -C SAT. NO. 153,157 GET 'Q' -C SAT. NO. 150,154,158 GET 'R' -C SAT. NO. 151,155,159 GET 'O' -C -----> INSAT: SAT. NO. 499 GET 'V' -C REPROCESSED CHAR 2 -----> GOES: RETURNED VALUE IN BUFR FOR 'SWPR' -C (PRODUCER) -C -----> OTHERS: SAT. PRODUCER -- ESA GET 'C' -C -- GMS GET 'D' -C -- INSAT GET 'E' -C REPROCESSED CHAR 6 -----> GOES: BUFR CHAR 6 -C -----> OTHERS -- INFRA-RED CLOUD DRIFT GET 'C' -C -- VISIBLE CLOUD DRIFT GET 'B' -C -- WATER VAPOR GET 'V' -C REPROCESSED CHAR 3-5 ---> SEQUENTIAL SERIAL INDEX (001 - 999) -C (UNIQUE FOR EACH BUFR CHAR 1/6 COMB.) -C REPROCESSED CHAR 7 -----> GROUP NUMBER FOR SERIAL INDEX IN -C REPROCESSED CHAR 3-5 (0 - 9, A - Z) -C REPROCESSED CHAR 8 -----> ALWAYS BLANK (' ') FOR NOW - - READ(SUBSET(8:8),'(I1)') INUM - IF(SID(1:1).GE.'A'.AND.SID(1:1).LE.'D') THEN - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWPR');SWPR=UFBINT_8 - IF(NINT(SWPR).GT.0.AND.NINT(SWPR).LT.10) - $ WRITE(RSV(3:3),'(I1)') NINT(SWPR) - SID(2:2) = RSV(3:3) - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWTP');SWTP=UFBINT_8 - IF(SWTP.LT.BMISS) ITP = NINT(SWTP) - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SWDL');SWDL=UFBINT_8 - IF(NINT(SWDL).GT.-1.AND.NINT(SWDL).LT.10) - $ WRITE(RSV(1:1),'(I1)') NINT(SWDL) - ELSE - SID = '????????' - IF(NINT(HDR(6)).LT.500) THEN - SID(1:1) = CSAT(NINT(HDR(6))) - SID(2:2) = CPROD(NINT(HDR(6))/100) - RSV(3:3) = SID(2:2) - END IF - IF(INUM.LT.4) THEN - SID(6:6) = CPRDF(INUM) - ITP = IPRDF(INUM) - END IF - END IF - CINDX3 = '???' - CINDX7 = '?' - IF(NINT(HDR(6)).LT.500.AND.ITP.LT.19) THEN - KOUNT(NINT(HDR(6)),ITP) = MIN(KOUNT(NINT(HDR(6)),ITP)+1,35999) - KOUNT3 = MOD(KOUNT(NINT(HDR(6)),ITP),1000) - KOUNT7 = INT(KOUNT(NINT(HDR(6)),ITP)/1000) - WRITE(CINDX3,'(I3.3)') KOUNT3 - IF(KOUNT7.LT.10) THEN - WRITE(CINDX7,'(I1.1)') KOUNT7 - ELSE - CINDX7 = C7(KOUNT7-9) - END IF - END IF - SID = SID(1:2)//CINDX3//SID(6:6)//CINDX7//' ' - - ELV = ELEV - RTP = E33O29(SUBSET,SID) - -C PUT THE LEVEL DATA INTO ON29 UNITS -C ---------------------------------- - - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,LVSTR);ARR=ARR_8 - DO L=1,NLEV - POB(L) = E01O29(ARR(1,L)) - -C GROSS CHECK ON PRESSURE -C ----------------------- - - IF(NINT(POB(L)).EQ.0) THEN - print'(" ~~IW3UNP29/R06O29: RPT with ID= ",A," TOSSED - ", - $ "PRES. IS ZERO MB")', SID - R06O29 = -9999 - KSKSAT = KSKSAT + 1 - RETURN - END IF - - QOB(L) = E07O29(ARR(2,L),ARR(3,L)) - TOB(L) = E06O29(ARR(3,L)) - ZOB(L) = ELEV - DOB(L) = E04O29(ARR(4,L),ARR(5,L)) - SOB(L) = E05O29(ARR(4,L),ARR(5,L)) - ENDDO - WSPD1 = ARR(5,1) - -C DETERMINE QUALITY MARKERS -C ------------------------- - - CALL UFBINT(LUNIT,ARR_8,10,255,NLEV,QMSTR);ARR=ARR_8 - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFFL');RFFL=UFBINT_8 - IF(RFFL.LT.BMISS.AND.(NINT(ARR(5,1)).EQ.2.OR.NINT(ARR(5,1)).GE. - $ BMISS)) THEN - IF(NINT(RFFL).GT.84) THEN - ARR(5,1) = 1 - ELSE IF(NINT(RFFL).GT.55) THEN - ARR(5,1) = 2 - ELSE IF(NINT(RFFL).GT.49) THEN - ARR(5,1) = 3 - ELSE - ARR(5,1) = 13 - END IF - END IF - - DO L=1,NLEV - WQM(L) = E35O29(ARR(5,L)) - - IF(WQM(L).EQ.'R'.OR.WQM(L).EQ.'P'.OR.WQM(L).EQ.'F') THEN - -C A REJECT, PURGE, OR FAIL FLAG ON WIND IS TRANSFERRED TO ALL VARIABLES -C --------------------------------------------------------------------- - - PQM(L) = WQM(L) - TQM(L) = WQM(L) - QQM(L) = WQM(L) - ZQM(L) = WQM(L) - - ELSE - - PQM(L) = E35O29(ARR(1,L)) - TQM(L) = E35O29(ARR(2,L)) - QQM(L) = E35O29(ARR(3,L)) - ZQM(L) = E35O29(ARR(4,L)) - - END IF - - ENDDO - -C PUT THE UNPACKED ON29 REPORT INTO OBS -C ------------------------------------- - - RSV2 = ' ' - CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP) - CALL S02O29(6,1,*9999) - -C --------------------------------------------------------------------- -C MISC DATA GOES INTO CATEGORY 08 -C --------------------------------------------------------------------- -C CODE FIGURE 013 - PRESSURE -C CODE FIGURE 920 - CHARACTERS 7 AND 8 OF ACTUAL STATION IDENTIFICATION -C (CURRENTLY ONLY APPLIES TO U.S. SATWND TYPES) -C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S -C --------------------------------------------------------------------- -C --------------------------------------------------------------------- - - IF(POB(1).LT.BMISS) THEN - OB8(1) = NINT(POB(1)*0.1) - CF8(1) = 13 - Q81(1) = ' ' - Q82(1) = ' ' - CALL S02O29(8,1,*9999) - END IF - IF(SID(1:1).GE.'A'.AND.SID(1:1).LE.'D') THEN - OB8(1) = 99999. - Q81(1) = SID(7:7) - Q82(1) = SID(8:8) - CF8(1) = 920 - CALL S02O29(8,1,*9999) - END IF - IF(WSPD1.LT.BMISS) THEN - OB8(2) = NINT(WSPD1*10.) - CF8(2) = 924 - Q81(2) = ' ' - Q82(2) = ' ' - CALL S02O29(8,2,*9999) - END IF - - CALL S03O29(OBS,SUBSET,*9999,*9998) - - RETURN - - 9999 CONTINUE - R06O29 = 999 - RETURN - - 9998 CONTINUE - print'(" IW3UNP29/R06O29: RPT with ID= ",A," TOSSED - ZERO ", - $ "CAT.1-6,51,52 LVLS")', SID - R06O29 = -9999 - KSKSAT =KSKSAT + 1 - RETURN - - END -C*********************************************************************** -C*********************************************************************** -C*********************************************************************** - FUNCTION R07O29(LUNIT,OBS) -C ---> formerly FUNCTION SPSSMI - - COMMON/IO29EE/POB(255),QOB(255),TOB(255),ZOB(255),DOB(255), - $ SOB(255),VSG(255),CLP(255),CLA(255),OB8(255), - $ CF8(255) - COMMON/IO29FF/PQM(255),QQM(255),TQM(255),ZQM(255),WQM(255), - $ QCP(255),QCA(255),Q81(255),Q82(255) - COMMON/IO29CC/SUBSET,IDAT10 - COMMON/IO29BB/KNDX,KSKACF(8),KSKUPA,KSKSFC,KSKSAT,KSKSMI - COMMON/IO29LL/BMISS - - CHARACTER*80 HDSTR - CHARACTER*8 SUBSET,SID,RSV,RSV2 - CHARACTER*4 CSTDV - CHARACTER*1 PQM,QQM,TQM,ZQM,WQM,QCP,QCA,Q81,Q82,CRF - REAL(8) RID_8,UFBINT_8,HDR_8(20),TMBR_8(7),ADDP_8(5),PROD_8(2,2) - REAL(8) BMISS - DIMENSION OBS(*),HDR(20),ADDP(5),PROD(2,2),TMBR(7) - - EQUIVALENCE (RID_8,SID) - - SAVE - - DATA HDSTR/'RPID CLON CLAT HOUR MINU SECO NMCT SAID '/ - -C CHECK IF THIS IS A PREPBUFR FILE -C -------------------------------- - - R07O29 = 99 -c#V#V#dak - future -cdak IF(SUBSET.EQ.'SPSSMI') R07O29 = PRPSMI(LUNIT,OBS) -caaaaadak - future - IF(R07O29.NE.99) RETURN - R07O29 = 0 - - CALL S05O29 - -C PUT THE HEADER INFORMATION INTO ON29 FORMAT -C ------------------------------------------- - - CALL UFBINT(LUNIT,HDR_8,20, 1,IRET,HDSTR);HDR(2:)=HDR_8(2:) - IF(HDR(5).GE.BMISS) HDR(5) = 0 - IF(HDR(6).GE.BMISS) HDR(6) = 0 - RID_8 = HDR_8(1) - XOB = HDR(2) - YOB = HDR(3) - RHR = BMISS - IF(HDR(4).LT.BMISS) RHR = NINT(HDR(4)) + ((NINT(HDR(5)) * 60.) + - $ NINT(HDR(6)))/3600. - RCH = 99999. - ELV = 99999. - ITP = 99 - RTP = HDR(7) - -C CHECK ON VALUE FOR SATELLITE ID TO DETERMINE IF THIS IS A SUPEROB -C (SATELLITE ID IS MISSING FOR SUPEROBS) -C ----------------------------------------------------------------- - - ISUPOB = 1 - IF(HDR(8).LT.BMISS) ISUPOB = 0 - -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - STDV = BMISS - -C PUT THE SSM/I DATA INTO ON29 UNITS (WILL RETURN TO HEADER DATA LATER) -C ALL PROCESSING GOES INTO CATEGORY 08 -C --------------------------------------------------------------------- - - IF(RTP.EQ.68) THEN -C --------------------------------------------------------------------- -C ** 7-CHANNEL BRIGHTNESS TEMPERATURES -- REPORT TYPE 68 ** -C --------------------------------------------------------------------- -C CODE FIGURE 189 - 19 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100) -C CODE FIGURE 190 - 19 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100) -C CODE FIGURE 191 - 22 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100) -C CODE FIGURE 192 - 37 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100) -C CODE FIGURE 193 - 37 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100) -C CODE FIGURE 194 - 85 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100) -C CODE FIGURE 195 - 85 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100) -C --------------------------------------------------------------------- - NLCAT8 = 7 - CALL UFBINT(LUNIT,TMBR_8,1,7,NLEV,'TMBR');TMBR=TMBR_8 - DO NCHN = 1,7 - OB8(NCHN) = MIN(NINT(TMBR(NCHN)*100.),99999) - CF8(NCHN) = 188 + NCHN - ENDDO - ELSE IF(RTP.EQ.575) THEN -C --------------------------------------------------------------------- -C ** ADDITIONAL PRODUCTS -- REPORT TYPE 575 ** -C --------------------------------------------------------------------- -C CODE FIGURE 210 - SURFACE TAG (RANGE: 0,1,3-6) -C CODE FIGURE 211 - ICE CONCENTRATION (PERCENT) -C CODE FIGURE 212 - ICE AGE (RANGE: 0,1) -C CODE FIGURE 213 - ICE EDGE (RANGE: 0,1) -C CODE FIGURE 214 - CALCULATED SURFACE TYPE (RANGE: 1-20) -C --------------------------------------------------------------------- - NLCAT8 = 5 - CALL UFBINT(LUNIT,ADDP_8,5,1,IRET,'SFTG ICON ICAG ICED SFTP') - ADDP=ADDP_8 - DO NADD = 1,5 - IF(ADDP(NADD).LT.BMISS) THEN - OB8(NADD) = NINT(ADDP(NADD)) - CF8(NADD) = 209 + NADD - END IF - ENDDO - ELSE IF(RTP.EQ.571) THEN -C --------------------------------------------------------------------- -C ** OCEAN SURFACE WIND SPEED PRODUCT -- REPORT TYPE 571 ** -C --------------------------------------------------------------------- -C CODE FIGURE 196 - OCEANIC WIND SPEED (M/S * 10) -C (RAIN FLAG IN Q.M. BYTE 2) -C --------------------------------------------------------------------- - CF8(1) = 196 - ELV = 0 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST WSOS');PROD=PROD_8 - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)*10.) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*100.) - END IF - ENDDO - ELSE - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'WSOS');PRODN=UFBINT_8 - OB8(1) = NINT(PRODN*10.) - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFLG');RFLG=UFBINT_8 - IF(RFLG.LT.BMISS) THEN - WRITE(CRF,'(I1.1)') NINT(RFLG) - Q82(1) = CRF - END IF - END IF - ELSE IF(RTP.EQ.65) THEN -C --------------------------------------------------------------------- -C ** OCEAN TOTAL PRECIPITABLE WATER PRODUCT -- REPORT TYPE 65 ** -C --------------------------------------------------------------------- -C CODE FIGURE 197 - TOTAL PRECIPITABLE WATER (MM * 10) -C (RAIN FLAG IN Q.M. BYTE 2) -C --------------------------------------------------------------------- - CF8(1) = 197 - ELV = 0 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST PH2O');PROD=PROD_8 - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)*10.) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*100.) - END IF - ENDDO - ELSE - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'PH2O');PRODN=UFBINT_8 - OB8(1) = NINT(PRODN*10.) - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'RFLG');RFLG=UFBINT_8 - IF(RFLG.LT.BMISS) THEN - WRITE(CRF,'(I1)') NINT(RFLG) - Q82(1) = CRF - END IF - END IF - ELSE IF(RTP.EQ.66) THEN -C --------------------------------------------------------------------- -C ** LAND/OCEAN RAINFALL RATE -- REPORT TYPE 66 ** -C --------------------------------------------------------------------- -C CODE FIGURE 198 - RAINFALL RATE (MM/HR) -C --------------------------------------------------------------------- - CF8(1) = 198 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST REQV');PROD=PROD_8 - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)*3600.) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*36000.) - END IF - ENDDO - ELSE - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'REQV');PRODN=UFBINT_8 - OB8(1) = NINT(PRODN*3600.) - END IF - ELSE IF(RTP.EQ.576) THEN -C --------------------------------------------------------------------- -C ** SURFACE TEMPERATURE -- REPORT TYPE 576 ** -C --------------------------------------------------------------------- -C CODE FIGURE 199 - SURFACE TEMPERATURE (DEGREES KELVIN) -C --------------------------------------------------------------------- - CF8(1) = 199 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST TMSK');PROD=PROD_8 - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*10.) - END IF - ENDDO - ELSE - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'TMSK');PRODN=UFBINT_8 - OB8(1) = NINT(PRODN) - END IF - ELSE IF(RTP.EQ.69) THEN -C --------------------------------------------------------------------- -C ** OCEAN CLOUD WATER -- REPORT TYPE 69 ** -C --------------------------------------------------------------------- -C CODE FIGURE 200 - CLOUD WATER (MM * 100) -C --------------------------------------------------------------------- - CF8(1) = 200 - ELV = 0 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST CH2O');PROD=PROD_8 - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)*100.) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*1000.) - END IF - ENDDO - ELSE - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'CH2O');PRODN=UFBINT_8 - OB8(1) = NINT(PRODN*100.) - END IF - ELSE IF(RTP.EQ.573) THEN -C --------------------------------------------------------------------- -C ** SOIL MOISTURE -- REPORT TYPE 573 ** -C --------------------------------------------------------------------- -C CODE FIGURE 201 - SOIL MOISTURE (MM) -C --------------------------------------------------------------------- - CF8(1) = 201 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST SMOI');PROD=PROD_8 - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)*1000.) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*10000.) - END IF - ENDDO - ELSE - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SMOI');PRODN=UFBINT_8 - OB8(1) = NINT(PRODN*1000.) - END IF - ELSE IF(RTP.EQ.574) THEN -C --------------------------------------------------------------------- -C ** SNOW DEPTH -- REPORT TYPE 574 ** -C --------------------------------------------------------------------- -C CODE FIGURE 202 - SNOW DEPTH (MM) -C --------------------------------------------------------------------- - CF8(1) = 202 - NLCAT8 = 1 - IF(ISUPOB.EQ.1) THEN - CALL UFBREP(LUNIT,PROD_8,2,2,IRET,'FOST SNDP');PROD=PROD_8 - DO JJ = 1,2 - IF(PROD(1,JJ).EQ.4) THEN - OB8(1) = NINT(PROD(2,JJ)*1000.) - ELSE IF(PROD(1,JJ).EQ.10) THEN - STDV = NINT(PROD(2,JJ)*10000.) - END IF - ENDDO - ELSE - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'SNDP');PRODN=UFBINT_8 - OB8(1) = NINT(PRODN*1000.) - END IF - END IF - -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -C FINISH PUTTING THE HEADER INFORMATION INTO ON29 FORMAT -C ------------------------------------------------------ - - RSV = '999 ' - RSV2 = ' ' - - IF(STDV.LT.BMISS) THEN - WRITE(CSTDV,'(I4.4)') NINT(STDV) - ELSE - CSTDV = '9999' - END IF - RSV2(3:4) = CSTDV(1:2) - RSV(1:2) = CSTDV(3:4) - - CALL UFBINT(LUNIT,UFBINT_8,1,1,IRET,'ACAV');ACAV=UFBINT_8 - IF(ACAV.LT.BMISS) THEN - WRITE(CSTDV(1:2),'(I2.2)') NINT(ACAV) - ELSE - CSTDV = '9999' - END IF - RSV2(1:2) = CSTDV(1:2) - - CALL S01O29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP) - - DO II = 1,NLCAT8 - IF(CF8(II).LT.BMISS) CALL S02O29(8,II,*9999) - ENDDO - -C PUT THE UNPACKED ON29 REPORT INTO OBS -C ------------------------------------- - - CALL S03O29(OBS,SUBSET,*9999,*9998) - - RETURN - 9999 CONTINUE - R07O29 = 999 - RETURN - 9998 CONTINUE - print'(" IW3UNP29/R07O29: RPT with ID= ",A," TOSSED - ZERO ", - $ "CAT.1-6,8,51,52 LVLS")', SID - R07O29 = -9999 - KSKSMI = KSKSMI + 1 - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: S06O29 MODIFIES AIRCRAFT ID -C PRGMMR: RAY CRAYTON ORG: W/NMC411 DATE: 1992-02-16 -C -C ABSTRACT: MODIFIES AMDAR REPORTS SO THAT LAST CHARACTER ENDS -C WITH 'Z'. -C -C PROGRAM HISTORY LOG: -C 1992-02-16 RAY CRAYTON -C -C USAGE: CALL S06O29(IDEN,ID) -C INPUT ARGUMENT LIST: -C IDEN - ACFT ID -C -C OUTPUT ARGUMENT LIST: -C ID - MODIFIED AIRCRAFT ID. -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - - SUBROUTINE S06O29(IDEN,ID) -C ---> formerly SUBROUTINE IDP - - CHARACTER*8 IDEN,ID - CHARACTER*6 ZEROES - CHARACTER*1 JCHAR - - SAVE - - DATA ZEROES/'000000'/ - - ID = ' ' - - L = INDEX(IDEN(1:8),' ') - IF(L.EQ.0) THEN - N = 8 - ELSE - N = L - 1 - IF(N.LT.1) THEN - ID = 'AMDARZ' - END IF - END IF - - IF(N.EQ.8) THEN - IF(IDEN(8:8).EQ.'Z') THEN - -C THE ID INDICATES IT IS AN 8-CHARACTER ASDAR REPORT. COMPRESS IT BY -C DELETING THE 6TH AND 7TH CHARACTER -C ------------------------------------------------------------------ - - ID = IDEN(1:5)//'Z' - GO TO 500 - END IF - END IF - - L = I05O29(IDEN(1:1),7,JCHAR) - - IF(L.EQ.0.OR.L.GT.6.OR.N.GT.6) THEN - -C UP THROUGH 6 CHARACTERS ARE LETTERS. CHANGE 6TH CHARACTER TO 'Z' -C --------------------------------------------------------------- - - IF(N.GE.5) THEN - ID = IDEN - ID(6:6) = 'Z' - ELSE - -C ZERO FILL AND ADD 'Z' TO MAKE 6 CHARAACTERS -C ------------------------------------------- - - ID = IDEN(1:N)//ZEROES(N+1:5)//'Z' - END IF - - ELSE IF(N.EQ.6) THEN - -C THE IDEN HAS 6 NUMERIC OR ALPHANUMERIC CHARACTERS -C ------------------------------------------------- - - IF(IDEN(6:6).EQ.'Z') THEN - ID = IDEN(1:6) - ELSE IF(L.GT.3) THEN - ID = IDEN(1:3)//IDEN(5:6)//'Z' - ELSE IF(L.EQ.1) THEN - ID = IDEN(2:6)//'Z' - ELSE - ID = IDEN(1:L-1)//IDEN(L+1:6)//'Z' - END IF - - ELSE IF(N.EQ.5) THEN - -C THE IDEN HAS 5 NUMERIC OR ALPHANUMERIC CHARACTERS -C ------------------------------------------------- - - ID = IDEN(1:5)//'Z' - ELSE - -C THE IDEN HAS 1-4 NUMERIC OR ALPHANUMERIC CHARACTERS -C --------------------------------------------------- - - IF(L.EQ.1) THEN - ID = ZEROES(1:5-N)//IDEN(1:N)//'Z' - ELSE - IF(N.LT.L) THEN - IDEN(1:6) = 'AMDARZ' - ELSE - ID = IDEN(1:L-1)// ZEROES(1:5-N)//IDEN(L:N)//'Z' - END IF - END IF - END IF - - 500 CONTINUE - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: I05O29 FINDS LOCATION OF NEXT NUMERIC -C PRGMMR: RAY CRAYTON ORG: W/NMC41 DATE: 1989-07-07 -C -C ABSTRACT: FINDS THE LOCATION OF THE NEXT NUMERIC CHARACTER -C IN A STRING OF CHARACTERS. -C -C PROGRAM HISTORY LOG: -C 1989-07-07 RAY CRAYTON -C -C USAGE: LOC=I05O29(STRING,NUM,CHAR) -C INPUT ARGUMENT LIST: -C STRING - CHARACTER ARRAY. -C NUM - NUMBER OF CHARACTERS TO SEARCH IN STRING. -C -C OUTPUT ARGUMENT LIST: -C I05O29 - INTEGER*4 LOCATION OF ALPHANUMERIC CHARACTER. -C = 0 IF NOT FOUND. -C CHAR - CHARACTER FOUND. -C -C REMARKS: NONE -C -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - FUNCTION I05O29(STRING,NUM,CHAR) -C ---> formerly FUNCTION IFIG - CHARACTER*1 STRING(1),CHAR - - SAVE - - DO I = 1,NUM - IF(STRING(I).GE.'0'.AND.STRING(I).LE.'9') THEN - I05O29 = I - CHAR = STRING(I) - GO TO 200 - END IF - ENDDO - I05O29 = 0 - CHAR = '?' - 200 CONTINUE - RETURN - END diff --git a/external/w3nco/v2.0.6/src/ixgb.f b/external/w3nco/v2.0.6/src/ixgb.f deleted file mode 100644 index 0645a3f9..00000000 --- a/external/w3nco/v2.0.6/src/ixgb.f +++ /dev/null @@ -1,155 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE IXGB(LUGB,LSKIP,LGRIB,NLEN,NNUM,MLEN,CBUF) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: IXGB MAKE INDEX RECORD -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 -C -C ABSTRACT: THIS SUBPROGRAM MAKES ONE INDEX RECORD. -C BYTE 001-004: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE -C BYTE 005-008: BYTES TO SKIP IN MESSAGE BEFORE PDS -C BYTE 009-012: BYTES TO SKIP IN MESSAGE BEFORE GDS (0 IF NO GDS) -C BYTE 013-016: BYTES TO SKIP IN MESSAGE BEFORE BMS (0 IF NO BMS) -C BYTE 017-020: BYTES TO SKIP IN MESSAGE BEFORE BDS -C BYTE 021-024: BYTES TOTAL IN THE MESSAGE -C BYTE 025-025: GRIB VERSION NUMBER -C BYTE 026-053: PRODUCT DEFINITION SECTION (PDS) -C BYTE 054-095: GRID DEFINITION SECTION (GDS) (OR NULLS) -C BYTE 096-101: FIRST PART OF THE BIT MAP SECTION (BMS) (OR NULLS) -C BYTE 102-112: FIRST PART OF THE BINARY DATA SECTION (BDS) -C BYTE 113-172: (OPTIONAL) BYTES 41-100 OF THE PDS -C BYTE 173-184: (OPTIONAL) BYTES 29-40 OF THE PDS -C BYTE 185-320: (OPTIONAL) BYTES 43-178 OF THE GDS -C -C PROGRAM HISTORY LOG: -C 95-10-31 IREDELL -C 96-10-31 IREDELL AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320 -C 2001-06-05 IREDELL APPLY LINUX PORT BY EBISUZAKI -C -C USAGE: CALL WRGI1R(LUGB,LSKIP,LGRIB,LUGI) -C INPUT ARGUMENTS: -C LUGB INTEGER LOGICAL UNIT OF INPUT GRIB FILE -C LSKIP INTEGER NUMBER OF BYTES TO SKIP BEFORE GRIB MESSAGE -C LGRIB INTEGER NUMBER OF BYTES IN GRIB MESSAGE -C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES -C NNUM INTEGER INDEX RECORD NUMBER TO MAKE -C OUTPUT ARGUMENTS: -C MLEN INTEGER ACTUAL VALID LENGTH OF INDEX RECORD -C CBUF CHARACTER*1 (MBUF) BUFFER TO RECEIVE INDEX DATA -C -C SUBPROGRAMS CALLED: -C GBYTEC GET INTEGER DATA FROM BYTES -C SBYTEC STORE INTEGER DATA IN BYTES -C BAREAD BYTE-ADDRESSABLE READ -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - CHARACTER CBUF(*) - PARAMETER(LINDEX=112,MINDEX=320) - PARAMETER(IXSKP=0,IXSPD=4,IXSGD=8,IXSBM=12,IXSBD=16,IXLEN=20, - & IXVER=24,IXPDS=25,IXGDS=53,IXBMS=95,IXBDS=101, - & IXPDX=112,IXPDW=172,IXGDX=184) - PARAMETER(MXSKP=4,MXSPD=4,MXSGD=4,MXSBM=4,MXSBD=4,MXLEN=4, - & MXVER=1,MXPDS=28,MXGDS=42,MXBMS=6,MXBDS=11, - & MXPDX=60,MXPDW=12,MXGDX=136) - CHARACTER CBREAD(MINDEX),CINDEX(MINDEX) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C INITIALIZE INDEX RECORD AND READ GRIB MESSAGE - MLEN=LINDEX - CINDEX=CHAR(0) - CALL SBYTEC(CINDEX,LSKIP,8*IXSKP,8*MXSKP) - CALL SBYTEC(CINDEX,LGRIB,8*IXLEN,8*MXLEN) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PUT PDS IN INDEX RECORD - ISKPDS=8 - IBSKIP=LSKIP - IBREAD=ISKPDS+MXPDS - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CINDEX(IXVER+1)=CBREAD(8) - CALL SBYTEC(CINDEX,ISKPDS,8*IXSPD,8*MXSPD) - CALL GBYTEC(CBREAD,LENPDS,8*ISKPDS,8*3) - CALL GBYTEC(CBREAD,INCGDS,8*ISKPDS+8*7+0,1) - CALL GBYTEC(CBREAD,INCBMS,8*ISKPDS+8*7+1,1) - ILNPDS=MIN(LENPDS,MXPDS) - CINDEX(IXPDS+1:IXPDS+ILNPDS)=CBREAD(ISKPDS+1:ISKPDS+ILNPDS) - ISKTOT=ISKPDS+LENPDS -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PUT PDS EXTENSION IN INDEX RECORD - IF(LENPDS.GT.MXPDS) THEN - ISKPDW=ISKPDS+MXPDS - ILNPDW=MIN(LENPDS-MXPDS,MXPDW) - IBSKIP=LSKIP+ISKPDW - IBREAD=ILNPDW - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CINDEX(IXPDW+1:IXPDW+ILNPDW)=CBREAD(1:ILNPDW) - ISKPDX=ISKPDS+(MXPDS+MXPDW) - ILNPDX=MIN(LENPDS-(MXPDS+MXPDW),MXPDX) - IBSKIP=LSKIP+ISKPDX - IBREAD=ILNPDX - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CINDEX(IXPDX+1:IXPDX+ILNPDX)=CBREAD(1:ILNPDX) - MLEN=MAX(MLEN,IXPDW+ILNPDW,IXPDX+ILNPDX) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PUT GDS IN INDEX RECORD - IF(INCGDS.NE.0) THEN - ISKGDS=ISKTOT - IBSKIP=LSKIP+ISKGDS - IBREAD=MXGDS - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CALL SBYTEC(CINDEX,ISKGDS,8*IXSGD,8*MXSGD) - CALL GBYTEC(CBREAD,LENGDS,0,8*3) - ILNGDS=MIN(LENGDS,MXGDS) - CINDEX(IXGDS+1:IXGDS+ILNGDS)=CBREAD(1:ILNGDS) - ISKTOT=ISKGDS+LENGDS - IF(LENGDS.GT.MXGDS) THEN - ISKGDX=ISKGDS+MXGDS - ILNGDX=MIN(LENGDS-MXGDS,MXGDX) - IBSKIP=LSKIP+ISKGDX - IBREAD=ILNGDX - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CINDEX(IXGDX+1:IXGDX+ILNGDX)=CBREAD(1:ILNGDX) - MLEN=MAX(MLEN,IXGDX+ILNGDX) - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PUT BMS IN INDEX RECORD - IF(INCBMS.NE.0) THEN - ISKBMS=ISKTOT - IBSKIP=LSKIP+ISKBMS - IBREAD=MXBMS - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CALL SBYTEC(CINDEX,ISKBMS,8*IXSBM,8*MXSBM) - CALL GBYTEC(CBREAD,LENBMS,0,8*3) - ILNBMS=MIN(LENBMS,MXBMS) - CINDEX(IXBMS+1:IXBMS+ILNBMS)=CBREAD(1:ILNBMS) - ISKTOT=ISKBMS+LENBMS - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PUT BDS IN INDEX RECORD - ISKBDS=ISKTOT - IBSKIP=LSKIP+ISKBDS - IBREAD=MXBDS - CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) - IF(LBREAD.NE.IBREAD) RETURN - CALL SBYTEC(CINDEX,ISKBDS,8*IXSBD,8*MXSBD) - CALL GBYTEC(CBREAD,LENBDS,0,8*3) - ILNBDS=MIN(LENBDS,MXBDS) - CINDEX(IXBDS+1:IXBDS+ILNBDS)=CBREAD(1:ILNBDS) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C STORE INDEX RECORD - MLEN=MIN(MLEN,NLEN) - NSKIP=NLEN*(NNUM-1) - CBUF(NSKIP+1:NSKIP+MLEN)=CINDEX(1:MLEN) - CBUF(NSKIP+MLEN+1:NSKIP+NLEN)=CHAR(0) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/lengds.f b/external/w3nco/v2.0.6/src/lengds.f deleted file mode 100644 index 051aed69..00000000 --- a/external/w3nco/v2.0.6/src/lengds.f +++ /dev/null @@ -1,40 +0,0 @@ -C----------------------------------------------------------------------- - FUNCTION LENGDS(KGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: LENGDS RETURN THE LENGTH OF A GRID -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-07-19 -C -C ABSTRACT: GIVEN A GRID DESCRIPTION SECTION (IN W3FI63 FORMAT), -C RETURN ITS SIZE IN TERMS OF NUMBER OF DATA POINTS. -C -C PROGRAM HISTORY LOG: -C 96-07-19 IREDELL -C -C USAGE: CALL LENGDS(KGDS) -C INPUT ARGUMENTS: -C KGDS INTEGER (200) GDS PARAMETERS IN W3FI63 FORMAT -C OUTPUT ARGUMENTS: -C LENGDS INTEGER SIZE OF GRID -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN -C -C$$$ - INTEGER KGDS(200) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C SPECIAL CASE OF STAGGERED ETA - IF(KGDS(1).EQ.201) THEN - LENGDS=KGDS(7)*KGDS(8)-KGDS(8)/2 -C SPECIAL CASE OF FILLED ETA - ELSEIF(KGDS(1).EQ.202) THEN - LENGDS=KGDS(7)*KGDS(8) -C SPECIAL CASE OF THINNED WAFS - ELSEIF(KGDS(19).EQ.0.AND.KGDS(20).NE.255) THEN - LENGDS=KGDS(21) -C GENERAL CASE - ELSE - LENGDS=KGDS(2)*KGDS(3) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END diff --git a/external/w3nco/v2.0.6/src/makwmo.f b/external/w3nco/v2.0.6/src/makwmo.f deleted file mode 100644 index d8d4e0c3..00000000 --- a/external/w3nco/v2.0.6/src/makwmo.f +++ /dev/null @@ -1,89 +0,0 @@ - SUBROUTINE MAKWMO (BULHED,IDAY,IHOUR,KWBX,HEADER) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: MAKWMO FORMAT THE WMO HEADER -C PRGMMR: FARLEY ORG: W/NMC42 DATE: 84-07-06 -C -C ABSTRACT: FORMS THE WMO HEADER FOR A GIVEN BULLETIN. -C -C PROGRAM HISTORY LOG: -C 84-07-06 FARLEY ORIGINAL AUTHOR -C 94-10-10 R.E.JONES CHANGES FOR CRAY -C 95-10-18 R.E.JONES ADD PARAMETER KWBX TO CALL -C 98-06-16 Gilbert Changed argument list to pass in day and hour -C instead of the old O.N. 84 date word. -C 2003-03-28 Gilbert Removed equivalences. -C -C USAGE: CALL MAKWMO(BULHED,IDAY,IHOUR,KWBX,HEADER) -C INPUT ARGUMENT LIST: -C BULHED - TTAAII BULLETIN HEADER FT10 -C IDAY - Day of Month -C IHOUR - Hour of Day. -C KWBX - 4 CHARACTERS (KWBC TO KWBQ) -C -C OUTPUT ARGUMENT LIST: -C HEADER - COMPLETE WMO HEADER IN ASCII -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM SP -C -C$$$ -C - CHARACTER * 6 BULHED - CHARACTER * 1 HEADER (*) - CHARACTER * 1 WMOHDR (21) - CHARACTER * 4 KWBX - CHARACTER * 2 CTEMP -C -C-------------------------------------------------------------------- -C -C 1. CREATE WMO HEADER. -C -C 1.1 CONVERT BULHED FROM EBCDIC TO ASCII. -C -C WRITE (6,FMT='('' MADE IT TO MAKWMO'')') -C - DO I = 1,6 - WMOHDR(I) = BULHED(I:I) - END DO - WMOHDR(7)=char(32) ! ASCII BLANK -C -C MOVE KWBX INTO WMO HEADER -C - DO I = 1,4 - WMOHDR(I+7) = KWBX(I:I) - END DO - WMOHDR(12)=char(32) ! ASCII BLANK -C -C 1.2 PICK OFF THE DAY OF MONTH (YY) -C AND CONVERT TO ASCII. -C - write(ctemp,fmt='(I2.2)') IDAY - WMOHDR(13)=ctemp(1:1) - WMOHDR(14)=ctemp(2:2) -C -C 1.3 PICK OFF THE HOUR(GG) AND CONVERT TO ASCII. -C - write(ctemp,fmt='(I2.2)') IHOUR - WMOHDR(15)=ctemp(1:1) - WMOHDR(16)=ctemp(2:2) -C -C 1.4 FIL IN REST OF HEADER -C - WMOHDR(17)=char(48) ! ASCII "0" - WMOHDR(18)=char(48) ! ASCII "0" - WMOHDR(19)=char(13) ! ASCII CR = '\r' - WMOHDR(20)=char(13) ! ASCII CR = '\r' - WMOHDR(21)=char(10) ! ASCII LF = '\n' -C -C-------------------------------------------------------------------- -C -C 2. MOVE WMOHDR TO OUTPUT FIELD. -C - DO 200 I = 1,21 - HEADER(I) = WMOHDR(I) - 200 CONTINUE -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/mkfldsep.f b/external/w3nco/v2.0.6/src/mkfldsep.f deleted file mode 100644 index 706dd1b1..00000000 --- a/external/w3nco/v2.0.6/src/mkfldsep.f +++ /dev/null @@ -1,105 +0,0 @@ - subroutine mkfldsep(csep,iopt,lenin,lenbull,lenout) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: mkfldsep Makes TOC Flag Field Separator Block -C PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-09-16 -C -C ABSTRACT: Generates a TOC Flag Field Separator Block used to separate -C WMO Bulletins within a transmission file to be ingested in TOC's -C FTP Input Service, which can be used to disseminate WMO buletins. -C ( see http://weather.gov/tg/ftpingest.html ) -C -C This routine can generate different flag field separator blocks -C depending on the value of variable iopt. -C -C Bulletin "Flag Field Separator" block - OPTION 1 (old) -C bytes 1 - 4 marker string (####) -C 5 - 7 block length [018 fixed value] -C 8 - 13 total length of bulletin in bytes [octets] -C (not including the flag field block) -C 14 - 17 marker string (####) -C 18 line Feed (ASCII "0A") -C -C Bulletin "Flag Field Separator" block - OPTION 1a (new) -C bytes 1 - 4 marker string (####) -C 5 - 7 block length (nnn) - value always greater than 018 -C 8 - 18 total length of bulletin in bytes [octets] -C (not including the flag field block) -C 19 - nnn-5 reserved for future use -C nnn-4 - nnn-1 marker string (####) -C nnn line Feed (ASCII "0A") -C -C Bulletin "Flag Field Separator" block - OPTION 2 (limited) -C bytes 1 - 4 marker string (****) -C 5 - 14 total length of bulletin in bytes [octets] -C (not including the flag field block) -C 15 - 18 marker string (****) -C 19 line Feed (ASCII "0A") -C -C -C PROGRAM HISTORY LOG: -C 2002-09-16 Gilbert ORIGINAL AUTHOR -C -C USAGE: call mkfldsep(csep,iopt,lenin,lenbull,lenout) -C INPUT ARGUMENT LIST: -C iopt Flag Field Separator block option: -C = 1: Separator block for use with alphanumeric bulletins. -C if lenin <= 18 and lenbull <= 999999, -C OPTION 1 block will be generated. -C if lenin > 18 or lenbull > 999999, -C OPTION 1a block will be generated. -C = 2: Separator block for use with GRIB/BUFR bulletins. -C lenin Desired length of the flag field separator block. -C ignored, if iopt=2. -C lenbull Integer length of the bulletin (in bytes) that will follow -C this separator block. -C -C OUTPUT ARGUMENT LIST: -C csep*(*) Character array containing the flag field separator. -C lenout Integer length of the flag field separator block. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM/SP -C -C$$$ -C - character*(*),intent(out) :: csep - integer,intent(in) :: iopt,lenin,lenbull - integer,intent(out) :: lenout -C - character(len=4),parameter :: cstar='****',clb='####' -C - if (iopt.eq.1) then - if ( lenin .le. 18 .and. lenbull .le. 999999 ) then - ! Create OPTION 1 separator block - csep(1:4)=clb - csep(5:7)='018' - write(csep(8:13),fmt='(I6.6)') lenbull - csep(14:17)=clb - csep(18:18)=char(10) - lenout=18 - else ! Create OPTION 1a separator block - nnn=lenin - if ( nnn.lt.23 ) nnn=23 - csep(1:4)=clb - write(csep(5:7),fmt='(I3.3)') nnn - write(csep(8:18),fmt='(I11.11)') lenbull - csep(19:nnn-5)='0' - csep(nnn-4:nnn-1)=clb - csep(nnn:nnn)=char(10) - lenout=nnn - endif - elseif (iopt.eq.2) then ! Create OPTION 2 separator block - csep(1:4)=cstar - write(csep(5:14),fmt='(I10.10)') lenbull - csep(15:18)=cstar - csep(19:19)=char(10) - lenout=19 - else - print *,"mkfldsep: Option ",iopt," not recognized." - csep(1:lenin)=' ' - endif -C - return - end diff --git a/external/w3nco/v2.0.6/src/mova2i.c b/external/w3nco/v2.0.6/src/mova2i.c deleted file mode 100644 index 7627c908..00000000 --- a/external/w3nco/v2.0.6/src/mova2i.c +++ /dev/null @@ -1,68 +0,0 @@ -/*$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: mova2i Moves a bit string from a char*1 to int -C PRGMMR: Gilbert ORG: W/NP11 DATE: 02-08-15 -C -C ABSTRACT: This Function copies a bit string from a Character*1 variable -C to an integer variable. It is intended to replace the Fortran Intrinsic -C Function ICHAR, which only supports 0 <= ICHAR(a) <= 127 on the -C IBM SP. If "a" is greater than 127 in the collating sequence, -C ICHAR(a) does not return the expected bit value. -C This function can be used for all values 0 <= ICHAR(a) <= 255. -C -C PROGRAM HISTORY LOG: -C 98-12-15 Gilbert -C -C USAGE: I = mova2i(a) -C -C INPUT ARGUMENT : -C -C a - Character*1 variable that holds the bitstring to extract -C -C RETURN ARGUMENT : -C -C mova2i - Integer value of the bitstring in character a -C -C REMARKS: -C -C None -C -C ATTRIBUTES: -C LANGUAGE: C -C MACHINE: IBM SP - -C -C$$$i*/ - -#ifdef CRAY90 - #include - int MOVA2I(unsigned char *a) -#endif -#ifdef HP - int mova2i(unsigned char *a) -#endif -#ifdef SGI - int mova2i_(unsigned char *a) -#endif -#ifdef MACOSX - int mova2i_(unsigned char *a) -#endif -#ifdef LINUX - int mova2i_(unsigned char *a) -#endif -#ifdef LINUXF90 - int MOVA2I(unsigned char *a) -#endif -#ifdef VPP5000 - int mova2i_(unsigned char *a) -#endif -#ifdef IBM4 - int mova2i(unsigned char *a) -#endif -#ifdef IBM8 - long long int mova2i(unsigned char *a) -#endif - -{ - return (int)(*a); -} diff --git a/external/w3nco/v2.0.6/src/pdsens.f b/external/w3nco/v2.0.6/src/pdsens.f deleted file mode 100644 index a5068026..00000000 --- a/external/w3nco/v2.0.6/src/pdsens.f +++ /dev/null @@ -1,76 +0,0 @@ -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: PDSENS.F PACKS GRIB PDS EXTENSION 41- FOR ENSEMBLE -C PRGMMR: RICHARD WOBUS ORG: W/NP20 DATE: 98-09-28 -C -C ABSTRACT: PACKS BRIB PDS EXTENSION STARTING ON BYTE 41 FOR ENSEMBLE -C FORECAST PRODUCTS. FOR FORMAT OF PDS EXTENSION, SEE NMC OFFICE NOTE 38 -C -C PROGRAM HISTORY LOG: -C 95-03-14 ZOLTAN TOTH AND MARK IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-09-28 WOBUS CORRECTED MEMBER ENTRY, BLANK ALL UNUSED FIELDS -C 2001-06-05 IREDELL APPLY LINUX PORT BY EBISUZAKI -C -C USAGE: CALL PDSENS.F(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA) -C INPUT ARGUMENT LIST: -C KENS(5) - BYTES 41-45 (GENERAL SECTION, ALWAYS PRESENT.) -C KPROB(2) - BYTES 46-47 (PROBABILITY SECTION, PRESENT ONLY IF NEEDE -C XPROB(2) - BYTES 48-51&52-55 (PROBABILITY SECTION, IF NEEDED.) -C KCLUST(16)-BYTES 61-76 (CLUSTERING SECTION, IF NEEDED.) -C KMEMBR(80)-BYTES 77-86 (CLUSTER MEMBERSHIP SECTION, IF NEEDED.) -C ILAST - LAST BYTE TO BE PACKED (IF GREATER OR EQUAL TO FIRST BY -C IN ANY OF FOUR SECTIONS ABOVE, WHOLE SECTION IS PACKED. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C MSGA - FULL PDS SECTION, INCLUDING NEW ENSEMBLE EXTENSION -C -C REMARKS: USE PDSEUP.F FOR UNPACKING PDS ENSEMBLE EXTENSION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ -C TESTING GRIB EXTENSION 41- PACKER AND UNPACKER SUBROUTINES -C -CFPP$ NOCONCUR R - SUBROUTINE PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA) - INTEGER KENS(5),KPROB(2),KCLUST(16),KMEMBR(80) - DIMENSION XPROB(2) - CHARACTER*1 MSGA(100) - IF(ILAST.LT.41) THEN - GO TO 333 - ENDIF -C PACKING IS DONE IN FOUR SECTIONS ENDING AT BYTE IL - IF(ILAST.GE.41) IL=45 - IF(ILAST.GE.46) IL=55 - IF(ILAST.GE.61) IL=76 - IF(ILAST.GE.77) IL=86 - do i=42,il - CALL SBYTEC(MSGA, 0, i*8, 8) - enddo -C CHANGING THE NUMBER OF BYTES (FIRST THREE BYTES IN PDS) - CALL SBYTEC(MSGA, IL, 0,24) -C PACKING FIRST SECTION (GENERAL INTORMATION SECTION) - IF(IL.GE.45) CALL SBYTESC(MSGA,KENS,40*8,8,0,5) -C PACKING 2ND SECTION (PROBABILITY SECTION) - IF(IL.GE.55) THEN - CALL SBYTESC(MSGA,KPROB,45*8,8,0,2) - CALL W3FI01(LW) - CALL W3FI76(XPROB(1),IEXP,IMANT,8*LW) - CALL SBYTEC(MSGA,IEXP,47*8,8) - CALL SBYTEC(MSGA,IMANT,48*8,24) - CALL W3FI76(XPROB(2),IEXP,IMANT,8*LW) - CALL SBYTEC(MSGA,IEXP,51*8,8) - CALL SBYTEC(MSGA,IMANT,52*8,24) - ENDIF -C PACKING 3RD SECTION (CLUSTERING INFORMATION) - IF(IL.GE.76) CALL SBYTESC(MSGA,KCLUST,60*8,8,0,16) -C PACKING 4TH SECTION (CLUSTER MEMBERSHIP) - IF(IL.GE.86) CALL SBYTESC(MSGA,KMEMBR,76*8,1,0,80) -C - 333 CONTINUE - RETURN - END diff --git a/external/w3nco/v2.0.6/src/pdseup.f b/external/w3nco/v2.0.6/src/pdseup.f deleted file mode 100644 index 7127a258..00000000 --- a/external/w3nco/v2.0.6/src/pdseup.f +++ /dev/null @@ -1,74 +0,0 @@ -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: PDSEUP.F UNPACKS GRIB PDS EXTENSION 41- FOR ENSEMBLE -C PRGMMR: RICHARD WOBUS ORG: W/NP20 DATE: 98-09-28 -C -C ABSTRACT: UNPACKS GRIB PDS EXTENSION STARTING ON BYTE 41 FOR ENSEMBLE -C FORECAST PRODUCTS. FOR FORMAT OF PDS EXTENSION, SEE NMC OFFICE NOTE 38 -C -C PROGRAM HISTORY LOG: -C 95-03-14 ZOLTAN TOTH AND MARK IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-09-28 WOBUS CORRECTED MEMBER EXTRACTION -C 2001-06-05 IREDELL APPLY LINUX PORT BY EBISUZAKI -C -C USAGE: CALL PDSENS.F(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA) -C INPUT ARGUMENT LIST: -C ILAST - LAST BYTE TO BE UNPACKED (IF GREATER/EQUAL TO FIRST BYT -C IN ANY OF FOUR SECTIONS BELOW, WHOLE SECTION IS PACKED. -C MSGA - FULL PDS SECTION, INCLUDING NEW ENSEMBLE EXTENSION -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KENS(5) - BYTES 41-45 (GENERAL SECTION, ALWAYS PRESENT.) -C KPROB(2) - BYTES 46-47 (PROBABILITY SECTION, PRESENT ONLY IF NEEDE -C XPROB(2) - BYTES 48-51&52-55 (PROBABILITY SECTION, IF NEEDED.) -C KCLUST(16)-BYTES 61-76 (CLUSTERING SECTION, IF NEEDED.) -C KMEMBR(80)-BYTES 77-86 (CLUSTER MEMBERSHIP SECTION, IF NEEDED.) -C -C REMARKS: USE PDSENS.F FOR PACKING PDS ENSEMBLE EXTENSION. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: CF77 FORTRAN -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ -C - SUBROUTINE PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA) - INTEGER KENS(5),KPROB(2),KCLUST(16),KMEMBR(80) - DIMENSION XPROB(2) - CHARACTER*1 MSGA(100) -C CHECKING TOTAL NUMBER OF BYTES IN PDS (IBYTES) - CALL GBYTEC(MSGA, IBYTES, 0,24) - IF(ILAST.GT.IBYTES) THEN -C ILAST=IBYTES - GO TO 333 - ENDIF - IF(ILAST.LT.41) THEN - GO TO 333 - ENDIF -C UNPACKING FIRST SECTION (GENERAL INFORMATION) - CALL GBYTESC(MSGA,KENS,40*8,8,0,5) -C UNPACKING 2ND SECTION (PROBABILITY SECTION) - IF(ILAST.GE.46) THEN - CALL GBYTESC(MSGA,KPROB,45*8,8,0,2) -C - CALL GBYTEC (MSGA,JSGN,47*8,1) - CALL GBYTEC (MSGA,JEXP,47*8+1,7) - CALL GBYTEC (MSGA,IFR,47*8+8,24) - XPROB(1)=(-1)**JSGN*IFR*16.**(JEXP-70) -C - CALL GBYTEC (MSGA,JSGN,51*8,1) - CALL GBYTEC (MSGA,JEXP,51*8+1,7) - CALL GBYTEC (MSGA,IFR,51*8+8,24) - XPROB(2)=(-1)**JSGN*IFR*16.**(JEXP-70) - ENDIF -C -C UNPACKING 3RD SECTION (CLUSTERING INFORMATION) - IF(ILAST.GE.61) CALL GBYTESC(MSGA,KCLUST,60*8,8,0,16) -C UNPACKING 4TH SECTION (CLUSTERMEMBERSHIP INFORMATION) - IF(ILAST.GE.77) CALL GBYTESC(MSGA,KMEMBR,76*8,1,0,80) -C - 333 CONTINUE - RETURN - END diff --git a/external/w3nco/v2.0.6/src/putgb.f b/external/w3nco/v2.0.6/src/putgb.f deleted file mode 100644 index 072062da..00000000 --- a/external/w3nco/v2.0.6/src/putgb.f +++ /dev/null @@ -1,201 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE PUTGB(LUGB,KF,KPDS,KGDS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PUTGB PACKS AND WRITES A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. -C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGB. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 09-10-15 GAYNO INCREASED MAXBIT FROM 16 TO 32 -C -C USAGE: CALL PUTGB(LUGB,KF,KPDS,KGDS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C KF INTEGER NUMBER OF DATA POINTS -C KPDS INTEGER (200) PDS PARAMETERS -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C KGDS INTEGER (200) GDS PARAMETERS -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C LB LOGICAL*1 (KF) BITMAP IF PRESENT -C F REAL (KF) DATA -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C 0 ALL OK -C OTHER W3FI72 GRIB PACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS -C GETBIT GET NUMBER OF BITS AND ROUND DATA -C W3FI72 PACK GRIB -C WRYTE WRITE DATA -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200) - LOGICAL*1 LB(KF) - REAL F(KF) - PARAMETER(MAXBIT=32) - INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) - REAL FR(KF) - CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET W3FI72 PARAMETERS - CALL R63W72(KPDS,KGDS,IPDS,IGDS) - IBDS=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COUNT VALID DATA - KBM=KF - IF(IPDS(7).NE.0) THEN - KBM=0 - DO I=1,KF - IF(LB(I)) THEN - IBM(I)=1 - KBM=KBM+1 - ELSE - IBM(I)=0 - ENDIF - ENDDO - IF(KBM.EQ.KF) IPDS(7)=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET NUMBER OF BITS AND ROUND DATA - IF(KBM.EQ.0) THEN - DO I=1,KF - FR(I)=0. - ENDDO - NBIT=0 - ELSE - CALL GETBIT(IPDS(7),0,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) - NBIT=MIN(NBIT,MAXBIT) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PACK AND WRITE GRIB DATA - CALL W3FI72(0,FR,0,NBIT,0,IPDS,PDS, - & 1,255,IGDS,0,0,IBM,KF,IBDS, - & KFO,GRIB,LGRIB,IRET) - IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/putgbe.f b/external/w3nco/v2.0.6/src/putgbe.f deleted file mode 100644 index 57b75673..00000000 --- a/external/w3nco/v2.0.6/src/putgbe.f +++ /dev/null @@ -1,213 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE PUTGBE(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PUTGBE PACKS AND WRITES A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. -C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL PUTGBE(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C KF INTEGER NUMBER OF DATA POINTS -C KPDS INTEGER (200) PDS PARAMETERS -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C KGDS INTEGER (200) GDS PARAMETERS -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C KENS INTEGER (200) ENSEMBLE PDS PARMS -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C LB LOGICAL*1 (KF) BITMAP IF PRESENT -C F REAL (KF) DATA -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C 0 ALL OK -C OTHER W3FI72 GRIB PACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS -C GETBIT GET NUMBER OF BITS AND ROUND DATA -C W3FI72 PACK GRIB -C WRYTE WRITE DATA -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200),KENS(200) - LOGICAL*1 LB(KF) - REAL F(KF) - PARAMETER(MAXBIT=16) - INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) - REAL FR(KF) - CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET W3FI72 PARAMETERS - CALL R63W72(KPDS,KGDS,IPDS,IGDS) - IBDS=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COUNT VALID DATA - KBM=KF - IF(IPDS(7).NE.0) THEN - KBM=0 - DO I=1,KF - IF(LB(I)) THEN - IBM(I)=1 - KBM=KBM+1 - ELSE - IBM(I)=0 - ENDIF - ENDDO - IF(KBM.EQ.KF) IPDS(7)=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET NUMBER OF BITS AND ROUND DATA - IF(KBM.EQ.0) THEN - DO I=1,KF - FR(I)=0. - ENDDO - NBIT=0 - ELSE - CALL GETBIT(IPDS(7),0,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) - NBIT=MIN(NBIT,MAXBIT) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CREATE PRODUCT DEFINITION SECTION - CALL W3FI68(IPDS,PDS) - IF(IPDS(24).EQ.2) THEN - ILAST=45 - CALL PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,PDS) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PACK AND WRITE GRIB DATA - CALL W3FI72(0,FR,0,NBIT,1,IPDS,PDS, - & 1,255,IGDS,0,0,IBM,KF,IBDS, - & KFO,GRIB,LGRIB,IRET) - IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/putgben.f b/external/w3nco/v2.0.6/src/putgben.f deleted file mode 100644 index cdae8600..00000000 --- a/external/w3nco/v2.0.6/src/putgben.f +++ /dev/null @@ -1,223 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE PUTGBEN(LUGB,KF,KPDS,KGDS,KENS,IBS,NBITS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PUTGBEN PACKS AND WRITES A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. -C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 2001-03-16 IREDELL CORRECTED ARGUMENT LIST TO INCLUDE IBS -C -C USAGE: CALL PUTGBEN(LUGB,KF,KPDS,KGDS,KENS,IBS,NBITS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C KF INTEGER NUMBER OF DATA POINTS -C KPDS INTEGER (200) PDS PARAMETERS -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C KGDS INTEGER (200) GDS PARAMETERS -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C KENS INTEGER (200) ENSEMBLE PDS PARMS -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C IBS INTEGER BINARY SCALE FACTOR (0 TO IGNORE) -C NBITS INTEGER NUMBER OF BITS IN WHICH TO PACK (0 TO IGNORE) -C LB LOGICAL*1 (KF) BITMAP IF PRESENT -C F REAL (KF) DATA -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C 0 ALL OK -C OTHER W3FI72 GRIB PACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS -C GETBIT GET NUMBER OF BITS AND ROUND DATA -C W3FI72 PACK GRIB -C WRYTE WRITE DATA -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200),KENS(200) - LOGICAL*1 LB(KF) - REAL F(KF) - PARAMETER(MAXBIT=16) - INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) - REAL FR(KF) - CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET W3FI72 PARAMETERS - CALL R63W72(KPDS,KGDS,IPDS,IGDS) - IBDS=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COUNT VALID DATA - KBM=KF - IF(IPDS(7).NE.0) THEN - KBM=0 - DO I=1,KF - IF(LB(I)) THEN - IBM(I)=1 - KBM=KBM+1 - ELSE - IBM(I)=0 - ENDIF - ENDDO - IF(KBM.EQ.KF) IPDS(7)=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET NUMBER OF BITS AND ROUND DATA - IF(NBITS.GT.0) THEN - DO I=1,KF - FR(I)=F(I) - ENDDO - NBIT=NBITS - ELSE - IF(KBM.EQ.0) THEN - DO I=1,KF - FR(I)=0. - ENDDO - NBIT=0 - ELSE - CALL GETBIT(IPDS(7),IBS,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) - NBIT=MIN(NBIT,MAXBIT) - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CREATE PRODUCT DEFINITION SECTION - CALL W3FI68(IPDS,PDS) - IF(IPDS(24).EQ.2) THEN - ILAST=45 - CALL PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,PDS) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PACK AND WRITE GRIB DATA - CALL W3FI72(0,FR,0,NBIT,1,IPDS,PDS, - & 1,255,IGDS,0,0,IBM,KF,IBDS, - & KFO,GRIB,LGRIB,IRET) - IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/putgbex.f b/external/w3nco/v2.0.6/src/putgbex.f deleted file mode 100644 index f21413e4..00000000 --- a/external/w3nco/v2.0.6/src/putgbex.f +++ /dev/null @@ -1,222 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE PUTGBEX(LUGB,KF,KPDS,KGDS,KENS, - & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PUTGBE PACKS AND WRITES A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. -C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 97-02-11 Y.ZHU INCLUDED PROBABILITY AND CLUSTER ARGUMENTS -C -C USAGE: CALL PUTGBE(LUGB,KF,KPDS,KGDS,KENS, -C & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C KF INTEGER NUMBER OF DATA POINTS -C KPDS INTEGER (200) PDS PARAMETERS -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C KGDS INTEGER (200) GDS PARAMETERS -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C KENS INTEGER (200) ENSEMBLE PDS PARMS -C (1) - APPLICATION IDENTIFIER -C (2) - ENSEMBLE TYPE -C (3) - ENSEMBLE IDENTIFIER -C (4) - PRODUCT IDENTIFIER -C (5) - SMOOTHING FLAG -C KPROB INTEGER (2) PROBABILITY ENSEMBLE PARMS -C XPROB REAL (2) PROBABILITY ENSEMBLE PARMS -C KCLUST INTEGER (16) CLUSTER ENSEMBLE PARMS -C KMEMBR INTEGER (8) CLUSTER ENSEMBLE PARMS -C LB LOGICAL*1 (KF) BITMAP IF PRESENT -C F REAL (KF) DATA -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C 0 ALL OK -C OTHER W3FI72 GRIB PACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS -C GETBIT GET NUMBER OF BITS AND ROUND DATA -C W3FI72 PACK GRIB -C WRYTE WRITE DATA -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200),KENS(200) - INTEGER KPROB(2),KCLUST(16),KMEMBR(80) - REAL XPROB(2) - LOGICAL*1 LB(KF) - REAL F(KF) - PARAMETER(MAXBIT=16) - INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) - REAL FR(KF) - CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET W3FI72 PARAMETERS - CALL R63W72(KPDS,KGDS,IPDS,IGDS) - IBDS=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COUNT VALID DATA - KBM=KF - IF(IPDS(7).NE.0) THEN - KBM=0 - DO I=1,KF - IF(LB(I)) THEN - IBM(I)=1 - KBM=KBM+1 - ELSE - IBM(I)=0 - ENDIF - ENDDO - IF(KBM.EQ.KF) IPDS(7)=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET NUMBER OF BITS AND ROUND DATA - IF(KBM.EQ.0) THEN - DO I=1,KF - FR(I)=0. - ENDDO - NBIT=0 - ELSE - CALL GETBIT(IPDS(7),0,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) - NBIT=MIN(NBIT,MAXBIT) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C CREATE PRODUCT DEFINITION SECTION - CALL W3FI68(IPDS,PDS) - IF(IPDS(24).EQ.2) THEN - ILAST=86 - CALL PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,PDS) - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PACK AND WRITE GRIB DATA - CALL W3FI72(0,FR,0,NBIT,1,IPDS,PDS, - & 1,255,IGDS,0,0,IBM,KF,IBDS, - & KFO,GRIB,LGRIB,IRET) - IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/putgbn.f b/external/w3nco/v2.0.6/src/putgbn.f deleted file mode 100644 index 671f1106..00000000 --- a/external/w3nco/v2.0.6/src/putgbn.f +++ /dev/null @@ -1,209 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE PUTGBN(LUGB,KF,KPDS,KGDS,IBS,NBITS,LB,F,IRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: PUTGBN PACKS AND WRITES A GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 -C -C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. -C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGB. -C -C PROGRAM HISTORY LOG: -C 94-04-01 IREDELL -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL PUTGBN(LUGB,KF,KPDS,KGDS,NBITS,LB,F,IRET) -C INPUT ARGUMENTS: -C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE -C KF INTEGER NUMBER OF DATA POINTS -C KPDS INTEGER (200) PDS PARAMETERS -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C KGDS INTEGER (200) GDS PARAMETERS -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C IBS INTEGER BINARY SCALE FACTOR (0 TO IGNORE) -C NBITS INTEGER NUMBER OF BITS IN WHICH TO PACK (0 TO IGNORE) -C LB LOGICAL*1 (KF) BITMAP IF PRESENT -C F REAL (KF) DATA -C OUTPUT ARGUMENTS: -C IRET INTEGER RETURN CODE -C 0 ALL OK -C OTHER W3FI72 GRIB PACKER RETURN CODE -C -C SUBPROGRAMS CALLED: -C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS -C GETBIT GET NUMBER OF BITS AND ROUND DATA -C W3FI72 PACK GRIB -C WRYTE WRITE DATA -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ - INTEGER KPDS(200),KGDS(200) - LOGICAL*1 LB(KF) - REAL F(KF) - PARAMETER(MAXBIT=16) - INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) - REAL FR(KF) - CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET W3FI72 PARAMETERS - CALL R63W72(KPDS,KGDS,IPDS,IGDS) - IBDS=0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C COUNT VALID DATA - KBM=KF - IF(IPDS(7).NE.0) THEN - KBM=0 - DO I=1,KF - IF(LB(I)) THEN - IBM(I)=1 - KBM=KBM+1 - ELSE - IBM(I)=0 - ENDIF - ENDDO - IF(KBM.EQ.KF) IPDS(7)=0 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C GET NUMBER OF BITS AND ROUND DATA - IF(NBITS.GT.0) THEN - DO I=1,KF - FR(I)=F(I) - ENDDO - NBIT=NBITS - ELSE - IF(KBM.EQ.0) THEN - DO I=1,KF - FR(I)=0. - ENDDO - NBIT=0 - ELSE - CALL GETBIT(IPDS(7),IBS,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) - NBIT=MIN(NBIT,MAXBIT) - ENDIF - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C PACK AND WRITE GRIB DATA - CALL W3FI72(0,FR,0,NBIT,0,IPDS,PDS, - & 1,255,IGDS,0,0,IBM,KF,IBDS, - & KFO,GRIB,LGRIB,IRET) - IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/q9ie32.f b/external/w3nco/v2.0.6/src/q9ie32.f deleted file mode 100644 index 09596b45..00000000 --- a/external/w3nco/v2.0.6/src/q9ie32.f +++ /dev/null @@ -1,139 +0,0 @@ - SUBROUTINE Q9IE32(A,B,N,ISTAT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: Q9IE32 CONVERT IBM370 F.P. TO IEEE F.P. -C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 90-06-04 -C -C ABSTRACT: CONVERT IBM370 32 BIT FLOATING POINT NUMBERS TO IEEE -C 32 BIT TASK 754 FLOATING POINT NUMBERS. -C -C PROGRAM HISTORY LOG: -C 90-06-04 R.E.JONES CHANGE TO SUN FORTRAN 1.3 -C 90-07-14 R.E.JONES CHANGE ISHFT TO LSHIFT OR LRSHFT -C 91-03-09 R.E.JONES CHANGE TO SiliconGraphics FORTRAN -C 92-07-20 R.E.JONES CHANGE TO IBM AIX XL FORTRAN -C 95-11-15 R.E.JONES ADD SAVE STATEMENT -C 98-11-15 gilbert Specified 4-byte integers for IBM SP -C -C USAGE: CALL Q9IE32(A, B, N, ISTAT) -C INPUT ARGUMENT LIST: -C A - REAL*4 ARRAY OF IBM370 32 BIT FLOATING POINT NUMBERS -C N - NUMBER OF POINTS TO CONVERT -C -C OUTPUT ARGUMENT LIST: -C B - REAL*4 ARRAY OF IEEE 32 BIT FLOATING POINT NUMBERS -C ISTAT - NUMBER OF POINT GREATER THAN 10E+38, NUMBERS ARE SET TO -C IEEE INFINITY, ONE IS ADDED TO ISTAT. NUMBERS LESS THAN -C E-38 ARE SET TO ZERO , ONE IS NOT ADDED TO ISTAT. -C -C REMARKS: SEE IEEE TASK 754 STANDARD FLOATING POINT ARITHMETIC -C FOR MORE INFORMATION ABOUT IEEE F.P. -C -C ATTRIBUTES: -C LANGUAGE: IBM AIX XL FORTRAN Compiler/6000 -C MACHINE: IBM RS6000 model 530 -C -C$$$ -C - INTEGER(4) A(*) - INTEGER(4) B(*) - INTEGER(4) SIGN - INTEGER(4) INFIN,MASKFR,MASKSN,MASK21,MASK22,MASK23 - INTEGER(4) ITEMP,ISIGN,IEEEXP,K,LTEMP -C - SAVE -C - DATA INFIN /Z'7F800000'/ - DATA MASKFR/Z'007FFFFF'/ - DATA MASKSN/Z'7FFFFFFF'/ - DATA MASK21/Z'00200000'/ - DATA MASK22/Z'00400000'/ - DATA MASK23/Z'00800000'/ - DATA SIGN /Z'80000000'/ -C - IF (N.LT.1) THEN - ISTAT = -1 - RETURN - ENDIF -C - ISTAT = 0 -C - DO 40 I = 1,N - ISIGN = 0 - ITEMP = A(I) -C -C TEST SIGN BIT -C - IF (ITEMP.EQ.0) GO TO 30 -C - IF (ITEMP.LT.0) THEN -C - ISIGN = SIGN -C -C SET SIGN BIT TO ZERO -C - ITEMP = IAND(ITEMP,MASKSN) -C - END IF -C -C -C CONVERT IBM EXPONENT TO IEEE EXPONENT -C - IEEEXP = (ISHFT(ITEMP,-24_4) - 64_4) * 4 + 126 -C - K = 0 -C -C TEST BIT 23, 22, 21 -C ADD UP NUMBER OF ZERO BITS IN FRONT OF IBM370 FRACTION -C - IF (IAND(ITEMP,MASK23).NE.0) GO TO 10 - K = K + 1 - IF (IAND(ITEMP,MASK22).NE.0) GO TO 10 - K = K + 1 - IF (IAND(ITEMP,MASK21).NE.0) GO TO 10 - K = K + 1 -C - 10 CONTINUE -C -C SUBTRACT ZERO BITS FROM EXPONENT -C - IEEEXP = IEEEXP - K -C -C TEST FOR OVERFLOW -C - IF (IEEEXP.GT.254) GO TO 20 -C -C TEST FOR UNDERFLOW -C - IF (IEEEXP.LT.1) GO TO 30 -C -C SHIFT IEEE EXPONENT TO BITS 1 TO 8 -C - LTEMP = ISHFT(IEEEXP,23_4) -C -C SHIFT IBM370 FRACTION LEFT K BIT, AND OUT BITS 0 - 8 -C OR TOGETHER THE EXPONENT AND THE FRACTION -C OR IN SIGN BIT -C - B(I) = IOR(IOR(IAND(ISHFT(ITEMP,K),MASKFR),LTEMP),ISIGN) -C - GO TO 40 -C - 20 CONTINUE -C -C OVERFLOW , SET TO IEEE INFINITY, ADD 1 TO OVERFLOW COUNTER -C - ISTAT = ISTAT + 1 - B(I) = IOR(INFIN,ISIGN) - GO TO 40 -C - 30 CONTINUE -C -C UNDERFLOW , SET TO ZERO -C - B(I) = 0 -C - 40 CONTINUE -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/r63w72.f b/external/w3nco/v2.0.6/src/r63w72.f deleted file mode 100644 index 4d52ab96..00000000 --- a/external/w3nco/v2.0.6/src/r63w72.f +++ /dev/null @@ -1,125 +0,0 @@ - SUBROUTINE R63W72(KPDS,KGDS,IPDS,IGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: R63W72 CONVERT W3FI63 PARMS TO W3FI72 PARMS -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 -C -C ABSTRACT: DETERMINES THE INTEGER PDS AND GDS PARAMETERS -C FOR THE GRIB1 PACKING ROUTINE W3FI72 GIVEN THE PARAMETERS -C RETURNED FROM THE GRIB1 UNPACKING ROUTINE W3FI63. -C -C PROGRAM HISTORY LOG: -C 91-10-31 MARK IREDELL -C 96-05-03 MARK IREDELL CORRECTED SOME LEVEL TYPES AND -C SOME DATA REPRESENTATION TYPES -C 97-02-14 MARK IREDELL ONLY ALTERED IPDS(26:27) FOR EXTENDED PDS -C 98-06-01 CHRIS CARUSO Y2K FIX FOR YEAR OF CENTURY -C 2005-05-06 DIANE STOKES RECOGNIZE LEVEL 236 -C -C USAGE: CALL R63W72(KPDS,KGDS,IPDS,IGDS) -C -C INPUT ARGUMENT LIST: -C KPDS - INTEGER (200) PDS PARAMETERS FROM W3FI63 -C KGDS - INTEGER (200) GDS PARAMETERS FROM W3FI63 -C -C OUTPUT ARGUMENT LIST: -C IPDS - INTEGER (200) PDS PARAMETERS FOR W3FI72 -C IGDS - INTEGER (200) GDS PARAMETERS FOR W3FI72 -C -C REMARKS: KGDS AND IGDS EXTEND BEYOND THEIR DIMENSIONS HERE -C IF PL PARAMETERS ARE PRESENT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN -C -C$$$ - DIMENSION KPDS(200),KGDS(200),IPDS(200),IGDS(200) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE PRODUCT DEFINITION SECTION (PDS) PARAMETERS - IF(KPDS(23).NE.2) THEN - IPDS(1)=28 ! LENGTH OF PDS - ELSE - IPDS(1)=45 ! LENGTH OF PDS - ENDIF - IPDS(2)=KPDS(19) ! PARAMETER TABLE VERSION - IPDS(3)=KPDS(1) ! ORIGINATING CENTER - IPDS(4)=KPDS(2) ! GENERATING MODEL - IPDS(5)=KPDS(3) ! GRID DEFINITION - IPDS(6)=MOD(KPDS(4)/128,2) ! GDS FLAG - IPDS(7)=MOD(KPDS(4)/64,2) ! BMS FLAG - IPDS(8)=KPDS(5) ! PARAMETER INDICATOR - IPDS(9)=KPDS(6) ! LEVEL TYPE - IF(KPDS(6).EQ.101.OR.KPDS(6).EQ.104.OR.KPDS(6).EQ.106.OR. - & KPDS(6).EQ.108.OR.KPDS(6).EQ.110.OR.KPDS(6).EQ.112.OR. - & KPDS(6).EQ.114.OR.KPDS(6).EQ.116.OR.KPDS(6).EQ.121.OR. - & KPDS(6).EQ.128.OR.KPDS(6).EQ.141.OR.KPDS(6).EQ.236) THEN - IPDS(10)=MOD(KPDS(7)/256,256) ! LEVEL VALUE 1 - IPDS(11)=MOD(KPDS(7),256) ! LEVEL VALUE 2 - ELSE - IPDS(10)=0 ! LEVEL VALUE 1 - IPDS(11)=KPDS(7) ! LEVEL VALUE 2 - ENDIF - IPDS(12)=KPDS(8) ! YEAR OF CENTURY - IPDS(13)=KPDS(9) ! MONTH - IPDS(14)=KPDS(10) ! DAY - IPDS(15)=KPDS(11) ! HOUR - IPDS(16)=KPDS(12) ! MINUTE - IPDS(17)=KPDS(13) ! FORECAST TIME UNIT - IPDS(18)=KPDS(14) ! TIME RANGE 1 - IPDS(19)=KPDS(15) ! TIME RANGE 2 - IPDS(20)=KPDS(16) ! TIME RANGE INDICATOR - IPDS(21)=KPDS(17) ! NUMBER IN AVERAGE - IPDS(22)=KPDS(20) ! NUMBER MISSING IN AVERAGE - IPDS(23)=KPDS(21) ! CENTURY - IPDS(24)=KPDS(23) ! SUBCENTER - IPDS(25)=KPDS(22) ! DECIMAL SCALING - IF(IPDS(1).GT.28) THEN - IPDS(26)=0 ! PDS BYTE 29 - IPDS(27)=0 ! PDS BYTE 30 - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C DETERMINE GRID DEFINITION SECTION (GDS) PARAMETERS - IGDS(1)=KGDS(19) ! NUMBER OF VERTICAL COORDINATES - IGDS(2)=KGDS(20) ! VERTICAL COORDINATES - IGDS(3)=KGDS(1) ! DATA REPRESENTATION - IGDS(4)=KGDS(2) ! (UNIQUE TO REPRESENTATION) - IGDS(5)=KGDS(3) ! (UNIQUE TO REPRESENTATION) - IGDS(6)=KGDS(4) ! (UNIQUE TO REPRESENTATION) - IGDS(7)=KGDS(5) ! (UNIQUE TO REPRESENTATION) - IGDS(8)=KGDS(6) ! (UNIQUE TO REPRESENTATION) - IGDS(9)=KGDS(7) ! (UNIQUE TO REPRESENTATION) - IGDS(10)=KGDS(8) ! (UNIQUE TO REPRESENTATION) - IGDS(11)=KGDS(9) ! (UNIQUE TO REPRESENTATION) - IGDS(12)=KGDS(10) ! (UNIQUE TO REPRESENTATION) - IGDS(13)=KGDS(11) ! (UNIQUE TO REPRESENTATION) - IGDS(14)=KGDS(12) ! (UNIQUE TO REPRESENTATION) - IGDS(15)=KGDS(13) ! (UNIQUE TO REPRESENTATION) - IGDS(16)=KGDS(14) ! (UNIQUE TO REPRESENTATION) - IGDS(17)=KGDS(15) ! (UNIQUE TO REPRESENTATION) - IGDS(18)=KGDS(16) ! (UNIQUE TO REPRESENTATION) -C EXCEPTIONS FOR LATLON OR GAUSSIAN - IF(KGDS(1).EQ.0.OR.KGDS(1).EQ.4) THEN - IGDS(11)=KGDS(10) - IGDS(12)=KGDS(9) -C EXCEPTIONS FOR MERCATOR - ELSEIF(KGDS(1).EQ.1) THEN - IGDS(11)=KGDS(13) - IGDS(12)=KGDS(12) - IGDS(13)=KGDS(9) - IGDS(14)=KGDS(11) -C EXCEPTIONS FOR LAMBERT CONFORMAL - ELSEIF(KGDS(1).EQ.3) THEN - IGDS(15)=KGDS(12) - IGDS(16)=KGDS(13) - IGDS(17)=KGDS(14) - IGDS(18)=KGDS(15) - ENDIF -C EXTENSION FOR PL PARAMETERS - IF(KGDS(1).EQ.0.AND.KGDS(19).EQ.0.AND.KGDS(20).NE.255) THEN - DO J=1,KGDS(3) - IGDS(18+J)=KGDS(21+J) - ENDDO - ENDIF -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/sbyte.f b/external/w3nco/v2.0.6/src/sbyte.f deleted file mode 100644 index df958fd0..00000000 --- a/external/w3nco/v2.0.6/src/sbyte.f +++ /dev/null @@ -1,79 +0,0 @@ - SUBROUTINE SBYTE(IOUT,IN,ISKIP,NBYTE) -C THIS PROGRAM WRITTEN BY..... -C DR. ROBERT C. GAMMILL, CONSULTANT -C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH -C JULY 1972 -C -C THIS IS THE FORTRAN 32 bit VERSION OF SBYTE. -C Changes for SiliconGraphics IRIS-4D/25 -C SiliconGraphics 3.3 FORTRAN 77 -C MARCH 1991 RUSSELL E. JONES -C NATIONAL WEATHER SERVICE -C - INTEGER IN - INTEGER IOUT(*) - INTEGER MASKS(32) -C - SAVE -C - DATA NBITSW/32/ -C -C DATA MASKS /Z'00000001',Z'00000003',Z'00000007',Z'0000000F', -C & Z'0000001F',Z'0000003F',Z'0000007F',Z'000000FF', -C & Z'000001FF',Z'000003FF',Z'000007FF',Z'00000FFF', -C & Z'00001FFF',Z'00003FFF',Z'00007FFF',Z'0000FFFF', -C & Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF', -C & Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF', -C & Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF', -C & Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/ -C -C MASK TABLE PUT IN DECIMAL SO IT WILL COMPILE ON AN 32 BIT -C COMPUTER -C - DATA MASKS / 1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, - & 4095, 8191, 16383, 32767, 65535, 131071, 262143, 524287, - & 1048575, 2097151, 4194303, 8388607, 16777215, 33554431, - & 67108863, 134217727, 268435455, 536870911, 1073741823, - & 2147483647, -1/ -C -C NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW -C - ICON = NBITSW - NBYTE - IF (ICON.LT.0) RETURN - MASK = MASKS(NBYTE) -C -C INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED. -C - INDEX = ISHFT(ISKIP,-5) -C -C II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT. -C - II = MOD(ISKIP,NBITSW) -C - J = IAND(MASK,IN) - MOVEL = ICON - II -C -C BYTE IS TO BE STORED IN MIDDLE OF WORD. SHIFT LEFT. -C - IF (MOVEL.GT.0) THEN - MSK = ISHFT(MASK,MOVEL) - IOUT(INDEX+1) = IOR(IAND(NOT(MSK),IOUT(INDEX+1)), - & ISHFT(J,MOVEL)) -C -C THE BYTE IS TO BE SPLIT ACROSS A WORD BREAK. -C - ELSE IF (MOVEL.LT.0) THEN - MSK = MASKS(NBYTE+MOVEL) - IOUT(INDEX+1) = IOR(IAND(NOT(MSK),IOUT(INDEX+1)), - & ISHFT(J,MOVEL)) - ITEMP = IAND(MASKS(NBITSW+MOVEL),IOUT(INDEX+2)) - IOUT(INDEX+2) = IOR(ITEMP,ISHFT(J,NBITSW+MOVEL)) -C -C BYTE IS TO BE STORED RIGHT-ADJUSTED. -C - ELSE - IOUT(INDEX+1) = IOR(IAND(NOT(MASK),IOUT(INDEX+1)),J) - ENDIF -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/sbytec.f b/external/w3nco/v2.0.6/src/sbytec.f deleted file mode 100644 index 042b1f66..00000000 --- a/external/w3nco/v2.0.6/src/sbytec.f +++ /dev/null @@ -1,6 +0,0 @@ - SUBROUTINE SBYTEC(OUT,IN,ISKIP,NBYTE) - character*1 out(*) - integer in(*) - CALL SBYTESC(OUT,IN,ISKIP,NBYTE,0,1) - RETURN - END diff --git a/external/w3nco/v2.0.6/src/sbytes.f b/external/w3nco/v2.0.6/src/sbytes.f deleted file mode 100644 index 5a149067..00000000 --- a/external/w3nco/v2.0.6/src/sbytes.f +++ /dev/null @@ -1,101 +0,0 @@ - SUBROUTINE SBYTES(IOUT,IN,ISKIP,NBYTE,NSKIP,N) -C THIS PROGRAM WRITTEN BY..... -C DR. ROBERT C. GAMMILL, CONSULTANT -C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH -C JULY 1972 -C THIS IS THE FORTRAN VERSIONS OF SBYTES. -C -C Changes for SiliconGraphics IRIS-4D/25 -C SiliconGraphics 3.3 FORTRAN 77 -C March 1991 RUSSELL E. JONES -C NATIONAL WEATHER SERVICE -C - INTEGER IN(*) - INTEGER IOUT(*) - INTEGER MASKS(32) -C - SAVE -C - DATA NBITSW/32/ -C -C DATA MASKS /Z'00000001',Z'00000003',Z'00000007',Z'0000000F', -C & Z'0000001F',Z'0000003F',Z'0000007F',Z'000000FF', -C & Z'000001FF',Z'000003FF',Z'000007FF',Z'00000FFF', -C & Z'00001FFF',Z'00003FFF',Z'00007FFF',Z'0000FFFF', -C & Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF', -C & Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF', -C & Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF', -C & Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/ -C -C MASKS TABLE PUT IN DECIMAL SO IT WILL COMPILE ON ANY 32 BIT -C COMPUTER -C - DATA MASKS / 1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, - & 4095, 8191, 16383, 32767, 65535, 131071, 262143, 524287, - & 1048575, 2097151, 4194303, 8388607, 16777215, 33554431, - & 67108863, 134217727, 268435455, 536870911, 1073741823, - & 2147483647, -1/ -C -C NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW -C - ICON = NBITSW - NBYTE - IF (ICON.LT.0) RETURN - MASK = MASKS(NBYTE) -C -C INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED. -C - INDEX = ISHFT(ISKIP,-5) -C -C II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT. -C - II = MOD(ISKIP,NBITSW) -C -C ISTEP IS THE DISTANCE IN BITS FROM ONE BYTE POSITION TO THE NEXT. -C - ISTEP = NBYTE + NSKIP -C -C IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT. -C - IWORDS = ISTEP / NBITSW -C -C IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS. -C - IBITS = MOD(ISTEP,NBITSW) -C - DO 10 I = 1,N - J = IAND(MASK,IN(I)) - MOVEL = ICON - II -C -C BYTE IS TO BE STORED IN MIDDLE OF WORD. SHIFT LEFT. -C - IF (MOVEL.GT.0) THEN - MSK = ISHFT(MASK,MOVEL) - IOUT(INDEX+1) = IOR(IAND(NOT(MSK),IOUT(INDEX+1)), - & ISHFT(J,MOVEL)) -C -C THE BYTE IS TO BE SPLIT ACROSS A WORD BREAK. -C - ELSE IF (MOVEL.LT.0) THEN - MSK = MASKS(NBYTE+MOVEL) - IOUT(INDEX+1) = IOR(IAND(NOT(MSK),IOUT(INDEX+1)), - & ISHFT(J,MOVEL)) - ITEMP = IAND(MASKS(NBITSW+MOVEL),IOUT(INDEX+2)) - IOUT(INDEX+2) = IOR(ITEMP,ISHFT(J,NBITSW+MOVEL)) -C -C BYTE IS TO BE STORED RIGHT-ADJUSTED. -C - ELSE - IOUT(INDEX+1) = IOR(IAND(NOT(MASK),IOUT(INDEX+1)),J) - ENDIF -C - II = II + IBITS - INDEX = INDEX + IWORDS - IF (II.GE.NBITSW) THEN - II = II - NBITSW - INDEX = INDEX + 1 - ENDIF -C -10 CONTINUE -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/sbytesc.f b/external/w3nco/v2.0.6/src/sbytesc.f deleted file mode 100644 index dd9a6b5e..00000000 --- a/external/w3nco/v2.0.6/src/sbytesc.f +++ /dev/null @@ -1,61 +0,0 @@ - SUBROUTINE SBYTESC(OUT,IN,ISKIP,NBYTE,NSKIP,N) -C Store bytes - pack bits: Put arbitrary size values into a -C packed bit string, taking the low order bits from each value -C in the unpacked array. -C IOUT = packed array output -C IN = unpacked array input -C ISKIP = initial number of bits to skip -C NBYTE = number of bits to pack -C NSKIP = additional number of bits to skip on each iteration -C N = number of iterations -C v1.1 -C - character*1 out(*) - integer in(N), bitcnt, ones(8), tbit - save ones - data ones/ 1, 3, 7, 15, 31, 63,127,255/ - -c number bits from zero to ... -c nbit is the last bit of the field to be filled - - nbit = iskip + nbyte - 1 - do i = 1, n - itmp = in(i) - bitcnt = nbyte - index=nbit/8+1 - ibit=mod(nbit,8) - nbit = nbit + nbyte + nskip - -c make byte aligned - if (ibit.ne.7) then - tbit = min(bitcnt,ibit+1) - imask = ishft(ones(tbit),7-ibit) - itmp2 = iand(ishft(itmp,7-ibit),imask) - itmp3 = iand(mova2i(out(index)), 255-imask) - out(index) = char(ior(itmp2,itmp3)) - bitcnt = bitcnt - tbit - itmp = ishft(itmp, -tbit) - index = index - 1 - endif - -c now byte aligned - -c do by bytes - do while (bitcnt.ge.8) - out(index) = char(iand(itmp,255)) - itmp = ishft(itmp,-8) - bitcnt = bitcnt - 8 - index = index - 1 - enddo - -c do last byte - - if (bitcnt.gt.0) then - itmp2 = iand(itmp,ones(bitcnt)) - itmp3 = iand(mova2i(out(index)), 255-ones(bitcnt)) - out(index) = char(ior(itmp2,itmp3)) - endif - enddo - - return - end diff --git a/external/w3nco/v2.0.6/src/skgb.f b/external/w3nco/v2.0.6/src/skgb.f deleted file mode 100644 index fed46547..00000000 --- a/external/w3nco/v2.0.6/src/skgb.f +++ /dev/null @@ -1,78 +0,0 @@ -C----------------------------------------------------------------------- - SUBROUTINE SKGB(LUGB,ISEEK,MSEEK,LSKIP,LGRIB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: SKGB SEARCH FOR NEXT GRIB MESSAGE -C PRGMMR: IREDELL ORG: W/NMC23 DATE: 93-11-22 -C -C ABSTRACT: THIS SUBPROGRAM SEARCHES A FILE FOR THE NEXT GRIB 1 MESSAGE. -C A GRIB 1 MESSAGE IS IDENTIFIED BY ITS INDICATOR SECTION, I.E. -C AN 8-BYTE SEQUENCE WITH 'GRIB' IN BYTES 1-4 AND 1 IN BYTE 8. -C IF FOUND, THE LENGTH OF THE MESSAGE IS DECODED FROM BYTES 5-7. -C THE SEARCH IS DONE OVER A GIVEN SECTION OF THE FILE. -C THE SEARCH IS TERMINATED IF AN EOF OR I/O ERROR IS ENCOUNTERED. -C -C PROGRAM HISTORY LOG: -C 93-11-22 IREDELL -C 95-10-31 IREDELL ADD CALL TO BAREAD -C 97-03-14 IREDELL CHECK FOR '7777' -C 2001-12-05 GILBERT MODIFIED TO ALSO LOOK FOR GRIB2 MESSAGES -C -C USAGE: CALL SKGB(LUGB,ISEEK,MSEEK,LSKIP,LGRIB) -C INPUT ARGUMENTS: -C LUGB INTEGER LOGICAL UNIT OF INPUT GRIB FILE -C ISEEK INTEGER NUMBER OF BYTES TO SKIP BEFORE SEARCH -C MSEEK INTEGER MAXIMUM NUMBER OF BYTES TO SEARCH -C OUTPUT ARGUMENTS: -C LSKIP INTEGER NUMBER OF BYTES TO SKIP BEFORE MESSAGE -C LGRIB INTEGER NUMBER OF BYTES IN MESSAGE (0 IF NOT FOUND) -C -C SUBPROGRAMS CALLED: -C BAREAD BYTE-ADDRESSABLE READ -C GBYTEC GET INTEGER DATA FROM BYTES -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN -C -C$$$ - PARAMETER(LSEEK=128) - CHARACTER Z(LSEEK) - CHARACTER Z4(4) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - LGRIB=0 - KS=ISEEK - KN=MIN(LSEEK,MSEEK) - KZ=LSEEK -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C LOOP UNTIL GRIB MESSAGE IS FOUND - DOWHILE(LGRIB.EQ.0.AND.KN.GE.8.AND.KZ.EQ.LSEEK) -C READ PARTIAL SECTION - CALL BAREAD(LUGB,KS,KN,KZ,Z) - KM=KZ-8+1 - K=0 -C LOOK FOR 'GRIB...1' IN PARTIAL SECTION - DOWHILE(LGRIB.EQ.0.AND.K.LT.KM) - CALL GBYTEC(Z,I4,(K+0)*8,4*8) - CALL GBYTEC(Z,I1,(K+7)*8,1*8) - IF(I4.EQ.1196575042.AND.(I1.EQ.1.OR.I1.EQ.2)) THEN -C LOOK FOR '7777' AT END OF GRIB MESSAGE - IF (I1.EQ.1) CALL GBYTEC(Z,KG,(K+4)*8,3*8) - IF (I1.EQ.2) CALL GBYTEC(Z,KG,(K+12)*8,4*8) - CALL BAREAD(LUGB,KS+K+KG-4,4,K4,Z4) - IF(K4.EQ.4) THEN - CALL GBYTEC(Z4,I4,0,4*8) - IF(I4.EQ.926365495) THEN -C GRIB MESSAGE FOUND - LSKIP=KS+K - LGRIB=KG - ENDIF - ENDIF - ENDIF - K=K+1 - ENDDO - KS=KS+KM - KN=MIN(LSEEK,ISEEK+MSEEK-KS) - ENDDO -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN - END diff --git a/external/w3nco/v2.0.6/src/summary.c b/external/w3nco/v2.0.6/src/summary.c deleted file mode 100644 index 1ad03e02..00000000 --- a/external/w3nco/v2.0.6/src/summary.c +++ /dev/null @@ -1,496 +0,0 @@ -/*************************************************************** - -This code will make a system call to return various -useful parameters. When subroutine summary is called, a list -of system resource statistics is printed to stdout. - -Users need to place a call to start() at the beginning of the -section of code to be "measured" and a call to summary() at the end. - -Use as follows: - -call start() - do stuff -call summary() - -Jim Tuccillo August 1999 -***************************************************************/ -#include -#include -#include -#include -#include -#include -#include -#include -#ifdef _AIX -#include -#endif -#ifdef __linux__ -#include -#include -#endif - -/* #include "trace_mpif.h" */ - -static FILE *fp = NULL; -int numtask, mypid; -int procid_0; -int profile, msglen; -int trace_flag; -double tcpu, twall, tbytes, f_bytes; -double tot_wall, final_wall, start_wall; -double cpu_comm, wall_comm; -#ifdef _AIX -extern double rtc (); -#endif -struct time_data { - double s_cpu; - double s_wall; - double f_cpu; - double f_wall; - double c_cpu; - double c_wall; - double c_bytes; - int c_calls; - int c_buckets[32]; - float c_sum[32]; - double b_cpu[32]; - double b_wall[32]; -}; - -struct time_data MPI_Allgather_data; -struct time_data MPI_Allgatherv_data; -struct time_data MPI_Allreduce_data; -struct time_data MPI_Alltoall_data; -struct time_data MPI_Alltoallv_data; -struct time_data MPI_Barrier_data; -struct time_data MPI_Bcast_data; -struct time_data MPI_Gather_data; -struct time_data MPI_Gatherv_data; -struct time_data MPI_Op_create_data; -struct time_data MPI_Op_free_data; -struct time_data MPI_Reduce_scatter_data; -struct time_data MPI_Reduce_data; -struct time_data MPI_Scan_data; -struct time_data MPI_Scatter_data; -struct time_data MPI_Scatterv_data; -struct time_data MPI_Attr_delete_data; -struct time_data MPI_Attr_get_data; -struct time_data MPI_Attr_put_data; -struct time_data MPI_Comm_compare_data; -struct time_data MPI_Comm_create_data; -struct time_data MPI_Comm_dup_data; -struct time_data MPI_Comm_free_data; -struct time_data MPI_Comm_group_data; -struct time_data MPI_Comm_rank_data; -struct time_data MPI_Comm_remote_group_data; -struct time_data MPI_Comm_remote_size_data; -struct time_data MPI_Comm_size_data; -struct time_data MPI_Comm_split_data; -struct time_data MPI_Comm_test_inter_data; -struct time_data MPI_Group_compare_data; -struct time_data MPI_Group_difference_data; -struct time_data MPI_Group_excl_data; -struct time_data MPI_Group_free_data; -struct time_data MPI_Group_incl_data; -struct time_data MPI_Group_intersection_data; -struct time_data MPI_Group_rank_data; -struct time_data MPI_Group_range_excl_data; -struct time_data MPI_Group_range_incl_data; -struct time_data MPI_Group_size_data; -struct time_data MPI_Group_translate_ranks_data; -struct time_data MPI_Group_union_data; -struct time_data MPI_Intercomm_create_data; -struct time_data MPI_Intercomm_merge_data; -struct time_data MPI_Keyval_create_data; -struct time_data MPI_Keyval_free_data; -struct time_data MPI_Abort_data; -struct time_data MPI_Error_class_data; -struct time_data MPI_Errhandler_create_data; -struct time_data MPI_Errhandler_free_data; -struct time_data MPI_Errhandler_get_data; -struct time_data MPI_Error_string_data; -struct time_data MPI_Errhandler_set_data; -struct time_data MPI_Get_processor_name_data; -struct time_data MPI_Initialized_data; -struct time_data MPI_Wtick_data; -struct time_data MPI_Wtime_data; -struct time_data MPI_Address_data; -struct time_data MPI_Bsend_data; -struct time_data MPI_Bsend_init_data; -struct time_data MPI_Buffer_attach_data; -struct time_data MPI_Buffer_detach_data; -struct time_data MPI_Cancel_data; -struct time_data MPI_Request_free_data; -struct time_data MPI_Recv_init_data; -struct time_data MPI_Send_init_data; -struct time_data MPI_Get_elements_data; -struct time_data MPI_Get_count_data; -struct time_data MPI_Ibsend_data; -struct time_data MPI_Iprobe_data; -struct time_data MPI_Irecv_data; -struct time_data MPI_Irsend_data; -struct time_data MPI_Isend_data; -struct time_data MPI_Issend_data; -struct time_data MPI_Pack_data; -struct time_data MPI_Pack_size_data; -struct time_data MPI_Probe_data; -struct time_data MPI_Recv_data; -struct time_data MPI_Rsend_data; -struct time_data MPI_Rsend_init_data; -struct time_data MPI_Send_data; -struct time_data MPI_Sendrecv_data; -struct time_data MPI_Sendrecv_replace_data; -struct time_data MPI_Ssend_data; -struct time_data MPI_Ssend_init_data; -struct time_data MPI_Start_data; -struct time_data MPI_Startall_data; -struct time_data MPI_Test_data; -struct time_data MPI_Testall_data; -struct time_data MPI_Testany_data; -struct time_data MPI_Test_cancelled_data; -struct time_data MPI_Testsome_data; -struct time_data MPI_Type_commit_data; -struct time_data MPI_Type_contiguous_data; -struct time_data MPI_Type_extent_data; -struct time_data MPI_Type_free_data; -struct time_data MPI_Type_hindexed_data; -struct time_data MPI_Type_hvector_data; -struct time_data MPI_Type_indexed_data; -struct time_data MPI_Type_lb_data; -struct time_data MPI_Type_size_data; -struct time_data MPI_Type_struct_data; -struct time_data MPI_Type_ub_data; -struct time_data MPI_Type_vector_data; -struct time_data MPI_Unpack_data; -struct time_data MPI_Wait_data; -struct time_data MPI_Waitall_data; -struct time_data MPI_Waitany_data; -struct time_data MPI_Waitsome_data; -struct time_data MPI_Cart_coords_data; -struct time_data MPI_Cart_create_data; -struct time_data MPI_Cart_get_data; -struct time_data MPI_Cart_map_data; -struct time_data MPI_Cart_rank_data; -struct time_data MPI_Cart_shift_data; -struct time_data MPI_Cart_sub_data; -struct time_data MPI_Cartdim_get_data; -struct time_data MPI_Dims_create_data; -struct time_data MPI_Graph_create_data; -struct time_data MPI_Graph_get_data; -struct time_data MPI_Graph_map_data; -struct time_data MPI_Graph_neighbors_data; -struct time_data MPI_Graph_neighbors_count_data; -struct time_data MPI_Graphdims_get_data; -struct time_data MPI_Topo_test_data; - - -int bucket (lng) - int lng; -{ - int i, j; - if (lng <= 0) {return(0);} - for (i=1, j=--lng; j>0; ++i) { - j = j>>1; - } - return (i); -} - - - -void elapse (timer) - double *timer; - -{ - -/* - - typedef struct { unsigned long tv_sec; - long tv_nsec; } timestruc; - - timestruc TimePointer; - int ret; - - ret = gettimer (TIMEOFDAY, &TimePointer); - if (ret != 0) { - printf ("getttimer FAILED!!!\n"); - printf ("ret = %d\n", ret); - return; - } - - - *timer = ((double) TimePointer.tv_sec) + (((double) TimePointer.tv_nsec) * ((double) 0.000000001)); - return; - -*/ -#ifdef _AIX - *timer = rtc(); -#endif -#ifdef __linux__ - struct timeval st; - if (gettimeofday (&st, NULL) == -1) { - fprintf (stderr, - "elapse: gettimeofday: %s.\n", - strerror (errno)); - *timer = 0.; - } - *timer = ((double) st.tv_sec) + 1.e-6 * ((double) st.tv_usec); -#endif - -} - - -void cputim (usr, sys) - double *usr; - double *sys; - -{ - - double real; - typedef struct { int tms_utime; - int tms_stime; - int tms_cutime; - int tms_cstime; } tms; - - tms Time_buffer; - int ret; - - ret = times (&Time_buffer); - - real = ((double) ret) * 0.01; - - *usr = ((double) Time_buffer.tms_utime) * 0.01; - *sys = ((double) Time_buffer.tms_stime) * 0.01; - return; - -} - - -void start_timer (time) - struct time_data *time; - -{ - double user, sys; - double wall; - - cputim (&user, &sys); - elapse (&wall); - time->s_cpu = user + sys; - time->s_wall = wall; - - return; -} - -void end_timer (time) - struct time_data *time; - -{ - double user, sys; - double wall; - - cputim (&user, &sys); - elapse (&wall); - time->f_cpu = user + sys; - time->f_wall = wall; - time->c_cpu += time->f_cpu - time->s_cpu; - time->c_wall += time->f_wall - time->s_wall; - - return; -} - - - - -void resource () - -{ - - double usr, sys; - long data[14]; -#ifdef _AIX - typedef struct { - int tv_sec; /* seconds */ - int tv_usec; /* microseconds */ - } timeval; -#endif - double user, system; - int ret; - - struct rusage RU; - ret = getrusage (0, &RU); - - if (ret != 0) { - printf ("getrusage FAILED!!!\n"); - printf ("ret = %d\n", ret); - return; - } - - - user = ((double) RU.ru_utime.tv_sec) + (((double) RU.ru_utime.tv_usec) * ((double) 0.000001)); - system = ((double) RU.ru_stime.tv_sec) + (((double) RU.ru_stime.tv_usec) * ((double) 0.000001)); - - - printf("*****************RESOURCE STATISTICS*******************************\n"); - printf("The total amount of wall time = %f\n", tot_wall); - printf("The total amount of time in user mode = %f\n", user); - printf("The total amount of time in sys mode = %f\n", system); -#ifdef _AIX - printf("The maximum resident set size (KB) = %d\n", RU.ru_maxrss); - printf("Average shared memory use in text segment (KB*sec) = %d\n", RU.ru_ixrss); - printf("Average unshared memory use in data segment (KB*sec) = %d\n", RU.ru_idrss); - printf("Average unshared memory use in stack segment(KB*sec) = %d\n", RU.ru_isrss); - printf("Number of page faults without I/O activity = %d\n", RU.ru_minflt); - printf("Number of page faults with I/O activity = %d\n", RU.ru_majflt); - printf("Number of times process was swapped out = %d\n", RU.ru_nswap); - printf("Number of times filesystem performed INPUT = %d\n", RU.ru_inblock); - printf("Number of times filesystem performed OUTPUT = %d\n", RU.ru_oublock); - printf("Number of IPC messages sent = %d\n", RU.ru_msgsnd); - printf("Number of IPC messages received = %d\n", RU.ru_msgrcv); - printf("Number of Signals delivered = %d\n", RU.ru_nsignals); - printf("Number of Voluntary Context Switches = %d\n", RU.ru_nvcsw); - printf("Number of InVoluntary Context Switches = %d\n", RU.ru_nivcsw); -#endif -#ifdef __linux__ - printf ("The maximum resident set size (KB) = %ld\n", RU.ru_maxrss); - printf ("Number of page faults without I/O activity = %ld\n", RU.ru_minflt); - printf ("Number of page faults with I/O activity = %ld\n", RU.ru_majflt); - printf ("Number of times filesystem performed INPUT = %ld\n", RU.ru_inblock); - printf ("Number of times filesystem performed OUTPUT = %ld\n", RU.ru_oublock); - printf ("Number of Voluntary Context Switches = %ld\n", RU.ru_nvcsw); - printf ("Number of InVoluntary Context Switches = %ld\n", RU.ru_nivcsw); -#endif - printf("*****************END OF RESOURCE STATISTICS*************************\n\n"); - - - usr = user; - sys = system; - data[0] = RU.ru_maxrss; - data[1] = RU.ru_ixrss; - data[2] = RU.ru_idrss; - data[3] = RU.ru_isrss; - data[4] = RU.ru_minflt; - data[5] = RU.ru_majflt; - data[6] = RU.ru_nswap; - data[7] = RU.ru_inblock; - data[8] = RU.ru_oublock; - data[9] = RU.ru_msgsnd; - data[10] = RU.ru_msgrcv; - data[11] = RU.ru_nsignals; - data[12] = RU.ru_nvcsw; - data[13] = RU.ru_nivcsw; - - return; - -} - - - - - -void print_timing (string, time) - char *string; - struct time_data *time; - -{ - - - if (time->c_calls > 0) { - fprintf (fp, "Information for %s: AVG. Length = %13.2f, CALLS = %d, WALL = %13.3f, CPU = %13.3f \n", - string, (double) (time->c_bytes) / (double) time->c_calls, time->c_calls, - time->c_wall, time->c_cpu); - } - - if (time->c_wall > 0.001 ) { - fprintf (fp, " %s: Total BYTES = %g, BW = %8.3f MBYTES/WALL SEC., BW = %8.3f MBYTES/CPU SEC.\n", - string, time->c_bytes, - ((double) time->c_bytes * 0.000001)/time->c_wall, - ((double) time->c_bytes * 0.000001)/time->c_cpu); - } - - twall += time->c_wall; - tcpu += time->c_cpu; - tbytes += time->c_bytes * 0.000001; - - /* Print the distribution of the message lengths */ - if (time->c_calls > 0) { - int i, j1, j2; - - j1 = 0; j2 = 0; - fprintf (fp, " AVG. Length # of Calls MB/WALL Sec. MB/CPU Sec. WALL Secs. CPU Secs. \n"); - if (time->c_buckets[0] >0) { - fprintf (fp, " %13.2f %13d %13.3f %13.3f %13.4f %13.4f \n", - time->c_sum[0]/(float)time->c_buckets[0], time->c_buckets[0], - ((double) time->c_sum[0] * 0.000001)/time->b_wall[0], - ((double) time->c_sum[0] * 0.000001)/time->b_cpu[0], - time->b_wall[0], time->b_cpu[0]); - } - time->c_buckets[3] = time->c_buckets[1] + time->c_buckets[2] + time->c_buckets[3]; - j1 = 1; j2 = 4; - for (i =3; i < 31; ++i) { - if (time->c_buckets[i] > 0) { - fprintf (fp, " %13.2f %13d %13.3f %13.3f %13.4f %13.4f \n", - time->c_sum[i]/(float)time->c_buckets[i], time->c_buckets[i], - ((double) time->c_sum[i] * 0.000001)/time->b_wall[i], - ((double) time->c_sum[i] * 0.000001)/time->b_cpu[i], - time->b_wall[i], time->b_cpu[i]); - } - j1 = j2 +1; - j2 = j2 + j2; - } - - fprintf (fp, "\n"); - - } - -} - -#ifdef _AIX -void summary( returnVal ) -int * returnVal; -#endif -#if defined(__linux__) || (__APPLE__) -void summary_ (int *returnVal) -#endif -{ - - double temp, temp1; - char trace_file[255], processor[8]; - -/* - MPI_Finalize - prototyping replacement for MPI_Finalize -*/ - - elapse(&final_wall); - tot_wall = final_wall - start_wall; - - - resource(); - - if (fp) fclose (fp); - - return; -} - -#ifdef _AIX -void start() -#endif -#if defined(__linux__) || (__APPLE__) -void start_ () -#endif -{ - int stateid; - int Argc; - char **Argv; - - char *answer; - - - trace_flag=1; - - profile = 0; - elapse (&start_wall); - - return; -} - diff --git a/external/w3nco/v2.0.6/src/w3ai00.f b/external/w3nco/v2.0.6/src/w3ai00.f deleted file mode 100644 index 5f769434..00000000 --- a/external/w3nco/v2.0.6/src/w3ai00.f +++ /dev/null @@ -1,505 +0,0 @@ - SUBROUTINE W3AI00(REAL8,PACK,LABEL) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3AI00 REAL ARRAY TO 16 BIT PACKED FORMAT -C AUTHOR: JONES,R.E. ORG: W342 DATE: 85-07-31 -C -C ABSTRACT: CONVERTS IEEE FLOATING POINT NUMBERS TO 16 BIT -C PACKED OFFICE NOTE 84 FORMAT. THE FLOATING POINT NUMBER ARE -C CONVERTED TO 16 BIT SIGNED SCALED INTEGERS. -C -C PROGRAM HISTORY LOG: -C 89-10-20 R.E.JONES CONVERT CYBER 205 VERSION OF W3AI00 TO CRAY -C 90-03-18 R.E.JONES CHANGE TO USE CRAY INTEGER*2 PACKER -C 90-10-11 R.E.JONES SPECIAL VERSION TO PACK GRIDS LARGER THAN -C 32743 WORDS. WILL DO OLD AND NEW VERSION. -C 91-02-16 R.E.JONES CHANGES SO EQUIVALENCE OF PACK AND REAL8 -C ARRAYS WILL WORK. -C 93-06-10 R.E.JONES CHANGES FOR ARRAY SIZE (512,512) 262144 WORDS. -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C 98-11-18 Gilbert Changed to pack IEEE values for the IBM SP -C -C USAGE: CALL W3AI00 (REAL8, PACK, LABEL) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C REAL8 ARG LIST ARRAY OF CRAY FLOATING POINT NUMBERS -C LABEL ARG LIST SIX 8-BYTE INTEGER WORDS. -C MUST HAVE FIRST 8 OF 12 32 BIT -C WORD OFFICE NOTE 84 LABEL. WORD 6 MUST HAVE -C IN BITS 31-00 THE NUMBER OF REAL WORDS IN ARRAY -C REAL8 IF J IS GREATER THAN 32743. J IN BITS -C 15-0 OF THE 4TH ID WORD IS SET ZERO. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C PACK ARG LIST PACKED OUTPUT ARRAY OF INTEGER WORDS OF -C SIZE 6 + (J+3)/4 , J = NO. POINTS IN LABEL -C (FROM WORD 4 BITS 15-00). -C LABEL WILL BE COPIED TO PACK WORDS 1-4. PACK -C WILL CONTAIN THE FOLLOWING IN WORDS 5-6 -C WORD 5 BITS 63-48 NUMBER OF BYTES IN WHOLE -C RECORD. WILL NOT BE -C CORRECT IF J > 32743. -C WORD 5 BITS 47-32 EXCLUSIVE-OR CHECKSUM BY 16 -C BIT WORDS OF WHOLE ARRAY PACK -C EXCLUDING CHECKSUM ITSELF. -C WORD 5 BITS 31-00 CENTER VALUE A = MEAN OF -C MAX AND MIN VALUES. -C CONVERTED TO IBM 32 -C FLOATING POINT NUMBER. -C WORD 6 BITS 63-48 ZERO. -C WORD 6 BITS 47-32 16 BIT SHIFT VALUE N. THE -C LEAST INTEGER SUCH THAT -C ABS(X-A)/2**N LT 1 FOR -C ALL X IN REAL8. LIMITED -C TO +-127. -C WORD 6 BITS 31-00 NUMBER OF WORDS IN REAL8 -C IF > 32743, RIGHT ADJUSTED -C IF <= 32743 SET ZERO. -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C IAND IOR BTEST SYSTEM -C -C REMARKS: PACK AND LABEL MAY BE EQUIVALENCED. N, THE NUMBER OF -C POINTS IN A GRID IS NOW IN 32 BIT ID WORD 12. -C -C ATTRIBUTES: -C LANGUAGE: IBM XL FORTRAN. -C MACHINE: IBM SP -C -C$$$ -C - REAL REAL8(*) - REAL XX(262144) -C - INTEGER(8) KK(262144) - INTEGER(8) LABEL(6) - INTEGER(8) PACK(*) - INTEGER(8) TPACK(6) - INTEGER(8) MASK16,MASK32,MASKN,IBYTES,IXOR - INTEGER(8) IB,N - REAL(8) B - REAL(4) X,A - real(4) rtemp(2) - integer(8) irtemp - equivalence (irtemp,rtemp(1)) -C - SAVE -C - EQUIVALENCE (B,IB) -C - DATA MASK16/X'000000000000FFFF'/ - DATA MASK32/X'00000000FFFFFFFF'/ - DATA MASKN /X'0000FFFF00000000'/ -C -C TRANSFER LABEL DATA TO WORDS 1-4. GET WORD COUNT, COMPUTE BYTES. -C - DO 10 I = 1,4 - TPACK(I) = LABEL(I) - 10 CONTINUE -C - TPACK(5) = 0 - TPACK(6) = 0 -C -C GET J, THE NUMBER OF WORDS IN A GRID, IF ZERO GET THE -C GET J FROM OFFICE NOTE 84 ID WORD 12. -C - J = IAND(MASK16,TPACK(4)) - IF (J.EQ.0) THEN - TPACK(6) = LABEL(6) - J = IAND(MASK32,TPACK(6)) - IF (J.EQ.0) THEN - PRINT *,' W3AI00: ERROR, NO. OF WORDS IN GRID = 0' - RETURN - ENDIF - IF (J.GT.262144) THEN - PRINT *,' W3AI00: ERROR, NO. OF WORDS IN GRID = ',J - PRINT *,' THERE IS A LIMIT OF 262144 WORDS.' - RETURN - ENDIF - ENDIF - M = J + 24 -C -C COMPUTE THE NUMBER OF 64 BIT INTEGER CRAY WORDS NEEDED FOR -C PACKED DATA. -C - IF (MOD(M,4).NE.0) THEN - IWORD = (M + 3) / 4 - ELSE - IWORD = M / 4 - ENDIF -C - IBYTES = M + M -C -C STORE NUMBER OF BYTES IN RECORD IN BITS 63-48 OF WORD 5. -C BITS ARE NUMBERED LEFT TO RIGHT 63 T0 00 -C - TPACK(5) = ISHFT(IBYTES,48_8) -C -C FIND MAX, MIN OF DATA, COMPUTE A AND N. -C - RMAX = REAL8(1) - RMIN = RMAX - DO 20 I = 2,J - RMAX = AMAX1(RMAX,REAL8(I)) - RMIN = AMIN1(RMIN,REAL8(I)) - 20 CONTINUE -C - A = 0.5 * (RMAX + RMIN) - X = RMAX - A - IF (RMAX.NE.RMIN) THEN -C CALL USDCTI(X,B,1,1,ISTAT) - CALL Q9E3I6(X,B,1,ISTAT) - IF (ISTAT.NE.0) PRINT *,' W3AI00-USDCTI OVERFLOW ERROR 1' - N = IAND(ISHFT(IB,-56_8),127_8) - N = 4 * (N - 64) - IF (BTEST(IB,55_8)) GO TO 30 - N = N - 1 - IF (BTEST(IB,54_8)) GO TO 30 - N = N - 1 - IF (BTEST(IB,53_8)) GO TO 30 - N = N - 1 - 30 CONTINUE - N = MAX0(-127_8,MIN0(127_8,N)) - ELSE -C -C FIELD IS ZERO OR A CONSTANT -C - N = 0 - ENDIF -C -C CONVERT AVERAGE VALUE FROM IEEE F.P. TO IBM370 32 BIT -C STORE IBM370 32 BIT F.P. AVG. VALUE IN BITS 31 - 00 OF WORD 5. -C -C CALL USSCTI(A,TPACK(5),5,1,ISTAT) - CALL Q9EI32(A,rtemp(2),1,ISTAT) - IF (ISTAT.NE.0) PRINT *,' W3AI00-USDCTI OVERFLOW ERROR 2' - TPACK(5)=IOR(TPACK(5),irtemp) -C -C STORE SCALING VALUE N IN BITS 47 - 32 OF WORD 6. -C - TPACK(6) = IOR(IAND(MASKN,ISHFT(N,32_8)),TPACK(6)) -C -C NOW PACK UP THE DATA, AND SCALE IT TO FIT AN INTEGER*2 WORD -C - TWON = 2.0 ** (15 - N) - DO 40 I = 1,J - XX(I) = (REAL8(I) - A) * TWON - KK(I) = XX(I) + SIGN(0.5,XX(I)) - IF (KK(I).GE.(-32767)) THEN - KK(I) = MIN0(32767_8,KK(I)) - ELSE - KK(I) = -32767 - ENDIF - KK(I) = IAND(KK(I),MASK16) - 40 CONTINUE -C -C SHIFT THE INTEGER*2 DATA TO FIT 4 IN A 64 BIT WORD -C - LIM = (J / 4 ) * 4 - IREM = J - LIM - DO 50 I = 1,LIM,4 - KK(I) = ISHFT(KK(I), 48_8) - KK(I+1) = ISHFT(KK(I+1),32_8) - KK(I+2) = ISHFT(KK(I+2),16_8) - 50 CONTINUE -C -C SHIFT THE REMAINING 1, 2, OR 3 INTEGER*2 WORDS -C - IF (IREM.EQ.1) THEN - KK(LIM+1) = ISHFT(KK(LIM+1),48_8) - ENDIF -C - IF (IREM.EQ.2) THEN - KK(LIM+1) = ISHFT(KK(LIM+1),48_8) - KK(LIM+2) = ISHFT(KK(LIM+2),32_8) - ENDIF -C - IF (IREM.EQ.3) THEN - KK(LIM+1) = ISHFT(KK(LIM+1),48_8) - KK(LIM+2) = ISHFT(KK(LIM+2),32_8) - KK(LIM+3) = ISHFT(KK(LIM+3),16_8) - ENDIF -C -C PACK THE DATA BY USE OF IOR FOUR TO A WORD -C - II = 7 - DO 60 I = 1,LIM,4 - PACK(II) = IOR(IOR(IOR(KK(I),KK(I+1)),KK(I+2)),KK(I+3)) - II = II + 1 - 60 CONTINUE -C -C PACK THE LAST 1, 2, OR 3 INTEGER*2 WORDS -C - IF (IREM.EQ.1) THEN - PACK(IWORD) = KK(LIM+1) - ENDIF -C - IF (IREM.EQ.2) THEN - PACK(IWORD) = IOR(KK(I),KK(I+1)) - ENDIF -C - IF (IREM.EQ.3) THEN - PACK(IWORD) = IOR(IOR(KK(I),KK(I+1)),KK(I+2)) - ENDIF -C -C MOVE LABEL FROM TEMPORARY ARRAY TO PACK -C - DO 70 I = 1,6 - PACK(I) = TPACK(I) - 70 CONTINUE -C -C COMPUTE CHECKSUM AND STORE -C - IXOR = 0 -C -C COMPUTES A 64 BIT CHECKSUM 1ST -C - DO 80 I = 1,IWORD - IXOR = IEOR(IXOR,PACK(I)) - 80 CONTINUE -C -C COMPUTES A 32 BIT CHECKSUM 2ND -C - IXOR = IEOR(ISHFT(IXOR,-32_8),IAND(IXOR,MASK32)) -C -C COMPUTES A 16 BIT CHECKSUM 3RD -C - IXOR = IEOR(ISHFT(IXOR,-16_8),IAND(IXOR,MASK16)) -C -C STORE 16 BIT CHECK SUM OF RECORD IN BITS 47-32 OF WORD 5. -C - PACK(5) = IOR(ISHFT(IXOR,32_8),PACK(5)) -C - RETURN - END - - SUBROUTINE Q9EI32(A,B,N,ISTAT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: Q9EI32 IEEE 32 BIT F.P. TO IBM370 F.P. -C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 90-06-04 -C -C ABSTRACT: CONVERT IEEE 32 BIT TASK 754 FLOATING POINT NUMBERS -C TO IBM370 32 BIT FLOATING POINT NUMBERS. -C -C PROGRAM HISTORY LOG: -C 90-06-04 R.E.JONES CONVERT TO SUN FORTRAN 1.3 -C 90-07-14 R.E.JONES CHANGE ISHFT TO LSHIFT OR LRSHFT -C 91-03-28 R.E.JONES CHANGE TO SiliconGraphics 3.3 FORTRAN 77 -C 92-07-20 R.E.JONES CHANGE TO IBM AIX XL FORTRAN -C 95-11-15 R.E.JONES ADD SAVE STATEMENT -C 98-11-18 Gilbert Specified 4-byte Integer values -C -C USAGE: CALL Q9EI32(A, B, N, ISTAT) -C INPUT ARGUMENT LIST: -C A - REAL*4 ARRAY OF IEEE 32 BIT FLOATING POINT NUMBERS -C N - NUMBER OF WORDS TO CONVERT TO IBM370 32 BIT F.P. -C -C OUTPUT ARGUMENT LIST: -C B - REAL*4 ARRAY OF IBM370 32 BIT FLOATING POINT NUMBERS -C ISTAT - 0 , ALL NUMBERS CONVERTED -C -1 , N IS LESS THAN ONE -C +K , K INFINITY OR NAN NUMBERS WERE FOUND -C -C REMARKS: SEE IEEE TASK 754 STANDARD FLOATING POINT ARITHMETIC FOR -C MORE INFORMATION ABOUT IEEE F.P. -C -C ATTRIBUTES: -C LANGUAGE: IBM AIX XL FORTRAN Compiler/6000 -C MACHINE: IBM RS6000 model 530 -C -C$$$ -C - INTEGER(4) A(*) - INTEGER(4) B(*) - INTEGER(4) SIGN,MASKFR,IBIT8,MASKSN,ITEMP,IBMEXP,IBX7 - INTEGER(4) ISIGN -C - SAVE -C - DATA MASKFR/Z'00FFFFFF'/ - DATA IBIT8 /Z'00800000'/ - DATA MASKSN/Z'7FFFFFFF'/ - DATA SIGN /Z'80000000'/ -C - IF (N.LT.1) THEN - ISTAT = -1 - RETURN - ENDIF -C - ISTAT = 0 -C - DO 30 I = 1,N -C -C SIGN BIT OFF -C - ISIGN = 0 - ITEMP = A(I) -C -C TEST SIGN BIT -C - IF (ITEMP.EQ.0) GO TO 20 -C - IF (ITEMP.LT.0) THEN -C -C SIGN BIT ON -C - ISIGN = SIGN -C -C TURN SIGN BIT OFF -C - ITEMP = IAND(ITEMP,MASKSN) -C - END IF -C - IBMEXP = ISHFT(ITEMP,-23_4) -C -C TEST FOR INDIFINITE OR NAN NUMBER -C - IF (IBMEXP.EQ.255) GO TO 10 -C -C TEST FOR ZERO EXPONENT AND FRACTION (UNDERFLOW) -C - IF (IBMEXP.EQ.0) GO TO 20 - IBMEXP = IBMEXP + 133 - IBX7 = IAND(3_4,IBMEXP) - IBMEXP = IEOR(IBMEXP,IBX7) - IBX7 = IEOR(3_4,IBX7) - ITEMP = IOR(ITEMP,IBIT8) - ITEMP = IOR(ISHFT(IBMEXP,22_4),ISHFT(IAND(ITEMP,MASKFR), - & -IBX7)) - B(I) = IOR(ITEMP,ISIGN) - GO TO 30 -C - 10 CONTINUE -C -C ADD 1 TO ISTAT FOR INDEFINITE OR NAN NUMBER -C - ISTAT = ISTAT + 1 -C - 20 CONTINUE - B(I) = 0 -C - 30 CONTINUE -C - RETURN - END - - SUBROUTINE Q9E3I6(A,B,N,ISTAT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: Q9E3I6 IEEE 32 BIT F.P. TO IBM370 64 BIT F.P. -C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 92-08-02 -C -C ABSTRACT: CONVERT IEEE 32 BIT TASK 754 FLOATING POINT NUMBERS -C TO IBM370 64 BIT FLOATING POINT NUMBERS. -C -C PROGRAM HISTORY LOG: -C 92-08-02 R.E.JONES -C 95-11-15 R.E.JONES ADD SAVE STATEMENT -C -C USAGE: CALL Q9E3I6(A, B, N, ISTAT) -C INPUT ARGUMENT LIST: -C A - REAL*4 ARRAY OF IEEE 32 BIT FLOATING POINT NUMBERS -C N - NUMBER OF WORDS TO CONVERT TO IBM370 64 BIT F.P. -C -C OUTPUT ARGUMENT LIST: -C B - REAL*8 ARRAY OF IBM370 64 BIT FLOATING POINT NUMBERS -C ISTAT - 0 , ALL NUMBERS CONVERTED -C -1 , N IS LESS THAN ONE -C +K , K INFINITY OR NAN NUMBERS WERE FOUND -C -C REMARKS: SEE IEEE TASK 754 STANDARD FLOATING POINT ARITHMETIC FOR -C MORE INFORMATION ABOUT IEEE F.P. -C -C ATTRIBUTES: -C LANGUAGE: IBM AIX XL FORTRAN -C MACHINE: IBM RS/6000 model 530 -C -C$$$ -C - INTEGER(4) A(N) - INTEGER(4) B(2,N) - INTEGER(4) SIGN,MASKFR,IBIT8,MASKSN,ITEMP,IEEEXP - INTEGER(4) IBMEXP,IBX7,JTEMP,ISIGN -C - SAVE -C - DATA MASKFR/Z'00FFFFFF'/ - DATA IBIT8 /Z'00800000'/ - DATA MASKSN/Z'7FFFFFFF'/ - DATA SIGN /Z'80000000'/ -C - IF (N.LT.1) THEN - ISTAT = -1 - RETURN - ENDIF -C - ISTAT = 0 -C - DO 30 I = 1,N - ISIGN = 0 - ITEMP = A(I) -C -C TEST SIGN BIT -C - IF (ITEMP.EQ.0) GO TO 20 -C -C TEST FOR NEGATIVE NUMBERS -C - IF (ITEMP.LT.0) THEN -C -C SIGN BIT ON -C - ISIGN = SIGN -C -C TURN SIGN BIT OFF -C - ITEMP = IAND(ITEMP,MASKSN) -C - END IF -C -C GET IEEE EXPONENT -C - IEEEXP = ISHFT(ITEMP,-23_4) -C -C TEST FOR INDIFINITE OR NAN NUMBER -C - IF (IEEEXP.EQ.255) GO TO 10 -C -C TEST FOR ZERO EXPONENT AND FRACTION (UNDERFLOW) -C CONVERT IEEE EXPONENT (BASE 2) TO IBM EXPONENT -C (BASE 16) -C - IF (IEEEXP.EQ.0) GO TO 20 - IBMEXP = IEEEXP + 133 - IBX7 = IAND(3_4,IBMEXP) - IBMEXP = IEOR(IBMEXP,IBX7) - IBX7 = IEOR(3_4,IBX7) - ITEMP = IOR(ITEMP,IBIT8) - JTEMP = IOR(ISHFT(IBMEXP,22_4),ISHFT(IAND(ITEMP,MASKFR), - & -IBX7)) - B(1,I) = IOR(JTEMP,ISIGN) - B(2,I) = 0 - IF (IBX7.GT.0) B(2,I) = ISHFT(ITEMP,32_4-IBX7) - GO TO 30 -C - 10 CONTINUE -C ADD 1 TO ISTAT FOR INDEFINITE OR NAN NUMBER -C - ISTAT = ISTAT + 1 -C - 20 CONTINUE - B(1,I) = 0 - B(2,I) = 0 -C - 30 CONTINUE -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3ai01.f b/external/w3nco/v2.0.6/src/w3ai01.f deleted file mode 100644 index 85423942..00000000 --- a/external/w3nco/v2.0.6/src/w3ai01.f +++ /dev/null @@ -1,120 +0,0 @@ - SUBROUTINE W3AI01(PACK,REAL8,LABEL) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3AI01 UNPACK RECORD INTO IEEE F.P. -C AUTHOR: JONES,R.E. ORG: W342 DATE: 89-10-17 -C -C ABSTRACT: UNPACKS A RECORD IN OFFICE NOTE 84 FORMAT AND CONVERT THE -C PACKED DATA TO IEEE REAL FLOATING POINT NUMBERS. THE -C OFFICE NOTE 84 DATA IS BIT FOR BIT THE SAME ON THE NAS-9050 AND -C THE CRAY. -C -C PROGRAM HISTORY LOG: -C 89-10-20 R.E.JONES -C 90-02-02 R.E.JONES CHANGE TO CRAY FUNCTION FOR INTEGER*2, F.P. -C 90-10-11 R.E.JONES SPECIAL VERSION OF W3AI01 TO UNPACK RECORDS -C PACKED BY BIG VERSION OF W3AI00. WILL DO -C OLD AND NEW VERSION. -C 91-03-19 R.E.JONES MAKE SPECIAL VERSION OF W3AI01 TO UNPACK -C BIG RECORDS THE OPERATIONAL VERSION. -C 93-06-10 R.E.JONES INCREACE ARRAY SIZE TO 262144 WORDS. -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C 98-11-17 Gilbert Changed to unpack into IEEE reals for the IBM SP -C -C USAGE: CALL W3AI01 (PACK, REAL8, LABEL) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C PACK ARG LIST INTEGER ARRAY WITH DATA IN OFFICE NOTE 84 -C FORMAT TO BE UNPACKED. -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C REAL8 ARG LIST REAL ARRAY OF N WORDS. WHERE N IS GIVEN IN -C WORD 6 OF PACK. WORD 6 OF PACK MUST -C CONTAIN CENTER AND SCALING VALUES. -C LABEL ARG LIST SIX WORD INTEGER LABEL COPIED FROM PACK, 12 -C OFFICE NOTE 84 32 BIT ID'S THAT ARE STORED INTO -C six 64-bit words. -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C Q9IE32 W3LIB -C -C REMARKS: LABEL AND PACK MAY BE EQUIVALENCED. -C -C ATTRIBUTES: -C LANGUAGE: IBM XL FORTRAN -C MACHINE: IBM SP -C -C$$$ -C - REAL REAL8(*) -C - INTEGER(2) ITEMP(262144) - INTEGER(8) LABEL(6) - INTEGER(8) PACK(*) - INTEGER(8) MASK16 - INTEGER(8) MASK32 - integer(2) i2(4) - real(4) rtemp(2) - integer(8) ktemp,jtemp(65536) - equivalence (ktemp,rtemp(1),i2(1)) - equivalence (itemp(1),jtemp(1)) -C - SAVE -C - DATA MASK16/X'000000000000FFFF'/ - DATA MASK32/X'00000000FFFFFFFF'/ -C -C MOVE OFFICE NOTE 84 12 32 BIT ID'S INTO LABEL -C - DO 10 I = 1,6 - LABEL(I) = PACK(I) - 10 CONTINUE -C -C GET WORD COUNT, AVERAGE VALUE, SCALING FACTOR, J, A , N. -C - J = IAND(LABEL(4),MASK16) - IF (J.EQ.0) THEN - J = IAND(LABEL(6),MASK32) - IF (J.EQ.0) THEN - PRINT *,' W3AI01 ERROR, NUMBER OF WORDS IN GRID IS 0' - RETURN - ENDIF - IF (J.GT.262144) THEN - PRINT *,' W3AI01 ERROR, NUMBER OF WORDS IN GRID IS ',J - PRINT *,' THERE IS A LIMIT OF 262144' - RETURN - ENDIF - ENDIF -C -C CONVERT IBM 32 BIT MEAN VALUE TO IEEE F.P. NUMBER -C -C CALL USSCTC(LABEL(5),5,A,1) - ktemp=LABEL(5) - call q9ie32(rtemp(2),rtemp(1),1,istat) - A=rtemp(1) -C -C GET SCALING VALUE N, CAN BE NEGATIVE (INTEGER*2 TWO'S COMPL.) -C -C CALL USICTC(LABEL(6),3,N,1,2) - ktemp=LABEL(6) - n=i2(2) -C - TWON = 2.0 ** (N - 15) -C -C UNPACK, CONVERT TO REAL 64 BIT FLOATING POINT DATA -C -C CALL USICTC(PACK(7),1,ITEMP,J,2) - jtemp(1:65536)=pack(7:65542) -C - DO 20 I = 1,J - REAL8(I) = FLOAT(ITEMP(I)) * TWON + A - 20 CONTINUE -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3ai08.f b/external/w3nco/v2.0.6/src/w3ai08.f deleted file mode 100644 index f7b4de32..00000000 --- a/external/w3nco/v2.0.6/src/w3ai08.f +++ /dev/null @@ -1,2848 +0,0 @@ - SUBROUTINE W3AI08(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AI08 UNPK GRIB FIELD TO GRIB GRID -C PRGMMR: BOSTELMAN ORG: NMC421 DATE:90-07-31 -C -C ABSTRACT: UNPACK A GRIB FIELD TO THE EXACT GRID SPECIFIED IN THE -C MESSAGE, ISOLATE THE BIT MAP AND MAKE THE VALUES OF THE PRODUCT -C DESCRIPTION SEC (PDS) AND THE GRID DESCRIPTION SEC (GDS) -C AVAILABLE IN RETURN ARRAYS. -C -C PROGRAM HISTORY LOG: -C 88-01-20 CAVANAUGH -C 90-05-11 CAVANAUGH TO ASSURE THAT ALL U.S. GRIDS IN THE -C GRIB DECODER COMPLY WITH SIZE CHANGES -C IN THE DECEMBER 1989 REVISIONS. -C 90-05-24 CAVANAUGH CORRECTS SEARCHING AN IMPROPER LOCATION -C FOR GRIB VERSION NUMBER IN GRIB MESSAGES. -C 90-07-15 BOSTELMAN MODIIFED SUB. AI084 SO THAT IT WILL TEST -C THE GRIB BDS BYTE SIZE TO DETERMINE WHAT -C ECMWF GRID ARRAY SIZE IS TO BE SPECIFIED. -C 90-09-14 R.E.JONES CHANGE'S FOR ANSI FORTRAN, AND PDS VERSION 1 -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3AI08(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET) -C INPUT ARGUMENT LIST: -C MSGA - GRIB FIELD - "GRIB" THRU "7777" CHAR*1 -C -C OUTPUT ARGUMENT LIST: -C DATA - ARRAY CONTAINING DATA ELEMENTS -C KPDS - ARRAY CONTAINING PDS ELEMENTS. (VERSION 0) -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - GRIB SPECIFICATION EDITION NUMBER -C KPDS - ARRAY CONTAINING PDS ELEMENTS. (VERSION 1) -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - TOTAL LENGTH OF GRIB MESSAGE (INCLUDING SECTION 0) -C KGDS - ARRAY CONTAINING GDS ELEMENTS. -C (1) - DATA REPRESENTATION TYPE -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUNDINAL DIRECTION OF INCREMENT -C (11) - SCANNING MODE FLAG -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESERVED -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LONGIT DIR INCREMENT -C (10) - LATIT DIR INCREMENT -C (11) - SCANNING MODE FLAG -C (12) - LATITUDE INTERSECTION -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESERVED -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF BDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C KRET - FLAG INDICATING QUALITY OF COMPLETION -C -C REMARKS: VALUES FOR RETURN FLAG (KRET) -C KRET = 0 - NORMAL RETURN, NO ERRORS -C = 1 - 'GRIB' NOT FOUND IN FIRST 100 CHARS -C = 2 - '7777' NOT IN CORRECT LOCATION -C = 3 - UNPACKED FIELD IS LARGER THAN 32768 -C = 4 - GDS/ GRID NOT ONE OF CURRENTLY ACCEPTED VALUES -C = 5 - GRID NOT CURRENTLY AVAIL FOR CENTER INDICATED -C = 8 - TEMP GDS INDICATED, BUT GDS FLAG IS OFF -C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID -C =10 - INCORRECT CENTER INDICATOR -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C 4 AUG 1988 -C W3AI08 -C -C -C GRIB UNPACKING ROUTINE -C -C -C THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID -C TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE -C VALUES OF THE PRODUCT DEFINITION SEC (PDS) AND THE GRID -C DESCRIPTION SEC (GDS) AVAILABLE IN RETURN ARRAYS. -C SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT -C INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN -C GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE -C DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER. -C -C THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS: -C -C CALL W3AI08(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET) -C -C INPUT: -C -C MSGA = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS -C "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES. -C -C OUTPUT: -C -C KPDS(100) INTEGER -C ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT -C DEFINITION SEC . -C (VERSION 0) -C KPDS(1) - ID OF CENTER -C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1) -C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2) -C KPDS(4) - GDS/BMS FLAG -C BIT DEFINITION -C 25 0 - GDS OMITTED -C 1 - GDS INCLUDED -C 26 0 - BMS OMITTED -C 1 - BMS INCLUDED -C NOTE:- LEFTMOST BIT = 1, -C RIGHTMOST BIT = 32 -C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5) -C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7) -C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL -C KPDS(8) - YEAR OF CENTURY -C KPDS(9) - MONTH OF YEAR -C KPDS(10) - DAY OF MONTH -C KPDS(11) - HOUR OF DAY -C KPDS(12) - MINUTE OF HOUR -C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB" -C TABLE 8) -C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A) -C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A) -C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A) -C KPDS(17) - NUMBER INCLUDED IN AVERAGE -C KPDS(18) - VERSION NR OF GRIB SPECIFICATION -C -C (VERSION 1) -C KPDS(1) - ID OF CENTER -C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1) -C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2) -C KPDS(4) - GDS/BMS FLAG -C BIT DEFINITION -C 25 0 - GDS OMITTED -C 1 - GDS INCLUDED -C 26 0 - BMS OMITTED -C 1 - BMS INCLUDED -C NOTE:- LEFTMOST BIT = 1, -C RIGHTMOST BIT = 32 -C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5) -C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7) -C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL -C KPDS(8) - YEAR INCLUDING CENTURY -C KPDS(9) - MONTH OF YEAR -C KPDS(10) - DAY OF MONTH -C KPDS(11) - HOUR OF DAY -C KPDS(12) - MINUTE OF HOUR -C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB" -C TABLE 8) -C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A) -C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A) -C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A) -C KPDS(17) - NUMBER INCLUDED IN AVERAGE -C KPDS(18) - VERSION NR OF GRIB SPECIFICATION -C KPDS(19) - VERSION NR OF PARAMETER TABLE -C KPDS(20) - TOTAL LENGTH 0F GRIB MESSAGE -C (INCLUDING SECTION 0) -C KGDS(13) INTEGER -C ARRAY CONTAINING GDS ELEMENTS. -C -C KGDS(1) - DATA REPRESENTATION TYPE -C -C LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10) -C KGDS(2) - N(I) NUMBER OF POINTS ON LATITUDE -C CIRCLE -C KGDS(3) - N(J) NUMBER OF POINTS ON LONGITUDE -C CIRCLE -C KGDS(4) - LA(1) LATITUDE OF ORIGIN -C KGDS(5) - LO(1) LONGITUDE OF ORIGIN -C KGDS(6) - RESOLUTION FLAG -C BIT MEANING -C 25 0 - DIRECTION INCREMENTS NOT -C GIVEN -C 1 - DIRECTION INCREMENTS GIVEN -C KGDS(7) - LA(2) LATITUDE OF EXTREME POINT -C KGDS(8) - LO(2) LONGITUDE OF EXTREME POINT -C KGDS(9) - DI LONGITUDINAL DIRECTION INCREMENT -C KGDS(10) - REGULAR LAT/LON GRID -C DJ - LATITUDINAL DIRECTION -C INCREMENT -C GAUSSIAN GRID -C N - NUMBER OF LATITUDE CIRCLES -C BETWEEN A POLE AND THE EQUATOR -C KGDS(11) - SCANNING MODE FLAG -C BIT MEANING -C 25 0 - POINTS ALONG A LATITUDE -C SCAN FROM WEST TO EAST -C 1 - POINTS ALONG A LATITUDE -C SCAN FROM EAST TO WEST -C 26 0 - POINTS ALONG A MERIDIAN -C SCAN FROM NORTH TO SOUTH -C 1 - POINTS ALONG A MERIDIAN -C SCAN FROM SOUTH TO NORTH -C 27 0 - POINTS SCAN FIRST ALONG -C CIRCLES OF LATITUDE, THEN -C ALONG MERIDIANS -C (FORTRAN: (I,J)) -C 1 - POINTS SCAN FIRST ALONG -C MERIDIANS THEN ALONG -C CIRCLES OF LATITUDE -C (FORTRAN: (J,I)) -C -C POLAR STEREOGRAPHIC GRIDS (SEE GRIB TABLE 12) -C KGDS(2) - N(I) NR POINTS ALONG LAT CIRCLE -C KGDS(3) - N(J) NR POINTS ALONG LON CIRCLE -C KGDS(4) - LA(1) LATITUDE OF ORIGIN -C KGDS(5) - LO(1) LONGITUDE OF ORIGIN -C KGDS(6) - RESERVED -C KGDS(7) - LOV GRID ORIENTATION -C KGDS(8) - DX - X DIRECTION INCREMENT -C KGDS(9) - DY - Y DIRECTION INCREMENT -C KGDS(10) - PROJECTION CENTER FLAG -C KGDS(11) - SCANNING MODE -C -C SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14) -C KGDS(2) - J PENTAGONAL RESOLUTION PARAMETER -C KGDS(3) - K PENTAGONAL RESOLUTION PARAMETER -C KGDS(4) - M PENTAGONAL RESOLUTION PARAMETER -C KGDS(5) - REPRESENTATION TYPE -C KGDS(6) - COEFFICIENT STORAGE MODE -C -C MERCATOR GRIDS -C KGDS(2) - N(I) NR POINTS ON LATITUDE CIRCLE -C KGDS(3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C KGDS(4) - LA(1) LATITUDE OF ORIGIN -C KGDS(5) - LO(1) LONGITUDE OF ORIGIN -C KGDS(6) - RESOLUTION FLAG -C KGDS(7) - LA(2) LATITUDE OF LAST GRID POINT -C KGDS(8) - LO(2) LONGITUDE OF LAST GRID POINT -C KGDS(9) - LONGIT DIR INCREMENT -C KGDS(10) - LATIT DIR INCREMENT -C KGDS(11) - SCANNING MODE FLAG -C KGDS(12) - LATITUDE INTERSECTION -C LAMBERT CONFORMAL GRIDS -C KGDS(2) - NX NR POINTS ALONG X-AXIS -C KGDS(3) - NY NR POINTS ALONG Y-AXIS -C KGDS(4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C KGDS(5) - LO1 LON OF ORIGIN (LOWER LEFT) -C KGDS(6) - RESERVED -C KGDS(7) - LOV - ORIENTATION OF GRID -C KGDS(8) - DX - X-DIR INCREMENT -C KGDS(9) - DY - Y-DIR INCREMENT -C KGDS(10) - PROJECTION CENTER FLAG -C KGDS(11) - SCANNING MODE FLAG -C KGDS(12) - LATIN 1 - FIRST LAT FROM POLE OF -C SECANT CONE INTERSECTION -C KGDS(13) - LATIN 2 - SECOND LAT FROM POLE OF -C SECANT CONE INTERSECTION -C -C LBMS(32768) LOGICAL -C ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE -C PLACEMENT OF DATA IN THE OUTPUT ARRAY. IF A -C BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE, -C ONE WILL BE GENERATED AUTOMATICALLY BY THE -C UNPACKING ROUTINE. -C -C -C DATA(32768) REAL -C THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS. -C -C NOTE:- 32768 IS MAXIMUN FIELD SIZE ALLOWABLE -C -C KPTR(10) INTEGER -C ARRAY CONTAINING STORAGE FOR THE FOLLOWING -C PARAMETERS. -C -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS (IN BYTES) -C (4) - LENGTH OF GDS (IN BYTES) -C (5) - LENGTH OF BMS (IN BYTES) -C (6) - LENGTH OF BDS (IN BYTES) -C (7) - USED BY UNPACKING ROUTINE -C (8) - NUMBER OF DATA POINTS FOR GRID -C (9) - "GRIB" CHARACTERS START IN BYTE NUMBER -C (10) - USED BY UNPACKING ROUTINE -C -C -C KRET INTEGER -C THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR. -C -C 0 - NO ERRORS DETECTED. -C -C 1 - 'GRIB' NOT FOUND IN FIRST 100 -C CHARACTERS. -C -C 2 - '7777' NOT FOUND, EITHER MISSING OR -C TOTAL OF SEC COUNTS OF INDIVIDUAL -C SEC'S IS INCORRECT. -C -C 3 - UNPACKED FIELD IS LARGER THAN 32768. -C -C 4 - IN GDS, DATA REPRESENTATION TYPE -C NOT ONE OF THE CURRENTLY ACCEPTABLE -C VALUES. SEE "GRIB" TABLE 9. VALUE -C OF INCORRECT TYPE RETURNED IN KGDS(1). -C -C 5 - GRID INDICATED IN KPDS(3) IS NOT -C AVAILABLE FOR THE CENTER INDICATED IN -C KPDS(1) AND NO GDS SENT. -C -C 7 - VERSION INDICATED IN KPDS(18) HAS NOT -C YET BEEN INCLUDED IN THE DECODER. -C -C 8 - GRID IDENTIFICATION = 255 (NOT STANDARD -C GRID) BUT FLAG INDICATING PRESENCE OF -C GDS IS TURNED OFF. NO METHOD OF -C GENERATING PROPER GRID. -C -C 9 - PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT -C MATCH STANDARD NUMBER OF POINTS FOR THIS -C GRID (FOR OTHER THAN SPECTRALS). THIS -C WILL OCCUR ONLY IF THE GRID. -C IDENTIFICATION, KPDS(3), AND A -C TRANSMITTED GDS ARE INCONSISTENT. -C -C 10 - CENTER INDICATOR WAS NOT ONE INDICATED -C IN "GRIB" TABLE 1. PLEASE CONTACT AD -C PRODUCTION MANAGEMENT BRANCH (W/NMC42) -C IF THIS ERROR IS ENCOUNTERED. -C -C -C -C LIST OF TEXT MESSAGES FROM CODE -C -C -C W3AI08/AI082 -C -C 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY -C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH -C (W/NMC42)' -C -C 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY -C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH -C (W/NMC42)' -C -C 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL -C OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION, -C PRODUCTION MANAGEMENT BRANCH (W/NMC42)' -C -C 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY -C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH -C (W/NMC42)' -C -C -C W3AI08/AI083 -C -C 'POLAR STEREO PROCESSING NOT AVAILABLE' * -C -C W3AI08/AI084 -C -C 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL -C COEFFICIENTS' -C -C -C W3AI08/AI087 -C -C 'NO CURRENT LISTING OF FNOC GRIDS' * -C -C -C * WILL BE AVAILABLE IN NEXT UPDATE -C *************************************************************** -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C BIT MAP - LOGICAL KBMS(*) -C -C ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS) - INTEGER KPDS(*) -C ELEMENTS OF GRID DESCRIPTION SEC (PDS) - INTEGER KGDS(*) -C -C CONTAINER FOR GRIB GRID - REAL DATA(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C -C ***************************************************************** -C 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE -C FIND 'GRIB' CHARACTERS -C 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE -C IF '7777' IS IN PROPER PLACE. -C 3.0 PARSE PRODUCT DEFINITION SECTION. -C 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED) -C 5.0 PARSE BIT MAP SEC (IF INCLUDED) -C 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID -C DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT -C DATA AND PLACE INTO PROPER ARRAY. -C ******************************************************************* -C -C MAIN DRIVER -C -C ******************************************************************* - KPTR(10) = 0 -C SEE IF PROPER 'GRIB' KEY EXISTS, THEN -C USING SEC COUNTS, DETERMINE IF '7777' -C IS IN THE PROPER LOCATION -C - CALL AI081(MSGA,KPTR,KPDS,KRET) - IF (KRET.NE.0) GO TO 900 -C -C PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION -C - IF (KPDS(18).EQ.0) THEN - CALL AI082(MSGA,KPTR,KPDS,KRET) - ELSE IF (KPDS(18).EQ.1) THEN - CALL AI082A(MSGA,KPTR,KPDS,KRET) - ELSE - PRINT *,'GRIB EDITION',KPDS(18),' NOT PROGRAMMED FOR' - KRET = 7 - GO TO 900 - END IF - IF (KRET.NE.0) GO TO 900 -C -C EXTRACT NEW GRID DESCRIPTION -C - CALL AI083(MSGA,KPTR,KPDS,KGDS,KRET) - IF (KRET.NE.0) GO TO 900 -C -C EXTRACT OR GENERATE BIT MAP -C - CALL AI084(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) - IF (KRET.NE.0) GO TO 900 -C -C USING INFORMATION FROM PDS, BMS AND BIT DATA SEC , -C EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES. -C - IF (KPDS(18).EQ.0) THEN - CALL AI085(MSGA,KPTR,KPDS,KBMS,DATA,KRET) - ELSE IF (KPDS(18).EQ.1) THEN - CALL AI085A(MSGA,KPTR,KPDS,KBMS,DATA,KRET) - ELSE - PRINT *,'AI085 NOT PROGRAMMED FOR VERSION NR',KPDS(18) - KRET = 7 - END IF -C - 900 RETURN - END - SUBROUTINE AI081(MSGA,KPTR,KPDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI081 FIND 'GRIB' CHARS & RESET POINTERS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20 -C -C ABSTRACT: FIND 'GRIB; CHARACTERS AND SET POINTERS TO THE NEXT -C BYTE FOLLOWING 'GRIB'. IF THEY EXIST EXTRACT COUNTS FROM GDS AND -C BMS. EXTRACT COUNT FROM BDS. DETERMINE IF SUM OF COUNTS ACTUALLY -C PLACES TERMINATOR '7777' AT THE CORRECT LOCATION. -C -C PROGRAM HISTORY LOG: -C 88-01-20 CAVANAUGH -C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C -C USAGE: CALL AI081(MSGA,KPTR,KPDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - GRIB FIELD - "GRIB" THRU "7777" -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF BDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE -C (10) - GRIB/GRID ELEMENT COUNT -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C KPTR - SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C ERROR RETURNS -C KRET = 1 - NO 'GRIB' -C 2 - NO '7777' OR MISLOCATED (BY COUNTS) -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C PRODUCT DESCRIPTION SECTION DATA. - INTEGER KPDS(*) -C - INTEGER KRET -C -C DATA MASK40/Z00000040/ -C DATA MASK80/Z00000080/ -C - DATA MASK40/64/ - DATA MASK80/128/ -C -C ****************************************************************** - KRET = 0 -C ------------------- FIND 'GRIB' KEY - DO 100 I = 1, 105 - IF (MOVA2I(MSGA(I )).NE.71) GO TO 100 - IF (MOVA2I(MSGA(I+1)).NE.82) GO TO 100 - IF (MOVA2I(MSGA(I+2)).NE.73) GO TO 100 - IF (MOVA2I(MSGA(I+3)).NE.66) GO TO 100 - KPTR(9) = I - GO TO 200 - 100 CONTINUE - KRET = 1 - RETURN -C - 200 CONTINUE - IS = KPTR(9) -C ------------------- HAVE 'GRIB' KEY - KCNT = 0 -C --------------- EXTRACT COUNT FROM PDS OR GRIB - ISS = IS + 4 - DO 300 I = 0, 2 - KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS)) - 300 CONTINUE -C -C TEST FOR VERSION NUMBER OF PDS 0 OR 1 -C - IF (KCNT.EQ.24) THEN - KPTR(3) = KCNT - IGRIBL = 4 -C -C --------------- EDITION NR OF GRIB SPECIFICATION, VERSION 0 -C - KPDS(18) = MOVA2I(MSGA(ISS + 3)) - ELSE - IGRIBL = 8 - ISS = IS + IGRIBL -C --------------- EDITION NR OF GRIB SPECIFICATION, VERSION 1 - KPDS(18) = MOVA2I(MSGA(IS + 7)) -C -C --------------- PARAMETER TABLE VERSION NUMBER FOR INTERNATIONAL -C EXCHANGE (CURRENTLY NO. 1) -C - KPDS(19) = MOVA2I(MSGA(ISS + 3)) -C -C ---------------- SAVE TOTAL LENGTH OF MESSAGE (INCLUDING SECTION 0) -C - KPDS(20) = KCNT -C -C --------------- EXTRACT COUNT FROM PDS VERSION 1 -C - KCNT = 0 - DO 400 I = 0, 2 - KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS)) - 400 CONTINUE - KPTR(3) = KCNT - ENDIF -C -C --------------- GET GDS, BMS INDICATOR -C - KPDS(4) = MOVA2I(MSGA(ISS+7)) -C -C READY FOR NEXT SECTION -C - KPTR(4) = 0 - KPTR(5) = 0 - IF (IAND(KPDS(4),MASK80).EQ.0) GO TO 600 -C -C --------------- EXTRACT COUNT FROM GDS -C - ISS = KPTR(3) + IS + IGRIBL - KCNT = 0 - DO 500 I = 0, 2 - KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS)) - 500 CONTINUE - KPTR(4) = KCNT - 600 CONTINUE - IF (IAND(KPDS(4),MASK40).EQ.0) GO TO 800 -C -C ---------------- EXTRACT COUNT FROM BMS -C - ISS = KPTR(3) + KPTR(4) + IS + IGRIBL - KCNT = 0 - DO 700 I = 0, 2 - KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS)) - 700 CONTINUE - KPTR(5) = KCNT -C -C --------------- EXTRACT COUNT FROM BDS -C - 800 CONTINUE - KCNT = 0 - ISS = KPTR(3) + KPTR(4) + KPTR(5) + IS + IGRIBL - DO 900 I = 0, 2 - KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS)) - 900 CONTINUE - KPTR(6) = KCNT -C -C --------------- TEST FOR '7777' -C - ISS = KPTR(3) + KPTR(4) + KPTR(5) + KPTR(6) + IS + IGRIBL - KRET = 0 - DO 1000 I = 0, 3 - IF (MOVA2I(MSGA(I+ISS)).EQ.55) THEN - GO TO 1000 - ELSE - KRET = 2 - RETURN - END IF - 1000 CONTINUE - RETURN - END - SUBROUTINE AI082(MSGA,KPTR,KPDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI082 GATHER INFO FROM PGM DESC SECTION -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20 -C -C ABSTRACT: EXTRACT INFORMATION FROM THE PRODUCT DESCRIPTION -C SEC , AND GENERATE LABEL INFORMATION TO PERMIT STORAGE -C IN OFFICE NOTE 84 FORMAT. -C -C PROGRAM HISTORY LOG: -C 88-01-20 CAVANAUGH -C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C -C USAGE: CALL AI082(MSGA,KPTR,KPDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF PDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NUMBER OF GRIB SPEFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - TOTAL LENGTH OF GRIB MESSAGE (INCLUDING SECTION 0) -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C ERROR RETURN = 0 - NO ERRORS -C = 8 - TEMP GDS INDICATED, BUT NO GDS -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C PRODUCT DESCRIPTION SECTION ENTRIES - INTEGER KPDS(*) -C - INTEGER KRET -C -C -------------------- COLLECT PDS VALUES -C KPDS(1) - ID OF CENTER -C KPDS(2) - MODEL IDENTIFICATION -C KPDS(3) - GRID IDENTIFICATION -C KPDS(4) - GDS/BMS FLAG -C KPDS(5) - INDICATOR OF PARAMETER -C ----------- KPDS(6) - TYPE OF LEVEL - IS = KPTR(9) - ISS = IS + 8 - DO 200 I = 0, 5 - KPDS(I+1) = MOVA2I(MSGA(I+ISS)) - 200 CONTINUE - IF (KPDS(3).NE.255) GO TO 250 - IF (IAND(KPDS(4),128).NE.0) GO TO 250 - KRET = 8 - RETURN - 250 CONTINUE - ISS = IS + 14 - KPDS(7) = 0 - DO 300 I = 0, 1 - KPDS(7) = KPDS(7) * 256 + MOVA2I(MSGA(I+ISS)) - 300 CONTINUE -C ----------- KPDS(8) - YEAR OF CENTURY -C KPDS(9) - MONTH OF YEAR -C KPDS(10) - DAY OF MONTH -C KPDS(11) - HOUR OF DAY -C KPDS(12) - MINUTE OF HOUR -C KPDS(13) - INDICATOR OF FORECAST TIME UNIT -C KPDS(14) - TIME RANGE 1 -C KPDS(15) - TIME RANGE 2 -C ----------- KPDS(16) - TIME RANGE FLAG -C - ISS = IS + 16 - DO 400 I = 0, 7 - KPDS(I+8) = MOVA2I(MSGA(I+ISS)) - 400 CONTINUE -C ----------- KPDS(17) - NUMBER INCLUDED IN AVERAGE - ISS = IS + 25 - KPDS(17) = 0 - DO 500 I = 0, 1 - KPDS(17) = KPDS(17) * 256 + MOVA2I(MSGA(I+ISS)) - 500 CONTINUE -C -----------SKIP OVER SOURCE BYTE 24 -C ----------- TEST FOR NEW GRID - IF (IAND(KPDS(4),128).NE.0) THEN - IF (IAND(KPDS(4),64).NE.0) THEN - IF (KPDS(3).NE.255) THEN - IF (KPDS(1).EQ.7) THEN - IF (KPDS(3).GE.21.AND.KPDS(3).LE.26) THEN - ELSE IF (KPDS(3).EQ.50) THEN - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - ELSE IF (KPDS(3).EQ.70) THEN - ELSE IF (KPDS(3).GE.85.AND.KPDS(3).LE.86) THEN - ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LE.103) THEN - ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.214) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' NMC' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.98) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' ECMWF' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.74) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - ELSE IF (KPDS(3).EQ.70) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' U.K. MET OFFICE, BRACKNELL' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.58) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' FNOC,' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - END IF - END IF - END IF - END IF - RETURN - END - SUBROUTINE AI082A(MSGA,KPTR,KPDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI082A GATHER INFO FROM PGM DESC SECTION -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20 -C -C ABSTRACT: EXTRACT INFORMATION FROM THE PRODUCT DESCRIPTION SECTION -C (VERSION 1) -C -C PROGRAM HISTORY LOG: -C 89-11-20 CAVANAUGH -C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C -C USAGE: CALL AI082A(MSGA,KPTR,KPDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF PDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C -C OUTPUT ARGUMENT LIST: -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR (INCLUDING CENTURY) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - TOTAL BYTE COUNT FOR SOURCE MESSAGE -C -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C SOURCE PDS STRUCTURE (VERSION 1) -C 1-3 - LENGTH OF PDS SECTION IN BYTES -C 4 - PARAMETER TABLE VERSION NO. FOR INTERNATIONAL -C EXCHANGE (CRRENTLY NO. 1) -C 5 - CENTER ID -C 6 - MODEL ID -C 7 - GRID ID -C 8 - FLAG FOR GDS/BMS -C 9 - INDICATOR FOR PARAMETER -C 10 - INDICATOR FOR TYPE OF LEVEL -C 11-12 - HEIGHT, PRESSURE OF LEVEL -C 13 - YEAR OF CENTURY -C 14 - MONTH -C 15 - DAY -C 16 - HOUR -C 17 - MINUTE -C 18 - FORECAST TIME UNIT -C 19 - P1 - PD OF TIME -C 20 - P2 - PD OF TIME -C 21 - TIME RANGE INDICATOR -C 22-23 - NUMBER IN AVERAGE -C 24 - NUMBER MISG FROM AVERAGES -C 25 - CENTURY -C 26 - INDICATOR OF PARAMETER IN LOCALLY RE-DEFINED -C PARAMETER TABLE. -C 27-28 - UNITS DECIMAL SCALE FACTOR (D) -C 29-40 - RESERVED: NEED NOT BE PRESENT -C 41-NN - NATIONAL USE -C . -C -C ERROR RETURN = 0 - NO ERRORS -C = 8 - TEMP GDS INDICATED, BUT NO GDS -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C PRODUCT DESCRIPTION SECTION ENTRIES - INTEGER KPDS(*) -C - INTEGER KRET -C - IS = KPTR(9) - IGRIBL = 8 -C -------------------- COLLECT PDS VALUES -C KPDS(1) - ID OF CENTER -C KPDS(2) - MODEL IDENTIFICATION -C KPDS(3) - GRID IDENTIFICATION -C KPDS(4) - GDS/BMS FLAG -C KPDS(5) - INDICATOR OF PARAMETER -C ----------- KPDS(6) - TYPE OF LEVEL - ISS = IS + IGRIBL + 4 - DO 200 I = 0, 5 - KPDS(I+1) = MOVA2I(MSGA(I+ISS)) - 200 CONTINUE - IF (KPDS(3).NE.255) GO TO 250 - IF (IAND(KPDS(4),128).NE.0) GO TO 250 - KRET = 8 - RETURN - 250 CONTINUE -C HEIGHT, PRESS OF LEVEL - ISS = IS + IGRIBL + 10 - KPDS(7) = 0 - DO 300 I = 0, 1 - KPDS(7) = KPDS(7) * 256 + MOVA2I(MSGA(I+ISS)) - 300 CONTINUE -C -C ----------- KPDS(8) - YEAR (INCLUDING CENTURY) -C - ISS = IS + IGRIBL + 12 - ICEN = IS + IGRIBL + 24 -C - KPDS(8) = MOVA2I(MSGA(ICEN)) * 100 + MOVA2I(MSGA(ISS)) -C -C KPDS(9) - MONTH OF YEAR -C KPDS(10) - DAY OF MONTH -C KPDS(11) - HOUR OF DAY -C KPDS(12) - MINUTE OF HOUR -C KPDS(13) - INDICATOR OF FORECAST TIME UNIT -C KPDS(14) - TIME RANGE 1 -C KPDS(15) - TIME RANGE 2 -C ----------- KPDS(16) - TIME RANGE FLAG -C - ISS = IS + IGRIBL + 13 - DO 400 I = 0, 7 - KPDS(I+9) = MOVA2I(MSGA(I+ISS)) - 400 CONTINUE -C ----------- KPDS(17) - NUMBER INCLUDED IN AVERAGE - ISS = IS + IGRIBL + 21 - KPDS(17) = 0 - DO 500 I = 0, 1 - KPDS(17) = KPDS(17) * 256 + MOVA2I(MSGA(I+ISS)) - 500 CONTINUE -C -----------SKIP OVER SOURCE BYTE 28 -C ----------- TEST FOR NEW GRID - IF (IAND(KPDS(4),128).NE.0) THEN - IF (IAND(KPDS(4),64).NE.0) THEN - IF (KPDS(3).NE.255) THEN - IF (KPDS(1).EQ.7) THEN - IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN - ELSE IF (KPDS(3).EQ.50) THEN - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - ELSE IF (KPDS(3).EQ.70) THEN - ELSE IF (KPDS(3).GE.85.AND.KPDS(3).LE.86) THEN - ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LE.103) THEN - ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.214) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' NMC' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.98) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' ECMWF' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.74) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - ELSE IF (KPDS(3).EQ.70) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' U.K. MET OFFICE, BRACKNELL' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.58) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - ELSE - PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', - * ' FNOC,' - PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' - PRINT *,' PRODUCTION MANAGEMENT BRANCH' - PRINT *,' W/NMC42)' - END IF - END IF - END IF - END IF - END IF - RETURN - END - SUBROUTINE AI083(MSGA,KPTR,KPDS,KGDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI083 EXTRACT INFO FROM GRIB-GDS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20 -C -C ABSTRACT: EXTRACT INFORMATION ON UNLISTED GRID TO ALLOW -C CONVERSION TO OFFICE NOTE 84 FORMAT. -C -C PROGRAM HISTORY LOG: -C 88-01-20 CAVANAUGH -C 89-03-16 CAVANAUGH ADDED MERCATOR & LAMBERT CONFORMAL PROCESSING -C 89-07-12 CAVANAUGH CORRECTED CHANGE ENTERED 89-03-16 REORDERING -C PROCESSING FOR LAMBERT CONFORMAL AND MERCATOR -C GRIDS. -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C -C USAGE: CALL AI083(MSGA,KPTR,KPDS,KGDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF BDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KGDS - ARRAY CONTAINING GDS ELEMENTS. -C (1) - DATA REPRESENTATION TYPE -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION OF INCREMENT -C (11) - SCANNING MODE FLAG -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESERVED -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LONGIT DIR INCREMENT -C (10) - LATIT DIR INCREMENT -C (11) - SCANNING MODE FLAG -C (12) - LATITUDE INTERSECTION -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESERVED -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C KRET = 0 -C = 4 - DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C ************************************************************ -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C ARRAY GDS ELEMENTS - INTEGER KGDS(*) -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C ARRAY OF PDS ELEMENTS - INTEGER KPDS(*) -C - INTEGER KRET -C -C DATA MSK80 /Z00000080/ -C - DATA MSK80 /128/ -C ******************************************************** -C IF FLAG IN PDS INDICATE THAT THERE IS NO GDS , -C RETURN IMMEDIATELY -C ************************************************************ - IF (IAND(KPDS(4),MSK80).EQ.0) GO TO 900 -C ------------------- BYTE 1-3 COUNT - IS = KPTR(9) - IF (KPDS(18).EQ.0) THEN - IGRIBL = 4 - ELSE - IGRIBL = 8 - ENDIF - ISS = IS + KPTR(3) + IGRIBL -C ------------------- BYTE 4 NUMBER OF UNUSED BITS AT END OF SEC -C ------------------- BYTE 5 RESERVED -C ------------------- BYTE 6 DATA REPRESENTATION TYPE - KGDS(1) = MOVA2I(MSGA(ISS+5)) -C ------------------- DIVERT TO PROCESS CORRECT TYPE - IF (KGDS(1).EQ.0) THEN - GO TO 1000 - ELSE IF (KGDS(1).EQ.1) THEN - GO TO 4000 - ELSE IF (KGDS(1).EQ.2.OR.KGDS(1).EQ.5) THEN - GO TO 2000 - ELSE IF (KGDS(1).EQ.3) THEN - GO TO 5000 - ELSE IF (KGDS(1).EQ.4) THEN - GO TO 1000 - ELSE IF (KGDS(1).EQ.50) THEN - GO TO 3000 - ELSE -C MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE - KRET = 4 - GO TO 900 - END IF -C -C ------------------- LATITUDE/LONGITUDE GRIDS -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE - 1000 KGDS(2) = 0 - DO 1005 I = 0, 1 - KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6)) - 1005 CONTINUE -C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN - KGDS(3) = 0 - DO 1010 I = 0, 1 - KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8)) - 1010 CONTINUE -C ------------------- BYTE 11-13 LATITUE OF ORIGIN - KGDS(4) = 0 - DO 1020 I = 0, 2 - KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10)) - 1020 CONTINUE - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = IAND(KGDS(4),8388607) * (-1) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN - KGDS(5) = 0 - DO 1030 I = 0, 2 - KGDS(5) = KGDS(5) * 256 + MOVA2I(MSGA(I+ISS+13)) - 1030 CONTINUE - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESOLUTION FLAG - KGDS(6) = MOVA2I(MSGA(ISS+16)) -C ------------------- BYTE 18-20 LATITUDE OF LAST GRID POINT - KGDS(7) = 0 - DO 1040 I = 0, 2 - KGDS(7) = KGDS(7) * 256 + MOVA2I(MSGA(I+ISS+17)) - 1040 CONTINUE - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 LONGITUDE OF LAST GRID POINT - KGDS(8) = 0 - DO 1050 I = 0, 2 - KGDS(8) = KGDS(8) * 256 + MOVA2I(MSGA(I+ISS+20)) - 1050 CONTINUE - IF (IAND(KGDS(8),8388608).NE.0) THEN - KGDS(8) = - IAND(KGDS(8),8388607) - END IF -C ------------------- BYTE 24-25 LATITUDINAL DIR INCREMENT - KGDS(9) = 0 - DO 1060 I = 0, 1 - KGDS(9) = KGDS(9) * 256 + MOVA2I(MSGA(I+ISS+23)) - 1060 CONTINUE -C ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID -C HAVE LONGIT DIR INCREMENT -C ELSE IF GAUSSIAN GRID -C HAVE NR OF LAT CIRCLES -C BETWEEN POLE AND EQUATOR - KGDS(10) = 0 - DO 1070 I = 0, 1 - KGDS(10) = KGDS(10) * 256 + MOVA2I(MSGA(I+ISS+25)) - 1070 CONTINUE -C ------------------- BYTE 28 SCANNING MODE FLAGS - KGDS(11) = MOVA2I(MSGA(ISS+27)) -C ------------------- BYTE 29-32 RESERVED -C ------------------- - GO TO 900 -C ------------------- -C ' POLAR STEREO PROCESSING ' -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG X=AXIS - 2000 KGDS(2) = 0 - DO 2005 I = 0, 1 - KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6)) - 2005 CONTINUE -C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS - KGDS(3) = 0 - DO 2010 I = 0, 1 - KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8)) - 2010 CONTINUE -C ------------------- BYTE 11-13 LATITUDE OF ORIGIN - KGDS(4) = 0 - DO 2020 I = 0, 2 - KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10)) - 2020 CONTINUE - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = - IAND(KGDS(4),8388607) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN - KGDS(5) = 0 - DO 2030 I = 0, 2 - KGDS(5) = KGDS(5) * 256 + MOVA2I(MSGA(I+ISS+13)) - 2030 CONTINUE - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESERVED - KGDS(6) = MOVA2I(MSGA(ISS+16)) -C ------------------- BYTE 18-20 LOV ORIENTATION OF THE GRID - KGDS(7) = 0 - DO 2040 I = 0, 2 - KGDS(7) = KGDS(7) * 256 + MOVA2I(MSGA(I+ISS+17)) - 2040 CONTINUE - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 DX - THE X DIRECTION INCREMENT - KGDS(8) = 0 - DO 2050 I = 0, 2 - KGDS(8) = KGDS(8) * 256 + MOVA2I(MSGA(I+ISS+20)) - 2050 CONTINUE - IF (IAND(KGDS(8),8388608).NE.0) THEN - KGDS(8) = - IAND(KGDS(8),8388607) - END IF -C ------------------- BYTE 24-26 DY - THE Y DIRECTION INCREMENT - KGDS(9) = 0 - DO 2060 I = 0, 2 - KGDS(9) = KGDS(9) * 256 + MOVA2I(MSGA(I+ISS+23)) - 2060 CONTINUE - IF (IAND(KGDS(9),8388608).NE.0) THEN - KGDS(9) = - IAND(KGDS(9),8388607) - END IF -C ------------------- BYTE 27 PROJECTION CENTER FLAG - KGDS(10) = MOVA2I(MSGA(ISS+26)) -C ------------------- BYTE 28 SCANNING MODE - KGDS(11) = MOVA2I(MSGA(ISS+27)) -C ------------------- BYTE 29-32 RESERVED -C ------------------- - GO TO 900 -C -C ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF. -C -C ------------------- BYTE 7-8 J PENTAGONAL RESOLUTION PARAMETER - 3000 KGDS(2) = 0 - DO 3010 I = 0, 1 - KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6)) - 3010 CONTINUE -C ------------------- BYTE 9-10 K PENTAGONAL RESOLUTION PARAMETER - KGDS(3) = 0 - DO 3020 I = 0, 1 - KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8)) - 3020 CONTINUE -C ------------------- BYTE 11-12 M PENTAGONAL RESOLUTION PARAMETER - KGDS(4) = 0 - DO 3030 I = 0, 1 - KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10)) - 3030 CONTINUE -C ------------------- BYTE 13 REPRESENTATION TYPE - KGDS(5) = MOVA2I(MSGA(ISS+12)) -C ------------------- BYTE 14 COEFFICIENT STORAGE MODE - KGDS(6) = MOVA2I(MSGA(ISS+13)) -C ------------------- EMPTY FIELDS - BYTES 15 - 32 - KRET = 0 - GO TO 900 -C ------------------- PROCESS MERCATOR GRIDS -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE - 4000 KGDS(2) = 0 - DO 4005 I = 0, 1 - KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6)) - 4005 CONTINUE -C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN - KGDS(3) = 0 - DO 4010 I = 0, 1 - KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8)) - 4010 CONTINUE -C ------------------- BYTE 11-13 LATITUE OF ORIGIN - KGDS(4) = 0 - DO 4020 I = 0, 2 - KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10)) - 4020 CONTINUE - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = - IAND(KGDS(4),8388607) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN - KGDS(5) = 0 - DO 4030 I = 0, 2 - KGDS(5) = KGDS(5) * 256 + MOVA2I(MSGA(I+ISS+13)) - 4030 CONTINUE - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESOLUTION FLAG - KGDS(6) = MOVA2I(MSGA(ISS+16)) -C ------------------- BYTE 18-20 LATITUDE OF EXTREME POINT - KGDS(7) = 0 - DO 4040 I = 0, 2 - KGDS(7) = KGDS(7) * 256 + MOVA2I(MSGA(I+ISS+17)) - 4040 CONTINUE - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 LONGITUDE OF EXTREME POINT - KGDS(8) = 0 - DO 4050 I = 0, 2 - KGDS(8) = KGDS(8) * 256 + MOVA2I(MSGA(I+ISS+20)) - 4050 CONTINUE - IF (IAND(KGDS(8),8388608).NE.0) THEN - KGDS(8) = - IAND(KGDS(8),8388607) - END IF -C ------------------- BYTE 24-25 LONGITUDE DIR INCREMENT - KGDS(9) = 0 - DO 4070 I = 0, 1 - KGDS(9) = KGDS(9) * 256 + MOVA2I(MSGA(I+ISS+23)) - 4070 CONTINUE - IF (IAND(KGDS(9),8388608).NE.0) THEN - KGDS(9) = - IAND(KGDS(9),32768) - END IF -C ------------------- BYTE 26-27 LATIT DIR INCREMENT - KGDS(10) = 0 - DO 4080 I = 0, 1 - KGDS(10) = KGDS(10) * 256 + MOVA2I(MSGA(I+ISS+25)) - 4080 CONTINUE - IF (IAND(KGDS(10),8388608).NE.0) THEN - KGDS(10) = - IAND(KGDS(10),32768) - END IF -C ------------------- BYTE 28 SCANNING MODE FLAGS - KGDS(11) = MOVA2I(MSGA(ISS+27)) -C ------------------- BYTE 29-31 INTERSECTION LATITUDE - KGDS(12) = 0 - DO 4060 I = 0, 2 - KGDS(12)= KGDS(12) * 256 + MOVA2I(MSGA(I+ISS+28)) - 4060 CONTINUE -C ------------------- BYTE 32 RESERVED -C ------------------- - GO TO 900 -C ------------------- PROCESS LAMBERT CONFORMAL -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG X-AXIS - 5000 KGDS(2) = 0 - DO 5005 I = 0, 1 - KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6)) - 5005 CONTINUE -C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS - KGDS(3) = 0 - DO 5010 I = 0, 1 - KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8)) - 5010 CONTINUE -C ------------------- BYTE 11-13 LATITUDE OF ORIGIN - KGDS(4) = 0 - DO 5020 I = 0, 2 - KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10)) - 5020 CONTINUE - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = - IAND(KGDS(4),8388607) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN (LOWER LEFT) - KGDS(5) = 0 - DO 5030 I = 0, 2 - KGDS(5) = KGDS(5) * 256 + MOVA2I(MSGA(I+ISS+13)) - 5030 CONTINUE - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESERVED -C KGDS(6) = -C ------------------- BYTE 18-20 LOV -ORIENTATION OF GRID - KGDS(7) = 0 - DO 5040 I = 0, 2 - KGDS(7) = KGDS(7) * 256 + MOVA2I(MSGA(I+ISS+17)) - 5040 CONTINUE - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 DX - X-DIR INCREMENT - KGDS(8) = 0 - DO 5060 I = 0, 2 - KGDS(8) = KGDS(8) * 256 + MOVA2I(MSGA(I+ISS+20)) - 5060 CONTINUE -C ------------------- BYTE 24-26 DY - Y-DIR INCREMENT - KGDS(9) = 0 - DO 5070 I = 0, 2 - KGDS(9) = KGDS(9) * 256 + MOVA2I(MSGA(I+ISS+23)) - 5070 CONTINUE -C ------------------- BYTE 27 PROJECTION CENTER FLAG - KGDS(10) = MOVA2I(MSGA(ISS+26)) -C ------------------- BYTE 28 SCANNING MODE - KGDS(11) = MOVA2I(MSGA(ISS+27)) -C ------------------- BYTE 29-31 LATIN1 - 1ST LAT FROM POLE - KGDS(12) = 0 - DO 5050 I = 0, 2 - KGDS(12)= KGDS(12)* 256 + MOVA2I(MSGA(I+ISS+28)) - 5050 CONTINUE - IF (IAND(KGDS(12),8388608).NE.0) THEN - KGDS(12) = - IAND(KGDS(12),8388607) - END IF -C ------------------- BYTE 32-34 LATIN2 - 2ND LAT FROM POLE - KGDS(13) = 0 - DO 5055 I = 0, 2 - KGDS(13)= KGDS(13)* 256 + MOVA2I(MSGA(I+ISS+31)) - 5055 CONTINUE - IF (IAND(KGDS(13),8388608).NE.0) THEN - KGDS(13) = - IAND(KGDS(13),8388607) - END IF -C ------------------- - 900 CONTINUE - RETURN - END - SUBROUTINE AI084(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI084 EXTRACT OR GENERATE BIT MAP FOR OUTPUT -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20 -C -C ABSTRACT: IF BIT MAP SEC IS AVAILABLE IN GRIB MESSAGE, EXTRACT -C FOR PROGRAM USE, OTHERWISE GENERATE AN APPROPRIATE BIT MAP. -C -C PROGRAM HISTORY LOG: -C 88-01-20 CAVANAUGH -C 89-02-24 CAVANAUGH INCREMENT OF POSITION IN BIT MAP WHEN BIT MAP -C WAS INCLUDED WAS HANDLED IMPROPERLY. -C CORRECTED THIS DATA. -C 89-07-12 CAVANAUGH ALTERED METHOD OF CALCULATING NR OF BITS -C IN A BIT MAP CONTAINED IN GRIB MESSAGE. -C 90-05-07 CAVANAUGH BRINGS ALL U.S. GRIDS TO -C REVISED VALUES AS OF DEC 89. -C 90-07-15 BOSTELMAN MODIIFED TO TEST -C THE GRIB BDS BYTE SIZE TO DETERMINE WHAT -C ECMWF GRID ARRAY SIZE IS TO BE SPECIFIED. -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C -C USAGE: CALL AI084(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - BUFR MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF BDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C -C OUTPUT ARGUMENT LIST: -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C KRET = 0 - NO ERROR -C = 5 - GRID NOT AVAIL FOR CENTER INDICATED -C =10 - INCORRECT CENTER INDICATOR -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C BIT MAP - LOGICAL KBMS(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(10) -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPDS(20) - INTEGER KGDS(13) -C - INTEGER KRET - INTEGER MASK(8) -C ----------------------GRID 21 AND GRID 22 ARE THE SAME - LOGICAL GRD21( 1369) -C ----------------------GRID 23 AND GRID 24 ARE THE SAME - LOGICAL GRD23( 1369) - LOGICAL GRD25( 1368) - LOGICAL GRD26( 1368) -C ----------------------GRID 27 AND GRID 28 ARE THE SAME -C ----------------------GRID 29 AND GRID 30 ARE THE SAME -C ----------------------GRID 33 AND GRID 34 ARE THE SAME - LOGICAL GRD50(1188) -C -----------------------GRID 61 AND GRID 62 ARE THE SAME - LOGICAL GRD61( 4186) -C -----------------------GRID 63 AND GRID 64 ARE THE SAME - LOGICAL GRD63( 4186) -C - DATA GRD21 /1333*.TRUE.,36*.FALSE./ - DATA GRD23 /.TRUE.,36*.FALSE.,1332*.TRUE./ - DATA GRD25 /1297*.TRUE.,71*.FALSE./ - DATA GRD26 /.TRUE.,71*.FALSE.,1296*.TRUE./ - DATA GRD50/ -C LINE 1-4 - & 7*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE., - & 14*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE.,7*.FALSE., -C LINE 5-8 - & 6*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE., - & 12*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE.,6*.FALSE., -C LINE 9-12 - & 5*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE., - & 10*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE.,5*.FALSE., -C LINE 13-16 - & 4*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE., - & 8*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE.,4*.FALSE., -C LINE 17-20 - & 3*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE., - & 6*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE.,3*.FALSE., -C LINE 21-24 - & 2*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE., - & 4*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE.,2*.FALSE., -C LINE 25-28 - & .FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE., - & 2*.FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE., .FALSE., -C LINE 29-33 - & 180*.TRUE./ - DATA GRD61 /4096*.TRUE.,90*.FALSE./ - DATA GRD63 /.TRUE.,90*.FALSE.,4095*.TRUE./ - DATA MASK /128,64,32,16,8,4,2,1/ -C DATA MSK40 /Z00000040/ - DATA MSK40 /64/ -C - IS = KPTR(9) - IF (KPDS(18).EQ.0) THEN - IGRIBL = 4 - ELSE - IGRIBL = 8 - ENDIF - ISS = IS + KPTR(3) + KPTR(4) + IGRIBL -C ********************************************************** -C IF THE FLAG IN PDS INDICATES THAT THERE IS NO BMS, -C SET BIT MAP WITH ALL BITS ON -C ELSE -C RECOVER BIT MAP -C THEN RETURN -C ********************************************************** -C ---------------- NON-STANDARD GRID - IF (KPDS(3).EQ.255) THEN - J = KGDS(2) * KGDS(3) - KPTR(10) = J - DO 600 I = 1, J - KBMS(I) = .TRUE. - 600 CONTINUE - END IF - IF (IAND(KPDS(4),MSK40).EQ.0)THEN -C PRINT *,' NO BIT MAP',MSK40,KPDS(4) - GO TO 400 - ELSE - PRINT *,' HAVE A BIT MAP' - END IF -C ---------------- FLAG INDICATING PRESENCE OF BIT MAP IS ON - IF (KGDS(1).EQ.50) THEN - PRINT *,' W3AI08/AI084 WARNING - BIT MAP MAY NOT BE', - * ' ASSOCIATED WITH SPHERICAL COEFFICIENTS' - RETURN - ENDIF -C GET NUMBER OF UNUSED BITS - IUBITS = MOVA2I(MSGA(ISS+3)) -C SEE IF BIT MAP IS CONTAINED - KFLAG = 0 - DO 150 I = 0, 1 - KFLAG = KFLAG * 256 + MOVA2I(MSGA(I+ISS+4)) - 150 CONTINUE - PRINT *,'KFLAG=',KFLAG -C ----------------- IF KFLAG = 0 PICK UP NEW BIT MAP -C ELSE -C ------------------ USE PREDEFINED BIT MAP - MAXBYT = KPTR(5) - 6 - IF (KFLAG.EQ.0) THEN -C ------------------ UTILIZE BIT MAP FROM MESSAGE - II = 1 - DO 300 I = 1, MAXBYT - KCNT = MOVA2I(MSGA(I+ISS+6)) - DO 200 K = 1, 8 - IF (IAND(KCNT,MASK(K)).NE.0) THEN - KBMS(II) = .TRUE. - ELSE - KBMS(II) = .FALSE. - END IF - II = II + 1 - 200 CONTINUE - 300 CONTINUE - KPTR(10) = 8 * (KPTR(5) - 6) - IUBITS - GO TO 900 - ELSE - PRINT *,'KFLAG SAYS USE STD BIT MAP',KFLAG - END IF -C ---------------------- PREDEFINED BIT MAP IS INDICATED -C IF GRID NUMBER DOES NOT MATCH AN -C EXISTING GRID, SET KRET TO 5 AND -C ---------------------- RETURN. - 400 CONTINUE - KRET = 0 -C ---------------------- ECMWF MAP GRIDS - IF (KPDS(1).EQ.98) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - J = 1073 -C*** TEST FOR FULL HEMISPHERIC GRID **** - IF (KPTR(6) .GT. 2158) J= 1369 -C*** *** **** *** *** - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 1000 I = 1, J - KBMS(I) = .TRUE. - 1000 CONTINUE - ELSE IF (KPDS(3).GE.13.AND.KPDS(3).LE.16) THEN - J = 361 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 1013 I = 1, J - KBMS(I) = .TRUE. - 1013 CONTINUE - ELSE - KRET = 5 - RETURN - END IF -C ---------------------- U.K. MET OFFICE BRACKNELL - ELSE IF (KPDS(1).EQ.74) THEN - IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22) THEN -C ----- INT'L GRIDS 21, 22 - MAP SIZE 1369 - J = 1369 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3021 I = 1, 1369 - KBMS(I) = GRD21(I) - 3021 CONTINUE - ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24) THEN -C ----- INT'L GRIDS 23, 24 - MAP SIZE 1369 - J = 1369 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3023 I = 1, 1369 - KBMS(I) = GRD23(I) - 3023 CONTINUE - ELSE IF (KPDS(3).EQ.25) THEN -C ----- INT'L GRID 25 - MAP SIZE 1368 - J = 1368 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3025 I = 1, 1368 - KBMS(I) = GRD25(I) - 3025 CONTINUE - ELSE IF (KPDS(3).EQ.26) THEN -C ----- INT'L GRID 26 - MAP SIZE 1368 - J = 1368 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3026 I = 1, 1368 - KBMS(I) = GRD26(I) - 3026 CONTINUE - ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN -C ----- INT'L GRIDS 61, 62 - MAP SIZE 4186 - J = 4186 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3061 I = 1, 4186 - KBMS(I) = GRD61(I) - 3061 CONTINUE - ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN -C ----- INT'L GRIDS 63, 64 - MAP SIZE 4186 - J = 4186 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3063 I = 1, 4186 - KBMS(I) = GRD63(I) - 3063 CONTINUE - ELSE IF (KPDS(3).EQ.70) THEN -C ----- U.S. GRID 70 - MAP SIZE 16380 - J = 16380 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 3070 I = 1, J - KBMS(I) = .TRUE. - 3070 CONTINUE - ELSE - KRET = 5 - RETURN - END IF -C ---------------------- FNOC NAVY - ELSE IF (KPDS(1).EQ.58) THEN - PRINT *,' NO STANDARD FNOC GRID AT THIS TIME' - RETURN -C ---------------------- U.S. GRIDS - ELSE IF (KPDS(1).EQ.7) THEN - IF (KPDS(3).EQ.5) THEN -C ----- U.S. GRID 5 - MAP SIZE 3021 - J = 3021 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2005 I = 1, J - KBMS(I) = .TRUE. - 2005 CONTINUE - ELSE IF (KPDS(3).EQ.6) THEN -C ----- U.S. GRID 6 - MAP SIZE 2385 - J = 2385 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2006 I = 1, J - KBMS(I) = .TRUE. - 2006 CONTINUE - ELSE IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22) THEN -C ----- U.S. GRIDS 21, 22 - MAP SIZE 1369 - J = 1369 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2021 I = 1, 1369 - KBMS(I) = GRD21(I) - 2021 CONTINUE - ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24) THEN -C ----- U.S GRIDS 23, 24 - MAP SIZE 1369 - J = 1369 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2023 I = 1, 1369 - KBMS(I) = GRD23(I) - 2023 CONTINUE - ELSE IF (KPDS(3).EQ.25) THEN -C ----- U.S. GRID 25 - MAP SIZE 1368 - J = 1368 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2025 I = 1, 1368 - KBMS(I) = GRD25(I) - 2025 CONTINUE - ELSE IF (KPDS(3).EQ.26) THEN -C ----- U.S.GRID 26 - MAP SIZE 1368 - J = 1368 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2026 I = 1, 1368 - KBMS(I) = GRD26(I) - 2026 CONTINUE - ELSE IF (KPDS(3).EQ.27.OR.KPDS(3).EQ.28) THEN -C ----- U.S. GRIDS 27, 28 - MAP SIZE 4225 - J = 4225 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2027 I = 1, J - KBMS(I) = .TRUE. - 2027 CONTINUE - ELSE IF (KPDS(3).EQ.29.OR.KPDS(3).EQ.30)THEN -C ----- U.S. GRIDS 29,30 - MAP SIZE 5365 - J = 5365 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2029 I = 1, J - KBMS(I) = .TRUE. - 2029 CONTINUE - ELSE IF (KPDS(3).EQ.33.OR.KPDS(3).EQ.34) THEN -C ----- U.S GRID 33, 34 - MAP SIZE 8326 (181 X 46) - J = 8326 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2033 I = 1, J - KBMS(I) = .TRUE. - 2033 CONTINUE - ELSE IF (KPDS(3).EQ.50) THEN -C ----- U.S. GRID 50 - MAP SIZE 964 - J = 1188 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2050 I = 1, 1188 - KBMS(I) = GRD50(I) - 2050 CONTINUE - ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN -C ----- U.S. GRIDS 61, 62 - MAP SIZE 4186 - J = 4186 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2061 I = 1, 4186 - KBMS(I) = GRD61(I) - 2061 CONTINUE - ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN -C ----- U.S. GRIDS 63, 64 - MAP SIZE 4186 - J = 4186 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2063 I = 1, 4186 - KBMS(I) = GRD63(I) - 2063 CONTINUE - ELSE IF (KPDS(3).EQ.70) THEN -C ----- U.S. GRID 70 - MAP SIZE 16380 - J = 16380 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2070 I = 1, J - KBMS(I) = .TRUE. - 2070 CONTINUE - ELSE IF (KPDS(3).EQ.85.OR.KPDS(3).EQ.86) THEN -C ----- U.S. GRIDS 85, 86 - MAP SIZE 32400 (360 X 90) - J = 32400 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2085 I = 1, J - KBMS(I) = .TRUE. - 2085 CONTINUE - ELSE IF (KPDS(3).EQ.100) THEN -C ----- U.S. GRID 100 - MAP SIZE 6889 (83 X 83) - J = 6889 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 1100 I = 1, J - KBMS(I) = .TRUE. - 1100 CONTINUE - ELSE IF (KPDS(3).EQ.101) THEN -C ----- U.S. GRID 101 - MAP SIZE 10283 (113 X 91) - J = 10283 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2101 I = 1, J - KBMS(I) = .TRUE. - 2101 CONTINUE - ELSE IF (KPDS(3).EQ.102) THEN -C ----- U.S. GRID 102 - MAP SIZE 14375 (115 X 125) - J = 14375 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2102 I = 1, J - KBMS(I) = .TRUE. - 2102 CONTINUE - ELSE IF (KPDS(3).EQ.103) THEN -C ----- U.S. GRID 103 - MAP SIZE 3640 (65 X 56) - J = 3640 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2103 I = 1, J - KBMS(I) = .TRUE. - 2103 CONTINUE - ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.214) THEN - IF (KPDS(3).EQ.201) J = 4225 - IF (KPDS(3).EQ.202) J = 2795 - IF (KPDS(3).EQ.203) J = 1755 - IF (KPDS(3).EQ.204) J = 5609 - IF (KPDS(3).EQ.205) J = 1755 - IF (KPDS(3).EQ.206) J = 2091 - IF (KPDS(3).EQ.207) J = 1715 - IF (KPDS(3).EQ.208) J = 625 - IF (KPDS(3).EQ.209) J = 8181 - IF (KPDS(3).EQ.210) J = 625 - IF (KPDS(3).EQ.211) J = 2915 - IF (KPDS(3).EQ.212) J = 4225 - IF (KPDS(3).EQ.213) J = 10965 - IF (KPDS(3).EQ.214) J = 6693 - KPTR(10) = J - CALL AI087(*900,J,KPDS,KGDS,KRET) - DO 2201 I = 1, J - KBMS(I) = .TRUE. - 2201 CONTINUE - ELSE - KRET = 5 - RETURN - END IF - ELSE - KRET = 10 - RETURN - END IF - 900 CONTINUE - RETURN - END - SUBROUTINE AI085(MSGA,KPTR,KPDS,KBMS,DATA,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI085 EXTRACT GRIB DATA ELEMENTS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20 -C -C ABSTRACT: EXTRACT GRIB DATA AND PLACE INTO OUTPUT ARRY IN -C PROPER POSITION. -C -C PROGRAM HISTORY LOG: -C 88-01-20 CAVANAUGH -C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C -C USAGE: CALL AI085(MSGA,KPTR,KPDS,KBMS,DATA,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF BDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C -C OUTPUT ARGUMENT LIST: -C DATA - REAL ARRAY OF GRIDDED ELEMENTS IN GRIB MESSAGE. -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C ERROR RETURN -C 3 = UNPACKED FIELD IS LARGER THAN 32768 -C 6 = DOES NOT MATCH NR OF ENTRIES FOR THIS GRIB/GRID -C 7 = NUMBER OF BITS IN FILL TOO LARGE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C ************************************************************* - CHARACTER*1 MSGA(*) - CHARACTER*1 KREF(8) - CHARACTER*1 KK(8) -C - LOGICAL KBMS(*) -C - INTEGER KPDS(*) - INTEGER KPTR(*) - INTEGER NRBITS - INTEGER KSAVE(105000) - INTEGER KSCALE -C - REAL DATA(*) - REAL REFNCE - REAL SCALE - REAL REALKK -C - LOGICAL IBM370 -C - EQUIVALENCE (REFNCE,KREF(1),IREF) - EQUIVALENCE (KK(1),REALKK,IKK) -C -C DATA MSK0F /Z0000000F/ -C DATA MSK80 /Z00000080/ -C DATA MSK40 /Z00000040/ -C - DATA MSK0F /15/ - DATA MSK80 /128/ - DATA MSK40 /64/ -C -C ************************************************************* - KRET = 0 - IS = KPTR(9) - ISS = IS + KPTR(3) + KPTR(4) + KPTR(5) + 4 -C BYTE 4 - KSPL = MOVA2I(MSGA(ISS+3)) -C POINT TO BYTE 5 OF BDS -C -C ------------- GET SCALE FACTOR -C - KSCALE = 0 - DO 100 I = 0, 1 - KSCALE = KSCALE * 256 + MOVA2I(MSGA(I+ISS+4)) - 100 CONTINUE - IF (IAND(KSCALE,32768).NE.0) THEN - KSCALE = - IAND(KSCALE,32767) - END IF - SCALE = 2.0**KSCALE -C -C ------------ GET REFERENCE VALUE -C - IREF = 0 - DO 200 I = 0, 3 - KREF(I+1) = MSGA(I+ISS+6) - 200 CONTINUE -C -C THE FLOATING POINT NUMBER IN THE REFERENCE VALUE IS AN IBM370 -C 32 BIT NUMBER, IF YOUR COMPUTER IS NOT AN IBM370 OR CLONE -C SET IBM370 TO .FALSE. SO THE NUMBER IS CONVERTED TO A F.P. -C NUMBER OF YOUR MACHINE TYPE. -C - IBM370 = .FALSE. -C - IF (.NOT.IBM370) THEN - KOFF = 0 -C GET 1 BIT SIGN - CALL GBYTE(IREF,ISGN,0,1) -C GET 7 BIT EXPONENT - CALL GBYTE(IREF,IEXP,1,7) -C GET 24 BIT FRACTION - CALL GBYTE(IREF,IFR,8,24) - IF (IFR.EQ.0.OR.IEXP.EQ.0) THEN - REFNCE = 0.0 - ELSE - REFNCE = FLOAT(IFR) * 16.0 ** (IEXP-64-6) - IF (ISGN.NE.0) REFNCE = - REFNCE - ENDIF - ENDIF -C -C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY -C - KBITS = MOVA2I(MSGA(ISS+10)) - KENTRY = KPTR(10) -C -C ------------- MAX SIZE CHECK -C - IF (KENTRY.GT.105000) THEN - KRET = 3 - RETURN - END IF - IF (KBITS.EQ.0) THEN -C -C -------------------- HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE -C - DO 210 I = 1, KENTRY - DATA(I) = 0.0 - IF (KBMS(I)) THEN - DATA(I) = REFNCE - END IF - 210 CONTINUE - GO TO 900 - END IF -C -C -------------------- -C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER) -C ENTRIES. -C -C ------------- UNUSED BITS IN DATA AREA -C - LESSBT = IAND(KSPL,MSK0F) -C -C ------------- NUMBER OF BYTES IN DATA AREA -C - NRBYTE = KPTR(6) - 11 -C -C ------------- TOTAL NR OF USABLE BITS -C - NRBITS = NRBYTE * 8 - LESSBT -C -C ------------- TOTAL NR OF ENTRIES -C - KENTRY = NRBITS / KBITS -C -C ------------- MAX SIZE CHECK -C - IF (KENTRY.GT.105000) THEN - KRET = 3 - RETURN - END IF -C - IBMS = IAND(KPDS(4),MSK40) -C -C -------------- CHECK TO SEE IF PROCESSING COEFFICIENTS -C IF YES, -C GO AND PROCESS AS SUCH -C ELSE -C CONTINUE PROCESSING -C - IF (IAND(KSPL,MSK80).EQ.0) THEN -C -C ------------- SET POINTERS -C -C XMOVEX MOVES THE DATA TO MAKE SURE IT IS ON A INTEGER WORD -C BOUNDARY, ON SOME COMPUTERS THIS DOES NOT HAVE TO BE DONE. -C (IBM PC, VAX) -C -C CALL XMOVEX(MSGB,MSGA(ISS+11),NRBYTE) -C ------------- UNPACK ALL FIELDS - KOFF = 0 -C -C THE BIT UNPACKER W3AI41 WILL CONSUME MOST OF THE CPU TIME -C CONVERTING THE GRIB DATA. FOR THE IBM370 WE HAVE AN -C ASSEMBLER AND FORTRAN VERSION. THE ASSMBLER VERSION WILL -C RUN TWO TO THREE TIMES FASTER. THE FORTRAN VERSION IS TO -C MAKE THE CODE MORE PORTABLE. FOR A VAX OR IBM PC WE HAVE -C ANOTHER VERSION, IT REVERSED THE ORDER OF THE BYTES IN -C AN INTEGER WORD. W3AI41 CAN BE REPLACED BY NCAR GBYTES -C BIT UNPACKER. NCAR HAS A LARGE NUMBER OF VERSIONS OF GBYTES -C IN FORTRAN AN ASSEMBLER FOR A NUMBER OF DIFFERENT BRANDS OF -C COMPUTERS. THEY ALSO HAVE A C VERSION. -C -C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF) -C -C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY -C INTEGER WORD BOUNDARY -C - LLL = MOD(ISS+10,8) - NNN = 11 - LLL - KOFF = LLL * 8 - CALL GBYTES(MSGA(ISS+NNN),KSAVE,KOFF,KBITS,0,KENTRY) -C -C ------------- CORRECTLY PLACE ALL ENTRIES -C - II = 1 - KENTRY = KPTR(10) - DO 500 I = 1, KENTRY - IF (KBMS(I)) THEN - DATA(I) = REFNCE + FLOAT(KSAVE(II)) * SCALE - II = II + 1 - ELSE - DATA(I) = 0.0 - END IF - 500 CONTINUE - GO TO 900 - END IF -C -C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS -C - IKK = 0 - DO 5500 I = 0, 3 - KK(I+1) = MSGA(I+ISS+11) - 5500 CONTINUE -C - IF (.NOT.IBM370) THEN - KOFF = 0 -C GET 1 BIT SIGN - CALL GBYTE(IKK,ISGN,0,1) -C GET 7 BIT EXPONENT - CALL GBYTE(IKK,IEXP,1,7) -C GET 24 BIT FRACTION - CALL GBYTE(IKK,IFR,8,24) - IF (IFR.EQ.0.OR.IEXP.EQ.0) THEN - REALKK = 0.0 - ELSE - REALKK = FLOAT(IFR) * 16.0 ** (IEXP-64-6) - IF (ISGN.NE.0) REALKK = - REALKK - ENDIF - ENDIF -C - DATA(1) = REALKK - KOFF = 0 -C CALL XMOVEX(MSGB,MSGA(ISS+15),NRBYTE) -C ------------- UNPACK ALL FIELDS -C -C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF) -C -C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY -C INTEGER WORD BOUNDARY -C - LLL = MOD(ISS+14,8) - NNN = 15 - LLL - KOFF = LLL * 8 -C - CALL GBYTES(MSGA(ISS+NNN),KSAVE,KOFF,KBITS,0,KENTRY) -C -C -------------- - DO 6000 I = 1, KENTRY - DATA(I+1) = REFNCE + FLOAT(KSAVE(I)) * SCALE - 6000 CONTINUE - 900 CONTINUE - RETURN - END - SUBROUTINE AI085A(MSGA,KPTR,KPDS,KBMS,DATA,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI085A EXTRACT GRIB DATA (VER 1) ELEMENTS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 89-11-20 -C -C ABSTRACT: EXTRACT GRIB DATA (VERSION 1) AND PLACE INTO PROPER -C POSITION IN OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 89-11-20 CAVANAUGH -C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C -C USAGE: CALL AI085A (MSGA,KPTR,KPDS,KBMS,DATA,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS -C (4) - LENGTH OF GDS -C (5) - LENGTH OF BMS -C (6) - LENGTH OF BDS -C (7) - VALUE OF CURRENT BYTE -C (8) - UNUSED -C (9) - GRIB START BYTE NR -C (10) - GRIB/GRID ELEMENT COUNT -C KPDS - ARRAY CONTAINING PDS ELEMENTS. (VERSION 1) -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - TOTAL LENGTH OF GRIB MESSAGE (INCLUDING SECTION 0) -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C -C OUTPUT ARGUMENT LIST: -C DATA - REAL ARRAY OF GRIDDED ELEMENTS IN GRIB MESSAGE. -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C STRUCTURE OF BINARY DATA SECTION (VERSION 1) -C 1-3 - LENGTH OF SECTION -C 4 - PACKING FLAGS -C 5-6 - SCALE FACTOR -C 7-10 - REFERENCE VALUE -C 11 - NUMBER OF BIT FOR EACH VALUE -C 12-N - DATA -C ERROR RETURN -C 3 = UNPACKED FIELD IS LARGER THAN 32768 -C 6 = DOES NOT MATCH NR OF ENTRIES FOR THIS GRIB/GRID -C 7 = NUMBER OF BITS IN FILL TOO LARGE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C ************************************************************* - CHARACTER*1 MSGA(*) - CHARACTER*1 KREF(8) - CHARACTER*1 KK(8) -C - LOGICAL KBMS(*) -C - INTEGER KPDS(*) - INTEGER KPTR(*) - INTEGER NRBITS - INTEGER KSAVE(105000) - INTEGER KSCALE -C - REAL DATA(*) - REAL REFNCE - REAL SCALE - REAL REALKK -C - LOGICAL IBM370 -C - EQUIVALENCE (REFNCE,KREF(1),IREF) - EQUIVALENCE (KK(1),REALKK,IKK) -C -C DATA MSK0F /Z0000000F/ -C DATA MSK40 /Z00000040/ -C DATA MSK80 /Z00000080/ -C - DATA MSK0F /15/ - DATA MSK40 /64/ - DATA MSK80 /128/ -C -C ************************************************************* -C - KRET = 0 - IS = KPTR(9) - IGRIBL = 8 - ISS = IS + KPTR(3) + KPTR(4) + KPTR(5) + IGRIBL -C BYTE 4 - KSPL = MOVA2I(MSGA(ISS+3)) -C -C ------------- POINT TO BYTE 5 OF BDS -C -C ------------- GET SCALE FACTOR -C - KSCALE = 0 - DO 100 I = 0, 1 - KSCALE = KSCALE * 256 + MOVA2I(MSGA(I+ISS+4)) - 100 CONTINUE - IF (IAND(KSCALE,32768).NE.0) THEN - KSCALE = - IAND(KSCALE,32767) - END IF - SCALE = 2.0**KSCALE -C -C -------------------- DECIMAL SCALE EXPONENT -C - IDEC = IS + IGRIBL + 26 - JSCALE = 0 - DO 150 I = 0, 1 - JSCALE = JSCALE * 256 + MOVA2I(MSGA(I+IDEC)) - 150 CONTINUE -C IF HIGH ORDER BIT IS ON, HAVE NEGATIVE EXPONENT - IF (IAND(JSCALE,32768).NE.0) THEN - JSCALE = - IAND(JSCALE,32767) - END IF - ASCALE = 10.0 ** JSCALE -C -C ------------ GET REFERENCE VALUE -C - IREF = 0 - DO 200 I = 0, 3 - KREF(I+1) = MSGA(I+ISS+6) - 200 CONTINUE -C -C THE FLOATING POINT NUMBER IN THE REFERENCE VALUE IS AN IBM370 -C 32 BIT NUMBER, IF YOUR COMPUTER IS NOT AN IBM370 OR CLONE -C SET IBM370 TO .FALSE. SO THE NUMBER IS CONVERTED TO A F.P. -C NUMBER OF YOUR MACHINE TYPE. -C - IBM370 = .FALSE. -C - IF (.NOT.IBM370) THEN - KOFF = 0 -C GET 1 BIT SIGN - CALL GBYTE(IREF,ISGN,0,1) -C GET 7 BIT EXPONENT - CALL GBYTE(IREF,IEXP,1,7) -C GET 24 BIT FRACTION - CALL GBYTE(IREF,IFR,8,24) - IF (IFR.EQ.0.OR.IEXP.EQ.0) THEN - REFNCE = 0.0 - ELSE - REFNCE = FLOAT(IFR) * 16.0 ** (IEXP-64-6) - IF (ISGN.NE.0) REFNCE = - REFNCE - ENDIF - ENDIF -C -C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY -C - KBITS = MOVA2I(MSGA(ISS+10)) - KENTRY = KPTR(10) -C -C ------------- MAX SIZE CHECK -C - IF (KENTRY.GT.105000) THEN - KRET = 3 - RETURN - END IF -C - IF (KBITS.EQ.0) THEN -C -C -------------------- HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE -C - DO 210 I = 1, KENTRY - DATA(I) = 0.0 - IF (KBMS(I)) THEN - DATA(I) = REFNCE - END IF - 210 CONTINUE - GO TO 900 - END IF -C -C -------------------- -C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER) -C ENTRIES. -C -C ------------- UNUSED BITS IN DATA AREA -C - LESSBT = IAND(KSPL,MSK0F) -C -C ------------- NUMBER OF BYTES IN DATA AREA -C - NRBYTE = KPTR(6) - 11 -C -C ------------- TOTAL NR OF USABLE BITS -C - NRBITS = NRBYTE * 8 - LESSBT -C -C ------------- TOTAL NR OF ENTRIES -C - KENTRY = NRBITS / KBITS -C -C ------------- MAX SIZE CHECK -C - IF (KENTRY.GT.105000) THEN - KRET = 3 - RETURN - END IF - IBMS = IAND(KPDS(4),MSK40) -C -C -------------- CHECK TO SEE IF PROCESSING COEFFICIENTS -C IF YES, -C GO AND PROCESS AS SUCH -C ELSE -C CONTINUE PROCESSING - IF (IAND(KSPL,MSK80).EQ.0) THEN -C -C ------------- SET POINTERS -C -C REPLACE XMOVEX AND W3AI41 WITH GBYTES -C CALL XMOVEX(MSGB,MSGA(ISS+11),NRBYTE) -C -C ------------- UNPACK ALL FIELDS -C - KOFF = 0 -C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF) -C -C THE BIT UNPACKER W3AI41 WILL CONSUME MOST OF THE CPU TIME -C CONVERTING THE GRIB DATA. FOR THE IBM370 WE HAVE AN -C ASSEMBLER AND FORTRAN VERSION. THE ASSMBLER VERSION WILL -C RUN TWO TO THREE TIMES FASTER. THE FORTRAN VERSION IS TO -C MAKE THE CODE MORE PORTABLE. FOR A VAX OR IBM PC WE HAVE -C ANOTHER VERSION, IT REVERSED THE ORDER OF THE BYTES IN -C AN INTEGER WORD. W3AI41 CAN BE REPLACED BY NCAR GBYTES -C BIT UNPACKER. NCAR HAS A LARGE NUMBER OF VERSIONS OF GBYTES -C IN FORTRAN AND ASSEMBLER FOR A NUMBER OF DIFFERENT BRANDS OF -C COMPUTERS. THEY ALSO HAVE A C VERSION. -C -C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY -C INTEGER WORD BOUNDARY -C - LLL = MOD(ISS+10,8) - NNN = 11 - LLL - KOFF = LLL * 8 -C - CALL GBYTES(MSGA(ISS+NNN),KSAVE,KOFF,KBITS,0,KENTRY) -C -C ------------- CORRECTLY PLACE ALL ENTRIES -C - II = 1 - KENTRY = KPTR(10) - DO 500 I = 1, KENTRY - IF (KBMS(I)) THEN -C MUST INCLUDE DECIMAL SCALE - DATA(I) = (REFNCE + FLOAT(KSAVE(II)) * SCALE) / ASCALE - II = II + 1 - ELSE - DATA(I) = 0.0 - END IF - 500 CONTINUE - GO TO 900 - END IF -C -C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS -C - IKK = 0 - DO 5500 I = 0, 3 - KK(I+1) = MSGA(I+ISS+11) - 5500 CONTINUE -C - IF (.NOT.IBM370) THEN - KOFF = 0 -C GET 1 BIT SIGN - CALL GBYTE(IKK,ISGN,0,1) -C GET 7 BIT EXPONENT - CALL GBYTE(IKK,IEXP,1,7) -C GET 24 BIT FRACTION - CALL GBYTE(IKK,IFR,8,24) - IF (IFR.EQ.0.OR.IEXP.EQ.0) THEN - REALKK = 0.0 - ELSE - REALKK = FLOAT(IFR) * 16.0 ** (IEXP-64-6) - IF (ISGN.NE.0) REALKK = - REALKK - ENDIF - ENDIF -C - DATA(1) = REALKK - KOFF = 0 -C CALL XMOVEX(MSGB,MSGA(ISS+15),NRBYTE) -C -C ------------- UNPACK ALL FIELDS -C -C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF) -C -------------- -C -C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY -C INTEGER WORD BOUNDARY -C - LLL = MOD(ISS+14,8) - NNN = 15 - LLL - KOFF = LLL * 8 -C - CALL GBYTES(MSGA(ISS+NNN),KSAVE,KOFF,KBITS,0,KENTRY) -C - DO 6000 I = 1, KENTRY - DATA(I+1) = REFNCE + FLOAT(KSAVE(I)) * SCALE - 6000 CONTINUE - 900 CONTINUE - RETURN - END - SUBROUTINE AI087(*,J,KPDS,KGDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: AI087 GRIB GRID/SIZE TEST -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-02-08 -C -C ABSTRACT: TO TEST WHEN GDS IS AVAILABLE TO SEE IF SIZE MISMATCH -C ON EXISTING GRIDS (BY CENTER) IS INDICATED -C -C PROGRAM HISTORY LOG: -C 88-02-08 CAVANAUGH -C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN -C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990 -C -C USAGE: CALL AI087(*,J,KPDS,KGDS,KRET) -C INPUT ARGUMENT LIST: -C J - SIZE FOR INDICATED GRID -C KPDS - -C KGDS - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KRET - ERROR RETURN -C -C REMARKS: -C KRET - -C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ - INTEGER KPDS(20) - INTEGER KGDS(13) - INTEGER J - INTEGER I -C --------------------------------------- -C --------------------------------------- -C IF GDS NOT INDICATED, RETURN -C ---------------------------------------- - IF (IAND(KPDS(4),128).EQ.0) RETURN -C --------------------------------------- -C GDS IS INDICATED, PROCEED WITH TESTING -C --------------------------------------- - I = KGDS(2) * KGDS(3) -C --------------------------------------- -C TEST ECMWF CONTENT -C --------------------------------------- - IF (KPDS(1).EQ.98) THEN - KRET = 9 - IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE - KRET = 5 - RETURN 1 - END IF -C --------------------------------------- -C U.K. MET OFFICE, BRACKNELL -C --------------------------------------- - ELSE IF (KPDS(1).EQ.74) THEN - KRET = 9 - IF (KPDS(3).GE.21.AND.KPDS(3).LE.24) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.25.OR.KPDS(3).EQ.26) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.70) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE - KRET = 5 - RETURN 1 - END IF -C --------------------------------------- -C NAVY - FNOC -C --------------------------------------- - ELSE IF (KPDS(1).EQ.58) THEN - PRINT *,' NO CURRENT LISTING OF NAVY GRIDS' - RETURN 1 -C --------------------------------------- -C U.S. GRIDS -C --------------------------------------- - ELSE IF (KPDS(1).EQ.7) THEN - KRET = 9 - IF (KPDS(3).EQ.5) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.6) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.24) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.25.OR.KPDS(3).EQ.26) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.27.OR.KPDS(3).EQ.28) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.29.OR.KPDS(3).EQ.30) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.33.OR.KPDS(3).EQ.34) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.50) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.70) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.85.OR.KPDS(3).EQ.86) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.100) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.101) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.102) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).EQ.103) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.214) THEN - IF (I.NE.J) THEN - RETURN 1 - END IF - ELSE - KRET = 5 - RETURN 1 - END IF - ELSE - KRET = 10 - RETURN 1 - END IF -C ------------------------------------ -C NORMAL EXIT -C ------------------------------------ - KRET = 0 - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3ai15.f b/external/w3nco/v2.0.6/src/w3ai15.f deleted file mode 100644 index 6e93f4ea..00000000 --- a/external/w3nco/v2.0.6/src/w3ai15.f +++ /dev/null @@ -1,132 +0,0 @@ - SUBROUTINE W3AI15 (NBUFA,NBUFB,N1,N2,MINUS) -C$$$ SUBROUTINE DOCUMENTATION BLOCK CCC -C -C SUBR: W3AI15 - CONVERT INTEGERS TO ACSII (ALTERNATE TO ENCODE) -C AUTHOR: ALLARD, R. ORG: W342 DATE: JANUARY, 1974 -C -C ABSTRACT: CONVERTS A SET OF BINARY NUMBERS TO AN EQUIVALENT SET -C OF ASCII NUMBER FIELDS IN CORE. THIS IS AN ALTERNATE PROCEDURE -C TO THE USE OF THE 360/195 VERSION OF ENCODE. -C -C PROGRAM HISTORY LOG: -C 74-01-15 R.ALLARD -C 89-02-06 R.E.JONES CHANGE FROM ASSEMBLER TO FORTRAN -C THIS SUBROUTINE SHOULD BE REWRITTEN IM -C INTEL 8088 ASSEMBLY LANGUAGE -C 90-08-13 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C 12-11-05 B. VUONG CHANGE VARIABLE ZERO FILL FOR LITTLE-ENDIAN -C -C USAGE: CALL W3AI15 (NBUFA,NBUFB,N1,N2,MINUS) -C -C INPUT: -C 'NBUFA' - INPUT ARRAY (INTEGER*4) -C ' N1' - NUMBER OF INTEGERS IN NBUFA TO BE CONVERTED -C ' N2' - DESIRED CHARACTER WIDTH OF ASCII NUMBER FIELD -C 'MINUS' - CHARACTER TO BE INSERTED IN THE HIGH ORDER POSITION -C OF A NEGATIVE NUMBER FIELD -C OUTPUT: -C 'NBUFB' - OUTPUT ARRAY (INTEGER*4) -C -C EXIT STATES: NONE -C -C EXTERNAL REFERENCES: NONE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C -C NOTE 1. - IF N2 IS GREATER THAN 4, ALLOW TWO WORDS (EIGHT CHARACTERS) -C IN THE NBUFB ARRAY FOR EACH ASCII NUMBER FIELD. A NUMBER FIELD -C IS LEFT ADJUSTED WITH BLANK FILL TO THE RIGHT IF NEEDED. -C LIKEWISE, IF N2 IS LESS THAN 4, THE RESULT IS LEFT ADJUSTED -C WITH BLANK FILL TO THE RIGHT. -C -C NOTE 2. - N2 CAN BE SPECIFIED IN THE RANGE 1-8. AN EIGHT DIGIT POSI- -C TIVE INTEGER CAN BE CONVERTED OR A SEVEN DIGIT NEGATIVE INTEGER -C AND A SIGN. ZERO FILL IS USED FOR HIGH ORDER POSITIONS IN A -C NUMBER FIELD. THE USER SHOULD BE AWARE THAT W3AI15 DOES NOT -C VERIFY THAT THE VALUE OF N2 IS IN THE CORRECT RANGE. -C -C NOTE 3. - THE MINUS SIGN CAN BE INSERTED AS A LITERAL IN THE CALL -C SEQUENCE OR DEFINED IN A DATA STATEMENT. 1H- AND 1H+ ARE THE -C TWO MOST LIKELY NEGATIVE SIGNS. UNFORTUNATELY THE ASCII PLUS -C CHARACTER IS THE NEGATIVE SIGN REQUIRED IN MOST TRANSMISSIONS. -C THE MINUS SIGN WILL ALWAYS BE IN THE HIGH ORDER POSITION OF A -C NEGATIVE NUMBER FIELD. -C -C NOTE 4. - IF A NUMBER CONTAINS MORE DIGITS THAN THE N2 SPECIFICATION -C ALLOWS, THE EXCESS HIGH ORDER DIGITS ARE LOST. -C - INTEGER ATEMP - INTEGER BTEMP - INTEGER IDIV(8) - INTEGER NBUFA(*) - INTEGER NBUFB(*) - INTEGER*8 ZERO(8) -C - CHARACTER*1 BLANK - CHARACTER*1 JTEMP(8) - CHARACTER*1 MINUS - CHARACTER*1 NUM(0:9) -C - LOGICAL ISIGN -C - EQUIVALENCE (BTEMP,JTEMP(1)) -C - DATA BLANK /' '/ - DATA IDIV /1,10,100,1000,10000,100000,1000000,10000000/ - DATA NUM /'0','1','2','3','4','5','6','7','8','9'/ -C FOR LITTLE_ENDIAN - DATA ZERO /X'2020202020202030',X'2020202020203030', - & X'2020202020303030',X'2020202030303030', - & X'2020203030303030',X'2020303030303030', - & X'2030303030303030',X'3030303030303030'/ - -C FOR BIG_ENDIAN -c DATA ZERO /X'3020202020202020',X'3030202020202020', -c & X'3030302020202020',X'3030303020202020', -c & X'3030303030202020',X'3030303030302020', -c & X'3030303030303020',X'3030303030303030'/ -C - DO 100 I = 1,N1 - IF (NBUFA(I).EQ.0) THEN - NBUFB(I) = ZERO(N2) - GO TO 100 - ENDIF - ATEMP = NBUFA(I) - ISIGN = .FALSE. - IF (ATEMP.LT.0) THEN - ISIGN = .TRUE. - ATEMP = IABS(ATEMP) - ENDIF - IF (.NOT.ISIGN) THEN - DO 10 J = 1,8 - IF (J.LE.N2) THEN - I1 = MOD(ATEMP/IDIV(N2-J+1),10) - JTEMP(J) = NUM(I1) - ELSE - JTEMP(J) = BLANK - ENDIF - 10 CONTINUE - - ELSE - - JTEMP(1) = MINUS - DO 20 J = 2,8 - IF (J.LE.N2) THEN - I1 = MOD(ATEMP/IDIV(N2-J+1),10) - JTEMP(J) = NUM(I1) - ELSE - JTEMP(J) = BLANK - ENDIF - 20 CONTINUE - ENDIF -C - NBUFB(I) = BTEMP -C - 100 CONTINUE - RETURN - END - diff --git a/external/w3nco/v2.0.6/src/w3ai18.f b/external/w3nco/v2.0.6/src/w3ai18.f deleted file mode 100644 index 178c9c6f..00000000 --- a/external/w3nco/v2.0.6/src/w3ai18.f +++ /dev/null @@ -1,113 +0,0 @@ - SUBROUTINE W3AI18(ITEM,I1,I2,LINE,L,K,N) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AI18 LINE BUILDER SUBROUTINE -C PRGMMR: ALLARD, R. ORG: W/NMC42 DATE: 74-02-01 -C -C ABSTRACT: BUILD A LINE OF INFORMATION COMPOSED OF USER SPECIFIED -C CHARACTER STRINGS. -C -C PROGRAM HISTORY LOG: -C 74-02-02 ROBERT ALLARD -C 84-07-05 R.E.JONES RECOMPILE -C 96-08-06 R.E.JONES CONVERT FROM IBM370 ASSEMBLER TO FORTRAN -C FOR THE CRAY, WORKSTATIONS, AND PC'S. -C -C USAGE: CALL W3AI18(ITEM, I1, I2, LINE, L, K, N) -C INPUT ARGUMENT LIST: -C ITEM - CHARACTER STRING TO BE ADDED TO LINE ARRAY -C I1 - NUMBER OF CHARACTER STRINGS TO BE ADDED TO LINE ARRAY -C I2 - NUMBER OF CHARACTERS PER STRING TO ADD TO LINE -C L - CHARACTER LENGTH OF LINE TO BE BUILT (2.LE.L.LE.256) -C K - NUMBER OF BLKANK CHARACTERS TO PRECEDE A CHARACTER -C STRING (0.LE.K.LE.256) -C N - POINTER SET EQUAL TO 0 WHEN BEGINNING A LINE -C -C OUTPUT ARGUMENT LIST: -C LINE - ARRAY IN WHICH CHARACTER STRING ARE PLACED WHILE -C BUILDING ALINE; MUST BE OF TYPE INTEGER -C N - CHARACTER COUNT, ERROR INDICATOR -C -C -C EXIT STATES: -C N = -1 CHARACTER STRING WILL NOT FIT IN THE LINE ARRAY; -C OTHERWISE, EACH TIME A CHACTER STRING IS ADDED -C TO THE LINE, N IS INCREMENTED BY (I2 + K) -C -C NOTE 1. - EACH CHARACTER STRING INCLUDED IN THE ITEM ARRAY MUST -C START ON A FULL WORD BOUNDARY AND BE EQUAL IN LENGTH. -C EACH SUCCESSIVE STRING MUST START ON THE NEST FULLWORD -C BOUNDARY FOLLOWING THE END OF THE PREVIOUS STRING. -C ON A CRAY THIS 8. -C -C NOTE 2. - THE DIMENSIONS OF THE ITEM ARRAY SHOULD BE AT LEAST THE -C VALUE OF (I1*(I2+J))/4, WHERE THE INTEGER J IS IN THE -C RANGE 0.LE.J.LE.3 AND THE SUM (I2+J) IS 4 OR A MULTIPLE -C OF 4. ON A CRAY THIS IS 8 OR A MULTIPLE OF 8. ON A CRAY -C (I1*(I2+J))/8, RANGE IS 0.LE.J.LE.7 -C -C NOTE 3. - THE MAXIMUM DIMENSION OF LINE IS 64 WORD OR 256 BYTES. -C ON A CRAY IT IS 32 WORDS OR 256 BYTES. -C -C NOTE 4. - THE USER SHOULD SET N = 0 EACH TIME A LINE IS STATED TO -C TELL W3AI18 TO FILL THE LINE ARRAY WITH BLANK CHARACTERS. -C EACH TIME A CHARACTER STRING IS ADDED TO THE LINE, THE -C VARIABLE (N) IS INCREMENTED BY (I2 + K). IF A CHARACTER -C STRING WILL NOT FIT IN THE LINE ARRAY, W3AI18 SETS N = -1 -C AND RETURNS TO THE USER. THE USER WILL NOT BE ABLE TO -C PROGRAM A RECOVERY PROCEDURE FOR THE LINE BEING FULL IF -C MORE THAN ONE CHARACTER STRING IS IN THE ITEM ARRAY. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048. -C -C$$$ -C - CHARACTER * (*) LINE - CHARACTER * (*) ITEM -C - SAVE -C -C TEST WORD LENGTH, LW WILL BE 4 OR 8 BYTES -C - CALL W3FI01(LW) -C -C BAIL OUT IF NEGATIVE -C - IF (N.LT.0) RETURN -C -C FILL LINE WITH BLANK CHAACTERS -C - IF (N.EQ.0) THEN - DO I = 1,L - LINE(I:I) = ' ' - END DO - END IF - IF (I1.EQ.1) THEN - J = 0 - IF ((I2+K+N).GT.L) GO TO 200 - LINE(K+N+1:K+N+I2) = ITEM(1:I2) - N = I2+K+N - RETURN - ELSE - JJ = MOD(I2, LW) - IF (JJ.EQ.0) THEN - J = 0 - ELSE - J = LW - JJ - END IF - IF ((I2+K+N).GT.L) GO TO 200 - LINE(K+N+1:K+N+I2) = ITEM(1:I2) - N = I2+K+N - DO I = 1,I1-1 - IF ((I2+K+N).GT.L) GO TO 200 - LINE(K+N+1:K+N+I2) = ITEM((I2+J)*I+1:(I2+J)*I+I2) - N = I2+K+N - END DO - RETURN - END IF - 200 CONTINUE - N = -1 - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3ai19.f b/external/w3nco/v2.0.6/src/w3ai19.f deleted file mode 100644 index f2654dac..00000000 --- a/external/w3nco/v2.0.6/src/w3ai19.f +++ /dev/null @@ -1,127 +0,0 @@ - SUBROUTINE W3AI19(LINE, L, NBLK, N, NEXT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AI19 LINE BLOCKER SUBROUTINE -C PRGMMR: BOB HOLLERN ORG: NCO/NP12 DATE: 97-04-15 -C -C ABSTRACT: FILLS A RECORD BLOCK WITH LOGICAL RECORDS OR LINES -C OF INFORMATION. -C -C PROGRAM HISTORY LOG: -C 74-02-01 BOB ALLARD, AUTHOR -C 90-09-15 R.E.JONES CONVERT FROM IBM370 ASSEMBLER TO MICROSOFT -C FORTRAN 5.0 -C 90-10-07 R.E.JONES CONVERT TO SUN FORTRAN 1.3 -C 91-07-20 R.E.JONES CONVERT TO SiliconGraphics 3.3 FORTRAN 77 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 94-04-22 R.E.JONES ADD XMOVEX AND XSTORE TO MOVE AND -C STORE CHARACTER DATA FASTER ON THE CRAY -C 97-04-15 Bob Hollern CORRECTED THE PROBLEM OF INIIALIZING NBLK -C TO @'S INSTEAD OF BLANKS -C -C USAGE: CALL W3AI19 (LINE, L, NBLK, N, NEXT) -C INPUT ARGUMENT LIST: -C LINE - ARRAY ADDRESS OF LOGICAL RECORD TO BE BLOCKED -C L - NUMBER OF CHARACTERS IN LINE TO BE BLOCKED -C N - MAXIMUM CHARACTER SIZE OF NBLK -C NEXT - FLAG, INITIALIZED TO 0 -C -C OUTPUT ARGUMENT LIST: -C NBLK - BLOCK FILLED WITH LOGICAL RECORDS -C NEXT - CHARACTER COUNT, ERROR INDICATOR -C -C EXIT STATES: -C NEXT = -1 LINE WILL NOT FIT INTO REMAINDER OF BLOCK; -C OTHERWISE, NEXT IS SET TO (NEXT + L) -C NEXT = -2 N IS ZERO OR LESS -C NEXT = -3 L IS ZERO OR LESS -C -C EXTERNAL REFERENCES: XMOVEX XSTORE -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C -C METHOD: -C -C THE USER MUST SET NEXT = 0 EACH TIME NBLK IS TO BE FILLED WITH -C LOGICAL RECORDS. -C -C W3AI19 WILL THEN MOVE THE LINE OF INFORMATION INTO NBLK, STORE -C BLANK CHARACTERS IN THE REMAINDER OF THE BLOCK, AND SET NEXT = NEXT -C + L. -C -C EACH TIME W3AI19 IS ENTERED, ONE LINE IS BLOCKED AND NEXT INCRE- -C MENTED UNTIL A LINE WILL NOT FIT THE REMAINDER OF THE BLOCK. THEN -C W3AI19 WILL SET NEXT = -1 AS A FLAG FOR THE USER TO DISPOSE OF THE -C BLOCK. THE USER SHOULD BE AWARE THAT THE LAST LOGICAL RECORD WAS NOT -C BLOCKED. -C - INTEGER L - INTEGER N - INTEGER NEXT - INTEGER(8) WBLANK -C - CHARACTER * 1 LINE(*) - CHARACTER * 1 NBLK(*) - CHARACTER * 1 BLANK -C - SAVE -C - DATA WBLANK/Z'2020202020202020'/ -C -C TEST VALUE OF NEXT. -C - IF (NEXT.LT.0) THEN - RETURN -C -C TEST N FOR ZERO OR LESS -C - ELSE IF (N.LE.0) THEN - NEXT = -2 - RETURN -C -C TEST L FOR ZERO OR LESS -C - ELSE IF (L.LE.0) THEN - NEXT = -3 - RETURN -C -C TEST TO SEE IF LINE WILL FIT IN BLOCK. -C - ELSE IF ((L + NEXT).GT.N) THEN - NEXT = -1 - RETURN -C -C FILL BLOCK WITH BLANK CHARACTERS IF NEXT EQUAL ZERO. -C BLANK IS EBCDIC BLANK, 40 HEX, OR 64 DECIMAL -C - ELSE IF (NEXT.EQ.0) THEN - CALL W3FI01(LW) - IWORDS = N / LW - CALL XSTORE(NBLK,WBLANK,IWORDS) - IF (MOD(N,LW).NE.0) THEN - NWORDS = IWORDS * LW - IBYTES = N - NWORDS - DO I = 1,IBYTES - NBLK(NWORDS+I) = CHAR(32) - END DO - END IF - END IF -C -C MOVE LINE INTO BLOCK. -C -C DO 20 I = 1,L -C NBLK(I + NEXT) = LINE(I) -C20 CONTINUE - CALL XMOVEX(NBLK(NEXT+1),LINE,L) -C -C ADJUST VALUE OF NEXT. -C - NEXT = NEXT + L -C - RETURN -C - END diff --git a/external/w3nco/v2.0.6/src/w3ai24.f b/external/w3nco/v2.0.6/src/w3ai24.f deleted file mode 100644 index bea6da9f..00000000 --- a/external/w3nco/v2.0.6/src/w3ai24.f +++ /dev/null @@ -1,49 +0,0 @@ - LOGICAL FUNCTION W3AI24(STRING1, STRING2,LENGTH) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C FUNCT W3AI24 TEST FOR MATCH OF TWO STRINGS -C PRGMMR: LUKELIN ORG: NMC421 DATE:94-08-31 -C -C ABSTACT: TEST TWO STRINGS. -C IF ALL EQUAL; OTHERWISE .FALSE. -C -C PROGRAM HISTORY LOG: -C 94-08-31 LUKE LIN -C -C USAGE: II = W3AI24(STRING1,STRING2,LENGTH) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C STRING1 ARG LIST CHARACTER ARRAY TO MATCH WITH STRING2 -C STRING2 ARG LIST CHARACTER ARRAY TO MATCH WITH STRING1 -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C W3AI24 FUNCTION LOGICAL .TRUE. IF S1 AND S2 MATCH ON ALL CHAR., -C LOGICAL .FALSE. IF NOT MATCH ON ANY CHAR. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN -C MACHINE: NAS -C -C$$$ -C - CHARACTER*1 STRING1(*) - CHARACTER*1 STRING2(*) - INTEGER*4 LENGTH -C - W3AI24 = .TRUE. -C - DO 10 I = 1,LENGTH - IF (STRING1(I).NE.STRING2(I)) GO TO 40 - 10 CONTINUE -C - RETURN -C - 40 CONTINUE - W3AI24 = .FALSE. - RETURN -C - END diff --git a/external/w3nco/v2.0.6/src/w3ai38.f b/external/w3nco/v2.0.6/src/w3ai38.f deleted file mode 100644 index b8e2f127..00000000 --- a/external/w3nco/v2.0.6/src/w3ai38.f +++ /dev/null @@ -1,84 +0,0 @@ - SUBROUTINE W3AI38 (IE, NC ) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AI38 EBCDIC TO ASCII -C PRGMMR: DESMARAIS ORG: W342 DATE: 82-11-29 -C -C ABSTRACT: CONVERT EBCDIC TO ASCII BY CHARACTER. -C THIS SUBROUTINE CAN BE REPLACED BY CRAY UTILITY SUBROUTINE -C USCCTC . SEE MANUAL SR-2079 PAGE 3-15. CRAY UTILITY TR -C CAN ALSO BE USED FOR ASCII, EBCDIC CONVERSION. SEE MANUAL SR-2079 -C PAGE 9-35. -C -C PROGRAM HISTORY LOG: -C 82-11-29 DESMARAIS -C 88-03-31 R.E.JONES CHANGE LOGIC SO IT WORKS LIKE A -C IBM370 TRANSLATE INSTRUCTION. -C 88-08-22 R.E.JONES CHANGES FOR MICROSOFT FORTRAN 4.10 -C 88-09-04 R.E.JONES CHANGE TABLES TO 128 CHARACTER SET -C 90-01-31 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C CRAY DOES NOT ALLOW CHAR*1 TO BE SET TO HEX -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C -C USAGE: CALL W3AI38 (IE, NC) -C INPUT ARGUMENT LIST: -C IE - CHARACTER*1 ARRAY OF EBCDIC DATA -C NC - INTEGER, CONTAINS CHARACTER COUNT TO CONVERT.... -C -C OUTPUT ARGUMENT LIST: -C IE - CHARACTER*1 ARRAY OF ASCII DATA -C -C REMARKS: SOFTWARE VERSION OF IBM370 TRANSLATE INSTRUCTION, BY -C CHANGING THE TWO TABLES WE COULD DO A 64, 96, 128 ASCII -C CHARACTER SET, CHANGE LOWER CASE TO UPPER, ETC. -C AEA CONVERTS DATA AT A RATE OF 1.5 MILLION CHARACTERS PER SEC. -C CRAY UTILITY USCCTI CONVERT ASCII TO IBM EBCDIC -C CRAY UTILITY USCCTC CONVERT IBM EBCDIC TO ASCII -C THEY CONVERT DATA AT A RATE OF 2.1 MILLION CHARACTERS PER SEC. -C CRAY UTILITY TR WILL ALSO DO A ASCII, EBCDIC CONVERSION. -C TR CONVERT DATA AT A RATE OF 5.4 MILLION CHARACTERS PER SEC. -C TR IS IN LIBRARY /USR/LIB/LIBCOS.A ADD TO SEGLDR CARD. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - INTEGER(8) IASCII(32) -C - CHARACTER*1 IE(*) - CHARACTER*1 ASCII(0:255) -C - EQUIVALENCE (IASCII(1),ASCII(0)) -C -C*** ASCII CONTAINS ASCII CHARACTERS, AS PUNCHED ON IBM029 -C - DATA IASCII/ - & X'000102030009007F',X'0000000B0C0D0E0F', - & X'1011120000000000',X'1819000000000000', - & X'00001C000A001700',X'0000000000050607', - & X'00001600001E0004',X'000000001415001A', - & X'2000600000000000',X'0000602E3C282B00', - & X'2600000000000000',X'000021242A293B5E', - & X'2D2F000000000000',X'00007C2C255F3E3F', - & X'0000000000000000',X'00603A2340273D22', - & X'2061626364656667',X'6869202020202020', - & X'206A6B6C6D6E6F70',X'7172202020202020', - & X'207E737475767778',X'797A2020205B2020', - & X'0000000000000000',X'00000000005D0000', - & X'7B41424344454647',X'4849202020202020', - & X'7D4A4B4C4D4E4F50',X'5152202020202020', - & X'5C20535455565758',X'595A202020202020', - & X'3031323334353637',X'3839202020202020'/ -C - IF (NC .LE. 0) RETURN -C -C*** CONVERT STRING ... EBCDIC TO ASCII, NC CHARACTERS -C - DO 20 J = 1, NC - IE(J) = ASCII(mova2i(IE(J))) - 20 CONTINUE -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3ai39.f b/external/w3nco/v2.0.6/src/w3ai39.f deleted file mode 100644 index 266bd233..00000000 --- a/external/w3nco/v2.0.6/src/w3ai39.f +++ /dev/null @@ -1,81 +0,0 @@ - SUBROUTINE W3AI39 (NFLD, N) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AI39 TRANSLATE 'ASCII' FIELD TO 'EBCDIC' -C PRGMMR: DESMARAIS ORG: W342 DATE: 93-10-06 -C -C ABSTRACT: TRANSLATE AN 'ASCII' FIELD TO 'EBCDIC', ALL ALPHANUMERICS, -C SPECIAL CHARCATERS, FILL SCATTER, BROCKEN< CLEAR, OVERCAST, BELL, -C HT AND VT (FOR AFOS). SPACE, '6D' TO '5E' CONVERSION (HDROLOGY), -C CHANGERS WERE MADE TO W3AI38 TO GIVE REVERSE TABLE TRANSLATION -C -C PROGRAM HISTORY LOG: -C 93-10-06 R.E.JONES CONVERT IBM370 ASSEBLER VERSION TO FORTRAN -C 94-04-28 R.E.JONES CHANGES FOR CRAY -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C -C USAGE: CALL W3AI39 (NFLD,N) -C INPUT ARGUMENT LIST: -C NFLD - CHARACTER*1 ARRAY OF ASCII DATA -C N - INTEGER, CONTAINS CHARACTER COUNT TO CONVERT.... -C -C OUTPUT ARGUMENT LIST: -C NFLD - CHARACTER*1 ARRAY OF EBCDIC DATA -C -C REMARKS: SOFTWARE VERSION OF IBM370 TRANSLATE INSTRUCTION, BY -C CHANGING THE TABLE WE COULD DO A 64, 96, ASCII -C CHARACTER SET, CHANGE LOWER CASE TO UPPER, ETC. -C TR CONVERT DATA AT A RATE OF 5.4 MILLION CHARACTERS PER SEC. -C TR IS IN LIBRARY /USR/LIB/LIBCOS.A ADD TO SEGLDR CARD. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - INTEGER(8) IEBCDC(32) -C - CHARACTER*1 NFLD(*) - CHARACTER*1 EBCDIC(0:255) -C - SAVE -C - EQUIVALENCE (IEBCDC(1),EBCDIC(0)) -C -C*** EBCDIC CONTAINS HEX. REPRESENTATION OF EBCDIC CHARACTERS -C -C DATA IEBCDC/ -C & X'00010203372D2E2F',X'1605250B0C0D0E0F', -C & X'101112003C3D3226',X'18193F2722003500', -C & X'405A7F7B5B6C507D',X'4D5D5C4E6B604B61', -C & X'F0F1F2F3F4F5F6F7',X'F8F97A5E4C7E6E6F', -C & X'7CC1C2C3C4C5C6C7',X'C8C9D1D2D3D4D5D6', -C & X'D7D8D9E2E3E4E5E6',X'E7E8E9ADE0BD5F6D', -C & X'7981828384858687',X'8889919293949596', -C & X'979899A2A3A4A5A6',X'A7A8A9C06AD0A107', -C & 16*X'4040404040404040'/ -C -C THIS TABLE IS THE SAME AS HDS ASSEMBLER VERSION -C - DATA IEBCDC/ - & X'007D006C000000E0',X'00657C66004C0000', - & X'0000000000000000',X'0000000000005B00', - & X'40D07F7B5000506E',X'4D5D5C4F6B604B61', - & X'F0F1F2F3F4F5F6F7',X'F8F90000007E00C0', - & X'64C1C2C3C4C5C6C7',X'C8C9D1D2D3D4D5D6', - & X'D7D8D9E2E3E4E5E6',X'E7E8E90062636D00', - & X'0000000000000000',X'0000000000000000', - & X'0000000000000000',X'000000000000005F', - & 16 * X'0000000000000000'/ -C - IF (N .LE. 0) RETURN -C -C*** CONVERT STRING ... ASCII TO EBCDIC, N CHARACTERS -C - DO 20 J = 1, N - NFLD(J) = EBCDIC(mova2i(NFLD(J))) - 20 CONTINUE -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3aq15.f b/external/w3nco/v2.0.6/src/w3aq15.f deleted file mode 100644 index 0f423c9f..00000000 --- a/external/w3nco/v2.0.6/src/w3aq15.f +++ /dev/null @@ -1,66 +0,0 @@ - SUBROUTINE W3AQ15(ITIME, QDESCR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AQ15 GMT TIME PACKER -C PRGMMR: R.E.JONES ORG: W/NMC421 DATE: 95-10-10 -C -C ABSTRACT: CONVERT 32 OR 64 BIT BINARY TIME (GMT) INTO A 16 BIT -C STRING AND STORE THESE 4 PACKED DECIMAL NUMBERS INTO BYTES -C 39 AND 40 OF THE OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 83-12-12 B. STRUBLE (ORIGINAL AUTHOR) -C 84-07-06 R.E.JONES CHANGE TO IBM ASSEMBLER V 02 -C 95-10-16 R.E.JONES CHANGE TO FORTRAN FOR CRAY AND 32 BIT -C WORKSTATIONS -C -C USAGE: CALL W3AQ15(ITIME, QDESCR) -C INPUT ARGUMENT LIST: -C ITIME - INTEGER WORD CONTAINING TIME IN BINARY -C -C OUTPUT ARGUMENT LIST: -C QDESCR - ARRAY CONTAINING TRANSMISSION QUEUE DESCRIPTOR -C NOTE- TIME WILL BE PLACED IN 39 AND 40TH -C BYTE OF THIS ARRAY AS 4 (4 BIT) BCD. -C -C -C REMARKS: THE USER CAN OBTAIN THE CURRENT TIME IN GMT BY INVOCKING -C THE W3 LIBRARY ROUTINE W3FQ02 WHICH FILLS AN EIGHT WORD ARRAY -C WITH THE CURRENT DATE AND TIME. THE 5TH WORD FROM THIS ARRAY -C CONTAINS THE TIME WHICH CAN BE PASSED TO W3AQ15 AS THE -C INPUT PARAMETER-ITIME. -C -C -C EXAMPLE: -C -C INTEGER NTIME(8) -C CHARACTER * 80 QUEUE -C -C CALL W3FQ02(NTIME,0) -C CALL W3AQ15(NTIME(5),QUEUE) -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048. -C -C$$$ - INTEGER ITIME -C - CHARACTER * 80 QDESCR -C -C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION -C TWO BYTES AS 4 BIT BCD -C -C -C CONVERT INTO 4 BIT BCD -C - KA = ITIME / 1000 - KB = MOD(ITIME,1000) / 100 - KC = MOD(ITIME,100) / 10 - KD = MOD(ITIME,10) -C - QDESCR(39:39) = CHAR(KA * 16 + KB) - QDESCR(40:40) = CHAR(kC * 16 + KD) -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3as00.f b/external/w3nco/v2.0.6/src/w3as00.f deleted file mode 100644 index 26183554..00000000 --- a/external/w3nco/v2.0.6/src/w3as00.f +++ /dev/null @@ -1,315 +0,0 @@ - subroutine W3AS00(nch_parm,cparm,iret_parm) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3AS00 GET PARM FIELD FROM COMMAND-LINE -C PRGMMR: SHIMOMURA ORG: W/NMC41 DATE: 95-05-23 -C -C ABSTRACT: TO GET THE ONE COMMAND-LINE ARGUMENT WHICH STARTS WITH -C "PARM="; RETURNING THE PARM FIELD (WITHOUT THE KEYWORD "PARM=") -C AS A NULL-TERMINATED STRING IN THE CHARACTER STRING:CPARM. -C -C PROGRAM HISTORY LOG: -C 95-05-23 DAVID SHIMOMURA -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C -C USAGE: CALL W3AS00(NCH_PARM, CPARM, iret_parm) -C 1 2 3 -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C (1.) NCH_PARM - NO. OF CHARACTERS IN THE PARM FIELD -C (2.) CPARM - C*(*) CPARM -- THE DESTINATION FOR THE PARMFIELD -C OBTAINED FROM THE COMMAND LINE; -C USER SHOULD DEFINE THE CHARACTER STRING FOR -C A SIZE .LE. 101-BYTES, WHICH WOULD BE -C BIG ENOUGH FOR THE 100-CHAR IBM LIMIT PLUS -C ONE EXTRA BYTE FOR MY NULL-TERMINATOR. -C -C (3.) iret_parm - RETURN CODE -C = 0; NORMAL RETURN -C = -1; ABNORMAL EXIT. THE USER HAS FAILED -C TO DEFINE THE CPARM DESTINATION -C AS A CHARACTER STRING. -C -C = +1; A WARNING: -C THE GIVEN ARG IN THE COMMAND LINE WAS -C TOO LONG TO FIT IN THE DESTINATION: CPARM, -C SO I HAVE TRUNCATED IT. -C -C = +2; A WARNING: NO ARGS AT ALL ON COMMAND LINE, -C SO I COULD NOT FETCH THE PARM FIELD. -C -C = +3; A WARNING: NO "PARM="-ARGUMENT EXISTS -C AMONG THE ARGS ON THE COMMAND LINE, -C SO I COULD NOT FETCH THE PARM FIELD. -C -C OUTPUT FILES: -C FT06F001 - SOME CHECKOUT PRINTOUT -C -C REMARKS: -C -C TO EMULATE THE IBM PARM FIELD, THE USER SHOULD KEY_IN ON THE -C COMMAND LINE: -C PARM='IN BETWEEN THE SINGLE_QUOTES IS THE PARM FIELD' -C WHAT IS RETURNED FROM W3AS00() FROM THE PARM= ARG IS -C THE PARM FIELD: WHICH STARTS WITH THE LOCATION BEYOND THE -C EQUAL_SIGN OF THE KEYWORD "PARM=", AND INCLUDES EVERYTHING -C WHICH WAS WITHIN THE BOUNDS OF THE SINGLE-QUOTE SIGNS. -C BUT THE QUOTE SIGNS THEMSELVES WILL DISAPPEAR; AND A NULL- -C TERMINATOR WILL BE ADDED. -C THE STARTING "PARM=" IS A KEY WORD FOR THE PARMS, AND SHOULD -C NOT BE USED TO START ANY OTHER ARGUMENT. -C -C CAUTION: I HAVE CHANGED THE CALL SEQUENCE BY ADDING A RETURN CODE -C -C -C ATTRIBUTES: -C LANGUAGE: CRAY FORTRAN77 -C MACHINE: CRAY2 -C -C$$$ -C - integer kbytpwrd - parameter (kbytpwrd=8) - integer maxnbyt - parameter (maxnbyt=112) -C ... WHERE 112 CHARACTERS IS SIZE OF CWORK FOR 100 CHARACTERS -C ... WITHIN QUOTES + 'PARM=' + BACKSLASHES + LINEFEEDS - - integer maxnwrds - parameter (maxnwrds=maxnbyt/kbytpwrd) - -C ... call seq. args ... - INTEGER NCH_PARM - CHARACTER*(*) CPARM - integer iret_parm - -C -C ... FUNCTIONS ... - external lastch - integer lastch - external notrail - integer notrail -C ------------------------------------------------------------- - integer jwork(maxnwrds) - character*112 cwork - equivalence (jwork,cwork) - - integer(4) nargsinline,iargc,iar - integer nchars - integer lmt_txt - integer non_parm - - LOGICAL LPARMQQ - character*1 KLF - character*1 NULLCHR - character*1 lonech - -C . . . . . . . . S T A R T . . . . . . . . . . . . . . . . - - NULLCHR = char(0) - KLF = char(10) -C - iret_parm = 0 - non_parm = 0 - - LPARMQQ = .FALSE. - NCH_PARM = 0 - - lmt_dest = len(cparm) - write(6,103)lmt_dest - 103 format(1h ,'W3AS00: dimensioned size (in bytes) of dest strng=', - 1 I11) - if(lmt_dest .le. 0) then - write(6,105) - 105 format(1h ,'W3AS00:FAILED on undefined destination ', - 1 'character string: CPARM') - iret_parm = -1 - nch_parm = 0 - go to 999 - else if (lmt_dest .gt. 101) then - lmt_dest = 101 - endif - lmt_txt = lmt_dest - 1 - - cparm(1:lmt_dest) = ' ' - - narg_got = 0 -C - nargsinline = iargc() - - write(6,115) nargsinline - 115 format(1h ,'W3AS00: count of args found in command line =', I3) - - if(nargsinline .gt. 0) then -C ... to scan every argument, looking only for the Arg which -C ... starts with "PARM=" - do iar = 1,nargsinline - LPARMQQ = .FALSE. - - cwork(1:) = ' ' - - call getarg(iar,cwork) - - narg_got = narg_got + 1 - nchars = lastch(cwork) - - if(nchars .le. 0) then - write(6,125)iar - 125 format(1h ,'W3AS00:getarg() returned an empty arg for', - A ' no.',I3 ) - else -C ... SOME TEXT EXISTS IN THIS ARG ... -C ... DOES IT START WITH "PARM=" ??? - if((cwork(1:5) .EQ. 'PARM=') .OR. - 1 (cwork(1:5) .EQ. 'parm=') ) then - LPARMQQ = .TRUE. -C ... this arg is special case of PARM= -C ... which can include blanks, so cannot lastch() it ... - nchars = notrail(cwork) - endif -C ... iwdss = ((nchars-1)/kbytpwrd) + 1 -C ... where iwdss points to last word so I could hex dump -C ... that last word, to see if NULL is there -C ... There was no NULL; only blank fill. - IF(LPARMQQ) THEN -C ... FILTER OUT ANY BACKSLASH or LINE_FEED ... - ioutc = 0 - do inc = 6,nchars - if(ioutc .LT. lmt_txt) then - lonech = cwork(inc:inc) - if((lonech .EQ. '\\') .OR. - 1 (lonech .EQ. KLF)) then - else - ioutc = ioutc + 1 - cparm(ioutc:ioutc) = lonech - endif - else -C ... comes here if ioutc .GE. lmt_txt, -C ... so I cannot increment ioutc for this inc char -C ... so truncate the string at (1:ioutc) -C ... a warning be return-coded ... - iret_parm = +1 - go to 155 - endif - enddo - 155 continue - nch_parm = ioutc - np1 = nchars+1 - cparm(np1:np1) = NULLCHR - go to 999 -C ... jump out of DO when PARM has been processed ... - else -C ... this is .not. a PARM field, do nothing w/ those, - non_parm = non_parm + 1 - endif - - endif - enddo -C ... IF IT FALLS THRU BOTTOM OF DO, THEN IT DID NOT FIND -C ... THE PARM FIELD AMONG THE EXISTING ARGS - iret_parm = 3 - nch_parm = 0 - - ELSE -C ... COMES HERE IF nargsinline = 0, so there were no args at all - iret_parm = 2 - nch_parm = 0 - endif - go to 999 - - 999 continue - return - end - integer function lastch(str) -C ... lastch() ... to point to the last character of a character -C ... string -C ... String terminators are first BLANK or NULL character -C ... encountered. -C ... Caution: I will limit scan on LEN(str) -C so you must give me a character string. -C - - character*(*) str - - character*1 NULLCHR - character*1 BLANK -C - integer i - integer limit -C - NULLCHR = char(0) - BLANK = ' ' - limit = len(str) - i = 0 - do while(i .LT. limit .AND. str(i+1:i+1) .NE. NULLCHR - 1 .AND. str(i+1:i+1) .NE. BLANK) - i = i + 1 - enddo - - lastch = i - return - end - integer function notrail(str) -C ... mods for CRAY version 8-Dec-1994/dss -C -C ... notrail() ... to point to the last non-blank character of a -C ... character string (which can have leading -C blanks and intermediate blanks); but after -C ignoring all trailing blank characters. -C ... String terminators are last BLANK or first NULL -C ... character encountered. -C -C ... This differs from LASTCH() which stops on first -C ... BLANK encountered when scanning from the start; -C ... NOTRAIL() will scan backwards from the end of the -C ... string, skipping over trailing blanks, until the -C ... last non-blank character is hit. -C ... -C ... Caution: I will limit scan on LEN(str) -C so you must give me a character string. -C - - character*(*) str - - character*1 BLANK - parameter (BLANK = ' ') -C - integer i - integer limit - integer limitnl - character*1 NULLCHR -C - NULLCHR = char(0) - i = 0 - limitnl = 0 - limit = len(str) - if(limit .le. 0) go to 999 -C ... otherwise, at least one char len string ... - limitnl = index(str(1:limit),NULLCHR) - if(limitnl .le. 0) then -C ... no NULLCHR exists in str(1:limit) ... -C ... so go scan from limit - go to 300 - - else if(limitnl .eq. 1) then - go to 999 -C ... which jumped out w/ pointer=0 if NULL in first position - else -C ... a NULLCHR existed within str(1:limit); so -C ... I want to scan backwards from before that NULLCHR -C ... which is located at limitnl - limit = limitnl - 1 - endif - if(limit .le. 0) go to 999 - 300 continue -C ... otherwise, we have a string of at least one char to look at -C ... which has no NULLCHR in interval (1:limit) - i = limit - do while((i .GT. 0) .AND. (str(i:i) .EQ. BLANK)) - i = i - 1 - enddo - - 999 continue - notrail = i - return - end diff --git a/external/w3nco/v2.0.6/src/w3difdat.f b/external/w3nco/v2.0.6/src/w3difdat.f deleted file mode 100644 index 1e76b6e7..00000000 --- a/external/w3nco/v2.0.6/src/w3difdat.f +++ /dev/null @@ -1,55 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3difdat(jdat,idat,it,rinc) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3DIFDAT RETURN A TIME INTERVAL BETWEEN TWO DATES -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM RETURNS THE ELAPSED TIME INTERVAL FROM -! AN NCEP ABSOLUTE DATE AND TIME GIVEN IN THE SECOND ARGUMENT UNTIL -! AN NCEP ABSOLUTE DATE AND TIME GIVEN IN THE FIRST ARGUMENT. -! THE OUTPUT TIME INTERVAL IS IN ONE OF SEVEN CANONICAL FORMS -! OF THE NCEP RELATIVE TIME INTERVAL DATA STRUCTURE. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: CALL W3DIFDAT(JDAT,IDAT,IT,RINC) -! -! INPUT VARIABLES: -! JDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! IT INTEGER RELATIVE TIME INTERVAL FORMAT TYPE -! (-1 FOR FIRST REDUCED TYPE (HOURS ALWAYS POSITIVE), -! 0 FOR SECOND REDUCED TYPE (HOURS CAN BE NEGATIVE), -! 1 FOR DAYS ONLY, 2 FOR HOURS ONLY, 3 FOR MINUTES ONLY, -! 4 FOR SECONDS ONLY, 5 FOR MILLISECONDS ONLY) -! -! OUTPUT VARIABLES: -! RINC REAL (5) NCEP RELATIVE TIME INTERVAL -! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) -! (TIME INTERVAL IS POSITIVE IF JDAT IS LATER THAN IDAT.) -! -! SUBPROGRAMS CALLED: -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer jdat(8),idat(8) - real rinc(5) - real rinc1(5) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! difference the days and time and put into canonical form - rinc1(1)=iw3jdn(jdat(1),jdat(2),jdat(3))- - & iw3jdn(idat(1),idat(2),idat(3)) - rinc1(2:5)=jdat(5:8)-idat(5:8) - call w3reddat(it,rinc1,rinc) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/external/w3nco/v2.0.6/src/w3doxdat.f b/external/w3nco/v2.0.6/src/w3doxdat.f deleted file mode 100644 index b36ad7c2..00000000 --- a/external/w3nco/v2.0.6/src/w3doxdat.f +++ /dev/null @@ -1,40 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3doxdat(idat,jdow,jdoy,jday) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3DOXDAT RETURN WEEK DAY, YEAR DAY, AND JULIAN DAY -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM RETURNS THE INTEGER DAY OF WEEK, THE DAY -! OF YEAR, AND JULIAN DAY GIVEN AN NCEP ABSOLUTE DATE AND TIME. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: CALL W3DOXDAT(IDAT,JDOW,JDOY,JDAY) -! -! INPUT VARIABLES: -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! OUTPUT VARIABLES: -! JDOW INTEGER DAY OF WEEK (1-7, WHERE 1 IS SUNDAY) -! JDOY INTEGER DAY OF YEAR (1-366, WHERE 1 IS JANUARY 1) -! JDAY INTEGER JULIAN DAY (DAY NUMBER FROM JAN. 1,4713 B.C.) -! -! SUBPROGRAMS CALLED: -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer idat(8) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! get julian day and then get day of week and day of year - jday=iw3jdn(idat(1),idat(2),idat(3)) - call w3fs26(jday,jy,jm,jd,jdow,jdoy) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/external/w3nco/v2.0.6/src/w3fi01.f b/external/w3nco/v2.0.6/src/w3fi01.f deleted file mode 100644 index a4d87dbc..00000000 --- a/external/w3nco/v2.0.6/src/w3fi01.f +++ /dev/null @@ -1,33 +0,0 @@ - SUBROUTINE W3FI01(LW) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI01 DETERMINES MACHINE WORD LENGTH IN BYTES -C PRGMMR: KEYSER ORG: W/NMC22 DATE: 06-29-92 -C -C ABSTRACT: DETERMINES THE NUMBER OF BYTES IN A FULL WORD FOR THE -C PARTICULAR MACHINE (IBM OR CRAY). -C -C PROGRAM HISTORY LOG: -C 92-01-10 R. KISTLER (W/NMC23) -C 92-05-22 D. A. KEYSER -- DOCBLOCKED/COMMENTED -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 2001-06-07 Gilbert Uses f90 standard routine bit_size to -C find integer word length -C -C USAGE: CALL W3FI01(LW) -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C LW - MACHINE WORD LENGTH IN BYTES -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY, WORKSTATIONS -C -C$$$ -C - INTEGER LW - LW=BIT_SIZE(LW) - LW=LW/8 - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi04.f b/external/w3nco/v2.0.6/src/w3fi04.f deleted file mode 100644 index 72197daa..00000000 --- a/external/w3nco/v2.0.6/src/w3fi04.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE W3FI04(IENDN,ITYPEC,LW) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FI04 FIND WORD SIZE, ENDIAN, CHARACTER SET -C PRGMNR: JONES,R.E. ORG: W/NMC42 DATE: 94-10-07 -C -C ABSTRACT: SUBROUTINE COMPUTES WORD SIZE, THE TYPE OF CHARACTER -C SET, ASCII OR EBCDIC, AND IF THE COMPUTER IS BIG-ENDIAN, OR -C LITTLE-ENDIAN. -C -C PROGRAM HISTORY LOG: -C 94-10-07 R.E.JONES -C 98-07-08 Gilbert - Removed the Fortran SAVE Statement. -C The SAVE statement is not needed for this -C routine, and may have been causing errors -C using the f90 compiler under the 2.0 -C Programming Environment. -C 02-10-15 Vuong Replaced Function ICHAR with mova2i -C -C USAGE: CALL W3FI04 (IENDN, ITYPEC, LW) -C -C OUTPUT ARGUMENT LIST: -C IENDN - INTEGER FOR BIG-ENDIAN OR LITTLE-ENDIAN -C = 0 BIG-ENDIAN -C = 1 LITTLE-ENDIAN -C = 2 CANNOT COMPUTE -C ITYPEC - INTEGER FOR TYPE OF CHARACTER SET -C = 0 ASCII CHARACTER SET -C = 1 EBCDIC CHARACTER SET -C = 2 NOT ASCII OR EBCDIC -C LW - INTEGER FOR WORDS SIZE OF COMPUTER IN BYTES -C = 4 FOR 32 BIT COMPUTERS -C = 8 FOR 64 BIT COMPUTERS -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, Y-MP8/64, Y-MP EL92/256, J916/2048 -C -C$$$ -C - INTEGER ITEST1 - INTEGER ITEST2 - INTEGER ITEST3 - INTEGER IENDN - INTEGER ITYPEC - INTEGER LW -C - CHARACTER * 8 CTEST1 - CHARACTER * 8 CTEST2 - CHARACTER * 1 CTEST3(8) - CHARACTER * 1 BLANK -C - EQUIVALENCE (CTEST1,ITEST1),(CTEST2,ITEST2) -C - EQUIVALENCE (ITEST3,CTEST3(1)) -C - DATA CTEST1/'12345678'/ - DATA ITEST3/Z'01020304'/ - DATA BLANK /' '/ -C -C SAVE -C -C TEST FOR TYPE OF CHARACTER SET -C BLANK IS 32 (20 HEX) IN ASCII, 64 (40 HEX) IN EBCDEC -C - IF (MOVA2I(BLANK).EQ.32) THEN - ITYPEC = 0 - ELSE IF (MOVA2I(BLANK).EQ.64) THEN -C -C COMPUTER IS PROBABLY AN IBM360, 370, OR 390 WITH -C A 32 BIT WORD SIZE, AND BIG-ENDIAN. -C - ITYPEC = 1 - ELSE - ITYPEC = 2 - END IF -C -C TEST FOR WORD SIZE, SET LW TO 4 FOR 32 BIT COMPUTER, -C 8 FOR FOR 64 BIT COMPUTERS -C - ITEST2 = ITEST1 - IF (CTEST1 .EQ. CTEST2) THEN -C -C COMPUTER MAY BE A CRAY, OR COULD BE DEC VAX ALPHA -C OR SGI WITH R4000, R4400, R8800 AFTER THEY CHANGE -C FORTRAN COMPILERS FOR 64 BIT INTEGER. -C - LW = 8 - ELSE - LW = 4 - ENDIF -C -C USING ITEST3 WITH Z'01020304' EQUIVALNCED TO CTEST3 -C ON A 32 BIT BIG-ENDIAN COMPUTER 03 IS IN THE 3RD -C BYTE OF A 4 BYTE WORD. ON A 32 BIT LITTLE-ENDIAN -C COMPUTER IT IS IN 2ND BYTE. -C ON A 64 BIT COMPUTER Z'01020304' IS RIGHT ADJUSTED IN -C A 64 BIT WORD, 03 IS IN THE 7TH BYTE. ON A LITTLE- -C ENDIAN 64 BIT COMPUTER IT IS IN THE 2ND BYTE. -C - IF (LW.EQ.4) THEN - IF (MOVA2I(CTEST3(3)).EQ.3) THEN - IENDN = 0 - ELSE IF (MOVA2I(CTEST3(3)).EQ.2) THEN - IENDN = 1 - ELSE - IENDN = 2 - END IF - ELSE IF (LW.EQ.8) THEN - IF (MOVA2I(CTEST3(7)).EQ.3) THEN - IENDN = 0 - ELSE IF (MOVA2I(CTEST3(2)).EQ.3) THEN - IENDN = 1 - ELSE - IENDN = 2 - END IF - ELSE - IENDN = 2 - END IF -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi58.f b/external/w3nco/v2.0.6/src/w3fi58.f deleted file mode 100644 index ec8ccf3e..00000000 --- a/external/w3nco/v2.0.6/src/w3fi58.f +++ /dev/null @@ -1,115 +0,0 @@ - SUBROUTINE W3FI58(IFIELD,NPTS,NWORK,NPFLD,NBITS,LEN,KMIN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK *** -C . . . . -C SUBPROGRAM: W3FI58 - PACK POSITIVE DIFFERENCES IN LEAST BITS -C PRGMMR: ALLARD, R. ORG: NMC411 DATE: JULY 1987 -C -C ABSTRACT: CONVERTS AN ARRAY OF INTEGER NUMBERS INTO AN ARRAY OF -C POSITIVE DIFFERENCES (NUMBER(S) - MINIMUM VALUE) AND PACKS THE -C MAGNITUDE OF EACH DIFFERENCE RIGHT-ADJUSTED INTO THE LEAST -C NUMBER OF BITS THAT HOLDS THE LARGEST DIFFERENCE. -C -C PROGRAM HISTORY LOG: -C 87-09-02 ALLARD -C 88-10-02 R.E.JONES CONVERTED TO CDC CYBER 205 FTN200 FORTRAN -C 90-05-17 R.E.JONES CONVERTED TO CRAY CFT77 FORTRAN -C 90-05-18 R.E.JONES CHANGE NAME VBIMPK TO W3LIB NAME W3FI58 -C 96-05-14 IREDELL GENERALIZED COMPUTATION OF NBITS -C 98-06-30 EBISUZAKI LINUX PORT -C -C USAGE: CALL W3FI58(IFIELD,NPTS,NWORK,NPFLD,NBITS,LEN,KMIN) -C -C INPUT: -C -C IFIELD - ARRAY OF INTEGER DATA FOR PROCESSING -C NPTS - NUMBER OF DATA VALUES TO PROCESS IN IFIELD (AND NWORK) -C WHERE, NPTS > 0 -C -C OUTPUT: -C -C NWORK - WORK ARRAY WITH INTEGER DIFFERENCE -C NPFLD - ARRAY FOR PACKED DATA (character*1) -C (USER IS RESPONSIBLE FOR AN ADEQUATE DIMENSION.) -C NBITS - NUMBER OF BITS USED TO PACK DATA WHERE, 0 < NBITS < 32 -C (THE MAXIMUM DIFFERENCE WITHOUT OVERFLOW IS 2**31 -1) -C LEN - NUMBER OF PACKED BYTES IN NPFLD (SET TO 0 IF NO PACKING) -C WHERE, LEN = (NBITS * NPTS + 7) / 8 WITHOUT REMAINDER -C KMIN - MINIMUM VALUE (SUBTRACTED FROM EACH DATUM). IF THIS -C PACKED DATA IS BEING USED FOR GRIB DATA, THE -C PROGRAMER WILL HAVE TO CONVERT THE KMIN VALUE TO AN -C IBM370 32 BIT FLOATING POINT NUMBER. -C -C SUBPROGRAMS CALLED: -C -C W3LIB: SBYTES, SBYTE -C -C EXIT STATES: NONE -C -C NOTE: LEN = 0, NBITS = 0, AND NO PACKING PERFORMED IF -C -C (1) KMAX = KMIN (A CONSTANT FIELD) -C (2) NPTS < 1 (SEE INPUT ARGUMENT) -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - PARAMETER(ALOG2=0.69314718056) - INTEGER IFIELD(*) - CHARACTER*1 NPFLD(*) - INTEGER NWORK(*) -C - DATA KZERO / 0 / -C -C / / / / / / -C - LEN = 0 - NBITS = 0 - IF (NPTS.LE.0) GO TO 3000 -C -C FIND THE MAX-MIN VALUES IN INTEGER FIELD (IFIELD). -C - KMAX = IFIELD(1) - KMIN = KMAX - DO 1000 I = 2,NPTS - KMAX = MAX(KMAX,IFIELD(I)) - KMIN = MIN(KMIN,IFIELD(I)) - 1000 CONTINUE -C -C IF A CONSTANT FIELD, RETURN WITH NO PACKING AND 'LEN' AND 'NBITS' SET -C TO ZERO. -C - IF (KMAX.EQ.KMIN) GO TO 3000 -C -C DETERMINE LARGEST DIFFERENCE IN IFIELD AND FLOAT (BIGDIF). -C - BIGDIF = KMAX - KMIN -C -C NBITS IS COMPUTED AS THE LEAST INTEGER SUCH THAT -C BIGDIF < 2**NBITS -C - NBITS=LOG(BIGDIF+0.5)/ALOG2+1 -C -C FORM DIFFERENCES IN NWORK ARRAY. -C - DO 2000 K = 1,NPTS - NWORK(K) = IFIELD(K) - KMIN - 2000 CONTINUE -C -C PACK EACH MAGNITUDE IN NBITS (NBITS = THE LEAST POWER OF 2 OR 'N') -C - LEN=(NBITS*NPTS-1)/8+1 - CALL SBYTESC(NPFLD,NWORK,0,NBITS,0,NPTS) -C -C ADD ZERO-BITS AT END OF PACKED DATA TO INSURE A BYTE BOUNDARY. -C - NOFF = NBITS * NPTS - NZERO=LEN*8-NOFF - IF(NZERO.GT.0) CALL SBYTEC(NPFLD,KZERO,NOFF,NZERO) -C - 3000 CONTINUE - RETURN -C - END diff --git a/external/w3nco/v2.0.6/src/w3fi59.f b/external/w3nco/v2.0.6/src/w3fi59.f deleted file mode 100644 index ac430d4a..00000000 --- a/external/w3nco/v2.0.6/src/w3fi59.f +++ /dev/null @@ -1,129 +0,0 @@ - SUBROUTINE W3FI59(FIELD,NPTS,NBITS,NWORK,NPFLD,ISCALE,LEN,RMIN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI59 FORM AND PACK POSITIVE, SCALED DIFFERENCES -C PRGMMR: ALLARD, R. ORG: NMC41 DATE: 84-08-01 -C -C ABSTRACT: CONVERTS AN ARRAY OF SINGLE PRECISION REAL NUMBERS INTO -C AN ARRAY OF POSITIVE SCALED DIFFERENCES (NUMBER(S) - MINIMUM VALUE), -C IN INTEGER FORMAT AND PACKS THE ARGUMENT-SPECIFIED NUMBER OF -C SIGNIFICANT BITS FROM EACH DIFFERENCE. -C -C PROGRAM HISTORY LOG: -C 84-08-01 ALLARD ORIGINAL AUTHOR -C 90-05-17 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C 90-05-18 R.E.JONES CHANGE NAME PAKMAG TO W3LIB NAME W3FI59 -C 93-07-06 R.E.JONES ADD NINT TO DO LOOP 2000 SO NUMBERS ARE -C ROUNDED TO NEAREST INTEGER, NOT TRUNCATED. -C 94-01-05 IREDELL COMPUTATION OF ISCALE FIXED WITH RESPECT TO -C THE 93-07-06 CHANGE. -C 98-06-30 EBISUZAKI LINUX PORT -C -C USAGE: CALL W3FI59(FIELD,NPTS,NBITS,NWORK,NPFLD,ISCALE,LEN,RMIN) -C INPUT ARGUMENT LIST: -C FIELD - ARRAY OF FLOATING POINT DATA FOR PROCESSING (REAL) -C NPTS - NUMBER OF DATA VALUES TO PROCESS IN FIELD (AND NWORK) -C WHERE, NPTS > 0 -C NBITS - NUMBER OF SIGNIFICANT BITS OF PROCESSED DATA TO BE PACKED -C WHERE, 0 < NBITS < 32+1 -C -C OUTPUT ARGUMENT LIST: -C NWORK - ARRAY FOR INTEGER CONVERSION (INTEGER) -C IF PACKING PERFORMED (SEE NOTE BELOW), THE ARRAY WILL -C CONTAIN THE PRE-PACKED, RIGHT ADJUSTED, SCALED, INTEGER -C DIFFERENCES UPON RETURN TO THE USER. -C (THE USER MAY EQUIVALENCE FIELD AND NWORK. SAME SIZE.) -C NPFLD - ARRAY FOR PACKED DATA (character*1) -C (DIMENSION MUST BE AT LEAST (NBITS * NPTS) / 64 + 1 ) -C ISCALE- POWER OF 2 FOR RESTORING DATA, SUCH THAT -C DATUM = (DIFFERENCE * 2**ISCALE) + RMIN -C LEN - NUMBER OF PACKED BYTES IN NPFLD (SET TO 0 IF NO PACKING) -C WHERE, LEN = (NBITS * NPTS + 7) / 8 WITHOUT REMAINDER -C RMIN - MINIMUM VALUE (REFERENCE VALUE SUBTRACTED FROM INPUT DATA) -C THIS IS A CRAY FLOATING POINT NUMBER, IT WILL HAVE TO BE -C CONVERTED TO AN IBM370 32 BIT FLOATING POINT NUMBER AT -C SOME POINT IN YOUR PROGRAM IF YOU ARE PACKING GRIB DATA. -C -C REMARKS: LEN = 0 AND NO PACKING PERFORMED IF -C -C (1) RMAX = RMIN (A CONSTANT FIELD) -C (2) NBITS VALUE OUT OF RANGE (SEE INPUT ARGUMENT) -C (3) NPTS VALUE LESS THAN 1 (SEE INPUT ARGUMENT) -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, Y-MP8/864, Y-MP EL92/256, J916/2048 -C -C$$$ -C NATURAL LOGARITHM OF 2 AND 0.5 PLUS NOMINAL SAFE EPSILON - PARAMETER(ALOG2=0.69314718056,HPEPS=0.500001) -C - REAL FIELD(*) -C - CHARACTER*1 NPFLD(*) - INTEGER NWORK(*) -C - DATA KZERO / 0 / -C -C / / / / / / -C - LEN = 0 - ISCALE = 0 - IF (NBITS.LE.0.OR.NBITS.GT.32) GO TO 3000 - IF (NPTS.LE.0) GO TO 3000 -C -C FIND THE MAX-MIN VALUES IN FIELD. -C - RMAX = FIELD(1) - RMIN = RMAX - DO 1000 K = 2,NPTS - RMAX = AMAX1(RMAX,FIELD(K)) - RMIN = AMIN1(RMIN,FIELD(K)) - 1000 CONTINUE -C -C IF A CONSTANT FIELD, RETURN WITH NO PACKING PERFORMED AND 'LEN' = 0. -C - IF (RMAX.EQ.RMIN) GO TO 3000 -C -C DETERMINE LARGEST DIFFERENCE IN FIELD (BIGDIF). -C - BIGDIF = RMAX - RMIN -C -C ISCALE IS THE POWER OF 2 REQUIRED TO RESTORE THE PACKED DATA. -C ISCALE IS COMPUTED AS THE LEAST INTEGER SUCH THAT -C BIGDIF*2**(-ISCALE) < 2**NBITS-0.5 -C IN ORDER TO ENSURE THAT THE PACKED INTEGERS (COMPUTED IN LOOP 2000 -C WITH THE NEAREST INTEGER FUNCTION) STAY LESS THAN 2**NBITS. -C - ISCALE=NINT(ALOG(BIGDIF/(2.**NBITS-0.5))/ALOG2+HPEPS) -C -C FORM DIFFERENCES, RESCALE, AND CONVERT TO INTEGER FORMAT. -C - TWON = 2.0 ** (-ISCALE) - DO 2000 K = 1,NPTS - NWORK(K) = NINT( (FIELD(K) - RMIN) * TWON ) - 2000 CONTINUE -C -C PACK THE MAGNITUDES (RIGHTMOST NBITS OF EACH WORD). -C - KOFF = 0 - ISKIP = 0 -C -C USE NCAR ARRAY BIT PACKER SBYTES (GBYTES PACKAGE) -C - CALL SBYTESC(NPFLD,NWORK,KOFF,NBITS,ISKIP,NPTS) -C -C ADD 7 ZERO-BITS AT END OF PACKED DATA TO INSURE BYTE BOUNDARY. -C USE NCAR WORD BIT PACKER SBYTE -C - NOFF = NBITS * NPTS - CALL SBYTEC(NPFLD,KZERO,NOFF,7) -C -C DETERMINE BYTE LENGTH (LEN) OF PACKED FIELD (NPFLD). -C - LEN = (NOFF + 7) / 8 -C - 3000 CONTINUE - RETURN -C - END diff --git a/external/w3nco/v2.0.6/src/w3fi62.f b/external/w3nco/v2.0.6/src/w3fi62.f deleted file mode 100644 index 333f0fae..00000000 --- a/external/w3nco/v2.0.6/src/w3fi62.f +++ /dev/null @@ -1,215 +0,0 @@ - SUBROUTINE W3FI62 (LOC,TTAAII,KARY,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI62 BUILD 80-CHAR ON295 QUEUE DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: NMC421 DATE:94-03-23 -C -C ABSTRACT: BUILD 80 CHARACTER QUEUE DESCRIPTOR USING INFORMATION -C SUPPLIED BY USER, PLACING THE COMPLETED QUEUE DESCRIPTOR IN THE -C LOCATION SPECIFIED BY THE USER. (BASED ON OFFICE NOTE 295). -C -C PROGRAM HISTORY LOG: -C 91-06-21 CAVANAUGH -C 94-03-08 CAVANAUGH MODIFIED TO ALLOW FOR BULLETIN SIZES THAT -C EXCEED 20000 BYTES -C 94-04-28 R.E.JONES CHANGE FOR CRAY 64 BIT WORD SIZE AND -C FOR ASCII CHARACTER SET COMPUTERS -C 96-01-29 R.E.JONES PRESET IERR TO ZERO -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3FI62 (LOC,TTAAII,KARY,IERR) -C INPUT ARGUMENT LIST: -C TTAAII - FIRST 6 CHARACTERS OF WMO HEADER -C KARY - INTEGER ARRAY CONTAINING USER INFORMATION -C (1) = DAY OF MONTH -C (2) = HOUR OF DAY -C (3) = HOUR * 100 + MINUTE -C (4) = CATALOG NUMBER -C (5) = NUMBER OF 80 BYTE INCREMENTS -C (6) = NUMBER OF BYTES IN LAST INCREMENT -C (7) = TOTAL SIZE OF MESSAGE -C WMO HEADER + BODY OF MESSAGE IN BYTES -C (NOT INCLUDING QUEUE DESCRIPTOR) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C LOC - LOCATION TO RECEIVE QUEUE DESCRIPTOR -C KARY - SEE INPUT ARGUMENT LIST -C IERR - ERROR RETURN -C -C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES) -C LIBRARY: -C W3LIB - GBYTE W3FI01 W3AI15 -C -C REMARKS: IF TOTAL SIZE IS ENTERED (KARY(7)) THEN KARY(5) AND -C KARY(6) WILL BE CALCULATED. -C IF KARY(5) AND KARY(6) ARE PROVIDED THEN KARY(7) WILL -C BE IGNORED. -C -C WARNING: EQUIVALENCE ARRAY LOC TO INTEGER ARRAY SO IT STARTS ON -C A WORD BOUNDARY FOR SBYTE SUBROUTINE. -C -C ERROR RETURNS -C IERR = 1 TOTAL BYTE COUNT AND/OR 80 BYTE INCREMENT -C COUNT IS MISSING. ONE OR THE OTHER IS -C REQUIRED TO COMPLETE THE QUEUE DESCRIPTOR. -C IERR = 2 TOTAL SIZE TOO SMALL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS -C -C$$$ -C - INTEGER IHOLD(2) - INTEGER KARY(7),II,IERR -C - LOGICAL IBM370 -C - CHARACTER*6 TTAAII,AHOLD - CHARACTER*80 LOC - CHARACTER*1 BLANK -C - EQUIVALENCE (AHOLD,IHOLD) -C - SAVE -C -C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE -C COMPUTER, THIS IS THE EBCDIC CHARACTER SET. -C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE -C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER -C SETS TO FIND IBM370 TYPE COMPUTER. -C - DATA BLANK /' '/ -C ---------------------------------------------------------------- -C -C TEST FOR CRAY 64 BIT COMPUTER, LW = 8 -C - CALL W3FI01(LW) -C -C TEST FOR EBCDIC CHARACTER SET -C - IBM370 = .FALSE. - IF (MOVA2I(BLANK).EQ.64) THEN - IBM370 = .TRUE. - END IF -C - INOFST = 0 -C BYTES 1-16 'QUEUE DESCRIPTOR' - CALL SBYTE (LOC,-656095772,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,-985611067,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,-490481207,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,-672934183,INOFST,32) - INOFST = INOFST + 32 -C BYTES 17-20 INTEGER ZEROES - CALL SBYTE (LOC,0,INOFST,32) - INOFST = INOFST + 32 -C IF TOTAL COUNT IS INCLUDED -C THEN WILL DETERMINE THE NUMBER OF -C 80 BYTE INCREMENTS AND WILL DETERMINE -C THE NUMBER OF BYTES IN THE LAST INCREMENT - IERR = 0 - IF (KARY(7).NE.0) THEN - IF (KARY(7).LT.35) THEN -C PRINT *,'LESS THAN MINIMUM SIZE' - IERR = 2 - RETURN - END IF - KARY(5) = KARY(7) / 80 - KARY(6) = MOD(KARY(7),80) - IF (KARY(6).EQ.0) THEN - KARY(6) = 80 - ELSE - KARY(5) = KARY(5) + 1 - END IF - ELSE - IF (KARY(5).LT.1) THEN - IERR = 1 - RETURN - END IF - END IF -C BYTE 21-22 NR OF 80 BYTE INCREMENTS - CALL SBYTE (LOC,KARY(5),INOFST,16) - INOFST = INOFST + 16 -C BYTE 23 NR OF BYTES IN LAST INCREMENT - CALL SBYTE (LOC,KARY(6),INOFST,8) - INOFST = INOFST + 8 -C BYTES 24-28 INTEGER ZEROES - CALL SBYTE (LOC,0,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,0,INOFST,8) - INOFST = INOFST + 8 -C BYTES 29-34 6 CHAR BULLETIN NAME TTAAII - LOC(29:34) = TTAAII(1:6) -C -C IF ON ASCII COMPUTER, CONVERT LAST 6 CHARACTERS TO EBCDIC -C - IF (.NOT.IBM370) CALL W3AI39(LOC(29:29),6) -C - INOFST = INOFST + 48 -C BYTES 35-38 DAY OF MONTH AND UTC(Z) HRS -C DAY -C -C NOTE: W3AI15 WILL MAKE ASCII OR EBCDIC CHARACTERS -C DEPENDING ON WHAT TYPE OF COMPUTER IT IS ON -C - CALL W3AI15 (KARY(1),II,1,LW,'-') - CALL SBYTE (LOC,II,INOFST,16) - INOFST = INOFST + 16 -C HOURS - CALL W3AI15 (KARY(2),II,1,LW,'-') - CALL SBYTE (LOC,II,INOFST,16) -C -C IF ON ASCII COMPUTER, CONVERT LAST 4 CHARACTERS TO EBCDIC -C - IF (.NOT.IBM370) CALL W3AI39(LOC(35:35),4) - INOFST = INOFST + 16 -C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION -C TWO BYTES AS 4 BIT BCD - KA = KARY(3) / 1000 - KB = MOD(KARY(3),1000) / 100 - KC = MOD(KARY(3),100) / 10 - KD = MOD(KARY(3),10) - CALL SBYTE (LOC,KA,INOFST,4) - INOFST = INOFST + 4 - CALL SBYTE (LOC,KB,INOFST,4) - INOFST = INOFST + 4 - CALL SBYTE (LOC,KC,INOFST,4) - INOFST = INOFST + 4 - CALL SBYTE (LOC,KD,INOFST,4) - INOFST = INOFST + 4 -C BYTES 41-45 CATALOG NUMBER ELSE (SET TO 55555) - IF (KARY(4).GE.1.AND.KARY(4).LE.99999) THEN - CALL W3AI15 (KARY(4),IHOLD,1,8,'-') - IF (LW.EQ.4) THEN - CALL SBYTE (LOC,IHOLD(1),INOFST,8) - INOFST = INOFST + 8 - CALL SBYTE (LOC,IHOLD(2),INOFST,32) - INOFST = INOFST + 32 -C -C ON CRAY 64 BIT COMPUTER -C - ELSE - CALL SBYTE (LOC,IHOLD,INOFST,40) - INOFST = INOFST + 40 - END IF -C -C IF ON ASCII COMPUTER, CONVERT LAST 5 CHARACTERS TO EBCDIC -C - IF (.NOT.IBM370) CALL W3AI39(LOC(41:41),5) - ELSE - CALL SBYTE (LOC,-168430091,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,245,INOFST,8) - INOFST = INOFST + 8 - END IF -C BYTES 46-80 INTEGER ZEROES - DO 4676 I = 1, 8 - CALL SBYTE (LOC,0,INOFST,32) - INOFST = INOFST + 32 - 4676 CONTINUE - CALL SBYTE (LOC,0,INOFST,24) - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi63.f b/external/w3nco/v2.0.6/src/w3fi63.f deleted file mode 100644 index ea17f45c..00000000 --- a/external/w3nco/v2.0.6/src/w3fi63.f +++ /dev/null @@ -1,4062 +0,0 @@ - SUBROUTINE W3FI63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI63 UNPK GRIB FIELD TO GRIB GRID -C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 -C -C ABSTRACT: UNPACK A GRIB (EDITION 1) FIELD TO THE EXACT GRID -C SPECIFIED IN THE GRIB MESSAGE, ISOLATE THE BIT MAP, AND MAKE -C THE VALUES OF THE PRODUCT DESCRIPTON SECTION (PDS) AND THE -C GRID DESCRIPTION SECTION (GDS) AVAILABLE IN RETURN ARRAYS. -C -C WHEN DECODING IS COMPLETED, DATA AT EACH GRID POINT HAS BEEN -C RETURNED IN THE UNITS SPECIFIED IN THE GRIB MANUAL. -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 91-11-12 CAVANAUGH MODIFIED SIZE OF ECMWF GRIDS 5-8 -C 91-12-22 CAVANAUGH CORRECTED PROCESSING OF MERCATOR PROJECTIONS -C IN GRID DEFINITION SECTION (GDS) IN -C ROUTINE FI633 -C 92-08-05 CAVANAUGH CORRECTED MAXIMUM GRID SIZE TO ALLOW FOR -C ONE DEGREE BY ONE DEGREE GLOBAL GRIDS -C 92-08-27 CAVANAUGH CORRECTED TYPO ERROR, ADDED CODE TO COMPARE -C TOTAL BYTE SIZE FROM SECTION 0 WITH SUM OF -C SECTION SIZES. -C 92-10-21 CAVANAUGH CORRECTIONS WERE MADE (IN FI634) TO REDUCE -C PROCESSING TIME FOR INTERNATIONAL GRIDS. -C REMOVED A TYPOGRAPHICAL ERROR IN FI635. -C 93-01-07 CAVANAUGH CORRECTIONS WERE MADE (IN FI635) TO -C FACILITATE USE OF THESE ROUTINES ON A PC. -C A TYPOGRAPHICAL ERROR WAS ALSO CORRECTED -C 93-01-13 CAVANAUGH CORRECTIONS WERE MADE (IN FI632) TO -C PROPERLY HANDLE CONDITION WHEN -C TIME RANGE INDICATOR = 10. -C ADDED U.S.GRID 87. -C 93-02-04 CAVANAUGH ADDED U.S.GRIDS 85 AND 86 -C 93-02-26 CAVANAUGH ADDED GRIDS 2, 3, 37 THRU 44,AND -C GRIDS 55, 56, 90, 91, 92, AND 93 TO -C LIST OF U.S. GRIDS. -C 93-04-07 CAVANAUGH ADDED GRIDS 67 THRU 77 TO -C LIST OF U.S. GRIDS. -C 93-04-20 CAVANAUGH INCREASED MAX SIZE TO ACCOMODATE -C GAUSSIAN GRIDS. -C 93-05-26 CAVANAUGH CORRECTED GRID RANGE SELECTION IN FI634 -C FOR RANGES 67-71 & 75-77 -C 93-06-08 CAVANAUGH CORRECTED FI635 TO ACCEPT GRIB MESSAGES -C WITH SECOND ORDER PACKING. ADDED ROUTINE FI636 -C TO PROCESS MESSAGES WITH SECOND ORDER PACKING. -C 93-09-22 CAVANAUGH MODIFIED TO EXTRACT SUB-CENTER NUMBER FROM -C PDS BYTE 26 -C 93-10-13 CAVANAUGH MODIFIED FI634 TO CORRECT GRID SIZES FOR -C GRIDS 204 AND 208 -C 93-10-14 CAVANAUGH INCREASED SIZE OF KGDS TO INCLUDE ENTRIES FOR -C NUMBER OF POINTS IN GRID AND NUMBER OF WORDS -C IN EACH ROW -C 93-12-08 CAVANAUGH CORRECTED TEST FOR EDITION NUMBER INSTEAD -C OF VERSION NUMBER -C 93-12-15 CAVANAUGH MODIFIED SECOND ORDER POINTERS TO FIRST ORDER -C VALUES AND SECOND ORDER VALUES CORRECTLY -C IN ROUTINE FI636 -C 94-03-02 CAVANAUGH ADDED CALL TO W3FI83 WITHIN DECODER. USER -C NO LONGER NEEDS TO MAKE CALL TO THIS ROUTINE -C 94-04-22 CAVANAUGH MODIFIED FI635, FI636 TO PROCESS ROW BY ROW -C SECOND ORDER PACKING, ADDED SCALING CORRECTION -C TO FI635, AND CORRECTED TYPOGRAPHICAL ERRORS -C IN COMMENT FIELDS IN FI634 -C 94-05-17 CAVANAUGH CORRECTED ERROR IN FI633 TO EXTRACT RESOLUTION -C FOR LAMBERT-CONFORMAL GRIDS. ADDED CLARIFYING -C INFORMATION TO DOCBLOCK ENTRIES -C 94-05-25 CAVANAUGH ADDED CODE TO PROCESS COLUMN BY COLUMN AS WELL -C AS ROW BY ROW ORDERING OF SECOND ORDER DATA -C 94-06-27 CAVANAUGH ADDED PROCESSING FOR GRIDS 45, 94 AND 95. -C INCLUDES CONSTRUCTION OF SECOND ORDER BIT MAPS -C FOR THINNED GRIDS IN FI636. -C 94-07-08 CAVANAUGH COMMENTED OUT PRINT OUTS USED FOR DEBUGGING -C 94-09-08 CAVANAUGH ADDED GRIDS 220, 221, 223 FOR FNOC -C 94-11-10 FARLEY INCREASED MXSIZE FROM 72960 TO 260000 -C FOR .5 DEGREE SST ANALYSIS FIELDS -C 94-12-06 R.E.JONES CHANGES IN FI632 FOR PDS GREATER THAN 28 -C 95-02-14 R.E.JONES CORRECT IN FI633 FOR NAVY WAFS GRIB -C 95-03-20 M.BALDWIN FI633 MODIFICATION TO GET -C DATA REP TYPES [KGDS(1)] 201 AND 202 TO WORK. -C 95-04-10 E.ROGERS ADDED GRIDS 96 AND 97 FOR ETA MODEL IN FI634. -C 95-04-26 R.E.JONES FI636 CORECTION FOR 2ND ORDER COMPLEX -C UNPACKING. R -C 95-05-19 R.E.JONES ADDED GRID 215, 20 KM AWIPS GRID -C 95-07-06 R.E.JONES ADDED GAUSSIAN T62, T126 GRID 98, 126 -C 95-10-19 R.E.JONES ADDED GRID 216, 45 KM ETA AWIPS ALASKA GRID -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 96-03-07 R.E.JONES CONTINUE UNPACK WITH KRET ERROR 9 IN FI631. -C 96-08-19 R.E.JONES ADDED MERCATOR GRIDS 8 AND 53, AND GRID 196 -C 97-02-12 W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING -C 98-06-17 IREDELL REMOVED ALTERNATE RETURN IN FI637 -C 98-08-31 IREDELL ELIMINATED NEED FOR MXSIZE -C 98-09-02 Gilbert Corrected error in map size for U.S. Grid 92 -C 98-09-08 BALDWIN ADD DATA REP TYPE [KGDS(1)] 203 -C 01-03-08 ROGERS CHANGED ETA GRIDS 90-97, ADDED ETA GRIDS -C 194, 198. ADDED AWIPS GRIDS 241,242,243, -C 245, 246, 247, 248, AND 250 -C 01-03-19 VUONG ADDED AWIPS GRIDS 238,239,240, AND 244 -C 2001-06-06 GILBERT Changed gbyte/sbyte calls to refer to -C Wesley Ebisuzaki's endian independent -C versions gbytec/sbytec. -C Removed equivalences. -C 01-05-03 ROGERS ADDED GRID 249 (12KM FOR ALASKA) -C 01-10-10 ROGERS REDEFINED GRID 218 FOR 12 KM ETA -C REDEFINED GRID 192 FOR NEW 32-KM ETA GRID -C 02-03-27 VUONG ADDED RSAS GRID 88 AND AWIPS GRIDS 219, 220, -C 223, 224, 225, 226, 227, 228, 229, 230, 231, -C 232, 233, 234, 235, 251, AND 252 -C 02-08-06 ROGERS REDEFINED GRIDS 90-93,97,194,245-250 FOR THE -C 8KM HI-RES-WINDOW MODEL AND ADD AWIPS GRID 253 -C 2003-06-30 GILBERT SET NEW VALUES IN ARRAY KPTR TO PASS BACK ADDITIONAL -C PACKING INFO. -C KPTR(19) - BINARY SCALE FACTOR -C KPTR(20) - NUM BITS USED TO PACK EACH DATUM -C 2003-06-30 GILBERT ADDED GRIDS 145 and 146 for CMAQ -C and GRID 175 for AWIPS over GUAM. -C 2003-07-08 VUONG ADDED GRIDS 110, 127, 171, 172 AND MODIFIED GRID 170 -C 2004-09-02 VUONG ADDED AWIPS GRIDS 147, 148, 173 AND 254 -C 2005-01-04 COOKE ADDED AWIPS GRIDS 160 AND 161 -C 2005-03-03 VUONG MOVED GRID 170 TO GRID 174 AND ADD GRID 170 -C 2005-03-21 VUONG ADDED AWIPS GRID 130 -C 2005-10-11 VUONG ADDED AWIPS GRID 163 -C 2006-12-12 VUONG ADDED AWIPS GRID 120 -C 2007-04-12 VUONG ADDED AWIPS 176 AND DATA REP TYPE KGDS(1) 204 -C 2007-06-11 VUONG ADDED NEW GRIDS 11 TO 18 AND 122 TO 125 AND 138 -C AND 180 TO 183 -C 2007-11-06 VUONG CHANGED GRID 198 FROM ARAKAWA STAGGERED E-GRID TO POLAR -C STEREOGRAPGIC GRID ADDED NEW GRID 10, 99, 150, 151, 197 -C 2008-01-17 VUONG ADDED NEW GRID 195 AND CHANGED GRID 196 (ARAKAWA-E TO MERCATOR) -C 2009-05-21 VUONG MODIFIED TO HANDLE GRID 45 -C 2010-05-11 VUONG DATA REP TYPE KGDS(1) 205 -C 2010-02-18 VUONG ADDED GRID 128, 139 AND 140 -C 2010-07-20 GAYNO ADDED ROTATED LAT/LON "A,B,C,D" STAGGERS -> KGDS(1) 205 -C 2010-08-05 VUONG ADDED NEW GRID 184, 199, 83 AND -C REDEFINED GRID 90 FOR NEW RTMA CONUS 1.27-KM -C REDEFINED GRID 91 FOR NEW RTMA ALASKA 2.976-KM -C REDEFINED GRID 92 FOR NEW RTMA ALASKA 1.488-KM -C 2010-09-08 ROGERS CHANGED GRID 94 TO ALASKA 6KM STAGGERED B-GRID -C CHANGED GRID 95 TO PUERTO RICO 3KM STAGGERED B-GRID -C CHANGED GRID 96 TO HAWAII 3KM STAGGERED B-GRID -C CHANGED GRID 96 TO HAWAII 3KM STAGGERED B-GRID -C CHANGED GRID 97 TO CONUS 4KM STAGGERED B-GRID -C CHANGED GRID 99 TO NAM 12KM STAGGERED B-GRID -C ADDED GRID 179 (12 KM POLAR STEREOGRAPHIC OVER NORTH AMERICA) -C CHANGED GRID 194 TO 3KM MERCATOR GRID OVER PUERTO RICO -C CORRECTED LATITUDE OF SW CORNER POINT OF GRID 151 -C 2011-10-12 VUONG ADDED GRID 129, 187, 188, 189 AND 193 -C 2012-04-16 VUONG ADDED NEW GRID 132, 200 -C -C USAGE: CALL W3FI63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET) -C INPUT ARGUMENT LIST: -C MSGA - GRIB FIELD - "GRIB" THRU "7777" CHAR*1 -C (MESSAGE CAN BE PRECEDED BY JUNK CHARS) -C -C OUTPUT ARGUMENT LIST: -C DATA - ARRAY CONTAINING DATA ELEMENTS -C KPDS - ARRAY CONTAINING PDS ELEMENTS. (EDITION 1) -C (1) - ID OF CENTER -C (2) - GENERATING PROCESS ID NUMBER -C (3) - GRID DEFINITION -C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR INCLUDING (CENTURY-1) -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - VERSION NR OF GRIB SPECIFICATION -C (19) - VERSION NR OF PARAMETER TABLE -C (20) - NR MISSING FROM AVERAGE/ACCUMULATION -C (21) - CENTURY OF REFERENCE TIME OF DATA -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER NUMBER -C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS -C 128 IF FORECAST FIELD ERROR -C 64 IF BIAS CORRECTED FCST FIELD -C 32 IF SMOOTHED FIELD -C WARNING: CAN BE COMBINATION OF MORE THAN 1 -C (25) - PDS BYTE 30, NOT USED -C (26-35) - RESERVED -C (36-N) - CONSECUTIVE BYTES EXTRACTED FROM PROGRAM -C DEFINITION SECTION (PDS) OF GRIB MESSAGE -C KGDS - ARRAY CONTAINING GDS ELEMENTS. -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C GAUSSIAN GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - N - NR OF CIRCLES POLE TO EQUATOR -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - NV - NR OF VERT COORD PARAMETERS -C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS -C OR -C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN -C EACH ROW (IF NO VERT COORD PARAMETERS -C ARE PRESENT -C OR -C 255 IF NEITHER ARE PRESENT -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C E-STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (TYPE 203) -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF CENTER -C (8) - LO(2) LONGITUDE OF CENTER -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C CURVILINEAR ORTHIGINAL GRID (TYPE 204) -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - RESERVED SET TO 0 -C (5) - RESERVED SET TO 0 -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - RESERVED SET TO 0 -C (8) - RESERVED SET TO 0 -C (9) - RESERVED SET TO 0 -C (10) - RESERVED SET TO 0 -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C ROTATED LAT/LON A,B,C,D-STAGGERED (TYPE 205) -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF FIRST POINT -C (5) - LO(1) LONGITUDE OF FIRST POINT -C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) -C (7) - LA(2) LATITUDE OF CENTER -C (8) - LO(2) LONGITUDE OF CENTER -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) -C (12) - LATITUDE OF LAST POINT -C (13) - LONGITUDE OF LAST POINT -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C (ALWAYS CONSTRUCTED) -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - TOTAL LENGTH OF GRIB MESSAGE -C (2) - LENGTH OF INDICATOR (SECTION 0) -C (3) - LENGTH OF PDS (SECTION 1) -C (4) - LENGTH OF GDS (SECTION 2) -C (5) - LENGTH OF BMS (SECTION 3) -C (6) - LENGTH OF BDS (SECTION 4) -C (7) - VALUE OF CURRENT BYTE -C (8) - BIT POINTER -C (9) - GRIB START BIT NR -C (10) - GRIB/GRID ELEMENT COUNT -C (11) - NR UNUSED BITS AT END OF SECTION 3 -C (12) - BIT MAP FLAG (COPY OF BMS OCTETS 5,6) -C (13) - NR UNUSED BITS AT END OF SECTION 2 -C (14) - BDS FLAGS (RIGHT ADJ COPY OF OCTET 4) -C (15) - NR UNUSED BITS AT END OF SECTION 4 -C (16) - RESERVED -C (17) - RESERVED -C (18) - RESERVED -C (19) - BINARY SCALE FACTOR -C (20) - NUM BITS USED TO PACK EACH DATUM -C KRET - FLAG INDICATING QUALITY OF COMPLETION -C -C REMARKS: WHEN DECODING IS COMPLETED, DATA AT EACH GRID POINT HAS BEEN -C RETURNED IN THE UNITS SPECIFIED IN THE GRIB MANUAL. -C -C VALUES FOR RETURN FLAG (KRET) -C KRET = 0 - NORMAL RETURN, NO ERRORS -C = 1 - 'GRIB' NOT FOUND IN FIRST 100 CHARS -C = 2 - '7777' NOT IN CORRECT LOCATION -C = 3 - UNPACKED FIELD IS LARGER THAN 260000 -C = 4 - GDS/ GRID NOT ONE OF CURRENTLY ACCEPTED VALUES -C = 5 - GRID NOT CURRENTLY AVAIL FOR CENTER INDICATED -C = 8 - TEMP GDS INDICATED, BUT GDS FLAG IS OFF -C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID -C =10 - INCORRECT CENTER INDICATOR -C =11 - BINARY DATA SECTION (BDS) NOT COMPLETELY PROCESSED. -C PROGRAM IS NOT SET TO PROCESS FLAG COMBINATIONS -C SHOWN IN OCTETS 4 AND 14. -C =12 - BINARY DATA SECTION (BDS) NOT COMPLETELY PROCESSED. -C PROGRAM IS NOT SET TO PROCESS FLAG COMBINATIONS -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -C 4 AUG 1988 -C W3FI63 -C -C -C GRIB UNPACKING ROUTINE -C -C -C THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID -C TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE -C VALUES OF THE PRODUCT DEFINITION SEC (PDS) AND THE GRID -C DESCRIPTION SEC (GDS) AVAILABLE IN RETURN ARRAYS. -C SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT -C INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN -C GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE -C DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER. -C -C THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS: -C -C CALL W3FI63(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET) -C -C INPUT: -C -C MSGA = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS -C "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES. -C -C OUTPUT: -C -C KPDS(100) INTEGER*4 -C ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT -C DEFINITION SEC . -C (VERSION 1) -C KPDS(1) - ID OF CENTER -C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1) -C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2) -C KPDS(4) - GDS/BMS FLAG -C BIT DEFINITION -C 25 0 - GDS OMITTED -C 1 - GDS INCLUDED -C 26 0 - BMS OMITTED -C 1 - BMS INCLUDED -C NOTE:- LEFTMOST BIT = 1, -C RIGHTMOST BIT = 32 -C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5) -C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7) -C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL -C KPDS(8) - YEAR INCLUDING CENTURY -C KPDS(9) - MONTH OF YEAR -C KPDS(10) - DAY OF MONTH -C KPDS(11) - HOUR OF DAY -C KPDS(12) - MINUTE OF HOUR -C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB" -C TABLE 8) -C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A) -C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A) -C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A) -C KPDS(17) - NUMBER INCLUDED IN AVERAGE -C KPDS(18) - EDITION NR OF GRIB SPECIFICATION -C KPDS(19) - VERSION NR OF PARAMETER TABLE -C -C KGDS(13) INTEGER*4 -C ARRAY CONTAINING GDS ELEMENTS. -C -C KGDS(1) - DATA REPRESENTATION TYPE -C -C LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10) -C KGDS(2) - N(I) NUMBER OF POINTS ON LATITUDE -C CIRCLE -C KGDS(3) - N(J) NUMBER OF POINTS ON LONGITUDE -C CIRCLE -C KGDS(4) - LA(1) LATITUDE OF ORIGIN -C KGDS(5) - LO(1) LONGITUDE OF ORIGIN -C KGDS(6) - RESOLUTION FLAG -C BIT MEANING -C 25 0 - DIRECTION INCREMENTS NOT -C GIVEN -C 1 - DIRECTION INCREMENTS GIVEN -C KGDS(7) - LA(2) LATITUDE OF EXTREME POINT -C KGDS(8) - LO(2) LONGITUDE OF EXTREME POINT -C KGDS(9) - DI LONGITUDINAL DIRECTION INCREMENT -C KGDS(10) - REGULAR LAT/LON GRID -C DJ - LATITUDINAL DIRECTION -C INCREMENT -C GAUSSIAN GRID -C N - NUMBER OF LATITUDE CIRCLES -C BETWEEN A POLE AND THE EQUATOR -C KGDS(11) - SCANNING MODE FLAG -C BIT MEANING -C 25 0 - POINTS ALONG A LATITUDE -C SCAN FROM WEST TO EAST -C 1 - POINTS ALONG A LATITUDE -C SCAN FROM EAST TO WEST -C 26 0 - POINTS ALONG A MERIDIAN -C SCAN FROM NORTH TO SOUTH -C 1 - POINTS ALONG A MERIDIAN -C SCAN FROM SOUTH TO NORTH -C 27 0 - POINTS SCAN FIRST ALONG -C CIRCLES OF LATITUDE, THEN -C ALONG MERIDIANS -C (FORTRAN: (I,J)) -C 1 - POINTS SCAN FIRST ALONG -C MERIDIANS THEN ALONG -C CIRCLES OF LATITUDE -C (FORTRAN: (J,I)) -C -C POLAR STEREOGRAPHIC GRIDS (SEE GRIB TABLE 12) -C KGDS(2) - N(I) NR POINTS ALONG LAT CIRCLE -C KGDS(3) - N(J) NR POINTS ALONG LON CIRCLE -C KGDS(4) - LA(1) LATITUDE OF ORIGIN -C KGDS(5) - LO(1) LONGITUDE OF ORIGIN -C KGDS(6) - RESERVED -C KGDS(7) - LOV GRID ORIENTATION -C KGDS(8) - DX - X DIRECTION INCREMENT -C KGDS(9) - DY - Y DIRECTION INCREMENT -C KGDS(10) - PROJECTION CENTER FLAG -C KGDS(11) - SCANNING MODE -C -C SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14) -C KGDS(2) - J PENTAGONAL RESOLUTION PARAMETER -C KGDS(3) - K PENTAGONAL RESOLUTION PARAMETER -C KGDS(4) - M PENTAGONAL RESOLUTION PARAMETER -C KGDS(5) - REPRESENTATION TYPE -C KGDS(6) - COEFFICIENT STORAGE MODE -C -C MERCATOR GRIDS -C KGDS(2) - N(I) NR POINTS ON LATITUDE CIRCLE -C KGDS(3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C KGDS(4) - LA(1) LATITUDE OF ORIGIN -C KGDS(5) - LO(1) LONGITUDE OF ORIGIN -C KGDS(6) - RESOLUTION FLAG -C KGDS(7) - LA(2) LATITUDE OF LAST GRID POINT -C KGDS(8) - LO(2) LONGITUDE OF LAST GRID POINT -C KGDS(9) - LATIN - LATITUDE OF PROJECTION INTERSECTION -C KGDS(10) - RESERVED -C KGDS(11) - SCANNING MODE FLAG -C KGDS(12) - LONGITUDINAL DIR GRID LENGTH -C KGDS(13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C KGDS(2) - NX NR POINTS ALONG X-AXIS -C KGDS(3) - NY NR POINTS ALONG Y-AXIS -C KGDS(4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C KGDS(5) - LO1 LON OF ORIGIN (LOWER LEFT) -C KGDS(6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C KGDS(7) - LOV - ORIENTATION OF GRID -C KGDS(8) - DX - X-DIR INCREMENT -C KGDS(9) - DY - Y-DIR INCREMENT -C KGDS(10) - PROJECTION CENTER FLAG -C KGDS(11) - SCANNING MODE FLAG -C KGDS(12) - LATIN 1 - FIRST LAT FROM POLE OF -C SECANT CONE INTERSECTION -C KGDS(13) - LATIN 2 - SECOND LAT FROM POLE OF -C SECANT CONE INTERSECTION -C -C LBMS(*) LOGICAL -C ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE -C PLACEMENT OF DATA IN THE OUTPUT ARRAY. IF A -C BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE, -C ONE WILL BE GENERATED AUTOMATICALLY BY THE -C UNPACKING ROUTINE. -C -C -C DATA(*) REAL*4 -C THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS. -C -C NOTE:- 65160 IS MAXIMUN FIELD SIZE ALLOWABLE -C -C KPTR(10) INTEGER*4 -C ARRAY CONTAINING STORAGE FOR THE FOLLOWING -C PARAMETERS. -C -C (1) - UNUSED -C (2) - UNUSED -C (3) - LENGTH OF PDS (IN BYTES) -C (4) - LENGTH OF GDS (IN BYTES) -C (5) - LENGTH OF BMS (IN BYTES) -C (6) - LENGTH OF BDS (IN BYTES) -C (7) - USED BY UNPACKING ROUTINE -C (8) - NUMBER OF DATA POINTS FOR GRID -C (9) - "GRIB" CHARACTERS START IN BYTE NUMBER -C (10) - USED BY UNPACKING ROUTINE -C -C -C KRET INTEGER*4 -C THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR. -C -C 0 - NO ERRORS DETECTED. -C -C 1 - 'GRIB' NOT FOUND IN FIRST 100 -C CHARACTERS. -C -C 2 - '7777' NOT FOUND, EITHER MISSING OR -C TOTAL OF SEC COUNTS OF INDIVIDUAL -C SECTIONS IS INCORRECT. -C -C 3 - UNPACKED FIELD IS LARGER THAN 65160. -C -C 4 - IN GDS, DATA REPRESENTATION TYPE -C NOT ONE OF THE CURRENTLY ACCEPTABLE -C VALUES. SEE "GRIB" TABLE 9. VALUE -C OF INCORRECT TYPE RETURNED IN KGDS(1). -C -C 5 - GRID INDICATED IN KPDS(3) IS NOT -C AVAILABLE FOR THE CENTER INDICATED IN -C KPDS(1) AND NO GDS SENT. -C -C 7 - EDITION INDICATED IN KPDS(18) HAS NOT -C YET BEEN INCLUDED IN THE DECODER. -C -C 8 - GRID IDENTIFICATION = 255 (NOT STANDARD -C GRID) BUT FLAG INDICATING PRESENCE OF -C GDS IS TURNED OFF. NO METHOD OF -C GENERATING PROPER GRID. -C -C 9 - PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT -C MATCH STANDARD NUMBER OF POINTS FOR THIS -C GRID (FOR OTHER THAN SPECTRALS). THIS -C WILL OCCUR ONLY IF THE GRID. -C IDENTIFICATION, KPDS(3), AND A -C TRANSMITTED GDS ARE INCONSISTENT. -C -C 10 - CENTER INDICATOR WAS NOT ONE INDICATED -C IN "GRIB" TABLE 1. PLEASE CONTACT AD -C PRODUCTION MANAGEMENT BRANCH (W/NMC42) -C IF THIS ERROR IS ENCOUNTERED. -C -C 11 - BINARY DATA SECTION (BDS) NOT COMPLETELY -C PROCESSED. PROGRAM IS NOT SET TO PROCESS -C FLAG COMBINATIONS AS SHOWN IN -C OCTETS 4 AND 14. -C -C -C LIST OF TEXT MESSAGES FROM CODE -C -C -C W3FI63/FI632 -C -C 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY -C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH -C (W/NMC42)' -C -C 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY -C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH -C (W/NMC42)' -C -C 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL -C OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION, -C PRODUCTION MANAGEMENT BRANCH (W/NMC42)' -C -C 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY -C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH -C (W/NMC42)' -C -C -C W3FI63/FI633 -C -C 'POLAR STEREO PROCESSING NOT AVAILABLE' * -C -C W3FI63/FI634 -C -C 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL -C COEFFICIENTS' -C -C -C W3FI63/FI637 -C -C 'NO CURRENT LISTING OF FNOC GRIDS' * -C -C -C * WILL BE AVAILABLE IN NEXT UPDATE -C *************************************************************** -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C BIT MAP - LOGICAL*1 KBMS(*) -C -C ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS) - INTEGER KPDS(*) -C ELEMENTS OF GRID DESCRIPTION SEC (PDS) - INTEGER KGDS(*) -C -C CONTAINER FOR GRIB GRID - REAL DATA(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C -C ***************************************************************** - INTEGER JSGN,JEXP,IFR,NPTS - REAL REALKK,FVAL1,FDIFF1 -C ***************************************************************** -C 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE -C FIND 'GRIB' CHARACTERS -C 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE -C IF '7777' IS IN PROPER PLACE. -C 3.0 PARSE PRODUCT DEFINITION SECTION. -C 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED) -C 5.0 PARSE BIT MAP SEC (IF INCLUDED) -C 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID -C DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT -C DATA AND PLACE INTO PROPER ARRAY. -C ******************************************************************* -C -C MAIN DRIVER -C -C ******************************************************************* - KPTR(10) = 0 -C SEE IF PROPER 'GRIB' KEY EXISTS, THEN -C USING SEC COUNTS, DETERMINE IF '7777' -C IS IN THE PROPER LOCATION -C - CALL FI631(MSGA,KPTR,KPDS,KRET) - IF(KRET.NE.0) THEN - GO TO 900 - END IF -C PRINT *,'FI631 KPTR',(KPTR(I),I=1,16) -C -C PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION -C - CALL FI632(MSGA,KPTR,KPDS,KRET) - IF(KRET.NE.0) THEN - GO TO 900 - END IF -C PRINT *,'FI632 KPTR',(KPTR(I),I=1,16) -C -C IF AVAILABLE, EXTRACT NEW GRID DESCRIPTION -C - IF (IAND(KPDS(4),128).NE.0) THEN - CALL FI633(MSGA,KPTR,KGDS,KRET) - IF(KRET.NE.0) THEN - GO TO 900 - END IF -C PRINT *,'FI633 KPTR',(KPTR(I),I=1,16) - END IF -C -C EXTRACT OR GENERATE BIT MAP -C - CALL FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) - IF (KRET.NE.0) THEN - IF (KRET.NE.9) THEN - GO TO 900 - END IF - END IF -C PRINT *,'FI634 KPTR',(KPTR(I),I=1,16) -C -C USING INFORMATION FROM PDS, BMS AND BIT DATA SEC , -C EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES. -C - IF (KPDS(18).EQ.1) THEN - CALL FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET) - IF (KPTR(3).EQ.50) THEN -C -C PDS EQUAL 50 BYTES -C THEREFORE SOMETHING SPECIAL IS GOING ON -C -C IN THIS CASE 2ND DIFFERENCE PACKING -C NEEDS TO BE UNDONE. -C -C EXTRACT FIRST VALUE FROM BYTE 41-44 PDS -C KPTR(9) CONTAINS OFFSET TO START OF -C GRIB MESSAGE. -C EXTRACT FIRST FIRST-DIFFERENCE FROM BYTES 45-48 PDS -C -C AND EXTRACT SCALE FACTOR (E) TO UNDO 2**E -C THAT WAS APPLIED PRIOR TO 2ND ORDER PACKING -C AND PLACED IN PDS BYTES 49-51 -C FACTOR IS A SIGNED TWO BYTE INTEGER -C -C ALSO NEED THE DECIMAL SCALING FROM PDS(27-28) -C (AVAILABLE IN KPDS(22) FROM UNPACKER) -C TO UNDO THE DECIMAL SCALING APPLIED TO THE -C SECOND DIFFERENCES DURING UNPACKING. -C SECOND DIFFS ALWAYS PACKED WITH 0 DECIMAL SCALE -C BUT UNPACKER DOESNT KNOW THAT. -C -C CALL GBYTE (MSGA,FVAL1,KPTR(9)+384,32) -C -C NOTE INTEGERS, CHARACTERS AND EQUIVALENCES -C DEFINED ABOVE TO MAKE THIS KKK EXTRACTION -C WORK AND LINE UP ON WORD BOUNDARIES -C -C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT -C TO THE FLOATING POINT USED ON YOUR MACHINE. -C - call gbytec(MSGA,JSGN,KPTR(9)+384,1) - call gbytec(MSGA,JEXP,KPTR(9)+385,7) - call gbytec(MSGA,IFR,KPTR(9)+392,24) -C - IF (IFR.EQ.0) THEN - REALKK = 0.0 - ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN - REALKK = 0.0 - ELSE - REALKK = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) - IF (JSGN.NE.0) REALKK = -REALKK - END IF - FVAL1 = REALKK -C -C CALL GBYTE (MSGA,FDIFF1,KPTR(9)+416,32) -C (REPLACED BY FOLLOWING EXTRACTION) -C -C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT -C TO THE FLOATING POINT USED ON YOUR MACHINE. -C - call gbytec(MSGA,JSGN,KPTR(9)+416,1) - call gbytec(MSGA,JEXP,KPTR(9)+417,7) - call gbytec(MSGA,IFR,KPTR(9)+424,24) -C - IF (IFR.EQ.0) THEN - REALKK = 0.0 - ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN - REALKK = 0.0 - ELSE - REALKK = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) - IF (JSGN.NE.0) REALKK = -REALKK - END IF - FDIFF1 = REALKK -C - CALL GBYTEC (MSGA,ISIGN,KPTR(9)+448,1) - CALL GBYTEC (MSGA,ISCAL2,KPTR(9)+449,15) - IF(ISIGN.GT.0) THEN - ISCAL2 = - ISCAL2 - ENDIF -C PRINT *,'DELTA POINT 1-',FVAL1 -C PRINT *,'DELTA POINT 2-',FDIFF1 -C PRINT *,'DELTA POINT 3-',ISCAL2 - NPTS = KPTR(10) -C WRITE (6,FMT='('' 2ND DIFF POINTS IN FIELD = '',/, -C & 10(3X,10F12.2,/))') (DATA(I),I=1,NPTS) -C PRINT *,'DELTA POINT 4-',KPDS(22) - CALL W3FI83 (DATA,NPTS,FVAL1,FDIFF1, - & ISCAL2,KPDS(22),KPDS,KGDS) -C WRITE (6,FMT='('' 2ND DIFF EXPANDED POINTS IN FIELD = '', -C & /,10(3X,10F12.2,/))') (DATA(I),I=1,NPTS) -C WRITE (6,FMT='('' END OF ARRAY IN FIELD = '',/, -C & 10(3X,10F12.2,/))') (DATA(I),I=NPTS-5,NPTS) - END IF - ELSE -C PRINT *,'FI635 NOT PROGRAMMED FOR EDITION NR',KPDS(18) - KRET = 7 - END IF -C - 900 RETURN - END - SUBROUTINE FI631(MSGA,KPTR,KPDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI631 FIND 'GRIB' CHARS & RESET POINTERS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 -C -C ABSTRACT: FIND 'GRIB; CHARACTERS AND SET POINTERS TO THE NEXT -C BYTE FOLLOWING 'GRIB'. IF THEY EXIST EXTRACT COUNTS FROM GDS AND -C BMS. EXTRACT COUNT FROM BDS. DETERMINE IF SUM OF COUNTS ACTUALLY -C PLACES TERMINATOR '7777' AT THE CORRECT LOCATION. -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI631(MSGA,KPTR,KPDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - GRIB FIELD - "GRIB" THRU "7777" -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - TOTAL LENGTH OF GRIB MESSAGE -C (2) - LENGTH OF INDICATOR (SECTION 0) -C (3) - LENGTH OF PDS (SECTION 1) -C (4) - LENGTH OF GDS (SECTION 2) -C (5) - LENGTH OF BMS (SECTION 3) -C (6) - LENGTH OF BDS (SECTION 4) -C (7) - VALUE OF CURRENT BYTE -C (8) - BIT POINTER -C (9) - GRIB START BIT NR -C (10) - GRIB/GRID ELEMENT COUNT -C (11) - NR UNUSED BITS AT END OF SECTION 3 -C (12) - BIT MAP FLAG -C (13) - NR UNUSED BITS AT END OF SECTION 2 -C (14) - BDS FLAGS -C (15) - NR UNUSED BITS AT END OF SECTION 4 -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C KPTR - SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C ERROR RETURNS -C KRET = 1 - NO 'GRIB' -C 2 - NO '7777' OR MISLOCATED (BY COUNTS) -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS9000 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C PRODUCT DESCRIPTION SECTION DATA. - INTEGER KPDS(*) -C - INTEGER KRET -C -C ****************************************************************** - KRET = 0 -C ------------------- FIND 'GRIB' KEY - DO 50 I = 0, 839, 8 - CALL GBYTEC (MSGA,MGRIB,I,32) - IF (MGRIB.EQ.1196575042) THEN - KPTR(9) = I - GO TO 60 - END IF - 50 CONTINUE - KRET = 1 - RETURN - 60 CONTINUE -C -------------FOUND 'GRIB' -C SKIP GRIB CHARACTERS -C PRINT *,'FI631 GRIB AT',I - KPTR(8) = KPTR(9) + 32 - CALL GBYTEC (MSGA,ITOTAL,KPTR(8),24) -C HAVE LIFTED WHAT MAY BE A MSG TOTAL BYTE COUNT - IPOINT = KPTR(9) + ITOTAL * 8 - 32 - CALL GBYTEC (MSGA,I7777,IPOINT,32) - IF (I7777.EQ.926365495) THEN -C HAVE FOUND END OF MESSAGE '7777' IN PROPER LOCATION -C MARK AND PROCESS AS GRIB VERSION 1 OR HIGHER -C PRINT *,'FI631 7777 AT',IPOINT - KPTR(8) = KPTR(8) + 24 - KPTR(1) = ITOTAL - KPTR(2) = 8 - CALL GBYTEC (MSGA,KPDS(18),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 - ELSE -C CANNOT FIND END OF GRIB EDITION 1 MESSAGE - KRET = 2 - RETURN - END IF -C ------------------- PROCESS SECTION 1 -C EXTRACT COUNT FROM PDS -C PRINT *,'START OF PDS',KPTR(8) - CALL GBYTEC (MSGA,KPTR(3),KPTR(8),24) - LOOK = KPTR(8) + 56 -C EXTRACT GDS/BMS FLAG - CALL GBYTEC (MSGA,KPDS(4),LOOK,8) - KPTR(8) = KPTR(8) + KPTR(3) * 8 -C PRINT *,'START OF GDS',KPTR(8) - IF (IAND(KPDS(4),128).NE.0) THEN -C EXTRACT COUNT FROM GDS - CALL GBYTEC (MSGA,KPTR(4),KPTR(8),24) - KPTR(8) = KPTR(8) + KPTR(4) * 8 - ELSE - KPTR(4) = 0 - END IF -C PRINT *,'START OF BMS',KPTR(8) - IF (IAND(KPDS(4),64).NE.0) THEN -C EXTRACT COUNT FROM BMS - CALL GBYTEC (MSGA,KPTR(5),KPTR(8),24) - ELSE - KPTR(5) = 0 - END IF - KPTR(8) = KPTR(8) + KPTR(5) * 8 -C PRINT *,'START OF BDS',KPTR(8) -C EXTRACT COUNT FROM BDS - CALL GBYTEC (MSGA,KPTR(6),KPTR(8),24) -C --------------- TEST FOR '7777' -C PRINT *,(KPTR(KJ),KJ=1,10) - KPTR(8) = KPTR(8) + KPTR(6) * 8 -C EXTRACT FOUR BYTES FROM THIS LOCATION -C PRINT *,'FI631 LOOKING FOR 7777 AT',KPTR(8) - CALL GBYTEC (MSGA,K7777,KPTR(8),32) - MATCH = KPTR(2) + KPTR(3) + KPTR(4) + KPTR(5) + KPTR(6) + 4 - IF (K7777.NE.926365495.OR.MATCH.NE.KPTR(1)) THEN - KRET = 2 - ELSE -C PRINT *,'FI631 7777 AT',KPTR(8) - IF (KPDS(18).EQ.0) THEN - KPTR(1) = KPTR(2) + KPTR(3) + KPTR(4) + KPTR(5) + - * KPTR(6) + 4 - END IF - END IF -C PRINT *,'KPTR',(KPTR(I),I=1,16) - RETURN - END - SUBROUTINE FI632(MSGA,KPTR,KPDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI632 GATHER INFO FROM PRODUCT DEFINITION SEC -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 -C -C ABSTRACT: EXTRACT INFORMATION FROM THE PRODUCT DESCRIPTION -C SEC , AND GENERATE LABEL INFORMATION TO PERMIT STORAGE -C IN OFFICE NOTE 84 FORMAT. -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 93-12-08 CAVANAUGH CORRECTED TEST FOR EDITION NUMBER INSTEAD -C OF VERSION NUMBER -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 99-01-20 BALDWIN MODIFIED TO HANDLE GRID 237 -C -C USAGE: CALL FI632(MSGA,KPTR,KPDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - TOTAL LENGTH OF GRIB MESSAGE -C (2) - LENGTH OF INDICATOR (SECTION 0) -C (3) - LENGTH OF PDS (SECTION 1) -C (4) - LENGTH OF GDS (SECTION 2) -C (5) - LENGTH OF BMS (SECTION 3) -C (6) - LENGTH OF BDS (SECTION 4) -C (7) - VALUE OF CURRENT BYTE -C (8) - BIT POINTER -C (9) - GRIB START BIT NR -C (10) - GRIB/GRID ELEMENT COUNT -C (11) - NR UNUSED BITS AT END OF SECTION 3 -C (12) - BIT MAP FLAG -C (13) - NR UNUSED BITS AT END OF SECTION 2 -C (14) - BDS FLAGS -C (15) - NR UNUSED BITS AT END OF SECTION 4 -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C (18) - -C (19) - -C (20) - NUMBER MISSING FROM AVGS/ACCUMULATIONS -C (21) - CENTURY -C (22) - UNITS DECIMAL SCALE FACTOR -C (23) - SUBCENTER -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C ERROR RETURN = 0 - NO ERRORS -C = 8 - TEMP GDS INDICATED, BUT NO GDS -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS9000 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C PRODUCT DESCRIPTION SECTION ENTRIES - INTEGER KPDS(*) -C - INTEGER KRET - KRET=0 -C ------------------- PROCESS SECTION 1 - KPTR(8) = KPTR(9) + KPTR(2) * 8 + 24 -C BYTE 4 -C PARAMETER TABLE VERSION NR - CALL GBYTEC (MSGA,KPDS(19),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 5 IDENTIFICATION OF CENTER - CALL GBYTEC (MSGA,KPDS(1),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 6 -C GET GENERATING PROCESS ID NR - CALL GBYTEC (MSGA,KPDS(2),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 7 -C GRID DEFINITION - CALL GBYTEC (MSGA,KPDS(3),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 8 -C GDS/BMS FLAGS -C CALL GBYTEC (MSGA,KPDS(4),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 9 -C INDICATOR OF PARAMETER - CALL GBYTEC (MSGA,KPDS(5),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 10 -C TYPE OF LEVEL - CALL GBYTEC (MSGA,KPDS(6),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 11,12 -C HEIGHT/PRESSURE - CALL GBYTEC (MSGA,KPDS(7),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C BYTE 13 -C YEAR OF CENTURY - CALL GBYTEC (MSGA,KPDS(8),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 14 -C MONTH OF YEAR - CALL GBYTEC (MSGA,KPDS(9),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 15 -C DAY OF MONTH - CALL GBYTEC (MSGA,KPDS(10),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 16 -C HOUR OF DAY - CALL GBYTEC (MSGA,KPDS(11),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 17 -C MINUTE - CALL GBYTEC (MSGA,KPDS(12),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 18 -C INDICATOR TIME UNIT RANGE - CALL GBYTEC (MSGA,KPDS(13),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 19 -C P1 - PERIOD OF TIME - CALL GBYTEC (MSGA,KPDS(14),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 20 -C P2 - PERIOD OF TIME - CALL GBYTEC (MSGA,KPDS(15),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 21 -C TIME RANGE INDICATOR - CALL GBYTEC (MSGA,KPDS(16),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C -C IF TIME RANGE INDICATOR IS 10, P1 IS PACKED IN -C PDS BYTES 19-20 -C - IF (KPDS(16).EQ.10) THEN - KPDS(14) = KPDS(14) * 256 + KPDS(15) - KPDS(15) = 0 - END IF -C BYTE 22,23 -C NUMBER INCLUDED IN AVERAGE - CALL GBYTEC (MSGA,KPDS(17),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C BYTE 24 -C NUMBER MISSING FROM AVERAGES/ACCUMULATIONS - CALL GBYTEC (MSGA,KPDS(20),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 25 -C IDENTIFICATION OF CENTURY - CALL GBYTEC (MSGA,KPDS(21),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 - IF (KPTR(3).GT.25) THEN -C BYTE 26 SUB CENTER NUMBER - CALL GBYTEC (MSGA,KPDS(23),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 - IF (KPTR(3).GE.28) THEN -C BYTE 27-28 -C UNITS DECIMAL SCALE FACTOR - CALL GBYTEC (MSGA,ISIGN,KPTR(8),1) - KPTR(8) = KPTR(8) + 1 - CALL GBYTEC (MSGA,IDEC,KPTR(8),15) - KPTR(8) = KPTR(8) + 15 - IF (ISIGN.GT.0) THEN - KPDS(22) = - IDEC - ELSE - KPDS(22) = IDEC - END IF - ISIZ = KPTR(3) - 28 - IF (ISIZ.LE.12) THEN -C BYTE 29 - CALL GBYTEC (MSGA,KPDS(24),KPTR(8)+8,8) -C BYTE 30 - CALL GBYTEC (MSGA,KPDS(25),KPTR(8)+16,8) -C BYTES 31-40 CURRENTLY RESERVED FOR FUTURE USE - KPTR(8) = KPTR(8) + ISIZ * 8 - ELSE -C BYTE 29 - CALL GBYTEC (MSGA,KPDS(24),KPTR(8)+8,8) -C BYTE 30 - CALL GBYTEC (MSGA,KPDS(25),KPTR(8)+16,8) -C BYTES 31-40 CURRENTLY RESERVED FOR FUTURE USE - KPTR(8) = KPTR(8) + 12 * 8 -C BYTES 41 - N LOCAL USE DATA - CALL W3FI01(LW) -C MWDBIT = LW * 8 - MWDBIT = bit_size(KPDS) - ISIZ = KPTR(3) - 40 - ITER = ISIZ / LW - IF (MOD(ISIZ,LW).NE.0) ITER = ITER + 1 - CALL GBYTESC (MSGA,KPDS(36),KPTR(8),MWDBIT,0,ITER) - KPTR(8) = KPTR(8) + ISIZ * 8 - END IF - END IF - END IF -C ----------- TEST FOR NEW GRID - IF (IAND(KPDS(4),128).NE.0) THEN - IF (IAND(KPDS(4),64).NE.0) THEN - IF (KPDS(3).NE.255) THEN - IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN - RETURN - ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44)THEN - RETURN - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - RETURN - END IF - IF (KPDS(1).EQ.7) THEN - IF (KPDS(3).GE.2.AND.KPDS(3).LE.3) THEN - ELSE IF (KPDS(3).GE.5.AND.KPDS(3).LE.6) THEN - ELSE IF (KPDS(3).EQ.8) THEN - ELSE IF (KPDS(3).EQ.10) THEN - ELSE IF (KPDS(3).GE.27.AND.KPDS(3).LE.34) THEN - ELSE IF (KPDS(3).EQ.50) THEN - ELSE IF (KPDS(3).EQ.53) THEN - ELSE IF (KPDS(3).GE.70.AND.KPDS(3).LE.77) THEN - ELSE IF (KPDS(3).EQ.98) THEN - ELSE IF (KPDS(3).EQ.99) THEN - ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LE.105) THEN - ELSE IF (KPDS(3).EQ.126) THEN - ELSE IF (KPDS(3).EQ.195) THEN - ELSE IF (KPDS(3).EQ.196) THEN - ELSE IF (KPDS(3).EQ.197) THEN - ELSE IF (KPDS(3).EQ.198) THEN - ELSE IF (KPDS(3).GE.200.AND.KPDS(3).LE.237) THEN - ELSE -C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', -C * ' NMC WITHOUT A GRID DESCRIPTION SECTION' -C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' -C PRINT *,' PRODUCTION MANAGEMENT BRANCH' -C PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.98) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN - ELSE -C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', -C * ' ECMWF WITHOUT A GRID DESCRIPTION SECTION' -C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' -C PRINT *,' PRODUCTION MANAGEMENT BRANCH' -C PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.74) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - ELSE IF (KPDS(3).GE.70.AND.KPDS(3).LE.77) THEN - ELSE -C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', -C * ' U.K. MET OFFICE, BRACKNELL', -C * ' WITHOUT A GRID DESCRIPTION SECTION' -C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' -C PRINT *,' PRODUCTION MANAGEMENT BRANCH' -C PRINT *,' W/NMC42)' - END IF - ELSE IF (KPDS(1).EQ.58) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - ELSE -C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', -C * ' FNOC WITHOUT A GRID DESCRIPTION SECTION' -C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' -C PRINT *,' PRODUCTION MANAGEMENT BRANCH' -C PRINT *,' W/NMC42)' - END IF - END IF - END IF - END IF - END IF - RETURN - END - SUBROUTINE FI633(MSGA,KPTR,KGDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI633 EXTRACT INFO FROM GRIB-GDS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 -C -C ABSTRACT: EXTRACT INFORMATION ON UNLISTED GRID TO ALLOW -C CONVERSION TO OFFICE NOTE 84 FORMAT. -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 95-03-20 M.BALDWIN FI633 MODIFICATION TO GET -C DATA REP TYPES [KGDS(1)] 201 AND 202 TO WORK. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-09-08 BALDWIN ADD DATA REP TYPE [KGDS(1)] 203 -C 07-04-24 VUONG ADD DATA REP TYPE [KGDS(1)] 204 -C 10-07-20 GAYNO ADD DATA REP TYPE [KGDS(1)] 205 -C -C -C USAGE: CALL FI633(MSGA,KPTR,KGDS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - TOTAL LENGTH OF GRIB MESSAGE -C (2) - LENGTH OF INDICATOR (SECTION 0) -C (3) - LENGTH OF PDS (SECTION 1) -C (4) - LENGTH OF GDS (SECTION 2) -C (5) - LENGTH OF BMS (SECTION 3) -C (6) - LENGTH OF BDS (SECTION 4) -C (7) - VALUE OF CURRENT BYTE -C (8) - BIT POINTER -C (9) - GRIB START BIT NR -C (10) - GRIB/GRID ELEMENT COUNT -C (11) - NR UNUSED BITS AT END OF SECTION 3 -C (12) - BIT MAP FLAG -C (13) - NR UNUSED BITS AT END OF SECTION 2 -C (14) - BDS FLAGS -C (15) - NR UNUSED BITS AT END OF SECTION 4 -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KGDS - ARRAY CONTAINING GDS ELEMENTS. -C (1) - DATA REPRESENTATION TYPE -C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS -C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE -C PARAMETERS -C OR -C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS -C IN EACH ROW -C OR -C 255 IF NEITHER ARE PRESENT -C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID -C (22) - NUMBER OF WORDS IN EACH ROW -C LATITUDE/LONGITUDE GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF EXTREME POINT -C (8) - LO(2) LONGITUDE OF EXTREME POINT -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG -C POLAR STEREOGRAPHIC GRIDS -C (2) - N(I) NR POINTS ALONG LAT CIRCLE -C (3) - N(J) NR POINTS ALONG LON CIRCLE -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESERVED -C (7) - LOV GRID ORIENTATION -C (8) - DX - X DIRECTION INCREMENT -C (9) - DY - Y DIRECTION INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE -C SPHERICAL HARMONIC COEFFICIENTS -C (2) - J PENTAGONAL RESOLUTION PARAMETER -C (3) - K " " " -C (4) - M " " " -C (5) - REPRESENTATION TYPE -C (6) - COEFFICIENT STORAGE MODE -C MERCATOR GRIDS -C (2) - N(I) NR POINTS ON LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF LAST GRID POINT -C (8) - LO(2) LONGITUDE OF LAST GRID POINT -C (9) - LATIN - LATITUDE OF PROJECTION INTERSECTION -C (10) - RESERVED -C (11) - SCANNING MODE FLAG -C (12) - LONGITUDINAL DIR GRID LENGTH -C (13) - LATITUDINAL DIR GRID LENGTH -C LAMBERT CONFORMAL GRIDS -C (2) - NX NR POINTS ALONG X-AXIS -C (3) - NY NR POINTS ALONG Y-AXIS -C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) -C (5) - LO1 LON OF ORIGIN (LOWER LEFT) -C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) -C (7) - LOV - ORIENTATION OF GRID -C (8) - DX - X-DIR INCREMENT -C (9) - DY - Y-DIR INCREMENT -C (10) - PROJECTION CENTER FLAG -C (11) - SCANNING MODE FLAG -C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER -C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER -C STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (203 E STAGGER) -C (2) - N(I) NR POINTS ON ROTATED LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON ROTATED LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF CENTER -C (8) - LO(2) LONGITUDE OF CENTER -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG -C STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (205 A,B,C,D STAGGERS) -C (2) - N(I) NR POINTS ON ROTATED LATITUDE CIRCLE -C (3) - N(J) NR POINTS ON ROTATED LONGITUDE MERIDIAN -C (4) - LA(1) LATITUDE OF ORIGIN -C (5) - LO(1) LONGITUDE OF ORIGIN -C (6) - RESOLUTION FLAG -C (7) - LA(2) LATITUDE OF CENTER -C (8) - LO(2) LONGITUDE OF CENTER -C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT -C (10) - DJ LATITUDINAL DIRECTION INCREMENT -C (11) - SCANNING MODE FLAG -C (12) - LATITUDE OF LAST POINT -C (13) - LONGITUDE OF LAST POINT -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C KRET = 0 -C = 4 - DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS9000 -C -C$$$ -C ************************************************************ -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C ARRAY GDS ELEMENTS - INTEGER KGDS(*) -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C - INTEGER KRET -C --------------------------------------------------------------- - KRET = 0 -C PROCESS GRID DEFINITION SECTION (IF PRESENT) -C MAKE SURE BIT POINTER IS PROPERLY SET - KPTR(8) = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + 24 - NSAVE = KPTR(8) - 24 -C BYTE 4 -C NV - NR OF VERT COORD PARAMETERS - CALL GBYTEC (MSGA,KGDS(19),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 5 -C PV - LOCATION - SEE FM92 MANUAL - CALL GBYTEC (MSGA,KGDS(20),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTE 6 -C DATA REPRESENTATION TYPE - CALL GBYTEC (MSGA,KGDS(1),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTES 7-32 ARE GRID DEFINITION DEPENDING ON -C DATA REPRESENTATION TYPE - IF (KGDS(1).EQ.0) THEN - GO TO 1000 - ELSE IF (KGDS(1).EQ.1) THEN - GO TO 4000 - ELSE IF (KGDS(1).EQ.2.OR.KGDS(1).EQ.5) THEN - GO TO 2000 - ELSE IF (KGDS(1).EQ.3) THEN - GO TO 5000 - ELSE IF (KGDS(1).EQ.4) THEN - GO TO 1000 -C ELSE IF (KGDS(1).EQ.10) THEN -C ELSE IF (KGDS(1).EQ.14) THEN -C ELSE IF (KGDS(1).EQ.20) THEN -C ELSE IF (KGDS(1).EQ.24) THEN -C ELSE IF (KGDS(1).EQ.30) THEN -C ELSE IF (KGDS(1).EQ.34) THEN - ELSE IF (KGDS(1).EQ.50) THEN - GO TO 3000 -C ELSE IF (KGDS(1).EQ.60) THEN -C ELSE IF (KGDS(1).EQ.70) THEN -C ELSE IF (KGDS(1).EQ.80) THEN - ELSE IF (KGDS(1).EQ.201.OR.KGDS(1).EQ.202.OR. - & KGDS(1).EQ.203.OR.KGDS(1).EQ.204.OR.KGDS(1).EQ.205) THEN - GO TO 1000 - ELSE -C MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE - KRET = 4 - RETURN - END IF -C BYTE 33-N VERTICAL COORDINATE PARAMETERS -C ----------- -C BYTES 33-42 EXTENSIONS OF GRID DEFINITION FOR ROTATION -C OR STRETCHING OF THE COORDINATE SYSTEM OR -C LAMBERT CONFORMAL PROJECTION. -C BYTE 43-N VERTICAL COORDINATE PARAMETERS -C ----------- -C BYTES 33-52 EXTENSIONS OF GRID DEFINITION FOR STRETCHED -C AND ROTATED COORDINATE SYSTEM -C BYTE 53-N VERTICAL COORDINATE PARAMETERS -C ----------- -C ************************************************************ -C ------------------- LATITUDE/LONGITUDE GRIDS -C ------------------- ARAKAWA STAGGERED, SEMI-STAGGERED, OR FILLED -C ROTATED LAT/LON GRIDS OR CURVILINEAR ORTHIGINAL GRIDS -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE - 1000 CONTINUE - CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN - CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 11-13 LATITUDE OF ORIGIN - CALL GBYTEC (MSGA,KGDS(4),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = IAND(KGDS(4),8388607) * (-1) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN - CALL GBYTEC (MSGA,KGDS(5),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESOLUTION FLAG - CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 18-20 LATITUDE OF LAST GRID POINT - CALL GBYTEC (MSGA,KGDS(7),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 LONGITUDE OF LAST GRID POINT - CALL GBYTEC (MSGA,KGDS(8),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(8),8388608).NE.0) THEN - KGDS(8) = - IAND(KGDS(8),8388607) - END IF -C ------------------- BYTE 24-25 LATITUDINAL DIR INCREMENT - CALL GBYTEC (MSGA,KGDS(9),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID -C HAVE LONGIT DIR INCREMENT -C ELSE IF GAUSSIAN GRID -C HAVE NR OF LAT CIRCLES -C BETWEEN POLE AND EQUATOR - CALL GBYTEC (MSGA,KGDS(10),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 28 SCANNING MODE FLAGS - CALL GBYTEC (MSGA,KGDS(11),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 - IF(KGDS(1).EQ.205)THEN -C ------------------- BYTE 29-31 LATITUDE OF LAST GRID POINT - CALL GBYTEC (MSGA,KGDS(12),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(12),8388608).NE.0) THEN - KGDS(12) = - IAND(KGDS(12),8388607) - END IF -C ------------------- BYTE 32-34 LONGITUDE OF LAST GRID POINT - CALL GBYTEC (MSGA,KGDS(13),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(13),8388608).NE.0) THEN - KGDS(13) = - IAND(KGDS(13),8388607) - END IF - ELSE - -C ------------------- BYTE 29-32 RESERVED -C SKIP TO START OF BYTE 33 - CALL GBYTEC (MSGA,KGDS(12),KPTR(8),32) - KPTR(8) = KPTR(8) + 32 - ENDIF -C ------------------- - GO TO 900 -C ****************************************************************** -C ' POLAR STEREO PROCESSING ' -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG X=AXIS - 2000 CONTINUE - CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS - CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 11-13 LATITUDE OF ORIGIN - CALL GBYTEC (MSGA,KGDS(4),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = - IAND(KGDS(4),8388607) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN - CALL GBYTEC (MSGA,KGDS(5),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESERVED - CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 18-20 LOV ORIENTATION OF THE GRID - CALL GBYTEC (MSGA,KGDS(7),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 DX - THE X DIRECTION INCREMENT - CALL GBYTEC (MSGA,KGDS(8),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(8),8388608).NE.0) THEN - KGDS(8) = - IAND(KGDS(8),8388607) - END IF -C ------------------- BYTE 24-26 DY - THE Y DIRECTION INCREMENT - CALL GBYTEC (MSGA,KGDS(9),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(9),8388608).NE.0) THEN - KGDS(9) = - IAND(KGDS(9),8388607) - END IF -C ------------------- BYTE 27 PROJECTION CENTER FLAG - CALL GBYTEC (MSGA,KGDS(10),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 28 SCANNING MODE - CALL GBYTEC (MSGA,KGDS(11),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 29-32 RESERVED -C SKIP TO START OF BYTE 33 - CALL GBYTEC (MSGA,KGDS(12),KPTR(8),32) - KPTR(8) = KPTR(8) + 32 -C -C ------------------- - GO TO 900 -C -C ****************************************************************** -C ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF. -C -C ------------------- BYTE 7-8 J PENTAGONAL RESOLUTION PARAMETER - 3000 CONTINUE - CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 9-10 K PENTAGONAL RESOLUTION PARAMETER - CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 11-12 M PENTAGONAL RESOLUTION PARAMETER - CALL GBYTEC (MSGA,KGDS(4),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 13 REPRESENTATION TYPE - CALL GBYTEC (MSGA,KGDS(5),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 14 COEFFICIENT STORAGE MODE - CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- EMPTY FIELDS - BYTES 15 - 32 -C SET TO START OF BYTE 33 - KPTR(8) = KPTR(8) + 18 * 8 - GO TO 900 -C ****************************************************************** -C PROCESS MERCATOR GRIDS -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE - 4000 CONTINUE - CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN - CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 11-13 LATITUE OF ORIGIN - CALL GBYTEC (MSGA,KGDS(4),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = - IAND(KGDS(4),8388607) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN - CALL GBYTEC (MSGA,KGDS(5),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESOLUTION FLAG - CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 18-20 LATITUDE OF EXTREME POINT - CALL GBYTEC (MSGA,KGDS(7),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 LONGITUDE OF EXTREME POINT - CALL GBYTEC (MSGA,KGDS(8),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(8),8388608).NE.0) THEN - KGDS(8) = - IAND(KGDS(8),8388607) - END IF -C ------------------- BYTE 24-26 LATITUDE OF PROJECTION INTERSECTION - CALL GBYTEC (MSGA,KGDS(9),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(9),8388608).NE.0) THEN - KGDS(9) = - IAND(KGDS(9),8388607) - END IF -C ------------------- BYTE 27 RESERVED - CALL GBYTEC (MSGA,KGDS(10),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 28 SCANNING MODE - CALL GBYTEC (MSGA,KGDS(11),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 29-31 LONGITUDINAL DIR INCREMENT - CALL GBYTEC (MSGA,KGDS(12),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(12),8388608).NE.0) THEN - KGDS(12) = - IAND(KGDS(12),8388607) - END IF -C ------------------- BYTE 32-34 LATITUDINAL DIR INCREMENT - CALL GBYTEC (MSGA,KGDS(13),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(13),8388608).NE.0) THEN - KGDS(13) = - IAND(KGDS(13),8388607) - END IF -C ------------------- BYTE 35-42 RESERVED -C SKIP TO START OF BYTE 43 - KPTR(8) = KPTR(8) + 8 * 8 -C ------------------- - GO TO 900 -C ****************************************************************** -C PROCESS LAMBERT CONFORMAL -C -C ------------------- BYTE 7-8 NR OF POINTS ALONG X-AXIS - 5000 CONTINUE - CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS - CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- BYTE 11-13 LATITUDE OF ORIGIN - CALL GBYTEC (MSGA,KGDS(4),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(4),8388608).NE.0) THEN - KGDS(4) = - IAND(KGDS(4),8388607) - END IF -C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN (LOWER LEFT) - CALL GBYTEC (MSGA,KGDS(5),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(5),8388608).NE.0) THEN - KGDS(5) = - IAND(KGDS(5),8388607) - END IF -C ------------------- BYTE 17 RESOLUTION - CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 18-20 LOV -ORIENTATION OF GRID - CALL GBYTEC (MSGA,KGDS(7),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(7),8388608).NE.0) THEN - KGDS(7) = - IAND(KGDS(7),8388607) - END IF -C ------------------- BYTE 21-23 DX - X-DIR INCREMENT - CALL GBYTEC (MSGA,KGDS(8),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 -C ------------------- BYTE 24-26 DY - Y-DIR INCREMENT - CALL GBYTEC (MSGA,KGDS(9),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 -C ------------------- BYTE 27 PROJECTION CENTER FLAG - CALL GBYTEC (MSGA,KGDS(10),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 28 SCANNING MODE - CALL GBYTEC (MSGA,KGDS(11),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ------------------- BYTE 29-31 LATIN1 - 1ST LAT FROM POLE - CALL GBYTEC (MSGA,KGDS(12),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(12),8388608).NE.0) THEN - KGDS(12) = - IAND(KGDS(12),8388607) - END IF -C ------------------- BYTE 32-34 LATIN2 - 2ND LAT FROM POLE - CALL GBYTEC (MSGA,KGDS(13),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(13),8388608).NE.0) THEN - KGDS(13) = - IAND(KGDS(13),8388607) - END IF -C ------------------- BYTE 35-37 LATITUDE OF SOUTHERN POLE - CALL GBYTEC (MSGA,KGDS(14),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(14),8388608).NE.0) THEN - KGDS(14) = - IAND(KGDS(14),8388607) - END IF -C ------------------- BYTE 38-40 LONGITUDE OF SOUTHERN POLE - CALL GBYTEC (MSGA,KGDS(15),KPTR(8),24) - KPTR(8) = KPTR(8) + 24 - IF (IAND(KGDS(15),8388608).NE.0) THEN - KGDS(15) = - IAND(KGDS(15),8388607) - END IF -C ------------------- BYTE 41-42 RESERVED - CALL GBYTEC (MSGA,KGDS(16),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ------------------- - 900 CONTINUE -C -C MORE CODE FOR GRIDS WITH PL -C - IF (KGDS(19).EQ.0.OR.KGDS(19).EQ.255) THEN - IF (KGDS(20).NE.255) THEN - ISUM = 0 - KPTR(8) = NSAVE + (KGDS(20) - 1) * 8 - CALL GBYTESC (MSGA,KGDS(22),KPTR(8),16,0,KGDS(3)) - DO 910 J = 1, KGDS(3) - ISUM = ISUM + KGDS(21+J) - 910 CONTINUE - KGDS(21) = ISUM - END IF - END IF - RETURN - END - SUBROUTINE FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI634 EXTRACT OR GENERATE BIT MAP FOR OUTPUT -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 -C -C ABSTRACT: IF BIT MAP SEC IS AVAILABLE IN GRIB MESSAGE, EXTRACT -C FOR PROGRAM USE, OTHERWISE GENERATE AN APPROPRIATE BIT MAP. -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 91-11-12 CAVANAUGH MODIFIED SIZE OF ECMWF GRIDS 5 - 8. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 97-02-12 W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING -C 97-09-19 IREDELL VECTORIZED BITMAP DECODER -C 98-09-02 GILBERT CORRECTED ERROR IN MAP SIZE FOR U.S. GRID 92 -C 98-09-08 BALDWIN ADD GRIDS 190,192 -C 99-01-20 BALDWIN ADD GRIDS 236,237 -C 01-10-02 ROGERS REDEFINED GRID #218 FOR 12 KM ETA -C REDEFINED GRID 192 FOR NEW 32-KM ETA GRID -C 2003-06-30 GILBERT ADDED GRIDS 145 and 146 for CMAQ -C and GRID 175 for AWIPS over GUAM. -C 2004-09-02 VUONG ADDED AWIPS GRIDS 147, 148, 173 AND 254 -C 2006-12-12 VUONG ADDED AWIPS GRIDS 120 -C 2007-04-20 VUONG ADDED AWIPS GRIDS 176 -C 2007-06-11 VUONG ADDED AWIPS GRIDS 11 TO 18 AND 122 TO 125 -C AND 180 TO 183 -C 2010-08-05 VUONG ADDED NEW GRID 184, 199, 83 AND -C REDEFINED GRID 90 FOR NEW RTMA CONUS 1.27-KM -C REDEFINED GRID 91 FOR NEW RTMA ALASKA 2.976-KM -C REDEFINED GRID 92 FOR NEW RTMA ALASKA 1.488-KM -C 2012-02-28 VUONG ADDED NEW GRID 200 -C -C USAGE: CALL FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) -C INPUT ARGUMENT LIST: -C MSGA - BUFR MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - TOTAL LENGTH OF GRIB MESSAGE -C (2) - LENGTH OF INDICATOR (SECTION 0) -C (3) - LENGTH OF PDS (SECTION 1) -C (4) - LENGTH OF GDS (SECTION 2) -C (5) - LENGTH OF BMS (SECTION 3) -C (6) - LENGTH OF BDS (SECTION 4) -C (7) - VALUE OF CURRENT BYTE -C (8) - BIT POINTER -C (9) - GRIB START BIT NR -C (10) - GRIB/GRID ELEMENT COUNT -C (11) - NR UNUSED BITS AT END OF SECTION 3 -C (12) - BIT MAP FLAG -C (13) - NR UNUSED BITS AT END OF SECTION 2 -C (14) - BDS FLAGS -C (15) - NR UNUSED BITS AT END OF SECTION 4 -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C (1) - ID OF CENTER -C (2) - MODEL IDENTIFICATION -C (3) - GRID IDENTIFICATION -C (4) - GDS/BMS FLAG -C (5) - INDICATOR OF PARAMETER -C (6) - TYPE OF LEVEL -C (7) - HEIGHT/PRESSURE , ETC OF LEVEL -C (8) - YEAR OF CENTURY -C (9) - MONTH OF YEAR -C (10) - DAY OF MONTH -C (11) - HOUR OF DAY -C (12) - MINUTE OF HOUR -C (13) - INDICATOR OF FORECAST TIME UNIT -C (14) - TIME RANGE 1 -C (15) - TIME RANGE 2 -C (16) - TIME RANGE FLAG -C (17) - NUMBER INCLUDED IN AVERAGE -C -C OUTPUT ARGUMENT LIST: -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C KRET = 0 - NO ERROR -C = 5 - GRID NOT AVAIL FOR CENTER INDICATED -C =10 - INCORRECT CENTER INDICATOR -C =12 - BYTES 5-6 ARE NOT ZERO IN BMS, PREDEFINED BIT MAP -C NOT PROVIDED BY THIS CENTER -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS9000 -C -C$$$ -C -C INCOMING MESSAGE HOLDER - CHARACTER*1 MSGA(*) -C -C BIT MAP - LOGICAL*1 KBMS(*) -C -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPTR(*) -C ARRAY OF POINTERS AND COUNTERS - INTEGER KPDS(*) - INTEGER KGDS(*) -C - INTEGER KRET - INTEGER MASK(8) -C ----------------------GRID 21 AND GRID 22 ARE THE SAME - LOGICAL*1 GRD21( 1369) -C ----------------------GRID 23 AND GRID 24 ARE THE SAME - LOGICAL*1 GRD23( 1369) - LOGICAL*1 GRD25( 1368) - LOGICAL*1 GRD26( 1368) -C ----------------------GRID 27 AND GRID 28 ARE THE SAME -C ----------------------GRID 29 AND GRID 30 ARE THE SAME -C ----------------------GRID 33 AND GRID 34 ARE THE SAME - LOGICAL*1 GRD50( 1188) -C -----------------------GRID 61 AND GRID 62 ARE THE SAME - LOGICAL*1 GRD61( 4186) -C -----------------------GRID 63 AND GRID 64 ARE THE SAME - LOGICAL*1 GRD63( 4186) -C LOGICAL*1 GRD70(16380)/16380*.TRUE./ -C ------------------------------------------------------------- - DATA GRD21 /1333*.TRUE.,36*.FALSE./ - DATA GRD23 /.TRUE.,36*.FALSE.,1332*.TRUE./ - DATA GRD25 /1297*.TRUE.,71*.FALSE./ - DATA GRD26 /.TRUE.,71*.FALSE.,1296*.TRUE./ - DATA GRD50/ -C LINE 1-4 - & 7*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE., - & 14*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE.,7*.FALSE., -C LINE 5-8 - & 6*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE., - & 12*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE.,6*.FALSE., -C LINE 9-12 - & 5*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE., - & 10*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE.,5*.FALSE., -C LINE 13-16 - & 4*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE., - & 8*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE.,4*.FALSE., -C LINE 17-20 - & 3*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE., - & 6*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE.,3*.FALSE., -C LINE 21-24 - & 2*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE., - & 4*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE.,2*.FALSE., -C LINE 25-28 - & .FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE., - & 2*.FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE., .FALSE., -C LINE 29-33 - & 180*.TRUE./ - DATA GRD61 /4096*.TRUE.,90*.FALSE./ - DATA GRD63 /.TRUE.,90*.FALSE.,4095*.TRUE./ - DATA MASK /128,64,32,16,8,4,2,1/ -C -C PRINT *,'FI634' - IF (IAND(KPDS(4),64).EQ.64) THEN -C -C SET UP BIT POINTER -C SECTION 0 SECTION 1 SECTION 2 - KPTR(8) = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + (KPTR(4)*8) + 24 -C -C BYTE 4 NUMBER OF UNUSED BITS AT END OF SECTION 3 -C - CALL GBYTEC (MSGA,KPTR(11),KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C -C BYTE 5,6 TABLE REFERENCE IF 0, BIT MAP FOLLOWS -C - CALL GBYTEC (MSGA,KPTR(12),KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C IF TABLE REFERENCE = 0, EXTRACT BIT MAP - IF (KPTR(12).EQ.0) THEN -C CALCULATE NR OF BITS IN BIT MAP - IBITS = (KPTR(5) - 6) * 8 - KPTR(11) - KPTR(10) = IBITS - IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22.OR.KPDS(3).EQ.25. - * OR.KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN -C NORTHERN HEMISPHERE 21, 22, 25, 61, 62 - CALL FI634X(IBITS,KPTR(8),MSGA,KBMS) - IF (KPDS(3).EQ.25) THEN - KADD = 71 - ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN - KADD = 90 - ELSE - KADD = 36 - END IF - DO 25 I = 1, KADD - KBMS(I+IBITS) = .FALSE. - 25 CONTINUE - KPTR(10) = KPTR(10) + KADD - RETURN - ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24.OR.KPDS(3).EQ.26. - * OR.KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN -C SOUTHERN HEMISPHERE 23, 24, 26, 63, 64 - CALL FI634X(IBITS,KPTR(8),MSGA,KBMS) - IF (KPDS(3).EQ.26) THEN - KADD = 72 - ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN - KADD = 91 - ELSE - KADD = 37 - END IF - DO 26 I = 1, KADD - KBMS(I+IBITS) = .FALSE. - 26 CONTINUE - KPTR(10) = KPTR(10) + KADD - 1 - RETURN - ELSE IF (KPDS(3).EQ.50) THEN - KPAD = 7 - KIN = 22 - KBITS = 0 - DO 55 I = 1, 7 - DO 54 J = 1, 4 - DO 51 K = 1, KPAD - KBITS = KBITS + 1 - KBMS(KBITS) = .FALSE. - 51 CONTINUE - CALL FI634X(KIN,KPTR(8),MSGA,KBMS(KBITS+1)) - KPTR(8)=KPTR(8)+KIN - KBITS=KBITS+KIN - DO 53 K = 1, KPAD - KBITS = KBITS + 1 - KBMS(KBITS) = .FALSE. - 53 CONTINUE - 54 CONTINUE - KIN = KIN + 2 - KPAD = KPAD - 1 - 55 CONTINUE - DO 57 II = 1, 5 - CALL FI634X(KIN,KPTR(8),MSGA,KBMS(KBITS+1)) - KPTR(8)=KPTR(8)+KIN - KBITS=KBITS+KIN - 57 CONTINUE - ELSE -C EXTRACT BIT MAP FROM BMS FOR OTHER GRIDS - CALL FI634X(IBITS,KPTR(8),MSGA,KBMS) - END IF - RETURN - ELSE -C PRINT *,'FI634-NO PREDEFINED BIT MAP PROVIDED BY THIS CENTER' - KRET = 12 - RETURN - END IF -C - END IF - KRET = 0 -C ------------------------------------------------------- -C PROCESS NON-STANDARD GRID -C ------------------------------------------------------- - IF (KPDS(3).EQ.255) THEN -C PRINT *,'NON STANDARD GRID, CENTER = ',KPDS(1) - J = KGDS(2) * KGDS(3) - KPTR(10) = J - DO 600 I = 1, J - KBMS(I) = .TRUE. - 600 CONTINUE - RETURN - END IF -C ------------------------------------------------------- -C CHECK INTERNATIONAL SET -C ------------------------------------------------------- - IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22) THEN -C ----- INT'L GRIDS 21, 22 - MAP SIZE 1369 - J = 1369 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 820 - DO 3021 I = 1, 1369 - KBMS(I) = GRD21(I) - 3021 CONTINUE - RETURN - ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24) THEN -C ----- INT'L GRIDS 23, 24 - MAP SIZE 1369 - J = 1369 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 820 - DO 3023 I = 1, 1369 - KBMS(I) = GRD23(I) - 3023 CONTINUE - RETURN - ELSE IF (KPDS(3).EQ.25) THEN -C ----- INT'L GRID 25 - MAP SIZE 1368 - J = 1368 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 820 - DO 3025 I = 1, 1368 - KBMS(I) = GRD25(I) - 3025 CONTINUE - RETURN - ELSE IF (KPDS(3).EQ.26) THEN -C ----- INT'L GRID 26 - MAP SIZE 1368 - J = 1368 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 820 - DO 3026 I = 1, 1368 - KBMS(I) = GRD26(I) - 3026 CONTINUE - RETURN - ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN -C ----- INT'L GRID 37-44 - MAP SIZE 3447 - J = 3447 - GO TO 800 - ELSE IF (KPDS(1).EQ.7.AND.KPDS(3).EQ.50) THEN -C ----- INT'L GRIDS 50 - MAP SIZE 964 - J = 1188 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 890 - DO 3050 I = 1, J - KBMS(I) = GRD50(I) - 3050 CONTINUE - RETURN - ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN -C ----- INT'L GRIDS 61, 62 - MAP SIZE 4186 - J = 4186 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 820 - DO 3061 I = 1, 4186 - KBMS(I) = GRD61(I) - 3061 CONTINUE - RETURN - ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN -C ----- INT'L GRIDS 63, 64 - MAP SIZE 4186 - J = 4186 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 820 - DO 3063 I = 1, 4186 - KBMS(I) = GRD63(I) - 3063 CONTINUE - RETURN - END IF -C ------------------------------------------------------- -C CHECK UNITED STATES SET -C ------------------------------------------------------- - IF (KPDS(1).EQ.7) THEN - IF (KPDS(3).LT.100) THEN - IF (KPDS(3).EQ.1) THEN -C ----- U.S. GRID 1 - MAP SIZE 1679 - J = 1679 - GO TO 800 - END IF - IF (KPDS(3).EQ.2) THEN -C ----- U.S. GRID 2 - MAP SIZE 10512 - J = 10512 - GO TO 800 - ELSE IF (KPDS(3).EQ.3) THEN -C ----- U.S. GRID 3 - MAP SIZE 65160 - J = 65160 - GO TO 800 - ELSE IF (KPDS(3).EQ.4) THEN -C ----- U.S. GRID 4 - MAP SIZE 259920 - J = 259920 - GO TO 800 - ELSE IF (KPDS(3).EQ.5) THEN -C ----- U.S. GRID 5 - MAP SIZE 3021 - J = 3021 - GO TO 800 - ELSE IF (KPDS(3).EQ.6) THEN -C ----- U.S. GRID 6 - MAP SIZE 2385 - J = 2385 - GO TO 800 - ELSE IF (KPDS(3).EQ.8) THEN -C ----- U.S. GRID 8 - MAP SIZE 5104 - J = 5104 - GO TO 800 - ELSE IF (KPDS(3).EQ.10) THEN -C ----- U.S. GRID 10 - MAP SIZE 25020 - J = 25020 - GO TO 800 - ELSE IF (KPDS(3).EQ.11) THEN -C ----- U.S. GRID 11 - MAP SIZE 223920 - J = 223920 - GO TO 800 - ELSE IF (KPDS(3).EQ.12) THEN -C ----- U.S. GRID 12 - MAP SIZE 99631 - J = 99631 - GO TO 800 - ELSE IF (KPDS(3).EQ.13) THEN -C ----- U.S. GRID 13 - MAP SIZE 36391 - J = 36391 - GO TO 800 - ELSE IF (KPDS(3).EQ.14) THEN -C ----- U.S. GRID 14 - MAP SIZE 153811 - J = 153811 - GO TO 800 - ELSE IF (KPDS(3).EQ.15) THEN -C ----- U.S. GRID 15 - MAP SIZE 74987 - J = 74987 - GO TO 800 - ELSE IF (KPDS(3).EQ.16) THEN -C ----- U.S. GRID 16 - MAP SIZE 214268 - J = 214268 - GO TO 800 - ELSE IF (KPDS(3).EQ.17) THEN -C ----- U.S. GRID 17 - MAP SIZE 387136 - J = 387136 - GO TO 800 - ELSE IF (KPDS(3).EQ.18) THEN -C ----- U.S. GRID 18 - MAP SIZE 281866 - J = 281866 - GO TO 800 - ELSE IF (KPDS(3).EQ.27.OR.KPDS(3).EQ.28) THEN -C ----- U.S. GRIDS 27, 28 - MAP SIZE 4225 - J = 4225 - GO TO 800 - ELSE IF (KPDS(3).EQ.29.OR.KPDS(3).EQ.30) THEN -C ----- U.S. GRIDS 29,30 - MAP SIZE 5365 - J = 5365 - GO TO 800 - ELSE IF (KPDS(3).EQ.33.OR.KPDS(3).EQ.34) THEN -C ----- U.S GRID 33, 34 - MAP SIZE 8326 - J = 8326 - GO TO 800 - ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN -C ----- U.S. GRID 37-44 - MAP SIZE 3447 - J = 3447 - GO TO 800 - ELSE IF (KPDS(3).EQ.45) THEN -C ----- U.S. GRID 45 - MAP SIZE 41760 - J = 41760 - GO TO 800 - ELSE IF (KPDS(3).EQ.53) THEN -C ----- U.S. GRID 53 - MAP SIZE 5967 - J = 5967 - GO TO 800 - ELSE IF (KPDS(3).EQ.55.OR.KPDS(3).EQ.56) THEN -C ----- U.S GRID 55, 56 - MAP SIZE 6177 - J = 6177 - GO TO 800 - ELSE IF (KPDS(3).GE.67.AND.KPDS(3).LE.71) THEN -C ----- U.S GRID 67-71 - MAP SIZE 13689 - J = 13689 - GO TO 800 - ELSE IF (KPDS(3).EQ.72) THEN -C ----- U.S GRID 72 - MAP SIZE 406 - J = 406 - GO TO 800 - ELSE IF (KPDS(3).EQ.73) THEN -C ----- U.S GRID 73 - MAP SIZE 13056 - J = 13056 - GO TO 800 - ELSE IF (KPDS(3).EQ.74) THEN -C ----- U.S GRID 74 - MAP SIZE 10800 - J = 10800 - GO TO 800 - ELSE IF (KPDS(3).GE.75.AND.KPDS(3).LE.77) THEN -C ----- U.S GRID 75-77 - MAP SIZE 12321 - J = 12321 - GO TO 800 - ELSE IF (KPDS(3).EQ.83) THEN -C ----- U.S GRID 83 - MAP SIZE 429786 - J = 429786 - GO TO 800 - ELSE IF (KPDS(3).EQ.85.OR.KPDS(3).EQ.86) THEN -C ----- U.S GRID 85,86 - MAP SIZE 32400 - J = 32400 - GO TO 800 - ELSE IF (KPDS(3).EQ.87) THEN -C ----- U.S GRID 87 - MAP SIZE 5022 - J = 5022 - GO TO 800 - ELSE IF (KPDS(3).EQ.88) THEN -C ----- U.S GRID 88 - MAP SIZE 317840 - J = 317840 - GO TO 800 - ELSE IF (KPDS(3).EQ.90) THEN -C ----- U.S GRID 90 - MAP SIZE 11807617 - J = 11807617 - GO TO 800 - ELSE IF (KPDS(3).EQ.91) THEN -C ----- U.S GRID 91 - MAP SIZE 1822145 - J = 1822145 - GO TO 800 - ELSE IF (KPDS(3).EQ.92) THEN -C ----- U.S GRID 92 - MAP SIZE 7283073 - J = 7283073 - GO TO 800 - ELSE IF (KPDS(3).EQ.93) THEN -C ----- U.S GRID 93 - MAP SIZE 111723 - J = 111723 - GO TO 800 - ELSE IF (KPDS(3).EQ.94) THEN -C ----- U.S GRID 94 - MAP SIZE 371875 - J = 371875 - GO TO 800 - ELSE IF (KPDS(3).EQ.95) THEN -C ----- U.S GRID 95 - MAP SIZE 130325 - J = 130325 - GO TO 800 - ELSE IF (KPDS(3).EQ.96) THEN -C ----- U.S GRID 96 - MAP SIZE 209253 - J = 209253 - GO TO 800 - ELSE IF (KPDS(3).EQ.97) THEN -C ----- U.S GRID 97 - MAP SIZE 1508100 - J = 1508100 - GO TO 800 - ELSE IF (KPDS(3).EQ.98) THEN -C ----- U.S GRID 98 - MAP SIZE 18048 - J = 18048 - GO TO 800 - ELSE IF (KPDS(3).EQ.99) THEN -C ----- U.S GRID 99 - MAP SIZE 779385 - J = 779385 - GO TO 800 - END IF - ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LT.200) THEN - IF (KPDS(3).EQ.100) THEN -C ----- U.S. GRID 100 - MAP SIZE 6889 - J = 6889 - GO TO 800 - ELSE IF (KPDS(3).EQ.101) THEN -C ----- U.S. GRID 101 - MAP SIZE 10283 - J = 10283 - GO TO 800 - ELSE IF (KPDS(3).EQ.103) THEN -C ----- U.S. GRID 103 - MAP SIZE 3640 - J = 3640 - GO TO 800 - ELSE IF (KPDS(3).EQ.104) THEN -C ----- U.S. GRID 104 - MAP SIZE 16170 - J = 16170 - GO TO 800 - ELSE IF (KPDS(3).EQ.105) THEN -C ----- U.S. GRID 105 - MAP SIZE 6889 - J = 6889 - GO TO 800 - ELSE IF (KPDS(3).EQ.106) THEN -C ----- U.S. GRID 106 - MAP SIZE 19305 - J = 19305 - GO TO 800 - ELSE IF (KPDS(3).EQ.107) THEN -C ----- U.S. GRID 107 - MAP SIZE 11040 - J = 11040 - GO TO 800 - ELSE IF (KPDS(3).EQ.110) THEN -C ----- U.S. GRID 110 - MAP SIZE 103936 - J = 103936 - GO TO 800 - ELSE IF (KPDS(3).EQ.120) THEN -C ----- U.S. GRID 120 - MAP SIZE 2020800 - J = 2020800 - GO TO 800 - ELSE IF (KPDS(3).EQ.122) THEN -C ----- U.S. GRID 122 - MAP SIZE 162750 - J = 162750 - GO TO 800 - ELSE IF (KPDS(3).EQ.123) THEN -C ----- U.S. GRID 123 - MAP SIZE 100800 - J = 100800 - GO TO 800 - ELSE IF (KPDS(3).EQ.124) THEN -C ----- U.S. GRID 124 - MAP SIZE 75360 - J = 75360 - GO TO 800 - ELSE IF (KPDS(3).EQ.125) THEN -C ----- U.S. GRID 125 - MAP SIZE 102000 - J = 102000 - GO TO 800 - ELSE IF (KPDS(3).EQ.126) THEN -C ----- U.S. GRID 126 - MAP SIZE 72960 - J = 72960 - GO TO 800 - ELSE IF (KPDS(3).EQ.127) THEN -C ----- U.S. GRID 127 - MAP SIZE 294912 - J = 294912 - GO TO 800 - ELSE IF (KPDS(3).EQ.128) THEN -C ----- U.S. GRID 128 - MAP SIZE 663552 - J = 663552 - GO TO 800 - ELSE IF (KPDS(3).EQ.129) THEN -C ----- U.S. GRID 129 - MAP SIZE 1548800 - J = 1548800 - GO TO 800 - ELSE IF (KPDS(3).EQ.130) THEN -C ----- U.S. GRID 130 - MAP SIZE 151987 - J = 151987 - GO TO 800 - ELSE IF (KPDS(3).EQ.132) THEN -C ----- U.S. GRID 132 - MAP SIZE 385441 - J = 385441 - GO TO 800 - ELSE IF (KPDS(3).EQ.138) THEN -C ----- U.S. GRID 138 - MAP SIZE 134784 - J = 134784 - GO TO 800 - ELSE IF (KPDS(3).EQ.139) THEN -C ----- U.S. GRID 139 - MAP SIZE 4160 - J = 4160 - GO TO 800 - ELSE IF (KPDS(3).EQ.140) THEN -C ----- U.S. GRID 140 - MAP SIZE 32437 - J = 32437 - GO TO 800 -C - ELSE IF (KPDS(3).EQ.145) THEN -C ----- U.S. GRID 145 - MAP SIZE 24505 - J = 24505 - GO TO 800 - ELSE IF (KPDS(3).EQ.146) THEN -C ----- U.S. GRID 146 - MAP SIZE 23572 - J = 23572 - GO TO 800 - ELSE IF (KPDS(3).EQ.147) THEN -C ----- U.S. GRID 147 - MAP SIZE 69412 - J = 69412 - GO TO 800 - ELSE IF (KPDS(3).EQ.148) THEN -C ----- U.S. GRID 148 - MAP SIZE 117130 - J = 117130 - GO TO 800 - ELSE IF (KPDS(3).EQ.150) THEN -C ----- U.S. GRID 150 - MAP SIZE 806010 - J = 806010 - GO TO 800 - ELSE IF (KPDS(3).EQ.151) THEN -C ----- U.S. GRID 151 - MAP SIZE 205062 - J = 205062 - GO TO 800 - ELSE IF (KPDS(3).EQ.160) THEN -C ----- U.S. GRID 160 - MAP SIZE 28080 - J = 28080 - GO TO 800 - ELSE IF (KPDS(3).EQ.161) THEN -C ----- U.S. GRID 161 - MAP SIZE 13974 - J = 13974 - GO TO 800 - ELSE IF (KPDS(3).EQ.163) THEN -C ----- U.S. GRID 163 - MAP SIZE 727776 - J = 727776 - GO TO 800 - ELSE IF (KPDS(3).EQ.170) THEN -C ----- U.S. GRID 170 - MAP SIZE 131072 - J = 131072 - GO TO 800 - ELSE IF (KPDS(3).EQ.171) THEN -C ----- U.S. GRID 171 - MAP SIZE 716100 - J = 716100 - GO TO 800 - ELSE IF (KPDS(3).EQ.172) THEN -C ----- U.S. GRID 172 - MAP SIZE 489900 - J = 489900 - GO TO 800 - ELSE IF (KPDS(3).EQ.173) THEN -C ----- U.S. GRID 173 - MAP SIZE 9331200 - J = 9331200 - GO TO 800 - ELSE IF (KPDS(3).EQ.174) THEN -C ----- U.S. GRID 174 - MAP SIZE 4147200 - J = 4147200 - GO TO 800 - ELSE IF (KPDS(3).EQ.175) THEN -C ----- U.S. GRID 175 - MAP SIZE 185704 - J = 185704 - GO TO 800 - ELSE IF (KPDS(3).EQ.176) THEN -C ----- U.S. GRID 176 - MAP SIZE 76845 - J = 76845 - GO TO 800 - ELSE IF (KPDS(3).EQ.179) THEN -C ----- U.S. GRID 179 - MAP SIZE 977132 - J = 977132 - GO TO 800 - ELSE IF (KPDS(3).EQ.180) THEN -C ----- U.S. GRID 180 - MAP SIZE 267168 - J = 267168 - GO TO 800 - ELSE IF (KPDS(3).EQ.181) THEN -C ----- U.S. GRID 181 - MAP SIZE 102860 - J = 102860 - GO TO 800 - ELSE IF (KPDS(3).EQ.182) THEN -C ----- U.S. GRID 182 - MAP SIZE 64218 - J = 64218 - GO TO 800 - ELSE IF (KPDS(3).EQ.183) THEN -C ----- U.S. GRID 183 - MAP SIZE 180144 - J = 180144 - GO TO 800 - ELSE IF (KPDS(3).EQ.184) THEN -C ----- U.S. GRID 184 - MAP SIZE 2953665 - J = 2953665 - GO TO 800 - ELSE IF (KPDS(3).EQ.187) THEN -C ----- U.S. GRID 187 - MAP SIZE 3425565 - J = 3425565 - GO TO 800 - ELSE IF (KPDS(3).EQ.188) THEN -C ----- U.S. GRID 188 - MAP SIZE 563655 - J = 563655 - GO TO 800 - ELSE IF (KPDS(3).EQ.189) THEN -C ----- U.S. GRID 189 - MAP SIZE 560025 - J = 560025 - GO TO 800 - ELSE IF (KPDS(3).EQ.190) THEN -C ----- U.S GRID 190 - MAP SIZE 796590 - J = 796590 - GO TO 800 - ELSE IF (KPDS(3).EQ.192) THEN -C ----- U.S GRID 192 - MAP SIZE 91719 - J = 91719 - GO TO 800 - ELSE IF (KPDS(3).EQ.193) THEN -C ----- U.S GRID 193 - MAP SIZE 1038240 - J = 1038240 - GO TO 800 - ELSE IF (KPDS(3).EQ.194) THEN -C ----- U.S GRID 194 - MAP SIZE 168640 - J = 168640 - GO TO 800 - ELSE IF (KPDS(3).EQ.195) THEN -C ----- U.S. GRID 195 - MAP SIZE 22833 - J = 22833 - GO TO 800 - ELSE IF (KPDS(3).EQ.196) THEN -C ----- U.S. GRID 196 - MAP SIZE 72225 - J = 72225 - GO TO 800 - ELSE IF (KPDS(3).EQ.197) THEN -C ----- U.S. GRID 197 - MAP SIZE 739297 - J = 739297 - GO TO 800 - ELSE IF (KPDS(3).EQ.198) THEN -C ----- U.S. GRID 198 - MAP SIZE 456225 - J = 456225 - GO TO 800 - ELSE IF (KPDS(3).EQ.199) THEN -C ----- U.S. GRID 199 - MAP SIZE 37249 - J = 37249 - GO TO 800 - ELSE IF (IAND(KPDS(4),128).EQ.128) THEN -C ----- U.S. NON-STANDARD GRID - GO TO 895 - END IF - ELSE IF (KPDS(3).GE.200) THEN - IF (KPDS(3).EQ.200) THEN - J = 10152 - GO TO 800 - ELSE IF (KPDS(3).EQ.201) THEN - J = 4225 - GO TO 800 - ELSE IF (KPDS(3).EQ.202) THEN - J = 2795 - GO TO 800 - ELSE IF (KPDS(3).EQ.203.OR.KPDS(3).EQ.205) THEN - J = 1755 - GO TO 800 - ELSE IF (KPDS(3).EQ.204) THEN - J = 6324 - GO TO 800 - ELSE IF (KPDS(3).EQ.206) THEN - J = 2091 - GO TO 800 - ELSE IF (KPDS(3).EQ.207) THEN - J = 1715 - GO TO 800 - ELSE IF (KPDS(3).EQ.208) THEN - J = 783 - GO TO 800 - ELSE IF (KPDS(3).EQ.209) THEN - J = 61325 - GO TO 800 - ELSE IF (KPDS(3).EQ.210) THEN - J = 625 - GO TO 800 - ELSE IF (KPDS(3).EQ.211) THEN - J = 6045 - GO TO 800 - ELSE IF (KPDS(3).EQ.212) THEN - J = 23865 - GO TO 800 - ELSE IF (KPDS(3).EQ.213) THEN - J = 10965 - GO TO 800 - ELSE IF (KPDS(3).EQ.214) THEN - J = 6693 - GO TO 800 - ELSE IF (KPDS(3).EQ.215) THEN - J = 94833 - GO TO 800 - ELSE IF (KPDS(3).EQ.216) THEN - J = 14873 - GO TO 800 - ELSE IF (KPDS(3).EQ.217) THEN - J = 59001 - GO TO 800 - ELSE IF (KPDS(3).EQ.218) THEN - J = 262792 - GO TO 800 - ELSE IF (KPDS(3).EQ.219) THEN - J = 179025 - GO TO 800 - ELSE IF (KPDS(3).EQ.220) THEN - J = 122475 - GO TO 800 - ELSE IF (KPDS(3).EQ.221) THEN - J = 96673 - GO TO 800 - ELSE IF (KPDS(3).EQ.222) THEN - J = 15456 - GO TO 800 - ELSE IF (KPDS(3).EQ.223) THEN - J = 16641 - GO TO 800 - ELSE IF (KPDS(3).EQ.224) THEN - J = 4225 - GO TO 800 - ELSE IF (KPDS(3).EQ.225) THEN - J = 24975 - GO TO 800 - ELSE IF (KPDS(3).EQ.226) THEN - J = 381029 - GO TO 800 - ELSE IF (KPDS(3).EQ.227) THEN - J = 1509825 - GO TO 800 - ELSE IF (KPDS(3).EQ.228) THEN - J = 10512 - GO TO 800 - ELSE IF (KPDS(3).EQ.229) THEN - J = 65160 - GO TO 800 - ELSE IF (KPDS(3).EQ.230) THEN - J = 259920 - GO TO 800 - ELSE IF (KPDS(3).EQ.231) THEN - J = 130320 - GO TO 800 - ELSE IF (KPDS(3).EQ.232) THEN - J = 32760 - GO TO 800 - ELSE IF (KPDS(3).EQ.233) THEN - J = 45216 - GO TO 800 - ELSE IF (KPDS(3).EQ.234) THEN - J = 16093 - GO TO 800 - ELSE IF (KPDS(3).EQ.235) THEN - J = 259200 - GO TO 800 - ELSE IF (KPDS(3).EQ.236) THEN - J = 17063 - GO TO 800 - ELSE IF (KPDS(3).EQ.237) THEN - J = 2538 - GO TO 800 - ELSE IF (KPDS(3).EQ.238) THEN - J = 55825 - GO TO 800 - ELSE IF (KPDS(3).EQ.239) THEN - J = 19065 - GO TO 800 - ELSE IF (KPDS(3).EQ.240) THEN - J = 987601 - GO TO 800 - ELSE IF (KPDS(3).EQ.241) THEN - J = 244305 - GO TO 800 - ELSE IF (KPDS(3).EQ.242) THEN - J = 235025 - GO TO 800 - ELSE IF (KPDS(3).EQ.243) THEN - J = 12726 - GO TO 800 - ELSE IF (KPDS(3).EQ.244) THEN - J = 55825 - GO TO 800 - ELSE IF (KPDS(3).EQ.245) THEN - J = 124992 - GO TO 800 - ELSE IF (KPDS(3).EQ.246) THEN - J = 123172 - GO TO 800 - ELSE IF (KPDS(3).EQ.247) THEN - J = 124992 - GO TO 800 - ELSE IF (KPDS(3).EQ.248) THEN - J = 13635 - GO TO 800 - ELSE IF (KPDS(3).EQ.249) THEN - J = 125881 - GO TO 800 - ELSE IF (KPDS(3).EQ.250) THEN - J = 13635 - GO TO 800 - ELSE IF (KPDS(3).EQ.251) THEN - J = 69720 - GO TO 800 - ELSE IF (KPDS(3).EQ.252) THEN - J = 67725 - GO TO 800 - ELSE IF (KPDS(3).EQ.253) THEN - J = 83552 - GO TO 800 - ELSE IF (KPDS(3).EQ.254) THEN - J = 110700 - GO TO 800 - ELSE IF (IAND(KPDS(4),128).EQ.128) THEN - GO TO 895 - END IF - KRET = 5 - RETURN - END IF - END IF -C ------------------------------------------------------- -C CHECK JAPAN METEOROLOGICAL AGENCY SET -C ------------------------------------------------------- - IF (KPDS(1).EQ.34) THEN - IF (IAND(KPDS(4),128).EQ.128) THEN -C PRINT *,'JMA MAP IS NOT PREDEFINED, THE GDS WILL' -C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3) - GO TO 900 - END IF - END IF -C ------------------------------------------------------- -C CHECK CANADIAN SET -C ------------------------------------------------------- - IF (KPDS(1).EQ.54) THEN - IF (IAND(KPDS(4),128).EQ.128) THEN -C PRINT *,'CANADIAN MAP IS NOT PREDEFINED, THE GDS WILL' -C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3) - GO TO 900 - END IF - END IF -C ------------------------------------------------------- -C CHECK FNOC SET -C ------------------------------------------------------- - IF (KPDS(1).EQ.58) THEN - IF (KPDS(3).EQ.220.OR.KPDS(3).EQ.221) THEN -C FNOC GRID 220, 221 - MAPSIZE 3969 (63 * 63) - J = 3969 - KPTR(10) = J - DO I = 1, J - KBMS(I) = .TRUE. - END DO - RETURN - END IF - IF (KPDS(3).EQ.223) THEN -C FNOC GRID 223 - MAPSIZE 10512 (73 * 144) - J = 10512 - KPTR(10) = J - DO I = 1, J - KBMS(I) = .TRUE. - END DO - RETURN - END IF - IF (IAND(KPDS(4),128).EQ.128) THEN -C PRINT *,'FNOC MAP IS NOT PREDEFINED, THE GDS WILL' -C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3) - GO TO 900 - END IF - END IF -C ------------------------------------------------------- -C CHECK UKMET SET -C ------------------------------------------------------- - IF (KPDS(1).EQ.74) THEN - IF (IAND(KPDS(4),128).EQ.128) THEN - GO TO 820 - END IF - END IF -C ------------------------------------------------------- -C CHECK ECMWF SET -C ------------------------------------------------------- - IF (KPDS(1).EQ.98) THEN - IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN - IF (KPDS(3).GE.5.AND.KPDS(3).LE.8) THEN - J = 1073 - ELSE - J = 1369 - END IF - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 810 - KPTR(10) = J ! Reset For Modified J - DO 1000 I = 1, J - KBMS(I) = .TRUE. - 1000 CONTINUE - RETURN - ELSE IF (KPDS(3).GE.13.AND.KPDS(3).LE.16) THEN - J = 361 - KPTR(10) = J - CALL FI637(J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 810 - DO 1013 I = 1, J - KBMS(I) = .TRUE. - 1013 CONTINUE - RETURN - ELSE IF (IAND(KPDS(4),128).EQ.128) THEN - GO TO 810 - ELSE - KRET = 5 - RETURN - END IF - ELSE -C PRINT *,'CENTER ',KPDS(1),' IS NOT DEFINED' - IF (IAND(KPDS(4),128).EQ.128) THEN -C PRINT *,'GDS WILL BE USED TO UNPACK THE DATA', -C * ' MAP = ',KPDS(3) - GO TO 900 - ELSE - KRET = 10 - RETURN - END IF - END IF -C ======================================= -C - 800 CONTINUE - KPTR(10) = J - CALL FI637 (J,KPDS,KGDS,KRET) - IF(KRET.NE.0) GO TO 801 - DO 2201 I = 1, J - KBMS(I) = .TRUE. - 2201 CONTINUE - RETURN - 801 CONTINUE -C -C ----- THE MAP HAS A GDS, BYTE 7 OF THE (PDS) THE GRID IDENTIFICATION -C ----- IS NOT 255, THE SIZE OF THE GRID IS NOT THE SAME AS THE -C ----- PREDEFINED SIZES OF THE U.S. GRIDS, OR KNOWN GRIDS OF THE -C ----- OF THE OTHER CENTERS. THE GRID CAN BE UNKNOWN, OR FROM AN -C ----- UNKNOWN CENTER, WE WILL USE THE INFORMATION IN THE GDS TO MAKE -C ----- A BIT MAP. -C - 810 CONTINUE -C PRINT *,'ECMWF PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE' - GO TO 895 -C - 820 CONTINUE -C PRINT *,'U.K. MET PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE' - GO TO 895 -C - 890 CONTINUE -C PRINT *,'PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE' - 895 CONTINUE -C PRINT *,'THE GDS TO UNPACK THE DATA, MAP TYPE = ',KPDS(3) -C - 900 CONTINUE - J = KGDS(2) * KGDS(3) -C AFOS AFOS AFOS SPECIAL CASE -C INVOLVES NEXT SINGLE STATEMENT ONLY - IF (KPDS(3).EQ.211) KRET = 0 - KPTR(10) = J - DO 2203 I = 1, J - KBMS(I) = .TRUE. - 2203 CONTINUE -C PRINT *,'EXIT FI634' - RETURN - END -C----------------------------------------------------------------------- - SUBROUTINE FI634X(NPTS,NSKP,MSGA,KBMS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI634X EXTRACT BIT MAP -C PRGMMR: IREDELL ORG: W/NP23 DATE: 91-09-19 -C -C ABSTRACT: EXTRACT THE PACKED BITMAP INTO A LOGICAL ARRAY. -C -C PROGRAM HISTORY LOG: -C 97-09-19 IREDELL VECTORIZED BITMAP DECODER -C -C USAGE: CALL FI634X(NPTS,NSKP,MSGA,KBMS) -C INPUT ARGUMENT LIST: -C NPTS - INTEGER NUMBER OF POINTS IN THE BITMAP FIELD -C NSKP - INTEGER NUMBER OF BITS TO SKIP IN GRIB MESSAGE -C MSGA - CHARACTER*1 GRIB MESSAGE -C -C OUTPUT ARGUMENT LIST: -C KBMS - LOGICAL*1 BITMAP -C -C REMARKS: -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: CRAY -C -C$$$ - CHARACTER*1 MSGA(*) - LOGICAL*1 KBMS(NPTS) - INTEGER ICHK(NPTS) -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - CALL GBYTESC(MSGA,ICHK,NSKP,1,0,NPTS) - KBMS=ICHK.NE.0 -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END - SUBROUTINE FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI635 EXTRACT GRIB DATA ELEMENTS FROM BDS -C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 -C -C ABSTRACT: EXTRACT GRIB DATA FROM BINARY DATA SECTION AND PLACE -C INTO OUTPUT ARRAY IN PROPER POSITION. -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 94-04-01 CAVANAUGH MODIFIED CODE TO INCLUDE DECIMAL SCALING WHEN -C CALCULATING THE VALUE OF DATA POINTS SPECIFIED -C AS BEING EQUAL TO THE REFERENCE VALUE -C 94-11-10 FARLEY INCREASED MXSIZE FROM 72960 TO 260000 -C FOR .5 DEGREE SST ANALYSIS FIELDS -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-08-31 IREDELL ELIMINATED NEED FOR MXSIZE -C -C USAGE: CALL FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET) -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C (1) - TOTAL LENGTH OF GRIB MESSAGE -C (2) - LENGTH OF INDICATOR (SECTION 0) -C (3) - LENGTH OF PDS (SECTION 1) -C (4) - LENGTH OF GDS (SECTION 2) -C (5) - LENGTH OF BMS (SECTION 3) -C (6) - LENGTH OF BDS (SECTION 4) -C (7) - VALUE OF CURRENT BYTE -C (8) - BIT POINTER -C (9) - GRIB START BIT NR -C (10) - GRIB/GRID ELEMENT COUNT -C (11) - NR UNUSED BITS AT END OF SECTION 3 -C (12) - BIT MAP FLAG -C (13) - NR UNUSED BITS AT END OF SECTION 2 -C (14) - BDS FLAGS -C (15) - NR UNUSED BITS AT END OF SECTION 4 -C (16) - RESERVED -C (17) - RESERVED -C (18) - RESERVED -C (19) - BINARY SCALE FACTOR -C (20) - NUM BITS USED TO PACK EACH DATUM -C KPDS - ARRAY CONTAINING PDS ELEMENTS. -C SEE INITIAL ROUTINE -C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. -C -C OUTPUT ARGUMENT LIST: -C KBDS - INFORMATION EXTRACTED FROM BINARY DATA SECTION -C KBDS(1) - N1 -C KBDS(2) - N2 -C KBDS(3) - P1 -C KBDS(4) - P2 -C KBDS(5) - BIT POINTER TO 2ND ORDER WIDTHS -C KBDS(6) - " " " " " BIT MAPS -C KBDS(7) - " " " FIRST ORDER VALUES -C KBDS(8) - " " " SECOND ORDER VALUES -C KBDS(9) - " " START OF BDS -C KBDS(10) - " " MAIN BIT MAP -C KBDS(11) - BINARY SCALING -C KBDS(12) - DECIMAL SCALING -C KBDS(13) - BIT WIDTH OF FIRST ORDER VALUES -C KBDS(14) - BIT MAP FLAG -C 0 = NO SECOND ORDER BIT MAP -C 1 = SECOND ORDER BIT MAP PRESENT -C KBDS(15) - SECOND ORDER BIT WIDTH -C KBDS(16) - CONSTANT / DIFFERENT WIDTHS -C 0 = CONSTANT WIDTHS -C 1 = DIFFERENT WIDTHS -C KBDS(17) - SINGLE DATUM / MATRIX -C 0 = SINGLE DATUM AT EACH GRID POINT -C 1 = MATRIX OF VALUES AT EACH GRID POINT -C (18-20)- UNUSED -C -C DATA - REAL*4 ARRAY OF GRIDDED ELEMENTS IN GRIB MESSAGE. -C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS -C SEE INPUT LIST -C KRET - ERROR RETURN -C -C REMARKS: -C ERROR RETURN -C 3 = UNPACKED FIELD IS LARGER THAN 65160 -C 6 = DOES NOT MATCH NR OF ENTRIES FOR THIS GRIB/GRID -C 7 = NUMBER OF BITS IN FILL TOO LARGE -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS9000 -C -C$$$ -C - CHARACTER*1 MSGA(*) -C - LOGICAL*1 KBMS(*) -C - INTEGER KPDS(*) - INTEGER KGDS(*) - INTEGER KBDS(20) - INTEGER KPTR(*) - INTEGER NRBITS - INTEGER,ALLOCATABLE:: KSAVE(:) - INTEGER KSCALE -C - REAL DATA(*) - REAL REFNCE - REAL SCALE - REAL REALKK -C -C -C CHANGED HEX VALUES TO DECIMAL TO MAKE CODE MORE PORTABLE -C -C ************************************************************* -C PRINT *,'ENTER FI635' -C SET UP BIT POINTER - KPTR(8) = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + (KPTR(4)*8) - * + (KPTR(5)*8) + 24 -C ------------- EXTRACT FLAGS -C BYTE 4 - CALL GBYTEC(MSGA,KPTR(14),KPTR(8),4) - KPTR(8) = KPTR(8) + 4 -C --------- NR OF UNUSED BITS IN SECTION 4 - CALL GBYTEC(MSGA,KPTR(15),KPTR(8),4) - KPTR(8) = KPTR(8) + 4 - KEND = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + (KPTR(4)*8) - * + (KPTR(5)*8) + KPTR(6) * 8 - KPTR(15) -C ------------- GET SCALE FACTOR -C BYTES 5,6 -C CHECK SIGN - CALL GBYTEC (MSGA,KSIGN,KPTR(8),1) - KPTR(8) = KPTR(8) + 1 -C GET ABSOLUTE SCALE VALUE - CALL GBYTEC (MSGA,KSCALE,KPTR(8),15) - KPTR(8) = KPTR(8) + 15 - IF (KSIGN.GT.0) THEN - KSCALE = - KSCALE - END IF - SCALE = 2.0**KSCALE - KPTR(19)=KSCALE -C ------------ GET REFERENCE VALUE -C BYTES 7,10 -C CALL GBYTE (MSGA,KREF,KPTR(8),32) - call gbytec(MSGA,JSGN,KPTR(8),1) - call gbytec(MSGA,JEXP,KPTR(8)+1,7) - call gbytec(MSGA,IFR,KPTR(8)+8,24) - KPTR(8) = KPTR(8) + 32 -C -C THE NEXT CODE WILL CONVERT THE IBM370 FLOATING POINT -C TO THE FLOATING POINT USED ON YOUR COMPUTER. -C -C -C PRINT *,109,JSGN,JEXP,IFR -C 109 FORMAT (' JSGN,JEXP,IFR = ',3(1X,Z8)) - IF (IFR.EQ.0) THEN - REFNCE = 0.0 - ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN - REFNCE = 0.0 - ELSE - REFNCE = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) - IF (JSGN.NE.0) REFNCE = - REFNCE - END IF -C PRINT *,'SCALE ',SCALE,' REF VAL ',REFNCE -C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY -C BYTE 11 - CALL GBYTEC (MSGA,KBITS,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 - KBDS(4) = KBITS -C KBDS(13) = KBITS - KPTR(20) = KBITS - IBYT12 = KPTR(8) -C ------------------ IF THERE ARE NO EXTENDED FLAGS PRESENT -C THIS IS WHERE DATA BEGINS AND AND THE PROCESSING -C INCLUDED IN THE FOLLOWING IF...END IF -C WILL BE SKIPPED -C PRINT *,'BASIC FLAGS =',KPTR(14) ,IAND(KPTR(14),1) - IF (IAND(KPTR(14),1).EQ.0) THEN -C PRINT *,'NO EXTENDED FLAGS' - ELSE -C BYTES 12,13 - CALL GBYTEC (MSGA,KOCTET,KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C --------------------------- EXTENDED FLAGS -C BYTE 14 - CALL GBYTEC (MSGA,KXFLAG,KPTR(8),8) -C PRINT *,'HAVE EXTENDED FLAGS',KXFLAG - KPTR(8) = KPTR(8) + 8 - IF (IAND(KXFLAG,16).EQ.0) THEN -C SECOND ORDER VALUES CONSTANT WIDTHS - KBDS(16) = 0 - ELSE -C SECOND ORDER VALUES DIFFERENT WIDTHS - KBDS(16) = 1 - END IF - IF (IAND (KXFLAG,32).EQ.0) THEN -C NO SECONDARY BIT MAP - KBDS(14) = 0 - ELSE -C HAVE SECONDARY BIT MAP - KBDS(14) = 1 - END IF - IF (IAND (KXFLAG,64).EQ.0) THEN -C SINGLE DATUM AT GRID POINT - KBDS(17) = 0 - ELSE -C MATRIX OF VALUES AT GRID POINT - KBDS(17) = 1 - END IF -C ---------------------- NR - FIRST DIMENSION (ROWS) OF EACH MATRIX -C BYTES 15,16 - CALL GBYTEC (MSGA,NR,KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ---------------------- NC - SECOND DIMENSION (COLS) OF EACH MATRIX -C BYTES 17,18 - CALL GBYTEC (MSGA,NC,KPTR(8),16) - KPTR(8) = KPTR(8) + 16 -C ---------------------- NRV - FIRST DIM COORD VALS -C BYTE 19 - CALL GBYTEC (MSGA,NRV,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ---------------------- NC1 - NR COEFF'S OR VALUES -C BYTE 20 - CALL GBYTEC (MSGA,NC1,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ---------------------- NCV - SECOND DIM COORD OR VALUE -C BYTE 21 - CALL GBYTEC (MSGA,NCV,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ---------------------- NC2 - NR COEFF'S OR VALS -C BYTE 22 - CALL GBYTEC (MSGA,NC2,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ---------------------- KPHYS1 - FIRST DIM PHYSICAL SIGNIF -C BYTE 23 - CALL GBYTEC (MSGA,KPHYS1,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C ---------------------- KPHYS2 - SECOND DIM PHYSICAL SIGNIF -C BYTE 24 - CALL GBYTEC (MSGA,KPHYS2,KPTR(8),8) - KPTR(8) = KPTR(8) + 8 -C BYTES 25-N - END IF - IF (KBITS.EQ.0) THEN -C HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE - SCAL10 = 10.0 ** KPDS(22) - SCAL10 = 1.0 / SCAL10 - REFN10 = REFNCE * SCAL10 - KENTRY = KPTR(10) - DO 210 I = 1, KENTRY - DATA(I) = 0.0 - IF (KBMS(I)) THEN - DATA(I) = REFN10 - END IF - 210 CONTINUE - GO TO 900 - END IF -C PRINT *,'KEND ',KEND,' KPTR(8) ',KPTR(8),'KBITS ',KBITS - KNR = (KEND - KPTR(8)) / KBITS -C PRINT *,'NUMBER OF ENTRIES IN DATA ARRAY',KNR -C -------------------- -C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER) -C ENTRIES. -C ------------- UNUSED BITS IN DATA AREA -C NUMBER OF BYTES IN DATA AREA - NRBYTE = KPTR(6) - 11 -C ------------- TOTAL NR OF USABLE BITS - NRBITS = NRBYTE * 8 - KPTR(15) -C ------------- TOTAL NR OF ENTRIES - KENTRY = NRBITS / KBITS -C ALLOCATE KSAVE - ALLOCATE(KSAVE(KENTRY)) -C -C IF (IAND(KPTR(14),2).EQ.0) THEN -C PRINT *,'SOURCE VALUES IN FLOATING POINT' -C ELSE -C PRINT *,'SOURCE VALUES IN INTEGER' -C END IF -C - IF (IAND(KPTR(14),8).EQ.0) THEN -C PRINT *,'PROCESSING GRID POINT DATA' - IF (IAND(KPTR(14),4).EQ.0) THEN -C PRINT *,' WITH SIMPLE PACKING' - IF (IAND(KPTR(14),1).EQ.0) THEN -C PRINT *,' WITH NO ADDITIONAL FLAGS' - GO TO 4000 - ELSE IF (IAND(KPTR(14),1).NE.0) THEN -C PRINT *,' WITH ADDITIONAL FLAGS',KXFLAG - IF (KBDS(17).EQ.0) THEN -C PRINT *,' SINGLE DATUM EACH GRID PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - ELSE IF (KBDS(17).NE.0) THEN -C PRINT *,' MATRIX OF VALS EACH PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - END IF - END IF - ELSE IF (IAND(KPTR(14),4).NE.0) THEN -C PRINT *,' WITH COMPLEX/SECOND ORDER PACKING' - IF (IAND(KPTR(14),1).EQ.0) THEN -C PRINT *,' WITH NO ADDITIONAL FLAGS' - ELSE IF (IAND(KPTR(14),1).NE.0) THEN -C PRINT *,' WITH ADDITIONAL FLAGS' - IF (KBDS(17).EQ.0) THEN -C PRINT *,' SINGLE DATUM AT EACH PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF -C ROW BY ROW - COL BY COL - CALL FI636 (DATA,MSGA,KBMS, - * REFNCE,KPTR,KPDS,KGDS) - GO TO 900 - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - CALL FI636 (DATA,MSGA,KBMS, - * REFNCE,KPTR,KPDS,KGDS) - GO TO 900 - END IF - ELSE IF (KBDS(17).NE.0) THEN -C PRINT *,' MATRIX OF VALS EACH PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - END IF - END IF - END IF - ELSE IF (IAND(KPTR(14),8).NE.0) THEN -C PRINT *,'PROCESSING SPHERICAL HARMONIC COEFFICIENTS' - IF (IAND(KPTR(14),4).EQ.0) THEN -C PRINT *,' WITH SIMPLE PACKING' - IF (IAND(KPTR(14),1).EQ.0) THEN -C PRINT *,' WITH NO ADDITIONAL FLAGS' - GO TO 5000 - ELSE IF (IAND(KPTR(14),1).NE.0) THEN -C PRINT *,' WITH ADDITIONAL FLAGS' - IF (KBDS(17).EQ.0) THEN -C PRINT *,' SINGLE DATUM EACH GRID PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - ELSE IF (KBDS(17).NE.0) THEN -C PRINT *,' MATRIX OF VALS EACH PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - END IF - END IF - ELSE IF (IAND(KPTR(14),4).NE.0) THEN -C COMPLEX/SECOND ORDER PACKING -C PRINT *,' WITH COMPLEX/SECOND ORDER PACKING' - IF (IAND(KPTR(14),1).EQ.0) THEN -C PRINT *,' WITH NO ADDITIONAL FLAGS' - ELSE IF (IAND(KPTR(14),1).NE.0) THEN -C PRINT *,' WITH ADDITIONAL FLAGS' - IF (KBDS(17).EQ.0) THEN -C PRINT *,' SINGLE DATUM EACH GRID PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - ELSE IF (KBDS(17).NE.0) THEN -C PRINT *,' MATRIX OF VALS EACH PT' - IF (KBDS(14).EQ.0) THEN -C PRINT *,' NO SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - ELSE IF (KBDS(14).NE.0) THEN -C PRINT *,' SEC BIT MAP' - IF (KBDS(16).EQ.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES CONSTANT WIDTH' - ELSE IF (KBDS(16).NE.0) THEN -C PRINT *,' SECOND ORDER', -C * ' VALUES DIFFERENT WIDTHS' - END IF - END IF - END IF - END IF - END IF - END IF - IF(ALLOCATED(KSAVE)) DEALLOCATE(KSAVE) -C PRINT *,' NOT PROCESSED - NOT PROCESSED - NOT PROCESSED' - KRET = 11 - RETURN - 4000 CONTINUE -C **************************************************************** -C -C GRID POINT DATA, SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS -C - SCAL10 = 10.0 ** KPDS(22) - SCAL10 = 1.0 / SCAL10 - IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24.OR.KPDS(3).EQ.26. - * OR.KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN - IF (KPDS(3).EQ.26) THEN - KADD = 72 - ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN - KADD = 91 - ELSE - KADD = 37 - END IF - CALL GBYTESC (MSGA,KSAVE,KPTR(8),KBITS,0,KNR) - KPTR(8) = KPTR(8) + KBITS * KNR - II = 1 - KENTRY = KPTR(10) - DO 4001 I = 1, KENTRY - IF (KBMS(I)) THEN - DATA(I) = (REFNCE+FLOAT(KSAVE(II))*SCALE)*SCAL10 - II = II + 1 - ELSE - DATA(I) = 0.0 - END IF - 4001 CONTINUE - DO 4002 I = 2, KADD - DATA(I) = DATA(1) - 4002 CONTINUE - ELSE IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22.OR.KPDS(3).EQ.25. - * OR.KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN - CALL GBYTESC (MSGA,KSAVE,KPTR(8),KBITS,0,KNR) - II = 1 - KENTRY = KPTR(10) - DO 4011 I = 1, KENTRY - IF (KBMS(I)) THEN - DATA(I) = (REFNCE + FLOAT(KSAVE(II)) * SCALE) * SCAL10 - II = II + 1 - ELSE - DATA(I) = 0.0 - END IF - 4011 CONTINUE - IF (KPDS(3).EQ.25) THEN - KADD = 71 - ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN - KADD = 90 - ELSE - KADD = 36 - END IF - LASTP = KENTRY - KADD - DO 4012 I = LASTP+1, KENTRY - DATA(I) = DATA(LASTP) - 4012 CONTINUE - ELSE - CALL GBYTESC (MSGA,KSAVE,KPTR(8),KBITS,0,KNR) - II = 1 - KENTRY = KPTR(10) - DO 500 I = 1, KENTRY - IF (KBMS(I)) THEN - DATA(I) = (REFNCE + FLOAT(KSAVE(II)) * SCALE) * SCAL10 - II = II + 1 - ELSE - DATA(I) = 0.0 - END IF - 500 CONTINUE - END IF - GO TO 900 -C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS, -C SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS - 5000 CONTINUE -C PRINT *,'CHECK POINT SPECTRAL COEFF' - KPTR(8) = IBYT12 -C CALL GBYTE (MSGA,KKK,KPTR(8),32) - call gbytec(MSGA,JSGN,KPTR(8),1) - call gbytec(MSGA,JEXP,KPTR(8)+1,7) - call gbytec(MSGA,IFR,KPTR(8)+8,24) - KPTR(8) = KPTR(8) + 32 -C -C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT -C TO THE FLOATING POINT USED ON YOUR MACHINE. -C - IF (IFR.EQ.0) THEN - REALKK = 0.0 - ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN - REALKK = 0.0 - ELSE - REALKK = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) - IF (JSGN.NE.0) REALKK = -REALKK - END IF - DATA(1) = REALKK - CALL GBYTESC (MSGA,KSAVE,KPTR(8),KBITS,0,KNR) -C -------------- - DO 6000 I = 1, KENTRY - DATA(I+1) = REFNCE + FLOAT(KSAVE(I)) * SCALE - 6000 CONTINUE - 900 CONTINUE - IF(ALLOCATED(KSAVE)) DEALLOCATE(KSAVE) -C PRINT *,'EXIT FI635' - RETURN - END - SUBROUTINE FI636 (DATA,MSGA,KBMS,REFNCE,KPTR,KPDS,KGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI636 PROCESS SECOND ORDER PACKING -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 92-09-22 -C -C ABSTRACT: PROCESS SECOND ORDER PACKING FROM THE BINARY DATA SECTION -C (BDS) FOR SINGLE DATA ITEMS GRID POINT DATA -C -C PROGRAM HISTORY LOG: -C 93-06-08 CAVANAUGH -C 93-12-15 CAVANAUGH MODIFIED SECOND ORDER POINTERS TO FIRST ORDER -C VALUES AND SECOND ORDER VALUES CORRECTLY. -C 95-04-26 R.E.JONES FI636 CORECTION FOR 2ND ORDER COMPLEX -C UNPACKING. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI636 (DATA,MSGA,KBMS,REFNCE,KPTR,KPDS,KGDS) -C INPUT ARGUMENT LIST: -C -C MSGA - ARRAY CONTAINING GRIB MESSAGE -C REFNCE - REFERENCE VALUE -C KPTR - WORK ARRAY -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C DATA - LOCATION OF OUTPUT ARRAY -C WORKING ARRAY -C KBDS(1) - N1 -C KBDS(2) - N2 -C KBDS(3) - P1 -C KBDS(4) - P2 -C KBDS(5) - BIT POINTER TO 2ND ORDER WIDTHS -C KBDS(6) - " " " " " BIT MAPS -C KBDS(7) - " " " FIRST ORDER VALUES -C KBDS(8) - " " " SECOND ORDER VALUES -C KBDS(9) - " " START OF BDS -C KBDS(10) - " " MAIN BIT MAP -C KBDS(11) - BINARY SCALING -C KBDS(12) - DECIMAL SCALING -C KBDS(13) - BIT WIDTH OF FIRST ORDER VALUES -C KBDS(14) - BIT MAP FLAG -C 0 = NO SECOND ORDER BIT MAP -C 1 = SECOND ORDER BIT MAP PRESENT -C KBDS(15) - SECOND ORDER BIT WIDTH -C KBDS(16) - CONSTANT / DIFFERENT WIDTHS -C 0 = CONSTANT WIDTHS -C 1 = DIFFERENT WIDTHS -C KBDS(17) - SINGLE DATUM / MATRIX -C 0 = SINGLE DATUM AT EACH GRID POINT -C 1 = MATRIX OF VALUES AT EACH GRID POINT -C (18-20)- UNUSED -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS, CRAY -C -C$$$ - REAL DATA(*) - REAL REFN - REAL REFNCE -C - INTEGER KBDS(20) - INTEGER KPTR(*) - character(len=1) BMAP2(1000000) - INTEGER I,IBDS - INTEGER KBIT,IFOVAL,ISOVAL - INTEGER KPDS(*),KGDS(*) -C - LOGICAL*1 KBMS(*) -C - CHARACTER*1 MSGA(*) -C -C ******************* SETUP ****************************** -C PRINT *,'ENTER FI636' -C START OF BMS (BIT POINTER) - DO I = 1,20 - KBDS(I) = 0 - END DO -C BYTE START OF BDS - IBDS = KPTR(2) + KPTR(3) + KPTR(4) + KPTR(5) -C PRINT *,'KPTR(2-5) ',KPTR(2),KPTR(3),KPTR(4),KPTR(5) -C BIT START OF BDS - JPTR = IBDS * 8 -C PRINT *,'JPTR ',JPTR - KBDS(9) = JPTR -C PRINT *,'START OF BDS ',KBDS(9) -C BINARY SCALE VALUE BDS BYTES 5-6 - CALL GBYTEC (MSGA,ISIGN,JPTR+32,1) - CALL GBYTEC (MSGA,KBDS(11),JPTR+33,15) - IF (ISIGN.GT.0) THEN - KBDS(11) = - KBDS(11) - END IF -C PRINT *,'BINARY SCALE VALUE =',KBDS(11) -C EXTRACT REFERENCE VALUE -C CALL GBYTEC(MSGA,JREF,JPTR+48,32) - call gbytec(MSGA,JSGN,KPTR(8),1) - call gbytec(MSGA,JEXP,KPTR(8)+1,7) - call gbytec(MSGA,IFR,KPTR(8)+8,24) - IF (IFR.EQ.0) THEN - REFNCE = 0.0 - ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN - REFNCE = 0.0 - ELSE - REFNCE = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) - IF (JSGN.NE.0) REFNCE = - REFNCE - END IF -C PRINT *,'DECODED REFERENCE VALUE =',REFN,REFNCE -C F O BIT WIDTH - CALL GBYTEC(MSGA,KBDS(13),JPTR+80,8) - JPTR = JPTR + 88 -C AT START OF BDS BYTE 12 -C EXTRACT N1 - CALL GBYTEC (MSGA,KBDS(1),JPTR,16) -C PRINT *,'N1 = ',KBDS(1) - JPTR = JPTR + 16 -C EXTENDED FLAGS - CALL GBYTEC (MSGA,KFLAG,JPTR,8) -C ISOLATE BIT MAP FLAG - IF (IAND(KFLAG,32).NE.0) THEN - KBDS(14) = 1 - ELSE - KBDS(14) = 0 - END IF - IF (IAND(KFLAG,16).NE.0) THEN - KBDS(16) = 1 - ELSE - KBDS(16) = 0 - END IF - IF (IAND(KFLAG,64).NE.0) THEN - KBDS(17) = 1 - ELSE - KBDS(17) = 0 - END IF - JPTR = JPTR + 8 -C EXTRACT N2 - CALL GBYTEC (MSGA,KBDS(2),JPTR,16) -C PRINT *,'N2 = ',KBDS(2) - JPTR = JPTR + 16 -C EXTRACT P1 - CALL GBYTEC (MSGA,KBDS(3),JPTR,16) -C PRINT *,'P1 = ',KBDS(3) - JPTR = JPTR + 16 -C EXTRACT P2 - CALL GBYTEC (MSGA,KBDS(4),JPTR,16) -C PRINT *,'P2 = ',KBDS(4) - JPTR = JPTR + 16 -C SKIP RESERVED BYTE - JPTR = JPTR + 8 -C START OF SECOND ORDER BIT WIDTHS - KBDS(5) = JPTR -C COMPUTE START OF SECONDARY BIT MAP - IF (KBDS(14).NE.0) THEN -C FOR INCLUDED SECONDARY BIT MAP - JPTR = JPTR + (KBDS(3) * 8) - KBDS(6) = JPTR - ELSE -C FOR CONSTRUCTED SECONDARY BIT MAP - KBDS(6) = 0 - END IF -C CREATE POINTER TO START OF FIRST ORDER VALUES - KBDS(7) = KBDS(9) + KBDS(1) * 8 - 8 -C PRINT *,'BIT POINTER TO START OF FOVALS',KBDS(7) -C CREATE POINTER TO START OF SECOND ORDER VALUES - KBDS(8) = KBDS(9) + KBDS(2) * 8 - 8 -C PRINT *,'BIT POINTER TO START OF SOVALS',KBDS(8) -C PRINT *,'KBDS( 1) - N1 ',KBDS( 1) -C PRINT *,'KBDS( 2) - N2 ',KBDS( 2) -C PRINT *,'KBDS( 3) - P1 ',KBDS( 3) -C PRINT *,'KBDS( 4) - P2 ',KBDS( 4) -C PRINT *,'KBDS( 5) - BIT PTR - 2ND ORDER WIDTHS ',KBDS( 5) -C PRINT *,'KBDS( 6) - " " " " BIT MAPS ',KBDS( 6) -C PRINT *,'KBDS( 7) - " " F O VALS ',KBDS( 7) -C PRINT *,'KBDS( 8) - " " S O VALS ',KBDS( 8) -C PRINT *,'KBDS( 9) - " " START OF BDS ',KBDS( 9) -C PRINT *,'KBDS(10) - " " MAIN BIT MAP ',KBDS(10) -C PRINT *,'KBDS(11) - BINARY SCALING ',KBDS(11) -C PRINT *,'KPDS(22) - DECIMAL SCALING ',KPDS(22) -C PRINT *,'KBDS(13) - FO BIT WIDTH ',KBDS(13) -C PRINT *,'KBDS(14) - 2ND ORDER BIT MAP FLAG ',KBDS(14) -C PRINT *,'KBDS(15) - 2ND ORDER BIT WIDTH ',KBDS(15) -C PRINT *,'KBDS(16) - CONSTANT/DIFFERENT WIDTHS ',KBDS(16) -C PRINT *,'KBDS(17) - SINGLE DATUM/MATRIX ',KBDS(17) -C PRINT *,'REFNCE VAL ',REFNCE -C ************************* PROCESS DATA ********************** - IJ = 0 -C ======================================================== - IF (KBDS(14).EQ.0) THEN -C NO BIT MAP, MUST CONSTRUCT ONE - IF (KGDS(2).EQ.65535) THEN - IF (KGDS(20).EQ.255) THEN -C PRINT *,'CANNOT BE USED HERE' - ELSE -C POINT TO PL - LP = KPTR(9) + KPTR(2)*8 + KPTR(3)*8 + KGDS(20)*8 - 8 -C PRINT *,'LP = ',LP - JT = 0 - DO 2000 JZ = 1, KGDS(3) -C GET NUMBER IN CURRENT ROW - CALL GBYTEC (MSGA,NUMBER,LP,16) -C INCREMENT TO NEXT ROW NUMBER - LP = LP + 16 -C PRINT *,'NUMBER IN ROW',JZ,' = ',NUMBER - DO 1500 JQ = 1, NUMBER - IF (JQ.EQ.1) THEN - CALL SBYTEC (BMAP2,1,JT,1) - ELSE - CALL SBYTEC (BMAP2,0,JT,1) - END IF - JT = JT + 1 - 1500 CONTINUE - 2000 CONTINUE - END IF - ELSE - IF (IAND(KGDS(11),32).EQ.0) THEN -C ROW BY ROW -C PRINT *,' ROW BY ROW' - KOUT = KGDS(3) - KIN = KGDS(2) - ELSE -C COL BY COL -C PRINT *,' COL BY COL' - KIN = KGDS(3) - KOUT = KGDS(2) - END IF -C PRINT *,'KIN=',KIN,' KOUT= ',KOUT - DO 200 I = 1, KOUT - DO 150 J = 1, KIN - IF (J.EQ.1) THEN - CALL SBYTEC (BMAP2,1,IJ,1) - ELSE - CALL SBYTEC (BMAP2,0,IJ,1) - END IF - IJ = IJ + 1 - 150 CONTINUE - 200 CONTINUE - END IF - END IF -C ======================================================== -C PRINT 99,(BMAP2(J),J=1,110) -C99 FORMAT ( 10(1X,Z8.8)) -C CALL BINARY (BMAP2,2) -C FOR EACH GRID POINT ENTRY -C - SCALE2 = 2.0**KBDS(11) - SCAL10 = 10.0**KPDS(22) -C PRINT *,'SCALE VALUES - ',SCALE2,SCAL10 - DO 1000 I = 1, KPTR(10) -C GET NEXT MASTER BIT MAP BIT POSITION -C IF NEXT MASTER BIT MAP BIT POSITION IS 'ON' (1) - IF (KBMS(I)) THEN -C WRITE(6,900)I,KBMS(I) -C 900 FORMAT (1X,I4,3X,14HMAIN BIT IS ON,3X,L4) - IF (KBDS(14).NE.0) THEN - CALL GBYTEC (MSGA,KBIT,KBDS(6),1) - ELSE - CALL GBYTEC (BMAP2,KBIT,KBDS(6),1) - END IF -C PRINT *,'KBDS(6) =',KBDS(6),' KBIT =',KBIT - KBDS(6) = KBDS(6) + 1 - IF (KBIT.NE.0) THEN -C PRINT *,' SOB ON' -C GET NEXT FIRST ORDER PACKED VALUE - CALL GBYTEC (MSGA,IFOVAL,KBDS(7),KBDS(13)) - KBDS(7) = KBDS(7) + KBDS(13) -C PRINT *,'FOVAL =',IFOVAL -C GET SECOND ORDER BIT WIDTH - CALL GBYTEC (MSGA,KBDS(15),KBDS(5),8) - KBDS(5) = KBDS(5) + 8 -C PRINT *,KBDS(7)-KBDS(13),' FOVAL =',IFOVAL,' KBDS(5)=', -C * ,KBDS(5), 'ISOWID =',KBDS(15) - ELSE -C PRINT *,' SOB NOT ON' - END IF - ISOVAL = 0 - IF (KBDS(15).EQ.0) THEN -C IF SECOND ORDER BIT WIDTH = 0 -C THEN SECOND ORDER VALUE IS 0 -C SO CALCULATE DATA VALUE FOR THIS POINT -C DATA(I) = (REFNCE + (FLOAT(IFOVAL) * SCALE2)) / SCAL10 - ELSE - CALL GBYTEC (MSGA,ISOVAL,KBDS(8),KBDS(15)) - KBDS(8) = KBDS(8) + KBDS(15) - END IF - DATA(I) = (REFNCE + (FLOAT(IFOVAL + ISOVAL) * - * SCALE2)) / SCAL10 -C PRINT *,I,DATA(I),REFNCE,IFOVAL,ISOVAL,SCALE2,SCAL10 - ELSE -C WRITE(6,901) I,KBMS(I) -C 901 FORMAT (1X,I4,3X,15HMAIN BIT NOT ON,3X,L4) - DATA(I) = 0.0 - END IF -C PRINT *,I,DATA(I),IFOVAL,ISOVAL,KBDS(5),KBDS(15) - 1000 CONTINUE -C ************************************************************** -C PRINT *,'EXIT FI636' - RETURN - END - SUBROUTINE FI637(J,KPDS,KGDS,KRET) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI637 GRIB GRID/SIZE TEST -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 -C -C ABSTRACT: TO TEST WHEN GDS IS AVAILABLE TO SEE IF SIZE MISMATCH -C ON EXISTING GRIDS (BY CENTER) IS INDICATED -C -C PROGRAM HISTORY LOG: -C 91-09-13 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 97-02-12 W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING -C 98-06-17 IREDELL REMOVED ALTERNATE RETURN -C 99-01-20 BALDWIN MODIFY TO HANDLE GRID 237 -C 09-05-21 VUONG MODIFY TO HANDLE GRID 45 -C -C USAGE: CALL FI637(J,KPDS,KGDS,KRET) -C INPUT ARGUMENT LIST: -C J - SIZE FOR INDICATED GRID -C KPDS - -C KGDS - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C J - SIZE FOR INDICATED GRID MODIFIED FOR ECMWF-US 2 -C KRET - ERROR RETURN -C (A MISMATCH WAS DETECTED IF KRET IS NOT ZERO) -C -C REMARKS: -C KRET - -C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS -C -C$$$ - INTEGER KPDS(*) - INTEGER KGDS(*) - INTEGER J - INTEGER I -C --------------------------------------- -C --------------------------------------- -C IF GDS NOT INDICATED, RETURN -C ---------------------------------------- - KRET=0 - IF (IAND(KPDS(4),128).EQ.0) RETURN -C --------------------------------------- -C GDS IS INDICATED, PROCEED WITH TESTING -C --------------------------------------- - IF (KGDS(2).EQ.65535) THEN - RETURN - END IF - KRET=1 - I = KGDS(2) * KGDS(3) -C --------------------------------------- -C INTERNATIONAL SET -C --------------------------------------- - IF (KPDS(3).GE.21.AND.KPDS(3).LE.26) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.50) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN - IF (I.NE.J) THEN - RETURN - END IF -C --------------------------------------- -C TEST ECMWF CONTENT -C --------------------------------------- - ELSE IF (KPDS(1).EQ.98) THEN - KRET = 9 - IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN - IF (I.NE.J) THEN - IF (KPDS(3) .NE. 2) THEN - RETURN - ELSEIF (I .NE. 10512) THEN ! Test for US Grid 2 - RETURN - END IF - J = I ! Set to US Grid 2, 2.5 Global - END IF - ELSE - KRET = 5 - RETURN - END IF -C --------------------------------------- -C U.K. MET OFFICE, BRACKNELL -C --------------------------------------- - ELSE IF (KPDS(1).EQ.74) THEN - KRET = 9 - IF (KPDS(3).GE.25.AND.KPDS(3).LE.26) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE - KRET = 5 - RETURN - END IF -C --------------------------------------- -C CANADA -C --------------------------------------- - ELSE IF (KPDS(1).EQ.54) THEN -C PRINT *,' NO CURRENT LISTING OF CANADIAN GRIDS' - RETURN -C --------------------------------------- -C JAPAN METEOROLOGICAL AGENCY -C --------------------------------------- - ELSE IF (KPDS(1).EQ.34) THEN -C PRINT *,' NO CURRENT LISTING OF JMA GRIDS' - RETURN -C --------------------------------------- -C NAVY - FNOC -C --------------------------------------- - ELSE IF (KPDS(1).EQ.58) THEN - IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.220.AND.KPDS(3).LE.221) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.223) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE - KRET = 5 - RETURN - END IF -C --------------------------------------- -C U.S. GRIDS -C --------------------------------------- - ELSE IF (KPDS(1).EQ.7) THEN - KRET = 9 - IF (KPDS(3).GE.1.AND.KPDS(3).LE.6) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.8) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.10) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.11.AND.KPDS(3).LE.18) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.27.AND.KPDS(3).LE.30) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.33.AND.KPDS(3).LE.34) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.45) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.53) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.55.AND.KPDS(3).LE.56) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.67.AND.KPDS(3).LE.77) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.85.AND.KPDS(3).LE.88) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.90.AND.KPDS(3).LE.99) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.100.OR.KPDS(3).EQ.101) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.103.AND.KPDS(3).LE.107) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.110) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.120) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.122.AND.KPDS(3).LE.130) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.132) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.138) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.139) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.140) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.145.AND.KPDS(3).LE.148) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.150.OR.KPDS(3).EQ.151) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.160.OR.KPDS(3).EQ.161) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.163) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.170.AND.KPDS(3).LE.176) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.179.AND.KPDS(3).LE.184) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.187) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.188) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.189) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).EQ.190.OR.KPDS(3).EQ.192) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.193.AND.KPDS(3).LE.199) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE IF (KPDS(3).GE.200.AND.KPDS(3).LE.254) THEN - IF (I.NE.J) THEN - RETURN - END IF - ELSE - KRET = 5 - RETURN - END IF - ELSE - KRET = 10 - RETURN - END IF -C ------------------------------------ -C NORMAL EXIT -C ------------------------------------ - KRET = 0 - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi64.f b/external/w3nco/v2.0.6/src/w3fi64.f deleted file mode 100644 index 2c7f1aca..00000000 --- a/external/w3nco/v2.0.6/src/w3fi64.f +++ /dev/null @@ -1,760 +0,0 @@ - SUBROUTINE W3FI64(COCBUF,LOCRPT,NEXT) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI64 NMC OFFICE NOTE 29 REPORT UNPACKER -C PRGMMR: KEYSER ORG: NMC22 DATE:92-08-06 -C -C ABSTRACT: UNPACKS AN ARRAY OF UPPER-AIR REPORTS THAT ARE PACKED IN -C THE FORMAT DESCRIBED BY NMC OFFICE NOTE 29, OR UNPACKS AN ARRAY -C OF SURFACE REPORTS THAT ARE PACKED IN THE FORMAT DESCRIBED BY NMC -C OFFICE NOTE 124. INPUT CHARACTER DATA ARE CONVERTED TO INTEGER, -C REAL OR CHARACTER TYPE AS SPECIFIED IN THE CATEGORY TABLES BELOW. -C MISSING INTEGER DATA ARE REPLACED WITH 99999, MISSING REAL DATA -C ARE REPLACED WITH 99999.0 AND MISSING CHARACTER DATA ARE REPLACED -C WITH BLANKS. THIS LIBRARY IS SIMILAR TO W3AI02 EXCEPT W3AI02 -C WAS WRITTEN IN ASSEMBLER AND COULD NOT HANDLE INTERNAL READ ERRORS -C (PROGRAM CALLING W3AI02 WOULD FAIL IN THIS CASE W/O EXPLANATION). -C -C PROGRAM HISTORY LOG: -C 90-01-?? L. MARX, UNIV. OF MD -- CONVERTED CODE FROM ASSEMBLER -C TO VS FORTRAN; EXPANDED ERROR RETURN CODES IN 'NEXT' -C 91-07-22 D. A. KEYSER, NMC22 -- USE SAME ARGUMENTS AS W3AI02; -C STREAMLINED CODE; DOCBLOCKED AND COMMENTED; DIAG- -C NOSTIC PRINT FOR ERRORS; ATTEMPTS TO SKIP TO NEXT -C REPORT IN SAME RECORD RATHER THAN EXITING RECORD -C 91-08-12 D. A. KEYSER, NMC22 -- SLIGHT CHANGES TO MAKE SUB- -C PROGRAM MORE PORTABLE; TEST FOR ABSENCE OF END- -C OF-RECORD INDICATOR, WILL GRACEFULLY EXIT RECORD -C 92-06-29 D. A. KEYSER W/NMC22 -- CONVERT TO CRAY CFT77 FORTRAN -C 92-08-06 D. A. KEYSER, NMC22 -- CORRECTED ERROR WHICH COULD -C LEAD TO THE LENGTH FOR A CONCATENATION OPERATOR -C BEING LESS THAN 1 WHEN AN INPUT PARAMETER SPANS -C ACROSS TWO 10-CHARACTER WORDS -C -C USAGE: CALL W3FI64(COCBUF,LOCRPT,NEXT) -C INPUT ARGUMENT LIST: -C COCBUF - CHARACTER*10 ARRAY CONTAINING A BLOCK OF PACKED -C - REPORTS IN NMC OFFICE NOTE 29/124 FORMAT. -C NEXT - MARKER INDICATING RELATIVE LOCATION (IN BYTES) OF -C - END OF LAST REPORT IN COCBUF. EXCEPTION: NEXT MUST -C - BE SET TO ZERO PRIOR TO UNPACKING THE FIRST REPORT OF -C - A NEW BLOCK OF REPORTS. SUBSEQUENTLY, THE VALUE OF -C - NEXT RETURNED BY THE PREVIOUS CALL TO W3FI64 SHOULD -C - BE USED AS INPUT. (SEE OUTPUT ARGUMENT LIST BELOW.) -C - IF NEXT IS NEGATIVE, W3FI64 WILL RETURN IMMEDIATELY -C - WITHOUT ACTION. -C -C OUTPUT ARGUMENT LIST: -C LOCRPT - ARRAY CONTAINING ONE UNPACKED REPORT WITH POINTERS -C - AND COUNTERS TO DIRECT THE USER. LOCRPT MUST BEGIN -C - ON A FULLWORD BOUNDARY. FORMAT IS MIXED, USER MUST -C - EQUIVALENCE REAL AND CHARACTER ARRAYS TO THIS ARRAY -C - (SEE BELOW AND REMARKS FOR CONTENT). -C *************************************************************** -C WORD CONTENT UNIT FORMAT -C ---- ---------------------- ------------------- --------- -C 1 LATITUDE 0.01 DEGREES REAL -C 2 LONGITUDE 0.01 DEGREES WEST REAL -C 3 UNUSED -C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL -C 5 RESERVED (3RD BYTE IS 4-CHARACTERS CHAR*8 -C ON29 "25'TH CHAR.; 4TH LEFT-JUSTIFIED -C BYTE IS ON29 "26'TH -C CHAR." (SEE ON29) -C 6 RESERVED (3RD BYTE IS 3-CHARACTERS CHAR*8 -C ON29 "27'TH CHAR. (SEE LEFT-JUSTIFIED -C ON29) -C 7 STATION ELEVATION METERS REAL -C 8 INSTRUMENT TYPE ON29 TABLE R.2 INTEGER -C 9 REPORT TYPE ON29 TABLE R.1 OR INTEGER -C ON124 TABLE S.3 -C 10 UNUNSED -C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHAR*8 -C LEFT-JUSTIFIED -C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHAR*8 -C LEFT-JUSTIFIED -C -C 13 CATEGORY 1, NO. LEVELS COUNT INTEGER -C 14 CATEGORY 1, DATA INDEX COUNT INTEGER -C 15 CATEGORY 2, NO. LEVELS COUNT INTEGER -C 16 CATEGORY 2, DATA INDEX COUNT INTEGER -C 17 CATEGORY 3, NO. LEVELS COUNT INTEGER -C 18 CATEGORY 3, DATA INDEX COUNT INTEGER -C 19 CATEGORY 4, NO. LEVELS COUNT INTEGER -C 20 CATEGORY 4, DATA INDEX COUNT INTEGER -C 21 CATEGORY 5, NO. LEVELS COUNT INTEGER -C 22 CATEGORY 5, DATA INDEX COUNT INTEGER -C 23 CATEGORY 6, NO. LEVELS COUNT INTEGER -C 24 CATEGORY 6, DATA INDEX COUNT INTEGER -C 25 CATEGORY 7, NO. LEVELS COUNT INTEGER -C 26 CATEGORY 7, DATA INDEX COUNT INTEGER -C 27 CATEGORY 8, NO. LEVELS COUNT INTEGER -C 28 CATEGORY 8, DATA INDEX COUNT INTEGER -C 29 CATEGORY 51, NO. LEVELS COUNT INTEGER -C 30 CATEGORY 51, DATA INDEX COUNT INTEGER -C 31 CATEGORY 52, NO. LEVELS COUNT INTEGER -C 32 CATEGORY 52, DATA INDEX COUNT INTEGER -C 33 CATEGORY 9, NO. LEVELS COUNT INTEGER -C 34 CATEGORY 9, DATA INDEX COUNT INTEGER -C 35-42 ZEROED OUT - NOT USED INTEGER -C -C 43-END UNPACKED DATA GROUPS (SEE REMARKS) MIXED -C *************************************************************** -C -C NEXT - MARKER INDICATING RELATIVE LOCATION (IN BYTES) -C - OF END OF CURRENT REPORT IN COCBUF. NEXT WILL BE -C - SET TO -1 IF W3FI64 ENCOUNTERS STRING 'END RECORD' -C - IN PLACE OF THE NEXT REPORT. THIS IS THE END OF THE -C - BLOCK. NO UNPACKING TAKES PLACE. NEXT IS SET TO-2 -C - WHEN INTERNAL (LOGIC) ERRORS HAVE BEEN DETECTED. -C - NEXT IS SET TO -3 WHEN DATA COUNT CHECK FAILS. IN -C - BOTH OF THE LATTER CASES SOME DATA (E.G., HEADER -C - INFORMATION) MAY BE UNPACKED INTO LOCRPT. -C -C OUTPUT FILES: -C FT06F001 - PRINTOUT -C -C REMARKS: AFTER FIRST READING AND PROCESSING THE OFFICE NOTE 85 -C (FIRST) DATE RECORD, THE USER'S FORTRAN PROGRAM BEGINS A READ -C LOOP AS FOLLOWS.. FOR EACH ITERATION A BLOCKED INPUT REPORT IS -C READ INTO ARRAY COCBUF. NOW TEST THE FIRST TEN CHARACTERS IN -C COCBUF FOR THE STRING 'ENDOF FILE' (SIC). THIS STRING SIGNALS -C THE END OF INPUT. OTHERWISE, SET THE MARKER 'NEXT' TO ZERO AND -C BEGIN THE UNPACKING LOOP. -C EACH ITERATION OF THE UNPACKING LOOP CONSISTS OF A CALL TO -C W3FI64 WITH THE CURRENT VALUE OF 'NEXT'. IF 'NEXT' IS -1 UPON -C RETURNING FROM W3FI64, IT HAS REACHED THE END OF THE INPUT -C RECORD, AND THE USER'S PROGRAM SHOULD READ THE NEXT RECORD AS -C ABOVE. IF 'NEXT' IS -2 OR -3 UPON RETURNING, THERE IS A GRIEVOUS -C ERROR IN THE CURRENT PACKED INPUT RECORD, AND THE USER'S PROGRAM -C SHOULD PRINT IT FOR EXAMINATION BY AUTOMATION DIVISION PERSONNEL. -C IF 'NEXT' IS POSITIVE, THE OUTPUT STRUCTURE LOCRPT CONTAINS -C AN UNPACKED REPORT, AND THE USER'S PROGRAM SHOULD PROCESS IT AT -C THIS POINT, SUBSEQUENTLY REPEATING THE UNPACKING LOOP. -C -C EXAMPLE: -C CHARACTER*10 COCBUF(644) -C CHARACTER*8 COCRPT(1608) -C CHARACTER*3 CQUMAN(20) -C INTEGER LOCRPT(1608) -C REAL ROCRPT(1608),GEOMAN(20),TMPMAN(20),DPDMAN(20), -C $ WDRMAN(20),WSPMAN(20) -C EQUIVALENCE (COCRPT,LOCRPT,ROCRPT) -C .......... -C C READ AND PROCESS THE OFFICE NOTE 85 DATE RECORD -C .......... -C C --- BEGIN READ LOOP -C 10 CONTINUE -C READ (UNIT=INP, IOSTAT=IOS, NUM=NBUF) COCBUF -C IF(IOS .LT. 0) GO TO (END OF INPUT) -C IF(IOS .GT. 0) GO TO (INPUT ERROR) -C IF(NBUF .GT. 6432) GO TO (BUFFER OVERFLOW) -C IF(COCBUF(1).EQ.'ENDOF FILE') GO TO (END OF INPUT) -C NEXT = 0 -C C ------ BEGIN UNPACKING LOOP -C 20 CONTINUE -C CALL W3FI64(COCBUF, LOCRPT, NEXT) -C IF(NEXT .EQ. -1) GO TO 10 -C IF(NEXT .LT. -1) GO TO (OFFICE NOTE 29/124 ERROR) -C RLAT = 0.01 * ROCRPT(1) (LATITUDE) -C ..... ETC ..... -C C --- BEGIN CATEGORY 1 FETCH -- MANDATORY LEVEL DATA -C IF(LOCRPT(13) .GT. 0) THEN -C NLVLS = MIN(20,LOCRPT(13)) -C INDX = LOCRPT(14) -C DO 66 I = 1,NLVLS -C GEOMAN(I) = ROCRPT(INDX) -C TMPMAN(I) = 0.1 * ROCRPT(INDX+1) -C DPDMAN(I) = 0.1 * ROCRPT(INDX+2) -C WDRMAN(I) = ROCRPT(INDX+3) -C WSPMAN(I) = ROCRPT(INDX+4) -C CQUMAN(I) = COCRPT(INDX+5) -C INDX = INDX + 6 -C 66 CONTINUE -C END IF -C ..... ETC ..... -C GO TO 20 -C ............... -C -C DATA FROM THE ON29/124 RECORD IS UNPACKED INTO FIXED LOCATIONS -C IN WORDS 1-12 AND INTO INDEXED LOCATIONS IN WORD 43 AND -C FOLLOWING. STUDY ON29 APPENDIX C/ON124 APPENDIX S.2 CAREFULLY. -C EACH CATEGORY (OR GROUP OF FIELDS) IN THE PACKED REPORT HAS A -C CORRESPONDING LAYOUT IN LOCATIONS IN ARRAY LOCRPT THAT MAY BE -C FOUND BY USING THE CORRESPONDING INDEX AMOUNT FROM WORDS 14, 16, -C ..., 34, IN ARRAY LOCRPT. FOR INSTANCE, IF A REPORT CONTAINS -C ONE OR MORE PACKED CATEGORY 3 DATA GROUPS (WIND DATA AT VARIABLE -C PRESSURE LEVELS) THAT DATA WILL BE UNPACKED INTO BINARY AND -C AND CHARACTER FIELDS IN ONE OR MORE UNPACKED CATEGORY 3 DATA -C GROUPS AS DESCRIBED BELOW. THE NUMBER OF LEVELS WILL BE STORED -C IN WORD 17 AND THE INDEX IN FULLWORDS OF THE FIRST LEVEL OF -C UNPACKED DATA IN THE OUTPUT ARRAY WILL BE STORED IN WORD 18. -C THE SECOND LEVEL, IF ANY, WILL BE STORED BEGINNING FOUR WORDS -C FURTHER ON, AND SO FORTH UNTIL THE COUNT IN WORD 17 IS -C EXHAUSTED. THE FIELD LAYOUT IN EACH CATEGORY IS GIVEN BELOW... -C -C CATEGORY 1 - MANDATORY LEVEL DATA -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 GEOPOTENTIAL METERS REAL -C 2 TEMPERATURE 0.1 DEGREES C REAL -C 3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL -C 4 WIND DIRECTION DEGREES REAL -C 5 WIND SPEED KNOTS REAL -C 6 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C GEOPOTENTIAL ON29 TABLE Q.A -C TEMPERATURE ON29 TABLE Q.A -C DEWPOINT DEPR. ON29 TABLE Q.C -C WIND ON29 TABLE Q.A -C -C CATEGORY 2 - TEMPERATURE AT VARIABLE PRESSURE -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 PRESSURE 0.1 MILLIBARS REAL -C 2 TEMPERATURE 0.1 DEGREES C REAL -C 3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL -C 4 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C PRESSURE ON29 TABLE Q.B -C TEMPERATURE ON29 TABLE Q.A -C DEWPOINT DEPR. ON29 TABLE Q.C -C NOT USED BLANK -C -C CATEGORY 3 - WINDS AT VARIABLE PRESSURE -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 PRESSURE 0.1 MILLIBARS REAL -C 2 WIND DIRECTION DEGREES REAL -C 3 WIND SPEED KNOTS REAL -C 4 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C PRESSURE ON29 TABLE Q.B -C WIND ON29 TABLE Q.A -C NOT USED BLANK -C NOT USED BLANK -C -C CATEGORY 4 - WINDS AT VARIABLE HEIGHTS -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 GEOPOTENTIAL METERS REAL -C 2 WIND DIRECTION DEGREES REAL -C 3 WIND SPEED KNOTS REAL -C 4 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C GEOPOTENTIAL ON29 TABLE Q.B -C WIND ON29 TABLE Q.A -C NOT USED BLANK -C NOT USED BLANK -C -C CATEGORY 5 - TROPOPAUSE DATA -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 GEOPOTENTIAL METERS REAL -C 2 TEMPERATURE 0.1 DEGREES C REAL -C 3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL -C 4 WIND DIRECTION DEGREES REAL -C 5 WIND SPEED KNOTS REAL -C 6 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C PRESSURE ON29 TABLE Q.B -C TEMPERATURE ON29 TABLE Q.A -C DEWPOINT DEPR. ON29 TABLE Q.C -C WIND ON29 TABLE Q.A -C -C CATEGORY 6 - CONSTANT-LEVEL DATA (AIRCRAFT, SAT. CLOUD-DRIFT) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 PRESSURE ALTITUDE METERS REAL -C 2 TEMPERATURE 0.1 DEGREES C REAL -C 3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL -C 4 WIND DIRECTION DEGREES REAL -C 5 WIND SPEED KNOTS REAL -C 6 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C PRESSURE ON29 TABLE Q.6 -C TEMPERATURE ON29 TABLE Q.6 -C DEWPOINT DEPR. ON29 TABLE Q.6 -C WIND ON29 TABLE Q.6C -C -C CATEGORY 7 - CLOUD COVER -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 PRESSURE 0.1 MILLIBARS REAL -C 2 AMOUNT OF CLOUDS PER CENT REAL -C 3 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C PRESSURE ON29 TABLE Q.7 -C CLOUD AMOUNT ON29 TABLE Q.7 -C NOT USED BLANK -C NOT USED BLANK -C -C CATEGORY 8 - ADDITIONAL DATA -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 SPECIFIED IN ON29 VARIABLE REAL -C TABLE 101.1 OR -C ON124 TABLE SM.8A.1 -C 2 FORM OF ADD'L DATA CODE FIGURE FROM REAL -C ON29 TABLE 101 OR -C ON124 TABLE SM.8A -C 3 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C VALUE 1 ON29 TABLE Q.8 OR -C ON124 TABLE SM.8B -C VALUE 2 ON29 TABLE Q.8A OR -C ON124 TABLE SM.8C -C NOT USED BLANK -C NOT USED BLANK -C -C CATEGORY 51 - SURFACE DATA -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 SEA-LEVEL PRESSURE 0.1 MILLIBARS REAL -C 2 STATION PRESSURE 0.1 MILLIBARS REAL -C 3 WIND DIRECTION DEGREES REAL -C 4 WIND SPEED KNOTS REAL -C 5 AIR TEMPERATURE 0.1 DEGREES C REAL -C 6 DEWPOINT DEPRESSION 0.1 DEGREES C REAL -C 7 MAXIMUM TEMPERATURE 0.1 DEGREES C REAL -C 8 MINIMUM TEMPERATURE 0.1 DEGREES C REAL -C 9 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C S-LEVEL PRESS. ON124 TABLE SM.51 -C STATION PRESS. ON124 TABLE SM.51 -C WIND ON124 TABLE SM.51 -C AIR TEMPERATURE ON124 TABLE SM.51 -C 10 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8 -C LEFT-JUSTIFIED -C DEWPOINT DEPR. ON124 TABLE SM.51 -C NOT USED BLANK -C NOT USED BLANK -C NOT USED BLANK -C 11 HORIZ. VISIBILITY WMO CODE TABLE 4300 INTEGER -C 12 PRESENT WEATHER WMO CODE TABLE 4677 INTEGER -C 13 PAST WEATHER WMO CODE TABLE 4561 INTEGER -C 14 TOTAL CLOUD COVER N WMO CODE TABLE 2700 INTEGER -C 15 CLOUD COVER OF C/LN WMO CODE TABLE 2700 INTEGER -C 16 CLOUD TYPE OF C/L WMO CODE TABLE 0513 INTEGER -C 17 CLOUD HEIGHT OF C/L WMO CODE TABLE 1600 INTEGER -C 18 CLOUD TYPE OF C/M WMO CODE TABLE 0515 INTEGER -C 19 CLOUD TYPE OF C/H WMO CODE TABLE 0509 INTEGER -C 20 CHARACTERISTIC OF WMO CODE TABLE 0200 INTEGER -C 3-HR PRESS TENDENCY -C 21 AMT. PRESS TENDENCY 0.1 MILLIBARS REAL -C (50.0 WILL BE ADDED TO INDICATE 24-HR TENDENCY) -C -C CATEGORY 52 - ADDITIONAL SURFACE DATA -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 6-HR PRECIPITATION 0.01 INCH INTEGER -C 2 SNOW DEPTH INCH INTEGER -C 3 24-HR PRECIPITATION 0.01 INCH INTEGER -C 4 DURATION OF PRECIP. NO. 6-HR PERIODS INTEGER -C 5 PERIOD OF WAVES SECONDS INTEGER -C 6 HEIGHT OF WAVES 0.5 METERS INTEGER -C 7 SWELL DIRECTION WMO CODE TABLE 0877 INTEGER -C 8 SWELL PERIOD SECONDS INTEGER -C 9 SWELL HEIGHT 0.5 METERS INTEGER -C 10 SEA SFC TEMPERATURE 0.1 DEGREES C INTEGER -C 11 SPECIAL PHEN, GEN'L INTEGER -C 12 SPECIAL PHEN, DET'L INTEGER -C 13 SHIP'S COURSE WMO CODE TABLE 0700 INTEGER -C 14 SHIP'S AVERAGE SPEED WMO CODE TABLE 4451 INTEGER -C 15 WATER EQUIVALENT OF 0.01 INCH INTEGER -C SNOW AND/OR ICE -C -C CATEGORY 9 - PLAIN LANGUAGE DATA (ALPHANUMERIC TEXT) -C WORD BYTES PARAMETER FORMAT -C ---- ----- --------------------------------------- -------- -C 1 1 INDICATOR OF CONTENT (ON124 TABLE SM.9) CHAR*8 -C (1 CHARACTER) -C 2-4 PLAIN LANGUAGE DATA, TEXT CHARACTERS 1-3 -C 4-8 NOT USED (BLANK) -C 2 1-4 PLAIN LANGUAGE DATA, TEXT CHARACTERS 4-7 CHAR*8 -C 4-8 NOT USED (BLANK) -C 3 1-4 PLAIN LANGUAGE DATA, TEXT CHARACTERS 8-11 CHAR*8 -C 4-8 NOT USED (BLANK) -C -C ONE REPORT MAY UNPACK INTO MORE THAN ONE CATEGORY HAVING -C MULTIPLE LEVELS. THE UNUSED PORTION OF LOCRPT IS NOT CLEARED. -C -C NOTE: ENTRY W3AI02 DUPLICATES PROCESSING IN W3FI64 SINCE NO -C ASSEMBLY LANGUAGE CODE IN CRAY W3LIB. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - CHARACTER*12 HOLD - CHARACTER*10 COCBUF(*) - CHARACTER*7 CNINES - CHARACTER*4 COCRPT(10000),BLANK - CHARACTER*2 KAT(11) -C - INTEGER LOCRPT(*),KATGC(20,11),KATGL(20,11),KATL(11),KATO(11), - $ MOCRPT(5000) -C - REAL ROCRPT(5000) -C - EQUIVALENCE (ROCRPT,MOCRPT,COCRPT) -C - SAVE -C - DATA BLANK/' '/,CNINES/'9999999'/,IMSG/99999/,XMSG/99999./ - DATA KATL/6,4,4,4,6,6,3,3,1,20,15/,KATO/13,15,17,19,21,23,25,27, - $ 33,29,31/,IREC/2/ - DATA KAT/'01','02','03','04','05','06','07','08','09','51','52'/ - DATA KATGC/ 5*2,4,14*0, 3*2,4,16*0, 3*2,4,16*0, 3*2,4,16*0, - $ 5*2,4,14*0, 5*2,4,14*0, 2*2,4,17*0, 2*2,4,17*0, 4,19*0, - $ 8*2,4,10*1,2, 15*1,5*0/ - DATA KATGL/ 5,4,3*3,4,14*0, 5,4,2*3,16*0, 5,2*3,2,16*0, - $ 5,2*3,2,16*0, 5,4,3*3,4,14*0, 5,4,3*3,4,14*0, 5,3,2,17*0, - $ 5,3,2,17*0, 12,19*0, - $ 2*5,2*3,4,3,2*4,5,2*3,7*2,1,3, 4,3,4,1,5*2,4,2*2,1,2,7,5*0/ - DATA LWFLAG/0/ -C - ENTRY W3AI02(COCBUF,LOCRPT,NEXT) -C - IF (LWFLAG.EQ.0) THEN -C FIRST TIME CALLED, DETERMINE MACHINE WORD LG IN BYTES (=8 FOR CRAY) -C DEPENDING ON WORD SIZE LW2*I-LW1 INDEXES THRU COCRPT -C EITHER AS 1,2,3...I FOR LW = 4 OR -C AS 1,3,5..2*I-1 FOR LW = 8 <------ HERE -C NECESSITATED BY LEFT JUSTIFICATION OF EQUIVALENCE - CALL W3FI01(LW) - LW2 = LW/4 - LW1 = LW/8 - LWFLAG = 1 - END IF - 7000 CONTINUE - IF(NEXT.LT.0) RETURN - NEXTO = NEXT/10 - N = NEXT/10 + 1 -C - IF(COCBUF(N).EQ.'END RECORD'.OR.COCBUF(N).EQ.'XXXXXXXXXX') THEN -C HIT END-OF-RECORD; RETURN WITH NEXT = -1 - IF(COCBUF(N).EQ.'XXXXXXXXXX') PRINT 109, IREC - IREC = IREC + 1 - NEXT = -1 - RETURN - END IF -C INITIALIZE REPORT ID AS MISSING OR 0 FOR RESERVED WORDS - ROCRPT(1) = XMSG - ROCRPT(2) = XMSG - ROCRPT(3) = 0. - ROCRPT(4) = XMSG - COCRPT(LW2*5-LW1) = ' ' - COCRPT(LW2*6-LW1) = ' ' - ROCRPT(7) = XMSG - MOCRPT(8) = 99 - MOCRPT(9) = IMSG - MOCRPT(10) = 0. - COCRPT(LW2*11-LW1) = ' ' - COCRPT(LW2*12-LW1) = ' ' -C INITIALIZE CATEGORY WORD PAIRS AS ZEROES - DO 100 MB = 13,42 - MOCRPT(MB) = 0 - 100 CONTINUE -C WRITE OUT LATITUDE INTO WORD 1 (REAL) - M = 1 - IF(COCBUF(N)(1:5).NE.'99999') READ(COCBUF(N)(1:5),51) ROCRPT(M) -C WRITE OUT LONGITUDE INTO WORD 2 (REAL) - M = 2 - IF(COCBUF(N)(6:10).NE.'99999') READ(COCBUF(N)(6:10),51) ROCRPT(M) -C WORD 3 IS RESERVED (KEEP AS A REAL NUMBER OF 0.) -C WRITE OUT STATION ID TO WORDS 11 AND 12 (CHAR*8) -C (CHAR. 1-4 OF ID IN WORD 11, CHAR. 5-6 OF ID IN WORD 12, LEFT-JUSTIF.) - M = 11 - N = N + 1 - COCRPT(LW2*M-LW1) = COCBUF(N)(1:4) - M = 12 - COCRPT(LW2*M-LW1) = COCBUF(N)(5:6)//' ' -C WRITE OUT OBSERVATION TIME INTO WORD 4 (REAL) - M = 4 - IF(COCBUF(N)(7:10).NE.'9999') READ(COCBUF(N)(7:10),41) ROCRPT(M) -C WORD 5 IS RESERVED (CHAR*8) (4 CHARACTERS, LEFT-JUSTIF.) - M = 5 - N = N + 1 - COCRPT(LW2*M-LW1) = COCBUF(N)(3:6) -C WORD 6 IS RESERVED (CHAR*8) (3 CHARACTERS, LEFT-JUSTIF.) - M = 6 - COCRPT(LW2*M-LW1) = COCBUF(N)(1:2)//COCBUF(N)(7:7)//' ' -C WRITE OUT REPORT TYPE INTO WORD 9 (INTEGER) - M = 9 - READ(COCBUF(N)(8:10),30) MOCRPT(M) -C WRITE OUT STATION ELEVATION INTO WORD 7 (REAL) - N = N + 1 - M = 7 - IF(COCBUF(N)(1:5).NE.'99999') READ(COCBUF(N)(1:5),51) ROCRPT(M) -C WRITE OUT INSTRUMENT TYPE INTO WORD 8 (INTEGER) - M = 8 - IF(COCBUF(N)(6:7).NE.'99') READ(COCBUF(N)(6:7),20) MOCRPT(M) -C READ IN NWDS, THE TOTAL NO. OF 10-CHARACTER WORDS IN ENTIRE REPORT - READ(COCBUF(N)(8:10),30) NWDS -C 'MO' WILL BE STARTING LOCATION IN MOCRPT FOR THE DATA - MO = 43 - N = N + 1 - 700 CONTINUE - IF(COCBUF(N).EQ.'END REPORT') THEN -C----------------------------------------------------------------------- -C HAVE HIT THE END OF THE REPORT - IF(N-NEXTO.EQ.NWDS) THEN -C EVERYTHING LOOKS GOOD, RETURN WITH NEXT SET TO LAST BYTE IN REPORT - NEXT = N * 10 - ELSE -C PROBLEM, MAY EXIT WITH NEXT = -3 - NEXTX = -3 - PRINT 101, - & COCRPT(LW2*11-LW1),COCRPT(LW2*12-LW1)(1:2),N-NEXTO,NWDS - GO TO 99 - END IF - MWORDS = MO - 1 - DO 1001 I =1, MWORDS - LOCRPT(I) = MOCRPT(I) - 1001 CONTINUE - RETURN -C----------------------------------------------------------------------- - END IF -C READ IN NWDSC, THE RELATIVE POSITION IN RPT OF THE NEXT CATEGORY - READ(COCBUF(N)(3:5),30) NWDSC -C READ IN LVLS, THE NUMBER OF LEVELS IN THE CURRENT CATEGORY - READ(COCBUF(N)(6:7),20) LVLS -C DETERMINE THE CATEGORY NUMBER OF THE CURRENT CATEGORY - DO 800 NCAT = 1,11 - IF(COCBUF(N)(1:2).EQ.KAT(NCAT)) GO TO 1000 - 800 CONTINUE -C----------------------------------------------------------------------- -C PROBLEM, CAT. CODE IN INPUT NOT VALID; MAY EXIT WITH NEXT = -2 - NEXTX = -2 - PRINT 102, - $ COCRPT(LW2*11-LW1),COCRPT(LW2*12-LW1)(1:2),COCBUF(N)(1:2) - GO TO 99 -C----------------------------------------------------------------------- - 1000 CONTINUE -C 'M' IS THE WORD IN MOCRPT WHERE THE NO. OF LEVELS WILL BE WRITTEN - M = KATO(NCAT) -C WRITE THIS CATEGORY WORD PAIR OUT - MOCRPT(M) = LVLS - MOCRPT(M+1) = MO - N = N + 1 - I = 1 -C*********************************************************************** -C LOOP THROUGH ALL THE LEVELS IN THE CURRENT CATEGORY -C*********************************************************************** - DO 2000 L = 1,LVLS -C NDG IS NO. OF OUTPUT PARAMETERS PER LEVEL IN THIS CATEGORY - NDG = KATL(NCAT) -C----------------------------------------------------------------------- -C LOOP THROUGH ALL THE PARAMETERS IN THE CURRENT LEVEL -C----------------------------------------------------------------------- - DO 1800 K = 1,NDG -C 'LL' IS THE NUMBER OF INPUT CHARACTERS PER PARAMETER FOR THIS CATEGORY - LL = KATGL(K,NCAT) -C 'I' IS POINTER FOR BEGINNING BYTE IN C*10 WORD FOR NEXT PARAMETER -C 'J' IS POINTER FOR ENDING BYTE IN C*10 WORD FOR NEXT PARAMETER - J = I + LL - 1 - IF(J.GT.10) THEN -C COME HERE IF INPUT PARAMETER SPANS ACROSS TWO C*10 WORDS - HOLD(1:LL) = COCBUF(N)(I:10)//COCBUF(N+1)(1:J-10) - N = N + 1 - I = J - 9 - IF(I.GE.11) THEN - N = N + 1 - I = 1 - END IF - ELSE - HOLD(1:LL) = COCBUF(N)(I:J) - I = J + 1 - IF(I.GE.11) THEN - N = N + 1 - I = 1 - END IF - END IF -C KATGC IS AN INDICATOR FOR THE OUTPUT FORMAT OF EACH INPUT PARAMETER -C (=2 - REAL, =1 - INTEGER, =4 - CHARACTER*8) - IF(KATGC(K,NCAT).EQ.4) GO TO 1500 - IF(KATGC(K,NCAT).NE.1.AND.KATGC(K,NCAT).NE.2) THEN -C....................................................................... -C PROBLEM IN INTERNAL READ; MAY EXIT WITH NEXT = -2 - NEXTX = -2 - PRINT 104, COCRPT(LW2*11-LW1),COCRPT(LW2*12)(1:2) - GO TO 99 -C....................................................................... - END IF - IF(HOLD(1:LL).EQ.CNINES(1:LL)) THEN -C INPUT PARAMETER IS MISSING OR NOT APPLICABLE -- OUTPUT IT AS SUCH - IF(KATGC(K,NCAT).EQ.1) MOCRPT(MO) = IMSG - IF(KATGC(K,NCAT).EQ.2) ROCRPT(MO) = XMSG - GO TO 1750 - END IF - IF(LL.EQ.1) THEN -C INPUT PARAMETER CONSISTS OF ONE CHARACTER - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),10) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),11) ROCRPT(MO) - ELSE IF(LL.EQ.2) THEN -C INPUT PARAMETER CONSISTS OF TWO CHARACTERS - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),20) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),21) ROCRPT(MO) - ELSE IF(LL.EQ.3) THEN -C INPUT PARAMETER CONSISTS OF THREE CHARACTERS - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),30) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),31) ROCRPT(MO) - ELSE IF(LL.EQ.4) THEN -C INPUT PARAMETER CONSISTS OF FOUR CHARACTERS - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),40) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),41) ROCRPT(MO) - ELSE IF(LL.EQ.5) THEN -C INPUT PARAMETER CONSISTS OF FIVE CHARACTERS - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),50) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),51) ROCRPT(MO) - ELSE IF(LL.EQ.6) THEN -C INPUT PARAMETER CONSISTS OF SIX CHARACTERS - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),60) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),61) ROCRPT(MO) - ELSE IF(LL.EQ.7) THEN -C INPUT PARAMETER CONSISTS OF SEVEN CHARACTERS - IF(KATGC(K,NCAT).EQ.1) READ(HOLD(1:LL),70) MOCRPT(MO) - IF(KATGC(K,NCAT).EQ.2) READ(HOLD(1:LL),71) ROCRPT(MO) - ELSE -C....................................................................... -C INPUT PARAMETER CONSISTS OF MORE THAN SEVEN CHARACTERS (NOT PERMITTED) - NEXTX = -2 - PRINT 108, COCRPT(LW2*11-LW1),COCRPT(LW2*12-LW1)(1:2) - GO TO 99 -C....................................................................... - END IF - GO TO 1750 - 1500 CONTINUE -C....................................................................... -C OUTPUT CHARACTER (MARKER) PROCESSING COMES HERE - IF(LL.LT.4) THEN -C THERE ARE ONE, TWO OR THREE MARKERS IN THE INPUT WORD - COCRPT(LW2*MO-LW1)(1:4)=HOLD(1:LL)//BLANK(1:4-LL) - ELSE IF(LL.EQ.4) THEN -C THERE ARE FOUR MARKERS IN THE INPUT WORD - COCRPT(LW2*MO-LW1)(1:4) = HOLD(1:LL) - ELSE -C THERE ARE MORE THAN FOUR MARKERS IN THE INPUT WORD - IP = 1 - 1610 CONTINUE - JP = IP + 3 - IF(JP.LT.LL) THEN -C FILL FIRST FOUR MARKERS TO OUTPUT WORD - COCRPT(LW2*MO-LW1)(1:4) = HOLD(IP:JP) - MO = MO + 1 - IP = JP + 1 - GO TO 1610 - ELSE IF(JP.EQ.LL) THEN -C FILL FOUR REMAINING MARKERS TO NEXT OUTPUT WORD - COCRPT(LW2*MO-LW1)(1:4) = HOLD(IP:JP) - ELSE -C FILL ONE, TWO, OR THREE REMAINING MARKERS TO NEXT OUTPUT WORD - COCRPT(LW2*MO-LW1)(1:4) = HOLD(IP:LL)//BLANK(1:JP-LL) - END IF - END IF -C....................................................................... - 1750 CONTINUE - MO = MO + 1 - 1800 CONTINUE -C----------------------------------------------------------------------- - 2000 CONTINUE -C*********************************************************************** - IF(I.GT.1) N = N + 1 - IF(N-NEXTO.NE.NWDSC) THEN -C----------------------------------------------------------------------- -C PROBLEM, REL. LOCATION OF NEXT CAT. NOT WHAT'S EXPECTED; MAY EXIT -C WITH NEXT = -3 -C ERROR - RELATIVE LOCATION OF NEXT CATEGORY NOT WHAT'S EXPECTED - NEXTX = -3 - PRINT 105, COCRPT(LW2*11-LW1),COCRPT(LW2*12-LW1)(1:2), - $ KAT(NCAT),N-NEXTO-1, - $ NWDSC-1 - GO TO 99 -C----------------------------------------------------------------------- - END IF -C GO ON TO NEXT CATEGORY - GO TO 700 -C----------------------------------------------------------------------- -C ALL OF THE PROBLEM REPORTS END UP HERE -- ATTEMPT TO MOVE AHEAD TO -C NEXT REPORT, IF NOT POSSIBLE THEN EXIT WITH NEXT = -2 OR -3 MEANING -C THE REST OF THE RECORD IS BAD, GO ON TO NEXT RECORD - 99 CONTINUE - DO 98 I = 1,644 - N = N + 1 - IF(N.GT.644) GO TO 97 - IF(COCBUF(N).EQ.'END RECORD') GO TO 97 - IF(COCBUF(N).EQ.'END REPORT') THEN -C WE'VE MADE IT TO THE END OF THIS PROBLEM REPORT - START OVER WITH -C NEXT ONE - PRINT 106 - NEXT = N * 10 - GO TO 7000 - END IF - 98 CONTINUE - 97 CONTINUE -C COULDN'T GET TO THE END OF THIS PROBLEM REPORT - RETURN WITH ORIGINAL -C NEXT VALUE (-2 OR -3) MEANING USER MUST GO ON TO NEXT RECORD - NEXT = NEXTX - PRINT 107, NEXT - MWORDS = MO - 1 - DO 1002 I =1, MWORDS - LOCRPT(I) = MOCRPT(I) - 1002 CONTINUE - RETURN -C----------------------------------------------------------------------- - 10 FORMAT(I1) - 11 FORMAT(F1.0) - 20 FORMAT(I2) - 21 FORMAT(F2.0) - 30 FORMAT(I3) - 31 FORMAT(F3.0) - 40 FORMAT(I4) - 41 FORMAT(F4.0) - 50 FORMAT(I5) - 51 FORMAT(F5.0) - 60 FORMAT(I6) - 61 FORMAT(F6.0) - 70 FORMAT(I7) - 71 FORMAT(F7.0) - 101 FORMAT(/' *** W3FI64 ERROR- REPORT: ',A4,A2,'; ACTUAL NO. 10-CHAR' - $,' WORDS:',I10,' NOT EQUAL TO VALUE READ IN WITH REPORT:',I10/6X, - $ '- MAY BE DUE TO INTERNAL READ PROBLEM ASSOC. W/ EITHER ORIG. ', - $ 'PACKING OR TRANSFER OF FILE RESULTING IN UNPROCESSABLE INFO.'/6X - $,'- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ', - $ 'WILL EXIT RECORD WITH NEXT = -3'/) - 102 FORMAT(/' *** W3FI64 ERROR- REPORT: ',A4,A2,'; PACKED CATEGORY ' - $,'CODE: ',A2,' IS NOT A VALID O.N. 29 CATEGORY'/6X, - $ '- MAY BE DUE TO INTERNAL READ PROBLEM ASSOC. W/ EITHER ORIG. ', - $ 'PACKING OR TRANSFER OF FILE RESULTING IN UNPROCESSABLE INFO.'/6X - $,'- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ', - $ 'WILL EXIT RECORD WITH NEXT = -2'/) - 104 FORMAT(/' *** W3FI64 ERROR- REPORT: ',A4,A2,'; INTERNAL READ ', - $ 'PROBLEM'/6X,'- EITHER ORIGINAL PACKING OF FILE OR TRANSFER ', - $ 'OF FILE HAS RESULTED IN UNPROCESSABLE INFORMATION'/6X, - $ '- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ', - $ 'WILL EXIT RECORD WITH NEXT = -2'/) - 105 FORMAT(/' *** W3FI64 ERROR- REPORT: ',A4,A2,'; ACTUAL NO. 10-CHAR' - $,' WORDS IN CAT. ',A2,',',I10,' .NE. TO VALUE READ IN WITH ', - $ 'REPORT:',I10/6X, - $ '- MAY BE DUE TO INTERNAL READ PROBLEM ASSOC. W/ EITHER ORIG. ', - $ 'PACKING OR TRANSFER OF FILE RESULTING IN UNPROCESSABLE INFO.'/6X - $,'- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ', - $ 'WILL EXIT RECORD WITH NEXT = -3'/) - 106 FORMAT(/' +++ IT WAS POSSIBLE TO MOVE TO NEXT REPORT IN THIS ', - $ 'RECORD -- CONTINUE WITH THE UNPACKING OF THIS NEW REPORT'/) - 107 FORMAT(/' *** IT WAS NOT POSSIBLE TO MOVE TO NEXT REPORT IN THIS', - $ ' RECORD -- MUST EXIT THIS RECORD WITH NEXT =',I3/) - 108 FORMAT(/' *** W3FI64 ERROR- REPORT: ',A4,A2,'; AN INPUT ', - $ 'PARAMETER CONSISTS OF MORE THAN SEVEN CHARACTERS'/6X, - $ '- MAY BE DUE TO INTERNAL READ PROBLEM ASSOC. W/ EITHER ORIG. ', - $ 'PACKING OR TRANSFER OF FILE RESULTING IN UNPROCESSABLE INFO.'/6X - $,'- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ', - $ 'WILL EXIT RECORD WITH NEXT = -2'/) - 109 FORMAT(/' *** W3FI64 ERROR- RECORD ',I4,' DOES NOT END WITH ', - $ '"END RECORD" BUT INSTEAD CONTAINS "X" FILLERS AFTER LAST ', - $ 'REPORT IN RECORD'/6X,'- WILL EXIT RECORD WITH NEXT = -1, NO ', - $ 'REPORTS SHOULD BE LOST'/) - END diff --git a/external/w3nco/v2.0.6/src/w3fi68.f b/external/w3nco/v2.0.6/src/w3fi68.f deleted file mode 100644 index 03a7ec3b..00000000 --- a/external/w3nco/v2.0.6/src/w3fi68.f +++ /dev/null @@ -1,184 +0,0 @@ - SUBROUTINE W3FI68 (ID, PDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI68 CONVERT 25 WORD ARRAY TO GRIB PDS -C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 91-05-14 -C -C ABSTRACT: CONVERTS AN ARRAY OF 25, OR 27 INTEGER WORDS INTO A -C GRIB PRODUCT DEFINITION SECTION (PDS) OF 28 BYTES , OR 30 BYTES. -C IF PDS BYTES > 30, THEY ARE SET TO ZERO. -C -C PROGRAM HISTORY LOG: -C 91-05-08 R.E.JONES -C 92-09-25 R.E.JONES CHANGE TO 25 WORDS OF INPUT, LEVEL -C CAN BE IN TWO WORDS. (10,11) -C 93-01-08 R.E.JONES CHANGE FOR TIME RANGE INDICATOR IF 10, -C STORE TIME P1 IN PDS BYTES 19-20. -C 93-01-26 R.E.JONES CORRECTION FOR FIXED HEIGHT ABOVE -C GROUND LEVEL -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-06-24 CAVANOUGH MODIFIED PROGRAM TO ALLOW FOR GENERATION -C OF PDS GREATER THAN 28 BYTES (THE DESIRED -C PDS SIZE IS IN ID(1). -C 93-09-30 FARLEY CHANGE TO ALLOW FOR SUBCENTER ID; PUT -C ID(24) INTO PDS(26). -C 93-10-12 R.E.JONES CHANGES FOR ON388 REV. OCT 9,1993, NEW -C LEVELS 125, 200, 201. -C 94-02-23 R.E.JONES TAKE OUT SBYTES, REPLACE WITH DO LOOP -C 94-04-14 R.E.JONES CHANGES FOR ON388 REV. MAR 24,1994, NEW -C LEVELS 115,116. -C 94-12-04 R.E.JONES CHANGE TO ADD ID WORDS 26, 27 FOR PDS -C BYTES 29 AND 30. -C 95-09-07 R.E.JONES CHANGE FOR NEW LEVEL 117, 119. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-06-30 EBISUZAKI LINUX PORT -C 2001-06-05 GILBERT Changed fortran intrinsic function OR() to -C f90 standard intrinsic IOR(). -C 2003-02-25 IREDELL RECOGNIZE LEVEL TYPE 126 -C 2005-05-06 D.C.STOKES RECOGNIZE LEVEL TYPES 235, 237, 238 -C -C USAGE: CALL W3FI68 (ID, PDS) -C INPUT ARGUMENT LIST: -C ID - 25, 27 WORD INTEGER ARRAY -C OUTPUT ARGUMENT LIST: -C PDS - 28 30, OR GREATER CHARACTER PDS FOR EDITION 1 -C -C REMARKS: LAYOUT OF 'ID' ARRAY: -C ID(1) = NUMBER OF BYTES IN PRODUCT DEFINITION SECTION (PDS) -C ID(2) = PARAMETER TABLE VERSION NUMBER -C ID(3) = IDENTIFICATION OF ORIGINATING CENTER -C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER) -C ID(5) = GRID IDENTIFICATION -C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED -C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED -C ID(8) = INDICATOR OF PARAMETER AND UNITS (TABLE 2) -C ID(9) = INDICATOR OF TYPE OF LEVEL (TABLE 3) -C ID(10) = VALUE 1 OF LEVEL (0 FOR 1-100,102,103,105,107 -C 109,111,113,115,117,119,125,126,160,200,201, -C 235,237,238 -C LEVEL IS IN ID WORD 11) -C ID(11) = VALUE 2 OF LEVEL -C ID(12) = YEAR OF CENTURY -C ID(13) = MONTH OF YEAR -C ID(14) = DAY OF MONTH -C ID(15) = HOUR OF DAY -C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0) -C ID(17) = FCST TIME UNIT -C ID(18) = P1 PERIOD OF TIME -C ID(19) = P2 PERIOD OF TIME -C ID(20) = TIME RANGE INDICATOR -C ID(21) = NUMBER INCLUDED IN AVERAGE -C ID(22) = NUMBER MISSING FROM AVERAGES -C ID(23) = CENTURY (20, CHANGE TO 21 ON JAN. 1, 2001) -C ID(24) = SUBCENTER IDENTIFICATION -C ID(25) = SCALING POWER OF 10 -C ID(26) = FLAG BYTE, 8 ON/OFF FLAGS -C BIT NUMBER VALUE ID(26) DEFINITION -C 1 0 0 FULL FCST FIELD -C 1 128 FCST ERROR FIELD -C 2 0 0 ORIGINAL FCST FIELD -C 1 64 BIAS CORRECTED FCST FIELD -C 3 0 0 ORIGINAL RESOLUTION RETAINED -C 1 32 SMOOTHED FIELD -C NOTE: ID(26) CAN BE THE SUM OF BITS 1, 2, 3. -C BITS 4-8 NOT USED, SET TO ZERO -C IF ID(1) IS 28, YOU DO NOT NEED ID(26) AND ID(27). -C ID(27) = UNUSED, SET TO 0 SO PDS BYTE 30 IS SET TO ZERO. -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: SiliconGraphics 3.5 FORTRAN 77 -C MACHINE: SiliconGraphics IRIS-4D/25, 35, INDIGO, Indy -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048 -C -C$$$ -C - INTEGER ID(*) -C - CHARACTER * 1 PDS(*) -C - PDS(1) = CHAR(MOD(ID(1)/65536,256)) - PDS(2) = CHAR(MOD(ID(1)/256,256)) - PDS(3) = CHAR(MOD(ID(1),256)) - PDS(4) = CHAR(ID(2)) - PDS(5) = CHAR(ID(3)) - PDS(6) = CHAR(ID(4)) - PDS(7) = CHAR(ID(5)) - i = 0 - if (ID(6).ne.0) i = i + 128 - if (ID(7).ne.0) i = i + 64 - PDS(8) = char(i) - - PDS(9) = CHAR(ID(8)) - PDS(10) = CHAR(ID(9)) - I9 = ID(9) -C -C TEST TYPE OF LEVEL TO SEE IF LEVEL IS IN TWO -C WORDS OR ONE -C - IF ((I9.GE.1.AND.I9.LE.100).OR.I9.EQ.102.OR. - & I9.EQ.103.OR.I9.EQ.105.OR.I9.EQ.107.OR. - & I9.EQ.109.OR.I9.EQ.111.OR.I9.EQ.113.OR. - & I9.EQ.115.OR.I9.EQ.117.OR.I9.EQ.119.OR. - & I9.EQ.125.OR.I9.EQ.126.OR.I9.EQ.160.OR. - & I9.EQ.200.OR.I9.EQ.201.OR.I9.EQ.235.OR. - & I9.EQ.237.OR.I9.EQ.238) THEN - LEVEL = ID(11) - IF (LEVEL.LT.0) THEN - LEVEL = - LEVEL - LEVEL = IOR(LEVEL,32768) - END IF - PDS(11) = CHAR(MOD(LEVEL/256,256)) - PDS(12) = CHAR(MOD(LEVEL,256)) - ELSE - PDS(11) = CHAR(ID(10)) - PDS(12) = CHAR(ID(11)) - END IF - PDS(13) = CHAR(ID(12)) - PDS(14) = CHAR(ID(13)) - PDS(15) = CHAR(ID(14)) - PDS(16) = CHAR(ID(15)) - PDS(17) = CHAR(ID(16)) - PDS(18) = CHAR(ID(17)) -C -C TEST TIME RANGE INDICATOR (PDS BYTE 21) FOR 10 -C IF SO PUT TIME P1 IN PDS BYTES 19-20. -C - IF (ID(20).EQ.10) THEN - PDS(19) = CHAR(MOD(ID(18)/256,256)) - PDS(20) = CHAR(MOD(ID(18),256)) - ELSE - PDS(19) = CHAR(ID(18)) - PDS(20) = CHAR(ID(19)) - END IF - PDS(21) = CHAR(ID(20)) - PDS(22) = CHAR(MOD(ID(21)/256,256)) - PDS(23) = CHAR(MOD(ID(21),256)) - PDS(24) = CHAR(ID(22)) - PDS(25) = CHAR(ID(23)) - PDS(26) = CHAR(ID(24)) - ISCALE = ID(25) - IF (ISCALE.LT.0) THEN - ISCALE = -ISCALE - ISCALE = IOR(ISCALE,32768) - END IF - PDS(27) = CHAR(MOD(ISCALE/256,256)) - PDS(28) = CHAR(MOD(ISCALE ,256)) - IF (ID(1).GT.28) THEN - PDS(29) = CHAR(ID(26)) - PDS(30) = CHAR(ID(27)) - END IF -C -C SET PDS 31-?? TO ZERO -C - IF (ID(1).GT.30) THEN - K = ID(1) - DO I = 31,K - PDS(I) = CHAR(0) - END DO - END IF -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi69.f b/external/w3nco/v2.0.6/src/w3fi69.f deleted file mode 100644 index 877867c6..00000000 --- a/external/w3nco/v2.0.6/src/w3fi69.f +++ /dev/null @@ -1,149 +0,0 @@ - SUBROUTINE W3FI69 (PDS, ID) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI69 CONVERT PDS TO 25, OR 27 WORD ARRAY -C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 91-05-14 -C -C ABSTRACT: CONVERTS AN EDITION 1 GRIB PRODUCE DEFINITION SECTION (PDS) -C TO A 25, OR 27 WORD INTEGER ARRAY. -C -C PROGRAM HISTORY LOG: -C 91-05-14 R.E.JONES -C 92-09-25 R.E.JONES CHANGE LEVEL TO USE ONE OR TWO WORDS -C 93-01-08 R.E.JONES CHANGE FOR TIME RANGE INDICATOR IF 10 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-10-21 R.E.JONES CHANGES FOR ON388 REV. OCT 9,1993, NEW -C LEVELS 125, 200, 201. -C 94-04-14 R.E.JONES CHANGES FOR ON388 REV. MAR 24,1994, NEW -C LEVELS 115, 116. -C 94-12-04 R.E.JONES CHANGES FOR 27 WORD INTEGER ARRAY IF -C PDS IS GREATER THAN 28 BYTES. -C 95-09-07 R.E.JONES CHANGES FOR LEVEL 117, 119. -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C -C USAGE: CALL W3FI69 (PDS, ID) -C INPUT ARGUMENT LIST: -C PDS - 28 TO 100 CHARACTER PRODUCT DEFINITION SECTION -C (PDS) -C OUTPUT ARGUMENT LIST: -C ID - 25, OR 27 WORD INTEGER ARRAY -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: SiliconGraphics 3.5 FORTRAN 77 -C MACHINE: SiliconGraphics IRIS-4D/25, 35, INDIGO, Indy -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, J916/2048 -C -C$$$ -C - INTEGER ID(*) -C - CHARACTER * 1 PDS(*) -C - SAVE -C -C ID(1) = NUMBER OF BYTES IN PDS -C ID(2) = PARAMETER TABLE VERSION NUMBER -C ID(3) = IDENTIFICATION OF ORIGINATING CENTER -C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER) -C ID(5) = GRID IDENTIFICATION -C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED -C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED -C ID(8) = INDICATOR OF PARAMETER AND UNITS -C ID(9) = INDICATOR OF TYPE OF LEVEL OR LAYER -C ID(10) = LEVEL 1 -C ID(11) = LEVEL 2 -C ID(12) = YEAR OF CENTURY -C ID(13) = MONTH OF YEAR -C ID(14) = DAY OF MONTH -C ID(15) = HOUR OF DAY -C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0) -C ID(17) = FCST TIME UNIT -C ID(18) = P1 PERIOD OF TIME -C ID(19) = P2 PERIOD OF TIME -C ID(20) = TIME RANGE INDICATOR -C ID(21) = NUMBER INCLUDED IN AVERAGE -C ID(22) = NUMBER MISSING FROM AVERAGES OR ACCUMULATIONS -C ID(23) = CENTURY -C ID(24) = IDENTIFICATION OF SUB-CENTER (TABLE 0 - PART 2) -C ID(25) = SCALING POWER OF 10 -C ID(26) = FLAG BYTE, 8 ON/OFF FLAGS -C BIT NUMBER VALUE ID(26) DEFINITION -C 1 0 0 FULL FCST FIELD -C 1 128 FCST ERROR FIELD -C 2 0 0 ORIGINAL FCST FIELD -C 1 64 BIAS CORRECTED FCST FIELD -C 3 0 0 ORIGINAL RESOLUTION RETAINED -C 1 32 SMOOTHED FIELD -C NOTE: ID(26) CAN BE THE SUM OF BITS 1, 2, 3. -C BITS 4-8 NOT USED, SET TO ZERO. -C IF ID(1) IS 28, YOU DO NOT NEED ID(26) AND ID(27). -C ID(27) = UNUSED, SET TO 0 SO PDS BYTE 30 IS SET TO ZERO.$ -C - ID(1) = mova2i(PDS(1)) * 65536 + mova2i(PDS(2)) * 256 + - & mova2i(PDS(3)) - ID(2) = mova2i(PDS(4)) - ID(3) = mova2i(PDS(5)) - ID(4) = mova2i(PDS(6)) - ID(5) = mova2i(PDS(7)) - ID(6) = IAND(ISHFT(mova2i(PDS(8)),-7),1) - ID(7) = IAND(ISHFT(mova2i(PDS(8)),-6),1) - ID(8) = mova2i(PDS(9)) - ID(9) = mova2i(PDS(10)) - I9 = mova2i(PDS(10)) -C -C TEST ID(9) FOR 1-100, 102,103, 105, 107, 109, -C 111,113,115,117,119,160,200,201, IF TRUE, SET ID(10) TO 0, -C AND STORE 16 BIT VALUE (BYTES 11 & 12) THE LEVEL IN ID(11). -C - IF ((I9.GE.1.AND.I9.LE.100).OR.I9.EQ.102.OR. - & I9.EQ.103.OR.I9.EQ.105.OR.I9.EQ.107.OR. - & I9.EQ.109.OR.I9.EQ.111.OR.I9.EQ.113.OR. - & I9.EQ.115.OR.I9.EQ.117.OR.I9.EQ.119.OR. - & I9.EQ.125.OR.I9.EQ.160.OR.I9.EQ.200.OR. - & I9.EQ.201) THEN - LEVEL = mova2i(PDS(11)) * 256 + mova2i(PDS(12)) - IF (IAND(LEVEL,32768).NE.0) THEN - LEVEL = -IAND(LEVEL,32767) - END IF - ID(10) = 0 - ID(11) = LEVEL - ELSE - ID(10) = mova2i(PDS(11)) - ID(11) = mova2i(PDS(12)) - END IF - ID(12) = mova2i(PDS(13)) - ID(13) = mova2i(PDS(14)) - ID(14) = mova2i(PDS(15)) - ID(15) = mova2i(PDS(16)) - ID(16) = mova2i(PDS(17)) - ID(17) = mova2i(PDS(18)) - ID(18) = mova2i(PDS(19)) - ID(19) = mova2i(PDS(20)) - ID(20) = mova2i(PDS(21)) -C -C IF TIME RANGE IDICATOR IS 10, P1 IS PACKED INTO -C PDS BYTES 19-20. PUT THEM IN P1 AND SET P2 TO ZERO. -C - IF (ID(20).EQ.10) THEN - ID(18) = ID(18) * 256 + ID(19) - ID(19) = 0 - END IF - ID(21) = mova2i(PDS(22)) * 256 + mova2i(PDS(23)) - ID(22) = mova2i(PDS(24)) - ID(23) = mova2i(PDS(25)) - ID(24) = mova2i(PDS(26)) - ISCALE = mova2i(PDS(27)) * 256 + mova2i(PDS(28)) - IF (IAND(ISCALE,32768).NE.0) THEN - ISCALE = -IAND(ISCALE,32767) - END IF - ID(25) = ISCALE - IF (ID(1).GT.28) THEN - ID(26) = mova2i(PDS(29)) - ID(27) = mova2i(PDS(30)) - END IF -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi71.f b/external/w3nco/v2.0.6/src/w3fi71.f deleted file mode 100644 index 8205a2b6..00000000 --- a/external/w3nco/v2.0.6/src/w3fi71.f +++ /dev/null @@ -1,1769 +0,0 @@ - SUBROUTINE W3FI71 (IGRID, IGDS, IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI71 MAKE ARRAY USED BY GRIB PACKER FOR GDS -C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 93-03-26 -C -C ABSTRACT: W3FI71 MAKES A 18, 37, 55, 64, OR 91 WORD INTEGER ARRAY -C USED BY W3FI72 GRIB PACKER TO MAKE THE GRID DESCRIPTION SECTION -C (GDS) - SECTION 2. -C -C PROGRAM HISTORY LOG: -C 92-02-21 R.E.JONES -C 92-07-01 M. FARLEY ADDED REMARKS FOR 'IGDS' ARRAY ELEMENTS. -C ADDED LAMBERT CONFORMAL GRIDS AND ENLARGED -C IDGS ARRAY FROM 14 TO 18 WORDS. -C 92-10-03 R.E.JONES ADDED CORRECTIONS TO AWIPS GRIB TABLES -C 92-10-16 R.E.JONES ADD GAUSSIAN GRID 126 TO TABLES -C 92-10-18 R.E.JONES CORRECTIONS TO LAMBERT CONFORMAL TABLES -C AND OTHER TABLES -C 92-10-19 R.E.JONES ADD GAUSSIAN GRID 98 TO TABLES -C 93-01-25 R.E.JONES ADD ON84 GRIDS 87, 106, 107 TO TABLES -C 93-03-10 R.E.JONES ADD ON84 GRIDS 1, 55, 56 TO TABLES -C 93-03-26 R.E.JONES ADD GRIB GRIDS 2, 3 TO TABLES -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-06-15 R.E.JONES ADD GRIB GRIDS 37 TO 44 TO TABLES -C 93-09-29 R.E.JONES GAUSSIAN GRID DOCUMENT NOT CORRECT, -C W3FI74 WILL BE CHANGED TO AGREE WITH -C IT. GAUSSIAN GRID 98 TABLE HAS WRONG -C VALUE. -C 93-10-12 R.E.JONES CHANGES FOR ON388 REV. OCT 8,1993 FOR -C GRID 204, 208. -C 93-10-13 R.E.JONES CORRECTION FOR GRIDS 37-44, BYTES 7-8, -C 24-25 SET TO ALL BITS 1 FOR MISSING. -C 93-11-23 R.E.JONES ADD GRIDS 90-93 FOR ETA MODEL -C ADD GRID 4 FOR 720*361 .5 DEG. GRID -C 94-04-12 R.E.JONES CORRECTION FOR GRID 28 -C 94-06-01 R.E.JONES ADD GRID 45, 288*145 1.25 DEG. GRID -C 94-06-22 R.E.JONES ADD GRIDS 94, 95 FOR ETA MODEL -C 95-04-11 R.E.JONES ADD GRIDS 96, 97 FOR ETA MODEL -C 95-05-19 R.E.JONES ADD FROM 20 KM ETA MODEL AWIPS GRID 215 -C 95-10-19 R.E.JONES ADD FROM 20 KM ETA MODEL ALASKA GRID 216 -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 96-05-08 IREDELL CORRECT FIRST LATITUDE FOR GRIDS 27 AND 28 -C 96-07-02 R.E.JONES ADD FROM 10 KM ETA MODEL OLYMPIC GRID 218 -C 96-07-02 R.E.JONES ADD 196 FOR ETA MODEL -C 96-08-15 R.E.JONES ADD O.N. 84 GRID 8 AND 53 AS GRIB GRID 8 -C AND 53 -C 96-11-29 R.E.JONES CORRECTION TO TABLES FOR GRID 21-26, 61-64 -C 97-01-31 IREDELL CORRECT FIRST LATITUDE FOR GRID 30 -C 97-10-20 IREDELL CORRECT LAST LONGITUDE FOR GRID 98 -C 98-07-07 Gilbert Add grids 217 and 219 through 235 -C 98-09-21 BALDWIN ADD GRIDS 190, 192 FOR ETA MODEL -C 99-01-20 BALDWIN ADD GRIDS 236, 237 -C 99-08-18 IREDELL ADD GRID 170 -C 01-03-08 ROGERS CHANGED ETA GRIDS 90-97, ADDED ETA GRIDS -C 194, 198. ADDED AWIPS GRIDS 241,242,243, -C 245, 246, 247, 248, AND 250 -C 01-03-19 VUONG ADDED AWIPS GRIDS 238,239,240, AND 244 -C 01-04-02 VUONG CORRECT LAST LONGITUDE FOR GRID 225 -C 01-05-03 ROGERS ADDED GRID 249 -C 01-10-10 ROGERS REDEFINED 218 FOR 12-KM ETA -C REDEFINED GRID 192 FOR NEW 32-KM ETA GRID -C 02-03-27 VUONG ADDED RSAS GRID 88 AND AWIPS GRIDS 251 AND 252 -C 02-08-06 ROGERS REDEFINED GRIDS 90-93,97,194,245-250 FOR THE -C 8KM HI-RES-WINDOW MODEL AND ADD AWIPS GRID 253 -C 2003-06-30 GILBERT ADDED GRIDS 145 and 146 for CMAQ -C and GRID 175 for AWIPS over GUAM. -C 2003-07-08 VUONG CORRECTED LATITUDE FOR GRID 253 AND 170, ADD GRID -C 110, 127, 171 AND 172 -C 2004-08-05 VUONG CORRECTED LATITUDE FOR GRID 253 -C 2004-09-01 GILBERT Corrected the orientation and projection center flag -C for southern hemisphere grids 28, 172, 220 and 224 -C 2004-09-02 VUONG ADDED GRIDS 147, 148, 173 AND 254 -C 2005-01-04 COOKE Added grids 160, 161 and corrected longitude of orientation for grid 172 -C 2005-03-03 VUONG MOVED GRID 170 TO GRID 174 AND ADD GRID 170 -C 2005-03-21 VUONG ADDED GRIDS 130 -C 2005-09-12 VUONG ADDED GRIDS 163 -C 2006-10-27 VUONG CORRECTED X AND Y-DIRECTION GRID LENGTH FOR GRIDS 252 -C 2006-11-16 VUONG CHANGED THE LONGITUDE FROM NEGATIVE TO POSITIVE DEGREE FOR GRIDS 252 -C 2006-12-12 VUONG CHANGED DATA REPRESENTATION TYPE (OCTET 6) FROM 0 TO 1 FOR GRID 254 -C ADD GRID 120 (CURVILINEAR ORTHOGONAL GRID) -C 2006-12-27 VUONG CORRECTED THE LAT/LON DIRECTION INCREMENT FOR GRID 160 -C 2007-03-21 VUONG CORRECTED THE LAT/LON DIRECTION INCREMENT, RESOULUTION, -C SCANNING MODE FOR GRID 235 AND GRID TYPE 204 FOR GRID 120 -C 2007-04-24 VUONG CORRECTED THE LAT/LON DIRECTION INCREMENT, RESOULUTION, -C FOR GRIDS (219,173,220,171,233,238,239,244,253) AND ADDED -C GRID 176. -C 2007-06-11 VUONG ADDED NEW GRIDS (11,12,13,14,15,16,18,122,123,124,125,138 -C 180, 181, 182, 183) AND CORRECTED THE LAT/LON DIRECTION -C INCREMENT FOR GRID 240. -C 2007-11-06 VUONG CORRECTED THE SCANNING MODE FOR GRIDS (11,12,13,14,15,16,18) -C CHANGED GRID 198 FROM ARAKAWA STAGGERED E-GRID TO POLAR -C STEREOGRAPHIC GRID ADDED NEW GRID 10, 99, 150, 151, 197 -C 2008-01-17 VUONG ADDED NEW GRID 195 AND CHANGED GRID 196 (ARAKAWA-E TO MERCATOR) -C 2010-02-15 VUONG MODIFIED TO CORRECT LATITUDE FOR GRID 151 AND ADDED -C 2010-06-01 VUONG MODIFIED TO CORRECT LATITUDE AND LONGITUDE FOR GRID 196 -C 2010-08-05 VUONG ADDED NEW GRID 184, 199, 83 AND -C REDEFINED GRID 90 FOR NEW RTMA CONUS 1.27-KM -C REDEFINED GRID 91 FOR NEW RTMA ALASKA 2.976-KM -C REDEFINED GRID 92 FOR NEW RTMA ALASKA 1.488-KM -C 2010-09-08 ROGERS CHANGED GRID 94 TO ALASKA 6KM STAGGERED B-GRID -C CHANGED GRID 95 TO PUERTO RICO 3KM STAGGERED B-GRID -C CHANGED GRID 96 TO HAWAII 3KM STAGGERED B-GRID -C CHANGED GRID 96 TO HAWAII 3KM STAGGERED B-GRID -C CHANGED GRID 97 TO CONUS 4KM STAGGERED B-GRID -C CHANGED GRID 99 TO NAM 12KM STAGGERED B-GRID -C ADDED GRID 179 (12 KM POLAR STEREOGRAPHIC OVER NORTH AMERICA) -C CHANGED GRID 194 TO 3KM MERCATOR GRID OVER PUERTO RICO -C CORRECTED LATITUDE OF SW CORNER POINT OF GRID 151 -C 2011-10-12 VUONG ADDED GRID 129, 187, 188, 189 and 193 -C 2012-04-16 VUONG ADDED GRID 132, 200 -C 2012-11-07 VUONG CORRECTED GRID 174 FOR RES. AND COMP. FLAG SET TO 128 -C -C USAGE: CALL W3FI71 (IGRID, IGDS, IERR) -C INPUT ARGUMENT LIST: -C IGRID - GRIB GRID NUMBER, OR OFFICE NOTE 84 GRID NUMBER -C -C OUTPUT ARGUMENT LIST: -C IGDS - 18, 37, 55, 64, OR 91 WORD INTEGER ARRAY WITH -C INFORMATION TO MAKE A GRIB GRID DESCRIPTION SECTION. -C IERR - 0 CORRECT EXIT -C 1 GRID TYPE IN IGRID IS NOT IN TABLE -C -C REMARKS: -C 1) OFFICE NOTE GRID TYPE 26 IS 6 IN GRIB, 26 IS AN -C INTERNATIONAL EXCHANGE GRID. -C -C 2) VALUES RETURNED IN 18, 37, 55, 64, OR 91 WORD INTEGER ARRAY -C IGDS VARY DEPENDING ON GRID REPRESENTATION TYPE. -C -C LAT/LON GRID: -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) -C IGDS( 4) = NO. OF POINTS ALONG A LATITUDE -C IGDS( 5) = NO. OF POINTS ALONG A LONGITUDE MERIDIAN -C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH - IVE) -C IGDS( 7) = LONGITUDE OF ORIGIN (WEST -IVE) -C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) -C IGDS( 9) = LATITUDE OF EXTREME POINT (SOUTH - IVE) -C IGDS(10) = LONGITUDE OF EXTREME POINT (WEST - IVE) -C IGDS(11) = LATITUDE INCREMENT -C IGDS(12) = LONGITUDE INCREMENT -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID -C IGDS(19) - IGDS(91) FOR GRIDS 37-44, NUMBER OF POINTS -C IN EACH OF 73 ROWS. -C -C GAUSSIAN GRID: -C IGDS( 1) = ... THROUGH ... -C IGDS(10) = ... SAME AS LAT/LON GRID -C IGDS(11) = NUMBER OF LATITUDE LINES BETWEEN A POLE -C AND THE EQUATOR -C IGDS(12) = LONGITUDE INCREMENT -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID -C -C SPHERICAL HARMONICS: -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) -C IGDS( 4) = J - PENTAGONAL RESOLUTION PARAMETER -C IGDS( 5) = K - PENTAGONAL RESOLUTION PARAMETER -C IGDS( 6) = M - PENTAGONAL RESOLUTION PARAMETER -C IGDS( 7) = REPRESENTATION TYPE (CODE TABLE 9) -C IGDS( 8) = REPRESENTATION MODE (CODE TABLE 10) -C IGDS( 9) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID -C -C POLAR STEREOGRAPHIC: -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) -C IGDS( 4) = NO. OF POINTS ALONG X-AXIS -C IGDS( 5) = NO. OF POINTS ALONG Y-AXIS -C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH -IVE) -C IGDS( 7) = LONGITUTE OF ORIGIN (WEST -IVE) -C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) -C IGDS( 9) = LONGITUDE OF MERIDIAN PARALLEL TO Y-AXIS -C IGDS(10) = X-DIRECTION GRID LENGTH (INCREMENT) -C IGDS(11) = Y-DIRECTION GRID LENGTH (INCREMENT) -C IGDS(12) = PROJECTION CENTER FLAG (0=NORTH POLE ON PLANE, -C 1=SOUTH POLE ON PLANE, -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = .. NOT USED FOR THIS GRID -C -C MERCATOR: -C IGDS( 1) = ... THROUGH ... -C IGDS(12) = ... SAME AS LAT/LON GRID -C IGDS(13) = LATITUDE AT WHICH PROJECTION CYLINDER -C INTERSECTS EARTH -C IGDS(14) = SCANNING MODE FLAGS -C IGDS(15) = ... THROUGH ... -C IGDS(18) = .. NOT USED FOR THIS GRID -C -C LAMBERT CONFORMAL: -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) -C IGDS( 4) = NO. OF POINTS ALONG X-AXIS -C IGDS( 5) = NO. OF POINTS ALONG Y-AXIS -C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH -IVE) -C IGDS( 7) = LONGITUTE OF ORIGIN (WEST -IVE) -C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) -C IGDS( 9) = LONGITUDE OF MERIDIAN PARALLEL TO Y-AXIS -C IGDS(10) = X-DIRECTION GRID LENGTH (INCREMENT) -C IGDS(11) = Y-DIRECTION GRID LENGTH (INCREMENT) -C IGDS(12) = PROJECTION CENTER FLAG (0=NORTH POLE ON PLANE, -C 1=SOUTH POLE ON PLANE, -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = NOT USED -C IGDS(15) = FIRST LATITUDE FROM THE POLE AT WHICH THE -C SECANT CONE CUTS THE SPERICAL EARTH -C IGDS(16) = SECOND LATITUDE ... -C IGDS(17) = LATITUDE OF SOUTH POLE (MILLIDEGREES) -C IGDS(18) = LONGITUDE OF SOUTH POLE (MILLIDEGREES) -C -C ARAKAWA SEMI-STAGGERED E-GRID ON ROTATED LAT/LON GRID -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [201] -C IGDS( 4) = NI - TOTAL NUMBER OF ACTUAL DATA POINTS -C INCLUDED ON GRID -C IGDS( 5) = NJ - DUMMY SECOND DIMENSION; SET=1 -C IGDS( 6) = LA1 - LATITUDE OF FIRST GRID POINT -C IGDS( 7) = LO1 - LONGITUDE OF FIRST GRID POINT -C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) -C IGDS( 9) = LA2 - NUMBER OF MASS POINTS ALONG -C SOUTHERNMOST ROW OF GRID -C IGDS(10) = LO2 - NUMBER OF ROWS IN EACH COLUMN -C IGDS(11) = DI - LONGITUDINAL DIRECTION INCREMENT -C IGDS(12) = DJ - LATITUDINAL DIRECTION INCREMENT -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID (SET TO ZERO) -C -C ARAKAWA FILLED E-GRID ON ROTATED LAT/LON GRID -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [202] -C IGDS( 4) = NI - TOTAL NUMBER OF ACTUAL DATA POINTS -C INCLUDED ON GRID -C IGDS( 5) = NJ - DUMMY SECOND DIMENTION; SET=1 -C IGDS( 6) = LA1 - LATITUDE LATITUDE OF FIRST GRID POINT -C IGDS( 7) = LO1 - LONGITUDE OF FIRST GRID POINT -C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) -C IGDS( 9) = LA2 - NUMBER OF (ZONAL) POINTS IN EACH ROW -C IGDS(10) = LO2 - NUMBER OF (MERIDIONAL) POINTS IN EACH -C COLUMN -C IGDS(11) = DI - LONGITUDINAL DIRECTION INCREMENT -C IGDS(12) = DJ - LATITUDINAL DIRECTION INCREMENT -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID -C -C ARAKAWA STAGGERED E-GRID ON ROTATED LAT/LON GRID -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [203] -C IGDS( 4) = NI - NUMBER OF DATA POINTS IN EACH ROW -C IGDS( 5) = NJ - NUMBER OF ROWS -C IGDS( 6) = LA1 - LATITUDE OF FIRST GRID POINT -C IGDS( 7) = LO1 - LONGITUDE OF FIRST GRID POINT -C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) -C IGDS( 9) = LA2 - CENTRAL LATITUDE -C IGDS(10) = LO2 - CENTRAL LONGTITUDE -C IGDS(11) = DI - LONGITUDINAL DIRECTION INCREMENT -C IGDS(12) = DJ - LATITUDINAL DIRECTION INCREMENT -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID -C -C CURVILINEAR ORTHOGONAL GRID -C IGDS( 1) = NUMBER OF VERTICAL COORDINATES -C IGDS( 2) = PV, PL OR 255 -C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [204] -C IGDS( 4) = NI - NUMBER OF DATA POINTS IN EACH ROW -C IGDS( 5) = NJ - NUMBER OF ROWS -C IGDS( 6) = RESERVED (SET TO 0) -C IGDS( 7) = RESERVED (SET TO 0) -C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) -C IGDS( 9) = RESERVED (SET TO 0) -C IGDS(10) = RESERVED (SET TO 0) -C IGDS(11) = RESERVED (SET TO 0) -C IGDS(12) = RESERVED (SET TO 0) -C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) -C IGDS(14) = ... THROUGH ... -C IGDS(18) = ... NOT USED FOR THIS GRID -C -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM SP -C -C$$$ -C - INTEGER IGRID - INTEGER IGDS (*) - INTEGER GRD1 (18) - INTEGER GRD2 (18) - INTEGER GRD3 (18) - INTEGER GRD4 (18) - INTEGER GRD5 (18) - INTEGER GRD6 (18) - INTEGER GRD8 (18) - INTEGER GRD10 (18) - INTEGER GRD11 (18) - INTEGER GRD12 (18) - INTEGER GRD13 (18) - INTEGER GRD14 (18) - INTEGER GRD15 (18) - INTEGER GRD16 (18) - INTEGER GRD17 (18) - INTEGER GRD18 (18) - INTEGER GRD21 (55) - INTEGER GRD22 (55) - INTEGER GRD23 (55) - INTEGER GRD24 (55) - INTEGER GRD25 (37) - INTEGER GRD26 (37) - INTEGER GRD27 (18) - INTEGER GRD28 (18) - INTEGER GRD29 (18) - INTEGER GRD30 (18) - INTEGER GRD33 (18) - INTEGER GRD34 (18) - INTEGER GRD37 (91) - INTEGER GRD38 (91) - INTEGER GRD39 (91) - INTEGER GRD40 (91) - INTEGER GRD41 (91) - INTEGER GRD42 (91) - INTEGER GRD43 (91) - INTEGER GRD44 (91) - INTEGER GRD45 (18) - INTEGER GRD53 (18) - INTEGER GRD55 (18) - INTEGER GRD56 (18) - INTEGER GRD61 (64) - INTEGER GRD62 (64) - INTEGER GRD63 (64) - INTEGER GRD64 (64) - INTEGER GRD83 (18) - INTEGER GRD85 (18) - INTEGER GRD86 (18) - INTEGER GRD87 (18) - INTEGER GRD88 (18) - INTEGER GRD90 (18) - INTEGER GRD91 (18) - INTEGER GRD92 (18) - INTEGER GRD93 (18) - INTEGER GRD94 (18) - INTEGER GRD95 (18) - INTEGER GRD96 (18) - INTEGER GRD97 (18) - INTEGER GRD98 (18) - INTEGER GRD99 (18) - INTEGER GRD100(18) - INTEGER GRD101(18) - INTEGER GRD103(18) - INTEGER GRD104(18) - INTEGER GRD105(18) - INTEGER GRD106(18) - INTEGER GRD107(18) - INTEGER GRD110(18) - INTEGER GRD120(18) - INTEGER GRD122(18) - INTEGER GRD123(18) - INTEGER GRD124(18) - INTEGER GRD125(18) - INTEGER GRD126(18) - INTEGER GRD127(18) - INTEGER GRD128(18) - INTEGER GRD129(18) - INTEGER GRD130(18) - INTEGER GRD132(18) - INTEGER GRD138(18) - INTEGER GRD139(18) - INTEGER GRD140(18) - INTEGER GRD145(18) - INTEGER GRD146(18) - INTEGER GRD147(18) - INTEGER GRD148(18) - INTEGER GRD150(18) - INTEGER GRD151(18) - INTEGER GRD160(18) - INTEGER GRD161(18) - INTEGER GRD163(18) - INTEGER GRD170(18) - INTEGER GRD171(18) - INTEGER GRD172(18) - INTEGER GRD173(18) - INTEGER GRD174(18) - INTEGER GRD175(18) - INTEGER GRD176(18) - INTEGER GRD179(18) - INTEGER GRD180(18) - INTEGER GRD181(18) - INTEGER GRD182(18) - INTEGER GRD183(18) - INTEGER GRD184(18) - INTEGER GRD187(18) - INTEGER GRD188(18) - INTEGER GRD189(18) - INTEGER GRD190(18) - INTEGER GRD192(18) - INTEGER GRD193(18) - INTEGER GRD194(18) - INTEGER GRD195(18) - INTEGER GRD196(18) - INTEGER GRD197(18) - INTEGER GRD198(18) - INTEGER GRD199(18) - INTEGER GRD200(18) - INTEGER GRD201(18) - INTEGER GRD202(18) - INTEGER GRD203(18) - INTEGER GRD204(18) - INTEGER GRD205(18) - INTEGER GRD206(18) - INTEGER GRD207(18) - INTEGER GRD208(18) - INTEGER GRD209(18) - INTEGER GRD210(18) - INTEGER GRD211(18) - INTEGER GRD212(18) - INTEGER GRD213(18) - INTEGER GRD214(18) - INTEGER GRD215(18) - INTEGER GRD216(18) - INTEGER GRD217(18) - INTEGER GRD218(18) - INTEGER GRD219(18) - INTEGER GRD220(18) - INTEGER GRD221(18) - INTEGER GRD222(18) - INTEGER GRD223(18) - INTEGER GRD224(18) - INTEGER GRD225(18) - INTEGER GRD226(18) - INTEGER GRD227(18) - INTEGER GRD228(18) - INTEGER GRD229(18) - INTEGER GRD230(18) - INTEGER GRD231(18) - INTEGER GRD232(18) - INTEGER GRD233(18) - INTEGER GRD234(18) - INTEGER GRD235(18) - INTEGER GRD236(18) - INTEGER GRD237(18) - INTEGER GRD238(18) - INTEGER GRD239(18) - INTEGER GRD240(18) - INTEGER GRD241(18) - INTEGER GRD242(18) - INTEGER GRD243(18) - INTEGER GRD244(18) - INTEGER GRD245(18) - INTEGER GRD246(18) - INTEGER GRD247(18) - INTEGER GRD248(18) - INTEGER GRD249(18) - INTEGER GRD250(18) - INTEGER GRD251(18) - INTEGER GRD252(18) - INTEGER GRD253(18) - INTEGER GRD254(18) -C - DATA GRD1 / 0, 255, 1, 73, 23, -48090, 0, 128, 48090, - & 0, 513669,513669, 22500, 64, 0, 0, 0, 0/ - DATA GRD2 / 0, 255, 0, 144, 73, 90000, 0, 128, -90000, - & -2500, 2500, 2500, 0, 0, 0, 0, 0, 0/ - DATA GRD3 / 0, 255, 0, 360,181, 90000, 0, 128, -90000, - & -1000, 1000, 1000, 0, 0, 0, 0, 0, 0/ - DATA GRD4 / 0, 255, 0, 720,361, 90000, 0, 128, -90000, - & -500, 500, 500, 0, 0, 0, 0, 0, 0/ - DATA GRD5 / 0, 255, 5, 53, 57, 7647, -133443, 8, -105000, - & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD6 / 0, 255, 5, 53, 45, 7647, -133443, 8, -105000, - & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD8 / 0, 255, 1, 116, 44, -48670, 3104, 128, 61050, - & 0, 318830, 318830, 22500, 64, 0, 0, 0, 0/ - DATA GRD10 / 0, 255, 0, 180, 139, 64000, 1000, 128, -74000, - & 359000, 1000, 2000, 0, 0, 0, 0, 0, 0/ - DATA GRD11 / 0, 255, 0, 720, 311, 77500, 0, 128, -77500, - & 359500, 500, 500, 0, 0, 0, 0, 0, 0/ - DATA GRD12 / 0, 255, 0, 301, 331, 55000, 260000, 128, 0, - & 310000, 166, 166, 0, 0, 0, 0, 0, 0/ - DATA GRD13 / 0, 255, 0, 241, 151, 50000, 210000, 128, 25000, - & 250000, 166, 166, 0, 0, 0, 0, 0, 0/ - DATA GRD14 / 0, 255, 0, 511, 301, 30000, 130000, 128, -20000, - & 215000, 166, 166, 0, 0, 0, 0, 0, 0/ - DATA GRD15 / 0, 255, 0, 401, 187, 75000, 140000, 128, 44000, - & 240000, 166, 250, 0, 0, 0, 0, 0, 0/ - DATA GRD16 / 0, 255, 0, 548, 391, 74000, 165000, 128, 48000, - & 237933, 66, 133, 0, 0, 0, 0, 0, 0/ - DATA GRD17 / 0, 255, 0, 736, 526, 50000, 195000, 128, 15000, - & 244000, 66, 66, 0, 0, 0, 0, 0, 0/ - DATA GRD18 / 0, 255, 0, 586, 481, 47000, 261000, 128, 15000, - & 300000, 66, 66, 0, 0, 0, 0, 0, 0/ - DATA GRD21 / 0, 33, 0,65535,37, 0, 0, 128, 90000, - & 180000, 2500, 5000, 64, 0, 0, 0, 0, 0, - & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 1/ - DATA GRD22 / 0, 33, 0,65535,37, 0, -180000, 128, 90000, - & 0, 2500, 5000, 64, 0, 0, 0, 0, 0, - & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 1/ - DATA GRD23 / 0, 33, 0,65535, 37, -90000, 0, 128, 0, - & 180000, 2500, 5000, 64, 0, 0, 0, 0, 0, - & 1, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 37/ - DATA GRD24 / 0, 33, 0,65535, 37, -90000, -180000, 128, 0, - & 0, 2500, 5000, 64, 0, 0, 0, 0, 0, - & 1, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - & 37, 37, 37, 37, 37, 37, 37/ - DATA GRD25 / 0, 33, 0,65535, 19, 0, 0, 128, 90000, - & 355000, 5000, 5000, 64, 0, 0, 0, 0, 0, - & 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, - & 72, 72, 72, 1/ - DATA GRD26 / 0, 33, 0,65535, 19, -90000, 0, 128, 0, - & 355000, 5000, 5000, 64, 0, 0, 0, 0, 0, - & 1, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, - & 72, 72, 72, 72/ - DATA GRD27 / 0, 255, 5, 65, 65, -20826, -125000, 8, -80000, - & 381000, 381000, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD28 / 0, 255, 5, 65, 65, 20826, 145000, 8, -80000, - & 381000, 381000,128, 64, 0, 0, 0, 0, 0/ - DATA GRD29 / 0, 255, 0, 145, 37, 0, 0, 128, 90000, - & 360000, 2500, 2500, 64, 0, 0, 0, 0, 0/ - DATA GRD30 / 0, 255, 0, 145, 37, -90000, 0, 128, 0, - & 360000, 2500, 2500, 64, 0, 0, 0, 0, 0/ - DATA GRD33 / 0, 255, 0, 181, 46, 0, 0, 128, 90000, - & 360000, 2000, 2000, 64, 0, 0, 0, 0, 0/ - DATA GRD34 / 0, 255, 0, 181, 46, -90000, 0, 128, 0, - & 360000, 2000, 2000, 64, 0, 0, 0, 0, 0/ - DATA GRD37 / 0, 33, 0,65535,73, 0, -30000, 128, 90000, - & 60000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, - & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, - & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, - & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, - & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ - DATA GRD38 / 0, 33, 0,65535,73, 0, 60000, 128, 90000, - & 150000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, - & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, - & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, - & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, - & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ - DATA GRD39 / 0, 33, 0,65535,73, 0, 150000, 128, 90000, - & -120000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, - & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, - & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, - & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, - & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ - DATA GRD40 / 0, 33, 0,65535,73, 0, -120000, 128, 90000, - & -30000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, - & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, - & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, - & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, - & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ - DATA GRD41 / 0, 33, 0,65535,73, -90000, -30000, 128, 0, - & 60000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23, - & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44, - & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60, - & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71, - & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/ - DATA GRD42 / 0, 33, 0,65535,73, -90000, 60000, 128, 0, - & 150000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23, - & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44, - & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60, - & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71, - & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/ - DATA GRD43 / 0, 33, 0,65535,73, -90000, 150000, 128, 0, - & -120000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23, - & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44, - & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60, - & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71, - & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/ - DATA GRD44 / 0, 33, 0,65535,73, -90000, -120000, 128, 0, - & -30000, 1250,65535, 64, 0, 0, 0, 0, 0, - & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23, - & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44, - & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60, - & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71, - & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/ - DATA GRD45 / 0, 255, 0, 288,145, 90000, 0, 128, -90000, - & -1250, 1250, 1250, 0, 0, 0, 0, 0, 0/ - DATA GRD53 / 0, 255, 1, 117, 51, -61050, 0, 128, 61050, - & 0, 318830, 318830, 22500, 64, 0, 0, 0, 0/ - DATA GRD55 / 0, 255, 5, 87, 71, -10947, -154289, 8, -105000, - & 254000, 254000, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD56 / 0, 255, 5, 87, 71, 7647, -133443, 8, -105000, - & 127000, 127000, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD61 / 0, 33, 0,65535, 46, 0, 0, 128, 90000, - & 180000, 2000, 2000, 64, 0, 0, 0, 0, 0, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 1/ - DATA GRD62 / 0, 33, 0,65535, 46, 0, -180000, 128, 90000, - & 0, 2000, 2000, 64, 0, 0, 0, 0, 0, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 1/ - DATA GRD63 / 0, 33, 0,65535, 46, 0, -90000, 128, 0, - & 180000, 2000, 2000, 64, 0, 0, 0, 0, 0, - & 1, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91/ - DATA GRD64 / 0, 33, 0,65535, 46, -90000, -180000, 128, 0, - & 0, 2000, 2000, 64, 0, 0, 0, 0, 0, - & 1, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, - & 91/ - DATA GRD83 / 0, 255,205,758,567, 2228, -140481, 136, 47500, - & -104000, 121,121,64, 53492, -10984, 0, 0, 0/ - DATA GRD85 / 0, 255, 0, 360, 90, 500, 500, 128, 89500, - & 359500, 1000, 1000, 64, 0, 0, 0, 0, 0/ - DATA GRD86 / 0, 255, 0, 360, 90, -89500, 500, 128, -500, - & 359500, 1000, 1000, 64, 0, 0, 0, 0, 0/ - DATA GRD87 / 0, 255, 5, 81, 62, 22876, -120491, 8, -105000, - & 68153, 68153, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD88 / 0, 255, 5, 580,548, 10000, -128000, 8, -105000, - & 15000, 15000, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD90 / 0, 255, 3,4289,2753, 20192, -121554, 8, -95000, - & 1270, 1270, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD91 / 0, 255, 5,1649,1105, 40530, -178571, 8, -150000, - & 2976, 2976, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD92 / 0, 255, 5,3297,2209, 40530, -178571, 8, -150000, - & 1488, 1488, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD93 / 0, 255,203,223,501, 44232, -169996, 136, 63000, - & -150000, 67,66,64, 0, 0, 0, 0, 0/ - DATA GRD94 / 0, 255,205,595,625, 34921, -161663, 136, 54000, - & -106000, 63, 54,64, 83771, -151721, 0, 0, 0/ - DATA GRD95 / 0, 255,205,401,325, 17609, -76327, 136, 54000, - & -106000, 31, 27,64, 18840, -61261, 0, 0, 0/ - DATA GRD96 / 0, 255,205,373,561, 11625, -156339, 136, 54000, - & -106000, 31, 27,64, 30429, -157827, 0, 0, 0/ - DATA GRD97 / 0, 255,205,1371,1100, 15947,-125468, 136, 54000, - & -106000, 42, 36,64,45407,-52390, 0, 0, 0/ - DATA GRD98 / 0, 255, 4, 192, 94, 88542, 0, 128, -88542, - & -1875, 47,1875, 0, 0, 0, 0, 0, 0/ - DATA GRD99 / 0, 255,203,669,1165, -7450, -144140, 136, 54000, - & -106000, 90, 77, 64, 0, 0, 0, 0, 0/ - DATA GRD100/ 0, 255, 5, 83, 83, 17108, -129296, 8, -105000, - & 91452, 91452, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD101/ 0, 255, 5, 113, 91, 10528, -137146, 8, -105000, - & 91452, 91452, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD103/ 0, 255, 5, 65, 56, 22405, -121352, 8, -105000, - & 91452, 91452, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD104/ 0, 255, 5, 147,110, -268, -139475, 8, -105000, - & 90755, 90755, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD105/ 0, 255, 5, 83, 83, 17529, -129296, 8, -105000, - & 90755, 90755, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD106/ 0, 255, 5, 165,117, 17533, -129296, 8, -105000, - & 45373, 45373, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD107/ 0, 255, 5, 120, 92, 23438, -120168, 8, -105000, - & 45373, 45373, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD110/ 0, 255, 0, 464,224, 25063, -124938, 128, 52938, - & -67063, 125, 125, 64, 0, 0, 0, 0, 0/ - DATA GRD120/ 0, 255,204,1200,1684, 0, 0, 8, 0, - & 0, 0, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD122/ 0, 255,204, 350, 465, 0, 0, 8, 0, - & 0, 0, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD123/ 0, 255,204, 280, 360, 0, 0, 8, 0, - & 0, 0, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD124/ 0, 255,204, 240, 314, 0, 0, 8, 0, - & 0, 0, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD125/ 0, 255,204, 300, 340, 0, 0, 8, 0, - & 0, 0, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD126/ 0, 255, 4, 384,190, 89277, 0, 128, -89277, - & -938, 95, 938, 0, 0, 0, 0, 0, 0/ - DATA GRD127/ 0, 255, 4, 768,384, 89642, 0, 128, -89642, - & -469, 192, 469, 0, 0, 0, 0, 0, 0/ - DATA GRD128/ 0, 255, 4,1152,576, 89761, 0, 128, -89761, - & -313, 288, 313, 0, 0, 0, 0, 0, 0/ - DATA GRD129/ 0, 255, 4,1760,880, 89844, 0, 128, -89844, - & -205, 440, 205, 0, 0, 0, 0, 0, 0/ - DATA GRD130/ 0, 255, 3, 451,337, 16281, -126138, 8, -95000, - & 13545, 13545, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD132/ 0, 255, 3, 697,553, 1000, -145500, 8, -107000, - & 16232, 16232, 0, 64, 0, 50000, 50000, 0, 0/ - DATA GRD138/ 0, 255, 3, 468,288, 21017, -123282, 8, -97000, - & 12000, 12000, 0, 64, 0, 33000, 45000, 0, 0/ - DATA GRD139/ 0, 255, 3, 80,52, 17721, -161973, 8, -157500, - & 12000, 12000, 0, 64, 0, 19000, 21000, 0, 0/ - DATA GRD140/ 0, 255, 3, 199,163, 53020, -166477, 8, -148600, - & 12000, 12000, 0, 64, 0, 57000, 63000, 0, 0/ - DATA GRD145/ 0, 255, 3, 169,145, 32174, -90159, 8, -79500, - & 12000, 12000, 0, 64, 0, 36000, 46000, 0, 0/ - DATA GRD146/ 0, 255, 3, 166,142, 32353, -89994, 8, -79500, - & 12000, 12000, 0, 64, 0, 36000, 46000, 0, 0/ - DATA GRD147/ 0, 255, 3, 268,259, 24595, -100998, 8, -97000, - & 12000, 12000, 0, 64, 0, 33000, 45000, 0, 0/ - DATA GRD148/ 0, 255, 3, 442,265, 21821, -120628, 8, -97000, - & 12000, 12000, 0, 64, 0, 33000, 45000, 0, 0/ - DATA GRD150/ 0, 255, 0, 401,201, 5000, -100000, 128, 25000, - & -60000, 100, 100, 64, 0, 0, 0, 0, 0/ - DATA GRD151/ 0, 255, 5, 478, 429, -7450, 215860, 8, -110000, - & 33812, 33812, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD160/ 0, 255, 5, 180,156, 19132, -185837, 8, -150000, - & 47625, 47625, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD161/ 0, 255, 0, 137,102, 50750, 271750, 72, -250, - & -19750, 500,500, 0, 0, 0, 0, 0, 0/ - DATA GRD163/ 0, 255, 3,1008,722, 20600, -118300, 8, -95000, - & 5000, 5000, 0, 64, 0, 38000, 38000, 0, 0/ - DATA GRD170/ 0, 255, 4, 512, 256, 89463, 0, 128, -89463, - & -703, 128, 703, 0, 0, 0, 0, 0, 0/ - DATA GRD171/ 0, 255, 5, 770,930, 25032, -119560, 0, -80000, - & 12700, 12700, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD172/ 0, 255, 5, 690,710, -36866, -220194, 0, -260000, - & 12700, 12700, 128, 64, 0, 0, 0, 0, 0/ - DATA GRD173/ 0, 255, 0,4320,2160, 89958, 42, 128, -89958, - & 359958, 83, 83, 0, 0, 0, 0, 0, 0/ - DATA GRD174/ 0, 255, 0,2880,1440, 89938, 62, 128, -89938, - & -62, 125, 125,64, 0, 0, 0, 0, 0/ - DATA GRD175/ 0, 255, 0, 556,334, 0, 130000, 128, 30060, - & 180040, 90, 90, 64, 0, 0, 0, 0, 0/ - DATA GRD176/ 0, 255, 0, 327,235, 49100, -92200, 128, 40910, - & -75900, 35, 50, 0, 0, 0, 0, 0, 0/ - DATA GRD179/ 0, 255, 5,1196,817, -2500, -142500, 8, -100000, - & 12679, 12679, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD180/ 0, 255, 0, 759,352, 55054, -127000, 128, 17146, - & -45136, 108, 108, 0, 0, 0, 0, 0, 0/ - DATA GRD181/ 0, 255, 0, 370,278, 30054, -100000, 128, 138, - & -60148, 108, 108, 0, 0, 0, 0, 0, 0/ - DATA GRD182/ 0, 255, 0, 278,231, 32973, -170000, 128, 8133, - & -140084, 108, 108, 0, 0, 0, 0, 0, 0/ - DATA GRD183/ 0, 255, 0, 648,278, 75054, -200000, 128, 45138, - & -130124, 108, 108, 0, 0, 0, 0, 0, 0/ - DATA GRD184/ 0, 255, 3,2145,1377, 20192, -121554, 8, -95000, - & 2540, 2540, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD187/ 0, 255, 3,2145,1597, 20192, -121554, 8, -95000, - & 2540, 2540, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD188/ 0, 255, 3, 709, 795, 37979, -125958, 8, -95000, - & 2540, 2540, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD189/ 0, 255, 5, 655, 855, 51500, -142500, 8, -135000, - & 1448, 1448, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD190/ 0, 255,205,954,835, -7491, -144134, 136, 54000, - & -106000, 126, 108, 64, 44540, 14802, 0, 0, 0/ - DATA GRD192/ 0, 255,203,237,387, -3441, -148799, 136, 50000, - & -111000, 225,207,64, 0, 0, 0, 0, 0/ - DATA GRD193 / 0, 255, 0, 1440, 721, 90000, 0, 128, -90000, - & -250, 250, 250, 0, 0, 0, 0, 0, 0/ - DATA GRD194/ 0, 255, 1, 544,310, 15000, -75500, 128, 22005, - & -62509, 2500, 2500, 20000, 64, 0, 0, 0, 0/ - DATA GRD195/ 0, 255, 1, 177,129, 16829, -68196, 128, 19747, - & -63972, 2500, 2500, 20000, 64, 0, 0, 0, 0/ - DATA GRD196/ 0, 255, 1, 321,225, 18073, -161525, 136, 23088, - & -153869, 2500, 2500, 20000, 64, 0, 0, 0, 0/ - DATA GRD197/ 0, 255, 3,1073,689, 20192, -121550, 8, -95000, - & 5079, 5079, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD198/ 0, 255, 5, 825, 553, 40530, -178571, 8, -150000, - & 5953, 5953, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD199/ 0, 255, 1, 193,193, 12350, -216313, 128, 16794, - & -211720, 2500, 2500, 20000, 64, 0, 0, 0, 0/ - DATA GRD200/ 0, 255, 3, 108, 94, 16201, 285720, 8, -107000, - & 16232, 16232, 0, 64, 0, 50000, 50000, 0, 0/ - DATA GRD201/ 0, 255, 5, 65, 65, -20826, -150000, 8, -105000, - & 381000, 381000, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD202/ 0, 255, 5, 65, 43, 7838, -141028, 8, -105000, - & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD203/ 0, 255, 5, 45, 39, 19132, -185837, 8, -150000, - & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD204/ 0, 255, 1, 93, 68, -25000, 110000, 128, 60644, - & -109129, 160000, 160000, 20000, 64, 0, 0, 0, 0/ - DATA GRD205/ 0, 255, 5, 45, 39, 616, -84904, 8, -60000, - & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD206/ 0, 255, 3, 51, 41, 22289, -117991, 8, - 95000, - & 81271, 81271, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD207/ 0, 255, 5, 49, 35, 42085, -175641, 8, -150000, - & 95250, 95250, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD208/ 0, 255, 1, 29, 27, 9343, -167315, 128, 28092, - & -145878, 80000, 80000, 20000, 64, 0, 0, 0, 0/ - DATA GRD209/ 0, 255, 3, 275,223, -4850, -151100, 8, -111000, - & 44000, 44000, 0, 64, 0, 45000, 45000, 0, 0/ - DATA GRD210/ 0, 255, 1, 25, 25, 9000, -77000, 128, 26422, - & -58625, 80000, 80000, 20000, 64, 0, 0, 0, 0/ - DATA GRD211/ 0, 255, 3, 93, 65, 12190, -133459, 8, -95000, - & 81271, 81271, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD212/ 0, 255, 3, 185,129, 12190, -133459, 8, -95000, - & 40635, 40635, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD213/ 0, 255, 5, 129, 85, 7838, -141028, 8, -105000, - & 95250, 95250, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD214/ 0, 255, 5, 97, 69, 42085, -175641, 8, -150000, - & 47625, 47625, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD215/ 0, 255, 3, 369,257, 12190, -133459, 8, -95000, - & 20318, 20318, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD216/ 0, 255, 5, 139,107, 30000, -173000, 8, -135000, - & 45000, 45000, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD217/ 0, 255, 5, 277,213, 30000, -173000, 8, -135000, - & 22500, 22500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD218/ 0, 255, 3, 614,428, 12190, -133459, 8, -95000, - & 12191, 12191, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD219/ 0, 255, 5, 385,465, 25032, -119560, 0, -80000, - & 25400, 25400, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD220/ 0, 255, 5, 345,355, -36866, -220194, 0, -260000, - & 25400, 25400, 128, 64, 0, 0, 0, 0, 0/ - DATA GRD221/ 0, 255, 3, 349,277, 1000, -145500, 8, -107000, - & 32463, 32463, 0, 64, 0, 50000, 50000, 0, 0/ - DATA GRD222/ 0, 255, 3, 138,112, -4850, -151100, 8, -111000, - & 88000, 88000, 0, 64, 0, 45000, 45000, 0, 0/ - DATA GRD223/ 0, 255, 5, 129,129, -20826, -150000, 8, -105000, - & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD224/ 0, 255, 5, 65, 65, 20826, 120000, 8, -105000, - & 381000, 381000, 128, 64, 0, 0, 0, 0, 0/ - DATA GRD225/ 0, 255, 1, 185,135, -25000, -250000, 128, 60640, - & -109129, 80000, 80000, 20000, 64, 0, 0, 0, 0/ - DATA GRD226/ 0, 255, 3, 737,513, 12190, -133459, 8, -95000, - & 10159, 10159, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD227/ 0, 255, 3,1473,1025, 12190, -133459, 8, -95000, - & 5079, 5079, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD228/ 0, 255, 0, 144, 73, 90000, 0, 128, -90000, - & -2500, 2500, 2500, 64, 0, 0, 0, 0, 0/ - DATA GRD229/ 0, 255, 0, 360,181, 90000, 0, 128, -90000, - & -1000, 1000, 1000, 64, 0, 0, 0, 0, 0/ - DATA GRD230/ 0, 255, 0, 720,361, 90000, 0, 128, -90000, - & -500, 500, 500, 64, 0, 0, 0, 0, 0/ - DATA GRD231/ 0, 255, 0, 720,181, 0, 0, 128, 90000, - & -500, 500, 500, 64, 0, 0, 0, 0, 0/ - DATA GRD232/ 0, 255, 0, 360, 91, 0, 0, 128, 90000, - & -1000, 1000, 1000, 64, 0, 0, 0, 0, 0/ - DATA GRD233/ 0, 255, 0, 288,157, 78000, 0, 128, -78000, - & -1250, 1000, 1250, 0, 0, 0, 0, 0, 0/ - DATA GRD234/ 0, 255, 0, 133,121, 15000, -98000, 128, -45000, - & -65000, 250, 250, 64, 0, 0, 0, 0, 0/ - DATA GRD235/ 0, 255, 0, 720,360, 89750, 250, 128, -89750, - & -250, 500, 500, 0, 0, 0, 0, 0, 0/ - DATA GRD236/ 0, 255, 3, 151,113, 16281, 233862, 8, -95000, - & 40635, 40635, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD237/ 0, 255, 3, 54, 47, 16201, 285720, 8, -107000, - & 32463, 32463, 0, 64, 0, 50000, 50000, 0, 0/ - DATA GRD238/ 0, 255, 0, 275, 203, 50250, 261750, 128, -250, - & -29750, 250, 250, 0, 0, 0, 0, 0, 0/ - DATA GRD239/ 0, 255, 0, 155, 123, 75250, 159500, 128, 44750, - & -123500, 250, 500, 0, 0, 0, 0, 0, 0/ - DATA GRD240/ 0, 255, 5, 1121, 881, 23098, -119036, 8, -105000, - & 4763, 4763, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD241/ 0, 255, 3, 549,445, -4850, -151100, 8, -111000, - & 22000, 22000, 0, 64, 0, 45000, 45000, 0, 0/ - DATA GRD242/ 0, 255, 5, 553,425, 30000, -173000, 8, -135000, - & 11250, 11250, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD243/ 0, 255, 0, 126,101, 10000, -170000, 128, 50000, - & -120000, 400, 400, 64, 0, 0, 0, 0, 0/ - DATA GRD244/ 0, 255, 0, 275, 203, 50250, 261750, 128, -250, - & -29750, 250, 250, 0, 0, 0, 0, 0, 0/ - DATA GRD245/ 0, 255, 3, 336,372, 22980, -92840, 8, -80000, - & 8000, 8000, 0, 64, 0, 35000, 35000, 0, 0/ - DATA GRD246/ 0, 255, 3, 332,371, 25970, -127973, 8, -115000, - & 8000, 8000, 0, 64, 0, 40000, 40000, 0, 0/ - DATA GRD247/ 0, 255, 3, 336,372, 22980, -110840, 8, -98000, - & 8000, 8000, 0, 64, 0, 35000, 35000, 0, 0/ - DATA GRD248/ 0, 255, 0, 135,101, 14500, -71500, 128, 22000, - & -61450, 75, 75, 64, 0, 0, 0, 0, 0/ - DATA GRD249/ 0, 255, 5, 367,343, 45400, -171600, 8, -150000, - & 9868, 9868, 0, 64, 0, 0, 0, 0, 0/ - DATA GRD250/ 0, 255, 0, 135,101, 16500, -162000, 128, 24000, - & -151950, 75, 75, 64, 0, 0, 0, 0, 0/ - DATA GRD251/ 0, 255, 0, 332,210, 26350, -83050, 128, 47250, - & -49950, 100, 100, 64, 0, 0, 0, 0, 0/ - DATA GRD252/ 0, 255, 3, 301,225, 16281, 233862, 8, 265000, - & 20318, 20318, 0, 64, 0, 25000, 25000, 0, 0/ - DATA GRD253/ 0, 255, 0, 373,224, 60500, 189750, 128, 4750, - & -77250, 250, 250, 0, 0, 0, 0, 0, 0/ - DATA GRD254/ 0, 255, 1, 369,300, -35000, -250000, 128, 60789, - & -109129, 40000,40000, 20000, 64, 0, 0, 0, 0/ -C - IERR = 0 -C - DO 1 I = 1,18 - IGDS(I) = 0 - 1 CONTINUE -C - IF (IGRID.GE.37.AND.IGRID.LE.44) THEN - DO 2 I = 19,91 - IGDS(I) = 0 - 2 CONTINUE - END IF -C - IF (IGRID.GE.21.AND.IGRID.LE.24) THEN - DO I = 19,55 - IGDS(I) = 0 - END DO - END IF -C - IF (IGRID.GE.25.AND.IGRID.LE.26) THEN - DO I = 19,37 - IGDS(I) = 0 - END DO - END IF -C - IF (IGRID.GE.61.AND.IGRID.LE.64) THEN - DO I = 19,64 - IGDS(I) = 0 - END DO - END IF -C - IF (IGRID.EQ.1) THEN - DO 3 I = 1,18 - IGDS(I) = GRD1(I) - 3 CONTINUE -C - ELSE IF (IGRID.EQ.2) THEN - DO 4 I = 1,18 - IGDS(I) = GRD2(I) - 4 CONTINUE -C - ELSE IF (IGRID.EQ.3) THEN - DO 5 I = 1,18 - IGDS(I) = GRD3(I) - 5 CONTINUE -C - ELSE IF (IGRID.EQ.4) THEN - DO 6 I = 1,18 - IGDS(I) = GRD4(I) - 6 CONTINUE -C - ELSE IF (IGRID.EQ.5) THEN - DO 10 I = 1,18 - IGDS(I) = GRD5(I) - 10 CONTINUE -C - ELSE IF (IGRID.EQ.6) THEN - DO 20 I = 1,18 - IGDS(I) = GRD6(I) - 20 CONTINUE -C - ELSE IF (IGRID.EQ.8) THEN - DO I = 1,18 - IGDS(I) = GRD8(I) - END DO -C - ELSE IF (IGRID.EQ.10) THEN - DO I = 1,18 - IGDS(I) = GRD10(I) - END DO -C - ELSE IF (IGRID.EQ.11) THEN - DO I = 1,18 - IGDS(I) = GRD11(I) - END DO -C - ELSE IF (IGRID.EQ.12) THEN - DO I = 1,18 - IGDS(I) = GRD12(I) - END DO -C - ELSE IF (IGRID.EQ.13) THEN - DO I = 1,18 - IGDS(I) = GRD13(I) - END DO -C - ELSE IF (IGRID.EQ.14) THEN - DO I = 1,18 - IGDS(I) = GRD14(I) - END DO -C - ELSE IF (IGRID.EQ.15) THEN - DO I = 1,18 - IGDS(I) = GRD15(I) - END DO -C - ELSE IF (IGRID.EQ.16) THEN - DO I = 1,18 - IGDS(I) = GRD16(I) - END DO -C - ELSE IF (IGRID.EQ.17) THEN - DO I = 1,18 - IGDS(I) = GRD17(I) - END DO -C - ELSE IF (IGRID.EQ.18) THEN - DO I = 1,18 - IGDS(I) = GRD18(I) - END DO -C - ELSE IF (IGRID.EQ.21) THEN - DO 30 I = 1,55 - IGDS(I) = GRD21(I) - 30 CONTINUE -C - ELSE IF (IGRID.EQ.22) THEN - DO 40 I = 1,55 - IGDS(I) = GRD22(I) - 40 CONTINUE -C - ELSE IF (IGRID.EQ.23) THEN - DO 50 I = 1,55 - IGDS(I) = GRD23(I) - 50 CONTINUE -C - ELSE IF (IGRID.EQ.24) THEN - DO 60 I = 1,55 - IGDS(I) = GRD24(I) - 60 CONTINUE -C - ELSE IF (IGRID.EQ.25) THEN - DO 70 I = 1,37 - IGDS(I) = GRD25(I) - 70 CONTINUE -C - ELSE IF (IGRID.EQ.26) THEN - DO 80 I = 1,37 - IGDS(I) = GRD26(I) - 80 CONTINUE -C - ELSE IF (IGRID.EQ.27) THEN - DO 90 I = 1,18 - IGDS(I) = GRD27(I) - 90 CONTINUE -C - ELSE IF (IGRID.EQ.28) THEN - DO 100 I = 1,18 - IGDS(I) = GRD28(I) - 100 CONTINUE -C - ELSE IF (IGRID.EQ.29) THEN - DO 110 I = 1,18 - IGDS(I) = GRD29(I) - 110 CONTINUE -C - ELSE IF (IGRID.EQ.30) THEN - DO 120 I = 1,18 - IGDS(I) = GRD30(I) - 120 CONTINUE -C - ELSE IF (IGRID.EQ.33) THEN - DO 130 I = 1,18 - IGDS(I) = GRD33(I) - 130 CONTINUE -C - ELSE IF (IGRID.EQ.34) THEN - DO 140 I = 1,18 - IGDS(I) = GRD34(I) - 140 CONTINUE -C - ELSE IF (IGRID.EQ.37) THEN - DO 141 I = 1,91 - IGDS(I) = GRD37(I) - 141 CONTINUE -C - ELSE IF (IGRID.EQ.38) THEN - DO 142 I = 1,91 - IGDS(I) = GRD38(I) - 142 CONTINUE -C - ELSE IF (IGRID.EQ.39) THEN - DO 143 I = 1,91 - IGDS(I) = GRD39(I) - 143 CONTINUE -C - ELSE IF (IGRID.EQ.40) THEN - DO 144 I = 1,91 - IGDS(I) = GRD40(I) - 144 CONTINUE -C - ELSE IF (IGRID.EQ.41) THEN - DO 145 I = 1,91 - IGDS(I) = GRD41(I) - 145 CONTINUE -C - ELSE IF (IGRID.EQ.42) THEN - DO 146 I = 1,91 - IGDS(I) = GRD42(I) - 146 CONTINUE -C - ELSE IF (IGRID.EQ.43) THEN - DO 147 I = 1,91 - IGDS(I) = GRD43(I) - 147 CONTINUE -C - ELSE IF (IGRID.EQ.44) THEN - DO 148 I = 1,91 - IGDS(I) = GRD44(I) - 148 CONTINUE -C - ELSE IF (IGRID.EQ.45) THEN - DO 149 I = 1,18 - IGDS(I) = GRD45(I) - 149 CONTINUE -C - ELSE IF (IGRID.EQ.53) THEN - DO I = 1,18 - IGDS(I) = GRD53(I) - END DO -C - ELSE IF (IGRID.EQ.55) THEN - DO 152 I = 1,18 - IGDS(I) = GRD55(I) - 152 CONTINUE -C - ELSE IF (IGRID.EQ.56) THEN - DO 154 I = 1,18 - IGDS(I) = GRD56(I) - 154 CONTINUE -C - ELSE IF (IGRID.EQ.61) THEN - DO 160 I = 1,64 - IGDS(I) = GRD61(I) - 160 CONTINUE -C - ELSE IF (IGRID.EQ.62) THEN - DO 170 I = 1,64 - IGDS(I) = GRD62(I) - 170 CONTINUE -C - ELSE IF (IGRID.EQ.63) THEN - DO 180 I = 1,64 - IGDS(I) = GRD63(I) - 180 CONTINUE -C - ELSE IF (IGRID.EQ.64) THEN - DO 190 I = 1,64 - IGDS(I) = GRD64(I) - 190 CONTINUE -C - ELSE IF (IGRID.EQ.83) THEN - DO I = 1,18 - IGDS(I) = GRD83(I) - ENDDO -C - ELSE IF (IGRID.EQ.85) THEN - DO 192 I = 1,18 - IGDS(I) = GRD85(I) - 192 CONTINUE -C - ELSE IF (IGRID.EQ.86) THEN - DO 194 I = 1,18 - IGDS(I) = GRD86(I) - 194 CONTINUE -C - ELSE IF (IGRID.EQ.87) THEN - DO 195 I = 1,18 - IGDS(I) = GRD87(I) - 195 CONTINUE -C - ELSE IF (IGRID.EQ.88) THEN - DO 2195 I = 1,18 - IGDS(I) = GRD88(I) -2195 CONTINUE -C - ELSE IF (IGRID.EQ.90) THEN - DO 196 I = 1,18 - IGDS(I) = GRD90(I) - 196 CONTINUE -C - ELSE IF (IGRID.EQ.91) THEN - DO 197 I = 1,18 - IGDS(I) = GRD91(I) - 197 CONTINUE -C - ELSE IF (IGRID.EQ.92) THEN - DO 198 I = 1,18 - IGDS(I) = GRD92(I) - 198 CONTINUE -C - ELSE IF (IGRID.EQ.93) THEN - DO 199 I = 1,18 - IGDS(I) = GRD93(I) - 199 CONTINUE -C - ELSE IF (IGRID.EQ.94) THEN - DO 200 I = 1,18 - IGDS(I) = GRD94(I) - 200 CONTINUE -C - ELSE IF (IGRID.EQ.95) THEN - DO 201 I = 1,18 - IGDS(I) = GRD95(I) - 201 CONTINUE -C - ELSE IF (IGRID.EQ.96) THEN - DO 202 I = 1,18 - IGDS(I) = GRD96(I) - 202 CONTINUE -C - ELSE IF (IGRID.EQ.97) THEN - DO 203 I = 1,18 - IGDS(I) = GRD97(I) - 203 CONTINUE -C - ELSE IF (IGRID.EQ.98) THEN - DO 204 I = 1,18 - IGDS(I) = GRD98(I) - 204 CONTINUE -C - ELSE IF (IGRID.EQ.99) THEN - DO I = 1,18 - IGDS(I) = GRD99(I) - ENDDO -C - ELSE IF (IGRID.EQ.100) THEN - DO 205 I = 1,18 - IGDS(I) = GRD100(I) - 205 CONTINUE -C - ELSE IF (IGRID.EQ.101) THEN - DO 210 I = 1,18 - IGDS(I) = GRD101(I) - 210 CONTINUE -C - ELSE IF (IGRID.EQ.103) THEN - DO 220 I = 1,18 - IGDS(I) = GRD103(I) - 220 CONTINUE -C - ELSE IF (IGRID.EQ.104) THEN - DO 230 I = 1,18 - IGDS(I) = GRD104(I) - 230 CONTINUE -C - ELSE IF (IGRID.EQ.105) THEN - DO 240 I = 1,18 - IGDS(I) = GRD105(I) - 240 CONTINUE -C - ELSE IF (IGRID.EQ.106) THEN - DO 242 I = 1,18 - IGDS(I) = GRD106(I) - 242 CONTINUE -C - ELSE IF (IGRID.EQ.107) THEN - DO 244 I = 1,18 - IGDS(I) = GRD107(I) - 244 CONTINUE -C - ELSE IF (IGRID.EQ.110) THEN - DO I = 1,18 - IGDS(I) = GRD110(I) - ENDDO -C - ELSE IF (IGRID.EQ.120) THEN - DO I = 1,18 - IGDS(I) = GRD120(I) - ENDDO -C - ELSE IF (IGRID.EQ.122) THEN - DO I = 1,18 - IGDS(I) = GRD122(I) - ENDDO -C - ELSE IF (IGRID.EQ.123) THEN - DO I = 1,18 - IGDS(I) = GRD123(I) - ENDDO -C - ELSE IF (IGRID.EQ.124) THEN - DO I = 1,18 - IGDS(I) = GRD124(I) - ENDDO -C - ELSE IF (IGRID.EQ.125) THEN - DO I = 1,18 - IGDS(I) = GRD125(I) - ENDDO -C - ELSE IF (IGRID.EQ.126) THEN - DO 245 I = 1,18 - IGDS(I) = GRD126(I) - 245 CONTINUE -C - ELSE IF (IGRID.EQ.127) THEN - DO I = 1,18 - IGDS(I) = GRD127(I) - ENDDO -C - ELSE IF (IGRID.EQ.128) THEN - DO I = 1,18 - IGDS(I) = GRD128(I) - ENDDO -C - ELSE IF (IGRID.EQ.129) THEN - DO I = 1,18 - IGDS(I) = GRD129(I) - ENDDO -C - ELSE IF (IGRID.EQ.130) THEN - DO I = 1,18 - IGDS(I) = GRD130(I) - ENDDO -C - ELSE IF (IGRID.EQ.132) THEN - DO I = 1,18 - IGDS(I) = GRD132(I) - ENDDO -C - ELSE IF (IGRID.EQ.138) THEN - DO I = 1,18 - IGDS(I) = GRD138(I) - ENDDO -C - ELSE IF (IGRID.EQ.139) THEN - DO I = 1,18 - IGDS(I) = GRD139(I) - ENDDO -C - ELSE IF (IGRID.EQ.140) THEN - DO I = 1,18 - IGDS(I) = GRD140(I) - ENDDO -C - ELSE IF (IGRID.EQ.145) THEN - DO I = 1,18 - IGDS(I) = GRD145(I) - ENDDO -C - ELSE IF (IGRID.EQ.146) THEN - DO I = 1,18 - IGDS(I) = GRD146(I) - ENDDO -C - ELSE IF (IGRID.EQ.147) THEN - DO I = 1,18 - IGDS(I) = GRD147(I) - ENDDO -C - ELSE IF (IGRID.EQ.148) THEN - DO I = 1,18 - IGDS(I) = GRD148(I) - ENDDO -C - ELSE IF (IGRID.EQ.150) THEN - DO I = 1,18 - IGDS(I) = GRD150(I) - ENDDO -C - ELSE IF (IGRID.EQ.151) THEN - DO I = 1,18 - IGDS(I) = GRD151(I) - ENDDO -C - ELSE IF (IGRID.EQ.160) THEN - DO I = 1,18 - IGDS(I) = GRD160(I) - ENDDO -C - ELSE IF (IGRID.EQ.161) THEN - DO I = 1,18 - IGDS(I) = GRD161(I) - ENDDO - ELSE IF (IGRID.EQ.163) THEN - DO I = 1,18 - IGDS(I) = GRD163(I) - ENDDO -C - ELSE IF (IGRID.EQ.170) THEN - DO I = 1,18 - IGDS(I) = GRD170(I) - ENDDO -C - ELSE IF (IGRID.EQ.171) THEN - DO I = 1,18 - IGDS(I) = GRD171(I) - ENDDO -C - ELSE IF (IGRID.EQ.172) THEN - DO I = 1,18 - IGDS(I) = GRD172(I) - ENDDO -C - ELSE IF (IGRID.EQ.173) THEN - DO I = 1,18 - IGDS(I) = GRD173(I) - ENDDO -C - ELSE IF (IGRID.EQ.174) THEN - DO I = 1,18 - IGDS(I) = GRD174(I) - ENDDO -C - ELSE IF (IGRID.EQ.175) THEN - DO I = 1,18 - IGDS(I) = GRD175(I) - ENDDO -C - ELSE IF (IGRID.EQ.176) THEN - DO I = 1,18 - IGDS(I) = GRD176(I) - ENDDO -C - ELSE IF (IGRID.EQ.179) THEN - DO I = 1,18 - IGDS(I) = GRD179(I) - ENDDO -C - ELSE IF (IGRID.EQ.180) THEN - DO I = 1,18 - IGDS(I) = GRD180(I) - ENDDO -C - ELSE IF (IGRID.EQ.181) THEN - DO I = 1,18 - IGDS(I) = GRD181(I) - ENDDO -C - ELSE IF (IGRID.EQ.182) THEN - DO I = 1,18 - IGDS(I) = GRD182(I) - ENDDO -C - ELSE IF (IGRID.EQ.183) THEN - DO I = 1,18 - IGDS(I) = GRD183(I) - ENDDO -C - ELSE IF (IGRID.EQ.184) THEN - DO I = 1,18 - IGDS(I) = GRD184(I) - ENDDO -C - ELSE IF (IGRID.EQ.187) THEN - DO I = 1,18 - IGDS(I) = GRD187(I) - ENDDO -C - ELSE IF (IGRID.EQ.188) THEN - DO I = 1,18 - IGDS(I) = GRD188(I) - ENDDO -C - ELSE IF (IGRID.EQ.189) THEN - DO I = 1,18 - IGDS(I) = GRD189(I) - ENDDO -C - ELSE IF (IGRID.EQ.190) THEN - DO 2190 I = 1,18 - IGDS(I) = GRD190(I) - 2190 CONTINUE -C - ELSE IF (IGRID.EQ.192) THEN - DO 2191 I = 1,18 - IGDS(I) = GRD192(I) - 2191 CONTINUE -C - ELSE IF (IGRID.EQ.193) THEN - DO I = 1,18 - IGDS(I) = GRD193(I) - END DO -C - ELSE IF (IGRID.EQ.194) THEN - DO 2192 I = 1,18 - IGDS(I) = GRD194(I) - 2192 CONTINUE -C - ELSE IF (IGRID.EQ.195) THEN - DO I = 1,18 - IGDS(I) = GRD195(I) - END DO -C - ELSE IF (IGRID.EQ.196) THEN - DO 249 I = 1,18 - IGDS(I) = GRD196(I) - 249 CONTINUE -C - ELSE IF (IGRID.EQ.197) THEN - DO I = 1,18 - IGDS(I) = GRD197(I) - END DO -C - ELSE IF (IGRID.EQ.198) THEN - DO 2490 I = 1,18 - IGDS(I) = GRD198(I) - 2490 CONTINUE -C - ELSE IF (IGRID.EQ.199) THEN - DO I = 1,18 - IGDS(I) = GRD199(I) - END DO -C - ELSE IF (IGRID.EQ.200) THEN - DO I = 1,18 - IGDS(I) = GRD200(I) - END DO -C - ELSE IF (IGRID.EQ.201) THEN - DO 250 I = 1,18 - IGDS(I) = GRD201(I) - 250 CONTINUE -C - ELSE IF (IGRID.EQ.202) THEN - DO 260 I = 1,18 - IGDS(I) = GRD202(I) - 260 CONTINUE -C - ELSE IF (IGRID.EQ.203) THEN - DO 270 I = 1,18 - IGDS(I) = GRD203(I) - 270 CONTINUE -C - ELSE IF (IGRID.EQ.204) THEN - DO 280 I = 1,18 - IGDS(I) = GRD204(I) - 280 CONTINUE -C - ELSE IF (IGRID.EQ.205) THEN - DO 290 I = 1,18 - IGDS(I) = GRD205(I) - 290 CONTINUE -C - ELSE IF (IGRID.EQ.206) THEN - DO 300 I = 1,18 - IGDS(I) = GRD206(I) - 300 CONTINUE -C - ELSE IF (IGRID.EQ.207) THEN - DO 310 I = 1,18 - IGDS(I) = GRD207(I) - 310 CONTINUE -C - ELSE IF (IGRID.EQ.208) THEN - DO 320 I = 1,18 - IGDS(I) = GRD208(I) - 320 CONTINUE -C - ELSE IF (IGRID.EQ.209) THEN - DO 330 I = 1,18 - IGDS(I) = GRD209(I) - 330 CONTINUE -C - ELSE IF (IGRID.EQ.210) THEN - DO 340 I = 1,18 - IGDS(I) = GRD210(I) - 340 CONTINUE -C - ELSE IF (IGRID.EQ.211) THEN - DO 350 I = 1,18 - IGDS(I) = GRD211(I) - 350 CONTINUE -C - ELSE IF (IGRID.EQ.212) THEN - DO 360 I = 1,18 - IGDS(I) = GRD212(I) - 360 CONTINUE -C - ELSE IF (IGRID.EQ.213) THEN - DO 370 I = 1,18 - IGDS(I) = GRD213(I) - 370 CONTINUE -C - ELSE IF (IGRID.EQ.214) THEN - DO 380 I = 1,18 - IGDS(I) = GRD214(I) - 380 CONTINUE -C - ELSE IF (IGRID.EQ.215) THEN - DO 390 I = 1,18 - IGDS(I) = GRD215(I) - 390 CONTINUE -C - ELSE IF (IGRID.EQ.216) THEN - DO 400 I = 1,18 - IGDS(I) = GRD216(I) - 400 CONTINUE -C - ELSE IF (IGRID.EQ.217) THEN - DO 401 I = 1,18 - IGDS(I) = GRD217(I) - 401 CONTINUE -C - ELSE IF (IGRID.EQ.218) THEN - DO 410 I = 1,18 - IGDS(I) = GRD218(I) - 410 CONTINUE -C - ELSE IF (IGRID.EQ.219) THEN - DO 411 I = 1,18 - IGDS(I) = GRD219(I) - 411 CONTINUE -C - ELSE IF (IGRID.EQ.220) THEN - DO 412 I = 1,18 - IGDS(I) = GRD220(I) - 412 CONTINUE -C - ELSE IF (IGRID.EQ.221) THEN - DO 413 I = 1,18 - IGDS(I) = GRD221(I) - 413 CONTINUE -C - ELSE IF (IGRID.EQ.222) THEN - DO 414 I = 1,18 - IGDS(I) = GRD222(I) - 414 CONTINUE -C - ELSE IF (IGRID.EQ.223) THEN - DO 415 I = 1,18 - IGDS(I) = GRD223(I) - 415 CONTINUE -C - ELSE IF (IGRID.EQ.224) THEN - DO 416 I = 1,18 - IGDS(I) = GRD224(I) - 416 CONTINUE -C - ELSE IF (IGRID.EQ.225) THEN - DO 417 I = 1,18 - IGDS(I) = GRD225(I) - 417 CONTINUE -C - ELSE IF (IGRID.EQ.226) THEN - DO 418 I = 1,18 - IGDS(I) = GRD226(I) - 418 CONTINUE -C - ELSE IF (IGRID.EQ.227) THEN - DO 419 I = 1,18 - IGDS(I) = GRD227(I) - 419 CONTINUE -C - ELSE IF (IGRID.EQ.228) THEN - DO 420 I = 1,18 - IGDS(I) = GRD228(I) - 420 CONTINUE -C - ELSE IF (IGRID.EQ.229) THEN - DO 421 I = 1,18 - IGDS(I) = GRD229(I) - 421 CONTINUE -C - ELSE IF (IGRID.EQ.230) THEN - DO 422 I = 1,18 - IGDS(I) = GRD230(I) - 422 CONTINUE -C - ELSE IF (IGRID.EQ.231) THEN - DO 423 I = 1,18 - IGDS(I) = GRD231(I) - 423 CONTINUE -C - ELSE IF (IGRID.EQ.232) THEN - DO 424 I = 1,18 - IGDS(I) = GRD232(I) - 424 CONTINUE -C - ELSE IF (IGRID.EQ.233) THEN - DO 425 I = 1,18 - IGDS(I) = GRD233(I) - 425 CONTINUE -C - ELSE IF (IGRID.EQ.234) THEN - DO 426 I = 1,18 - IGDS(I) = GRD234(I) - 426 CONTINUE -C - ELSE IF (IGRID.EQ.235) THEN - DO 427 I = 1,18 - IGDS(I) = GRD235(I) - 427 CONTINUE -C - ELSE IF (IGRID.EQ.236) THEN - DO 428 I = 1,18 - IGDS(I) = GRD236(I) - 428 CONTINUE -C - ELSE IF (IGRID.EQ.237) THEN - DO 429 I = 1,18 - IGDS(I) = GRD237(I) - 429 CONTINUE -C - ELSE IF (IGRID.EQ.238) THEN - DO I = 1,18 - IGDS(I) = GRD238(I) - END DO -C - ELSE IF (IGRID.EQ.239) THEN - DO I = 1,18 - IGDS(I) = GRD239(I) - END DO -C - ELSE IF (IGRID.EQ.240) THEN - DO I = 1,18 - IGDS(I) = GRD240(I) - END DO -C - ELSE IF (IGRID.EQ.241) THEN - DO 430 I = 1,18 - IGDS(I) = GRD241(I) - 430 CONTINUE -C - ELSE IF (IGRID.EQ.242) THEN - DO 431 I = 1,18 - IGDS(I) = GRD242(I) - 431 CONTINUE -C - ELSE IF (IGRID.EQ.243) THEN - DO 432 I = 1,18 - IGDS(I) = GRD243(I) - 432 CONTINUE -C - ELSE IF (IGRID.EQ.244) THEN - DO I = 1,18 - IGDS(I) = GRD244(I) - END DO -C - ELSE IF (IGRID.EQ.245) THEN - DO 433 I = 1,18 - IGDS(I) = GRD245(I) - 433 CONTINUE -C - ELSE IF (IGRID.EQ.246) THEN - DO 434 I = 1,18 - IGDS(I) = GRD246(I) - 434 CONTINUE -C - ELSE IF (IGRID.EQ.247) THEN - DO 435 I = 1,18 - IGDS(I) = GRD247(I) - 435 CONTINUE -C - ELSE IF (IGRID.EQ.248) THEN - DO 436 I = 1,18 - IGDS(I) = GRD248(I) - 436 CONTINUE -C - ELSE IF (IGRID.EQ.249) THEN - DO 437 I = 1,18 - IGDS(I) = GRD249(I) - 437 CONTINUE -C - ELSE IF (IGRID.EQ.250) THEN - DO 438 I = 1,18 - IGDS(I) = GRD250(I) - 438 CONTINUE -C - ELSE IF (IGRID.EQ.251) THEN - DO 439 I = 1,18 - IGDS(I) = GRD251(I) - 439 CONTINUE -C - ELSE IF (IGRID.EQ.252) THEN - DO 440 I = 1,18 - IGDS(I) = GRD252(I) - 440 CONTINUE - ELSE IF (IGRID.EQ.253) THEN - DO 441 I = 1,18 - IGDS(I) = GRD253(I) - 441 CONTINUE - ELSE IF (IGRID.EQ.254) THEN - DO 442 I = 1,18 - IGDS(I) = GRD254(I) - 442 CONTINUE -C - ELSE - IERR = 1 - ENDIF -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi72.f b/external/w3nco/v2.0.6/src/w3fi72.f deleted file mode 100644 index 5797f2f1..00000000 --- a/external/w3nco/v2.0.6/src/w3fi72.f +++ /dev/null @@ -1,455 +0,0 @@ - SUBROUTINE W3FI72(ITYPE,FLD,IFLD,IBITL, - & IPFLAG,ID,PDS, - & IGFLAG,IGRID,IGDS,ICOMP, - & IBFLAG,IBMAP,IBLEN,IBDSFL, - & NPTS,KBUF,ITOT,JERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI72 MAKE A COMPLETE GRIB MESSAGE -C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 -C -C ABSTRACT: MAKES A COMPLETE GRIB MESSAGE FROM A USER SUPPLIED -C ARRAY OF FLOATING POINT OR INTEGER DATA. THE USER HAS THE -C OPTION OF SUPPLYING THE PDS OR AN INTEGER ARRAY THAT WILL BE -C USED TO CREATE A PDS (WITH W3FI68). THE USER MUST ALSO -C SUPPLY OTHER NECESSARY INFO; SEE USAGE SECTION BELOW. -C -C PROGRAM HISTORY LOG: -C 91-05-08 R.E.JONES -C 92-07-01 M. FARLEY ADDED GDS AND BMS LOGIC. PLACED EXISTING -C LOGIC FOR BDS IN A ROUTINE. -C 92-10-02 R.E.JONES ADD ERROR EXIT FOR W3FI73 -C 93-04-30 R.E.JONES REPLACE DO LOOPS TO MOVE CHARACTER DATA -C WITH XMOVEX, USE XSTORE TO ZERO CHARACTER -C ARRAY. MAKE CHANGE SO FLAT FIELD WILL PACK. -C 93-08-06 CAVANAUGH MODIFIED CALL TO W3FI75 -C 93-10-26 CAVANAUGH ADDED CODE TO RESTORE INPUT FIELD TO ORIGINAL -C VALUES IF D-SCALE NOT 0 -C 94-01-27 CAVANAUGH ADDED IGDS ARRAY IN CALL TO W3FI75 TO PROVIDE -C INFORMATION FOR BOUSTROPHEDONIC PROCESSING -C 94-03-03 CAVANAUGH INCREASED SIZE OF GDS ARRAY FOR THIN GRIDS -C 94-05-16 FARLEY CLEANED UP DOCUMENTATION -C 94-11-10 FARLEY INCREASED SIZE OF PFLD/IFLD ARRARYS FROM -C 100K TO 260K FOR .5 DEGREE SST ANAL FIELDS -C 94-12-04 R.E.JONES CHANGE DOCUMENT FOR IPFLAG. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-05-19 Gilbert Increased array dimensions to handle grids -C of up to 500,000 grid points. -C 95-10-31 IREDELL GENERALIZED WORD SIZE -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C 99-02-01 Gilbert Changed the method of zeroing out array KBUF. -C the old method, using W3FI01 and XSTORE was -C incorrect with 4-byte integers and 8-byte reals. -C 2001-06-07 Gilbert Removed calls to xmovex. -C changed IPFLD from integer to character. -C 10-02-19 GAYNO FIX ALLOCATION OF ARRAY BMS -C -C USAGE: CALL W3FI72(ITYPE,FLD,IFLD,IBITL, -C & IPFLAG,ID,PDS, -C & IGFLAG,IGRID,IGDS,ICOMP, -C & IBFLAG,IBMAP,IBLEN,IBDSFL, -C & IBDSFL, -C & NPTS,KBUF,ITOT,JERR) -C -C INPUT ARGUMENT LIST: -C ITYPE - 0 = FLOATING POINT DATA SUPPLIED IN ARRAY 'FLD' -C 1 = INTEGER DATA SUPPLIED IN ARRAY 'IFLD' -C FLD - REAL ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE -C CONVERTED TO GRIB FORMAT IF ITYPE=0. -C SEE REMARKS #1 & 2. -C IFLD - INTEGER ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE -C CONVERTED TO GRIB FORMAT IF ITYPE=1. -C SEE REMARKS #1 & 2. -C IBITL - 0 = COMPUTER COMPUTES LENGTH FOR PACKING DATA FROM -C POWER OF 2 (NUMBER OF BITS) BEST FIT OF DATA -C USING 'VARIABLE' BIT PACKER W3FI58. -C 8, 12, ETC. COMPUTER RESCALES DATA TO FIT INTO THAT -C 'FIXED' NUMBER OF BITS USING W3FI59. -C SEE REMARKS #3. -C -C IPFLAG - 0 = MAKE PDS FROM USER SUPPLIED ARRAY (ID) -C 1 = USER SUPPLYING PDS -C NOTE: IF PDS IS GREATER THAN 30, USE IPLFAG=1. -C THE USER COULD CALL W3FI68 BEFORE HE CALLS -C W3FI72. THIS WOULD MAKE THE FIRST 30 BYTES OF -C THE PDS, USER THEN WOULD MAKE BYTES AFTER 30. -C ID - INTEGER ARRAY OF VALUES THAT W3FI68 WILL USE -C TO MAKE AN EDITION 1 PDS IF IPFLAG=0. (SEE THE -C DOCBLOCK FOR W3FI68 FOR LAYOUT OF ARRAY) -C PDS - CHARACTER ARRAY OF VALUES (VALID PDS SUPPLIED -C BY USER) IF IPFLAG=1. LENGTH MAY EXCEED 28 BYTES -C (CONTENTS OF BYTES BEYOND 28 ARE PASSED -C THROUGH UNCHANGED). -C -C IGFLAG - 0 = MAKE GDS BASED ON 'IGRID' VALUE. -C 1 = MAKE GDS FROM USER SUPPLIED INFO IN 'IGDS' -C AND 'IGRID' VALUE. -C SEE REMARKS #4. -C IGRID - # = GRID IDENTIFICATION (TABLE B) -C 255 = IF USER DEFINED GRID; IGDS MUST BE SUPPLIED -C AND IGFLAG MUST =1. -C IGDS - INTEGER ARRAY CONTAINING USER GDS INFO (SAME -C FORMAT AS SUPPLIED BY W3FI71 - SEE DOCKBLOCK FOR -C LAYOUT) IF IGFLAG=1. -C ICOMP - RESOLUTION AND COMPONENT FLAG FOR BIT 5 OF GDS(17) -C 0 = EARTH ORIENTED WINDS -C 1 = GRID ORIENTED WINDS -C -C IBFLAG - 0 = MAKE BIT MAP FROM USER SUPPLIED DATA -C # = BIT MAP PREDEFINED BY CENTER -C SEE REMARKS #5. -C IBMAP - INTEGER ARRAY CONTAINING BIT MAP -C IBLEN - LENGTH OF BIT MAP WILL BE USED TO VERIFY LENGTH -C OF FIELD (ERROR IF IT DOESN'T MATCH). -C -C IBDSFL - INTEGER ARRAY CONTAINING TABLE 11 FLAG INFO -C BDS OCTET 4: -C (1) 0 = GRID POINT DATA -C 1 = SPHERICAL HARMONIC COEFFICIENTS -C (2) 0 = SIMPLE PACKING -C 1 = SECOND ORDER PACKING -C (3) ... SAME VALUE AS 'ITYPE' -C 0 = ORIGINAL DATA WERE FLOATING POINT VALUES -C 1 = ORIGINAL DATA WERE INTEGER VALUES -C (4) 0 = NO ADDITIONAL FLAGS AT OCTET 14 -C 1 = OCTET 14 CONTAINS FLAG BITS 5-12 -C (5) 0 = RESERVED - ALWAYS SET TO 0 -C BYTE 6 OPTION 1 NOT AVAILABLE (AS OF 5-16-93) -C (6) 0 = SINGLE DATUM AT EACH GRID POINT -C 1 = MATRIX OF VALUES AT EACH GRID POINT -C BYTE 7 OPTION 0 WITH SECOND ORDER PACKING N/A (AS OF 5-16-93) -C (7) 0 = NO SECONDARY BIT MAPS -C 1 = SECONDARY BIT MAPS PRESENT -C (8) 0 = SECOND ORDER VALUES HAVE CONSTANT WIDTH -C 1 = SECOND ORDER VALUES HAVE DIFFERENT WIDTHS -C -C OUTPUT ARGUMENT LIST: -C NPTS - NUMBER OF GRIDPOINTS IN ARRAY FLD OR IFLD -C KBUF - ENTIRE GRIB MESSAGE ('GRIB' TO '7777') -C EQUIVALENCE TO INTEGER ARRAY TO MAKE SURE IT -C IS ON WORD BOUNARY. -C ITOT - TOTAL LENGTH OF GRIB MESSAGE IN BYTES -C JERR - = 0, COMPLETED MAKING GRIB FIELD WITHOUT ERROR -C 1, IPFLAG NOT 0 OR 1 -C 2, IGFLAG NOT 0 OR 1 -C 3, ERROR CONVERTING IEEE F.P. NUMBER TO IBM370 F.P. -C 4, W3FI71 ERROR/IGRID NOT DEFINED -C 5, W3FK74 ERROR/GRID REPRESENTATION TYPE NOT VALID -C 6, GRID TOO LARGE FOR PACKER DIMENSION ARRAYS -C SEE AUTOMATION DIVISION FOR REVISION! -C 7, LENGTH OF BIT MAP NOT EQUAL TO SIZE OF FLD/IFLD -C 8, W3FI73 ERROR, ALL VALUES IN IBMAP ARE ZERO -C -C OUTPUT FILES: -C FT06F001 - STANDARD FORTRAN OUTPUT PRINT FILE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - W3FI58, W3FI59, W3FI68, W3FI71, W3FI73, W3FI74 -C W3FI75, W3FI76 -C FORTRAN 90 INTRINSIC - BIT_SIZE -C -C REMARKS: -C 1) IF BIT MAP TO BE INCLUDED IN MESSAGE, NULL DATA SHOULD -C BE INCLUDED IN FLD OR IFLD. THIS ROUTINE WILL TAKE CARE -C OF 'DISCARDING' ANY NULL DATA BASED ON THE BIT MAP. -C 2) UNITS MUST BE THOSE IN GRIB DOCUMENTATION: NMC O.N. 388 -C OR WMO PUBLICATION 306. -C 3) IN EITHER CASE, INPUT NUMBERS WILL BE MULTIPLIED BY -C '10 TO THE NTH' POWER FOUND IN ID(25) OR PDS(27-28), -C THE D-SCALING FACTOR, PRIOR TO BINARY PACKING. -C 4) ALL NMC PRODUCED GRIB FIELDS WILL HAVE A GRID DEFINITION -C SECTION INCLUDED IN THE GRIB MESSAGE. ID(6) WILL BE -C SET TO '1'. -C - GDS WILL BE BUILT BASED ON GRID NUMBER (IGRID), UNLESS -C IGFLAG=1 (USER SUPPLYING IGDS). USER MUST STILL SUPPLY -C IGRID EVEN IF IGDS PROVIDED. -C 5) IF BIT MAP USED THEN ID(7) OR PDS(8) MUST INDICATE THE -C PRESENCE OF A BIT MAP. -C 6) ARRAY KBUF SHOULD BE EQUIVALENCED TO AN INTEGER VALUE OR -C ARRAY TO MAKE SURE IT IS ON A WORD BOUNDARY. -C 7) SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -C - REAL FLD(*) -C - INTEGER IBDSFL(*) - INTEGER IBMAP(*) - INTEGER ID(*) - INTEGER IFLD(*) - INTEGER IGDS(*) - INTEGER IB(4) - INTEGER NLEFT, NUMBMS -C - CHARACTER * 1 BDS11(11) - CHARACTER * 1 KBUF(*) - CHARACTER * 1 PDS(*) - CHARACTER * 1 GDS(200) - CHARACTER(1),ALLOCATABLE:: BMS(:) - CHARACTER(1),ALLOCATABLE:: PFLD(:) - CHARACTER(1),ALLOCATABLE:: IPFLD(:) - CHARACTER * 1 SEVEN - CHARACTER * 1 ZERO -C -C -C ASCII REP OF /'G', 'R', 'I', 'B'/ -C - DATA IB / 71, 82, 73, 66/ -C - IER = 0 - IBERR = 0 - JERR = 0 - IGRIBL = 8 - IPDSL = 0 - LENGDS = 0 - LENBMS = 0 - LENBDS = 0 - ITOSS = 0 -C -C 1.0 PRODUCT DEFINITION SECTION(PDS). -C -C SET ID(6) TO 1 ...OR... MODIFY PDS(8) ... -C REGARDLESS OF USER SPECIFICATION... -C NMC GRIB FIELDS WILL ALWAYS HAVE A GDS -C - IF (IPFLAG .EQ.0) THEN - ID(6) = 1 - CALL W3FI68(ID,PDS) - ELSE IF (IPFLAG .EQ. 1) THEN - IF (IAND(mova2i(PDS(8)),64) .EQ. 64) THEN -C BOTH GDS AND BMS - PDS(8) = CHAR(192) - ELSE IF (mova2i(PDS(8)) .EQ. 0) THEN -C GDS ONLY - PDS(8) = CHAR(128) - END IF - CONTINUE - ELSE -C PRINT *,' W3FI72 ERROR, IPFLAG IS NOT 0 OR 1 IPFLAG = ',IPFLAG - JERR = 1 - GO TO 900 - END IF -C -C GET LENGTH OF PDS -C - IPDSL = mova2i(PDS(1)) * 65536 + mova2i(PDS(2)) * 256 + - & mova2i(PDS(3)) -C -C 2.0 GRID DEFINITION SECTION (GDS). -C -C IF IGFLAG=1 THEN USER IS SUPPLYING THE IGDS INFORMATION -C - IF (IGFLAG .EQ. 0) THEN - CALL W3FI71(IGRID,IGDS,IGERR) - IF (IGERR .EQ. 1) THEN -C PRINT *,' W3FI71 ERROR, GRID TYPE NOT DEFINED...',IGRID - JERR = 4 - GO TO 900 - END IF - END IF - IF (IGFLAG .EQ. 0 .OR. IGFLAG .EQ.1) THEN - CALL W3FI74(IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR) - IF (IGERR .EQ. 1) THEN -C PRINT *,' W3FI74 ERROR, GRID REP TYPE NOT VALID...',IGDS(3) - JERR = 5 - GO TO 900 - ELSE - END IF - ELSE -C PRINT *,' W3FI72 ERROR, IGFLAG IS NOT 0 OR 1 IGFLAG = ',IGFLAG - JERR = 2 - GO TO 900 - END IF -C -C 3.0 BIT MAP SECTION (BMS). -C -C SET ITOSS=1 IF BITMAP BEING USED. W3FI75 WILL TOSS DATA -C PRIOR TO PACKING. LATER CODING WILL BE NEEDED WHEN THE -C 'PREDEFINED' GRIDS ARE FINALLY 'DEFINED'. -C - IF (mova2i(PDS(8)) .EQ. 64 .OR. - & mova2i(PDS(8)) .EQ. 192) THEN - ITOSS = 1 - IF (IBFLAG .EQ. 0) THEN - IF (IBLEN .NE. NPTS) THEN -C PRINT *,' W3FI72 ERROR, IBLEN .NE. NPTS = ',IBLEN,NPTS - JERR = 7 - GO TO 900 - END IF - IF (MOD(IBLEN,16).NE.0) THEN - NLEFT = 16 - MOD(IBLEN,16) - ELSE - NLEFT = 0 - END IF - NUMBMS = 6 + (IBLEN+NLEFT) / 8 - ALLOCATE(BMS(NUMBMS)) - ZERO = CHAR(00) - BMS = ZERO - CALL W3FI73(IBFLAG,IBMAP,IBLEN,BMS,LENBMS,IER) - IF (IER .NE. 0) THEN -C PRINT *,' W3FI73 ERROR, IBMAP VALUES ARE ALL ZERO' - JERR = 8 - GO TO 900 - END IF - ELSE -C PRINT *,' BIT MAP PREDEFINED BY CENTER, IBFLAG = ',IBFLAG - END IF - END IF -C -C 4.0 BINARY DATA SECTION (BDS). -C -C 4.1 SCALE THE DATA WITH D-SCALE FROM PDS(27-28) -C - JSCALE = mova2i(PDS(27)) * 256 + mova2i(PDS(28)) - IF (IAND(JSCALE,32768).NE.0) THEN - JSCALE = - IAND(JSCALE,32767) - END IF - SCALE = 10.0 ** JSCALE - IF (ITYPE .EQ. 0) THEN - DO 410 I = 1,NPTS - FLD(I) = FLD(I) * SCALE - 410 CONTINUE - ELSE - DO 411 I = 1,NPTS - IFLD(I) = NINT(FLOAT(IFLD(I)) * SCALE) - 411 CONTINUE - END IF -C -C 4.2 CALL W3FI75 TO PACK DATA AND MAKE BDS. -C - ALLOCATE(PFLD(NPTS*4)) -C - IF(IBDSFL(2).NE.0) THEN - ALLOCATE(IPFLD(NPTS*4)) - IPFLD=char(0) - ELSE - ALLOCATE(IPFLD(1)) - ENDIF -C - CALL W3FI75(IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL, - & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS) -C - IF(IBDSFL(2).NE.0) THEN -C CALL XMOVEX(PFLD,IPFLD,NPTS*4) - do ii = 1, NPTS*4 - PFLD(ii) = IPFLD(ii) - enddo - ENDIF - DEALLOCATE(IPFLD) -C - IF (IBERR .EQ. 1) THEN - JERR = 3 - GO TO 900 - END IF -C 4.3 IF D-SCALE NOT 0, RESCALE INPUT FIELD TO -C ORIGINAL VALUE -C - IF (JSCALE.NE.0) THEN - DSCALE = 1.0 / SCALE - IF (ITYPE.EQ.0) THEN - DO 412 I = 1, NPTS - FLD(I) = FLD(I) * DSCALE - 412 CONTINUE - ELSE - DO 413 I = 1, NPTS - FLD(I) = NINT(FLOAT(IFLD(I)) * DSCALE) - 413 CONTINUE - END IF - END IF -C -C 5.0 OUTPUT SECTION. -C -C 5.1 ZERO OUT THE OUTPUT ARRAY KBUF. -C - ZERO = CHAR(00) - ITOT = IGRIBL + IPDSL + LENGDS + LENBMS + LENBDS + 4 -C PRINT *,'IGRIBL =',IGRIBL -C PRINT *,'IPDSL =',IPDSL -C PRINT *,'LENGDS =',LENGDS -C PRINT *,'LENBMS =',LENBMS -C PRINT *,'LENBDS =',LENBDS -C PRINT *,'ITOT =',ITOT - KBUF(1:ITOT)=ZERO -C -C 5.2 MOVE SECTION 0 - 'IS' INTO KBUF (8 BYTES). -C - ISTART = 0 - DO 520 I = 1,4 - KBUF(I) = CHAR(IB(I)) - 520 CONTINUE -C - KBUF(5) = CHAR(MOD(ITOT / 65536,256)) - KBUF(6) = CHAR(MOD(ITOT / 256,256)) - KBUF(7) = CHAR(MOD(ITOT ,256)) - KBUF(8) = CHAR(1) -C -C 5.3 MOVE SECTION 1 - 'PDS' INTO KBUF (28 BYTES). -C - ISTART = ISTART + IGRIBL - IF (IPDSL.GT.0) THEN -C CALL XMOVEX(KBUF(ISTART+1),PDS,IPDSL) - do ii = 1, IPDSL - KBUF(ISTART+ii) = PDS(ii) - enddo - ELSE -C PRINT *,'LENGTH OF PDS LESS OR EQUAL 0, IPDSL = ',IPDSL - END IF -C -C 5.4 MOVE SECTION 2 - 'GDS' INTO KBUF. -C - ISTART = ISTART + IPDSL - IF (LENGDS .GT. 0) THEN -C CALL XMOVEX(KBUF(ISTART+1),GDS,LENGDS) - do ii = 1, LENGDS - KBUF(ISTART+ii) = GDS(ii) - enddo - END IF -C -C 5.5 MOVE SECTION 3 - 'BMS' INTO KBUF. -C - ISTART = ISTART + LENGDS - IF (LENBMS .GT. 0) THEN -C CALL XMOVEX(KBUF(ISTART+1),BMS,LENBMS) - do ii = 1, LENBMS - KBUF(ISTART+ii) = BMS(ii) - enddo - END IF -C -C 5.6 MOVE SECTION 4 - 'BDS' INTO KBUF. -C -C MOVE THE FIRST 11 OCTETS OF THE BDS INTO KBUF. -C - ISTART = ISTART + LENBMS -C CALL XMOVEX(KBUF(ISTART+1),BDS11,11) - do ii = 1, 11 - KBUF(ISTART+ii) = BDS11(ii) - enddo -C -C MOVE THE PACKED DATA INTO THE KBUF -C - ISTART = ISTART + 11 - IF (LEN.GT.0) THEN -C CALL XMOVEX(KBUF(ISTART+1),PFLD,LEN) - do ii = 1, LEN - KBUF(ISTART+ii) = PFLD(ii) - enddo - END IF -C -C ADD '7777' TO END OFF KBUF -C NOTE THAT THESE 4 OCTETS NOT INCLUDED IN ACTUAL SIZE OF BDS. -C - SEVEN = CHAR(55) - ISTART = ITOT - 4 - DO 562 I = 1,4 - KBUF(ISTART+I) = SEVEN - 562 CONTINUE -C - 900 CONTINUE - IF(ALLOCATED(BMS)) DEALLOCATE(BMS) - IF(ALLOCATED(PFLD)) DEALLOCATE(PFLD) - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi73.f b/external/w3nco/v2.0.6/src/w3fi73.f deleted file mode 100644 index 629373c8..00000000 --- a/external/w3nco/v2.0.6/src/w3fi73.f +++ /dev/null @@ -1,100 +0,0 @@ - SUBROUTINE W3FI73 (IBFLAG,IBMAP,IBLEN,BMS,LENBMS,IER) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI73 CONSTRUCT GRIB BIT MAP SECTION (BMS) -C PRGMMR: FARLEY ORG: NMC421 DATE:92-11-16 -C -C ABSTRACT: THIS SUBROUTINE CONSTRUCTS A GRIB BIT MAP SECTION. -C -C PROGRAM HISTORY LOG: -C 92-07-01 M. FARLEY ORIGINAL AUTHOR -C 94-02-14 CAVANAUGH RECODED -C 98-06-30 EBISUZAKI LINUX PORT -C -C USAGE: CALL W3FI73 (IBFLAG, IBMAP, IBLEN, BMS, LENBMS, IER) -C INPUT ARGUMENT LIST: -C IBFLAG - 0, IF BIT MAP SUPPLIED BY USER -C - #, NUMBER OF PREDEFINED CENTER BIT MAP -C IBMAP - INTEGER ARRAY CONTAINING USER BIT MAP -C IBLEN - LENGTH OF BIT MAP -C -C OUTPUT ARGUMENT LIST: -C BMS - COMPLETED GRIB BIT MAP SECTION -C LENBMS - LENGTH OF BIT MAP SECTION -C IER - 0 NORMAL EXIT, 8 = IBMAP VALUES ARE ALL ZERO -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - SBYTE -C -C ATTRIBUTES: -C LANGUAGE: IBM370 VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, CRAY J916/2048 -C -C$$$ -C - INTEGER IBMAP(*) - INTEGER LENBMS - INTEGER IBLEN - INTEGER IBFLAG -C - CHARACTER*1 BMS(*) -C - IER = 0 -C - IZ = 0 - DO 20 I = 1, IBLEN - IF (IBMAP(I).EQ.0) IZ = IZ + 1 - 20 CONTINUE - IF (IZ.EQ.IBLEN) THEN -C -C AT THIS POINT ALL BIT MAP POSITIONS ARE ZERO -C - IER = 8 - RETURN - END IF -C -C BIT MAP IS A COMBINATION OF ONES AND ZEROS -C OR BIT MAP ALL ONES -C -C CONSTRUCT BIT MAP FIELD OF BIT MAP SECTION -C - CALL SBYTESC(BMS,IBMAP,48,1,0,IBLEN) -C - IF (MOD(IBLEN,16).NE.0) THEN - NLEFT = 16 - MOD(IBLEN,16) - ELSE - NLEFT = 0 - END IF -C - NUM = 6 + (IBLEN+NLEFT) / 8 -C -C CONSTRUCT BMS FROM COLLECTED DATA -C -C SIZE INTO FIRST THREE BYTES -C - CALL SBYTEC(BMS,NUM,0,24) -C NUMBER OF FILL BITS INTO BYTE 4 - CALL SBYTEC(BMS,NLEFT,24,8) -C OCTET 5-6 TO CONTAIN INFO FROM IBFLAG - CALL SBYTEC(BMS,IBFLAG,32,16) -C -C BIT MAP MAY BE ALL ONES OR A COMBINATION -C OF ONES AND ZEROS -C -C ACTUAL BITS OF BIT MAP PLACED ALL READY -C -C INSTALL FILL POSITIONS IF NEEDED - IF (NLEFT.NE.0) THEN - NLEFT = 16 - NLEFT -C ZERO FILL POSITIONS - CALL SBYTEC(BMS,0,IBLEN+48,NLEFT) - END IF -C -C STORE NUM IN LENBMS (LENGTH OF BMS SECTION) -C - LENBMS = NUM -C PRINT *,'W3FI73 - BMS LEN =',NUM,LENBMS -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi74.f b/external/w3nco/v2.0.6/src/w3fi74.f deleted file mode 100644 index 8cc06dd6..00000000 --- a/external/w3nco/v2.0.6/src/w3fi74.f +++ /dev/null @@ -1,426 +0,0 @@ - SUBROUTINE W3FI74 (IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI74 CONSTRUCT GRID DEFINITION SECTION (GDS) -C PRGMMR: FARLEY ORG: W/NMC42 DATE: 93-08-24 -C -C ABSTRACT: THIS SUBROUTINE CONSTRUCTS A GRIB GRID DEFINITION -C SECTION. -C -C PROGRAM HISTORY LOG: -C 92-07-07 M. FARLEY ORIGINAL AUTHOR -C 92-10-16 R.E.JONES ADD CODE TO LAT/LON SECTION TO DO -C GAUSSIAN GRIDS. -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-08-24 R.E.JONES CHANGES FOR GRIB GRIDS 37-44 -C 93-09-29 R.E.JONES CHANGES FOR GAUSSIAN GRID FOR DOCUMENT -C CHANGE IN W3FI71. -C 94-02-15 R.E.JONES CHANGES FOR ETA MODEL GRIDS 90-93 -C 95-04-20 R.E.JONES CHANGE 200 AND 201 TO 201 AND 202 -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-08-20 BALDWIN ADD TYPE 203 -C 07-03-20 VUONG ADD TYPE 204 -C 10-01-21 GAYNO ADD GRID 205 - ROTATED LAT/LON A,B,C,D STAGGERS -C -C -C USAGE: CALL W3FI74 (IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR) -C INPUT ARGUMENT LIST: -C IGDS - INTEGER ARRAY SUPPLIED BY W3FI71 -C ICOMP - TABLE 7- RESOLUTION & COMPONENT FLAG (BIT 5) -C FOR GDS(17) WIND COMPONENTS -C -C OUTPUT ARGUMENT LIST: -C GDS - COMPLETED GRIB GRID DEFINITION SECTION -C LENGDS - LENGTH OF GDS -C NPTS - NUMBER OF POINTS IN GRID -C IGERR - 1, GRID REPRESENTATION TYPE NOT VALID -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN 77, IBM370 VS FORTRAN -C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256, HDS -C -C$$$ -C - INTEGER IGDS (*) -C - CHARACTER*1 GDS (*) -C - ISUM = 0 - IGERR = 0 -C -C PRINT *,' ' -C PRINT *,'(W3FI74-IGDS = )' -C PRINT *,(IGDS(I),I=1,18) -C PRINT *,' ' -C -C COMPUTE LENGTH OF GDS IN OCTETS (OCTETS 1-3) -C LENGDS = 32 FOR LAT/LON, GNOMIC, GAUSIAN LAT/LON, -C POLAR STEREOGRAPHIC, SPHERICAL HARMONICS, -C ROTATED LAT/LON E-STAGGER -C LENGDS = 34 ROTATED LAT/LON A,B,C,D STAGGERS -C LENGDS = 42 FOR MERCATOR, LAMBERT, TANGENT CONE -C LENGDS = 178 FOR MERCATOR, LAMBERT, TANGENT CONE -C - IF (IGDS(3) .EQ. 0 .OR. IGDS(3) .EQ. 2 .OR. - & IGDS(3) .EQ. 4 .OR. IGDS(3) .EQ. 5 .OR. - & IGDS(3) .EQ. 50 .OR. IGDS(3) .EQ. 201.OR. - & IGDS(3) .EQ. 202.OR. IGDS(3) .EQ. 203.OR. - & IGDS(3) .EQ. 204 ) THEN - LENGDS = 32 -C -C CORRECTION FOR GRIDS 37-44 -C - IF (IGDS(3).EQ.0.AND.IGDS(1).EQ.0.AND.IGDS(2).NE. - & 255) THEN - LENGDS = IGDS(5) * 2 + 32 - ENDIF - ELSE IF (IGDS(3) .EQ. 1 .OR. IGDS(3) .EQ. 3 .OR. - & IGDS(3) .EQ. 13) THEN - LENGDS = 42 - ELSE IF (IGDS(3) .EQ. 205) THEN - LENGDS = 34 - ELSE -C PRINT *,' W3FI74 ERROR, GRID REPRESENTATION TYPE NOT VALID' - IGERR = 1 - RETURN - ENDIF -C -C PUT LENGTH OF GDS SECTION IN BYTES 1,2,3 -C - GDS(1) = CHAR(MOD(LENGDS/65536,256)) - GDS(2) = CHAR(MOD(LENGDS/ 256,256)) - GDS(3) = CHAR(MOD(LENGDS ,256)) -C -C OCTET 4 = NV, NUMBER OF VERTICAL COORDINATE PARAMETERS -C OCTET 5 = PV, PL OR 255 -C OCTET 6 = DATA REPRESENTATION TYPE (TABLE 6) -C - GDS(4) = CHAR(IGDS(1)) - GDS(5) = CHAR(IGDS(2)) - GDS(6) = CHAR(IGDS(3)) -C -C FILL OCTET THE REST OF THE GDS BASED ON DATA REPRESENTATION -C TYPE (TABLE 6) -C -C$$ -C PROCESS ROTATED LAT/LON A,B,C,D STAGGERS -C - IF (IGDS(3).EQ.205) THEN - GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) - GDS( 8) = CHAR(MOD(IGDS(4) ,256)) - GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) - GDS(10) = CHAR(MOD(IGDS(5) ,256)) - LATO = IGDS(6) ! LAT OF FIRST POINT - IF (LATO .LT. 0) THEN - LATO = -LATO - LATO = IOR(LATO,8388608) - ENDIF - GDS(11) = CHAR(MOD(LATO/65536,256)) - GDS(12) = CHAR(MOD(LATO/ 256,256)) - GDS(13) = CHAR(MOD(LATO ,256)) - LONO = IGDS(7) ! LON OF FIRST POINT - IF (LONO .LT. 0) THEN - LONO = -LONO - LONO = IOR(LONO,8388608) - ENDIF - GDS(14) = CHAR(MOD(LONO/65536,256)) - GDS(15) = CHAR(MOD(LONO/ 256,256)) - GDS(16) = CHAR(MOD(LONO ,256)) - LATEXT = IGDS(9) ! CENTER LAT - IF (LATEXT .LT. 0) THEN - LATEXT = -LATEXT - LATEXT = IOR(LATEXT,8388608) - ENDIF - GDS(18) = CHAR(MOD(LATEXT/65536,256)) - GDS(19) = CHAR(MOD(LATEXT/ 256,256)) - GDS(20) = CHAR(MOD(LATEXT ,256)) - LONEXT = IGDS(10) ! CENTER LON - IF (LONEXT .LT. 0) THEN - LONEXT = -LONEXT - LONEXT = IOR(LONEXT,8388608) - ENDIF - GDS(21) = CHAR(MOD(LONEXT/65536,256)) - GDS(22) = CHAR(MOD(LONEXT/ 256,256)) - GDS(23) = CHAR(MOD(LONEXT ,256)) - GDS(24) = CHAR(MOD(IGDS(11)/256,256)) - GDS(25) = CHAR(MOD(IGDS(11) ,256)) - GDS(26) = CHAR(MOD(IGDS(12)/256,256)) - GDS(27) = CHAR(MOD(IGDS(12) ,256)) - GDS(28) = CHAR(IGDS(13)) - LATO = IGDS(14) ! LAT OF LAST POINT - IF (LATO .LT. 0) THEN - LATO = -LATO - LATO = IOR(LATO,8388608) - ENDIF - GDS(29) = CHAR(MOD(LATO/65536,256)) - GDS(30) = CHAR(MOD(LATO/ 256,256)) - GDS(31) = CHAR(MOD(LATO ,256)) - LONO = IGDS(15) ! LON OF LAST POINT - IF (LONO .LT. 0) THEN - LONO = -LONO - LONO = IOR(LONO,8388608) - ENDIF - GDS(32) = CHAR(MOD(LONO/65536,256)) - GDS(33) = CHAR(MOD(LONO/ 256,256)) - GDS(34) = CHAR(MOD(LONO ,256)) -C -C PROCESS LAT/LON GRID TYPES OR GAUSSIAN GRID OR ARAKAWA -C STAGGERED, SEMI-STAGGERED, OR FILLED E-GRIDS -C - ELSEIF (IGDS(3).EQ.0.OR.IGDS(3).EQ.4.OR. - & IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR. - & IGDS(3).EQ.203.OR.IGDS(3).EQ.204) THEN - GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) - GDS( 8) = CHAR(MOD(IGDS(4) ,256)) - GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) - GDS(10) = CHAR(MOD(IGDS(5) ,256)) - LATO = IGDS(6) - IF (LATO .LT. 0) THEN - LATO = -LATO - LATO = IOR(LATO,8388608) - ENDIF - GDS(11) = CHAR(MOD(LATO/65536,256)) - GDS(12) = CHAR(MOD(LATO/ 256,256)) - GDS(13) = CHAR(MOD(LATO ,256)) - LONO = IGDS(7) - IF (LONO .LT. 0) THEN - LONO = -LONO - LONO = IOR(LONO,8388608) - ENDIF - GDS(14) = CHAR(MOD(LONO/65536,256)) - GDS(15) = CHAR(MOD(LONO/ 256,256)) - GDS(16) = CHAR(MOD(LONO ,256)) - LATEXT = IGDS(9) - IF (LATEXT .LT. 0) THEN - LATEXT = -LATEXT - LATEXT = IOR(LATEXT,8388608) - ENDIF - GDS(18) = CHAR(MOD(LATEXT/65536,256)) - GDS(19) = CHAR(MOD(LATEXT/ 256,256)) - GDS(20) = CHAR(MOD(LATEXT ,256)) - LONEXT = IGDS(10) - IF (LONEXT .LT. 0) THEN - LONEXT = -LONEXT - LONEXT = IOR(LONEXT,8388608) - ENDIF - GDS(21) = CHAR(MOD(LONEXT/65536,256)) - GDS(22) = CHAR(MOD(LONEXT/ 256,256)) - GDS(23) = CHAR(MOD(LONEXT ,256)) - IRES = IAND(IGDS(8),128) - IF (IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR. - & IGDS(3).EQ.203.OR.IGDS(3).EQ.204) THEN - GDS(24) = CHAR(MOD(IGDS(11)/256,256)) - GDS(25) = CHAR(MOD(IGDS(11) ,256)) - ELSE IF (IRES.EQ.0) THEN - GDS(24) = CHAR(255) - GDS(25) = CHAR(255) - ELSE - GDS(24) = CHAR(MOD(IGDS(12)/256,256)) - GDS(25) = CHAR(MOD(IGDS(12) ,256)) - END IF - IF (IGDS(3).EQ.4) THEN - GDS(26) = CHAR(MOD(IGDS(11)/256,256)) - GDS(27) = CHAR(MOD(IGDS(11) ,256)) - ELSE IF (IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR. - & IGDS(3).EQ.203.OR.IGDS(3).EQ.204)THEN - GDS(26) = CHAR(MOD(IGDS(12)/256,256)) - GDS(27) = CHAR(MOD(IGDS(12) ,256)) - ELSE IF (IRES.EQ.0) THEN - GDS(26) = CHAR(255) - GDS(27) = CHAR(255) - ELSE - GDS(26) = CHAR(MOD(IGDS(11)/256,256)) - GDS(27) = CHAR(MOD(IGDS(11) ,256)) - END IF - GDS(28) = CHAR(IGDS(13)) - GDS(29) = CHAR(0) - GDS(30) = CHAR(0) - GDS(31) = CHAR(0) - GDS(32) = CHAR(0) - IF (LENGDS.GT.32) THEN - ISUM = 0 - I = 19 - DO 10 J = 33,LENGDS,2 - ISUM = ISUM + IGDS(I) - GDS(J) = CHAR(MOD(IGDS(I)/256,256)) - GDS(J+1) = CHAR(MOD(IGDS(I) ,256)) - I = I + 1 - 10 CONTINUE - END IF -C -C$$ PROCESS MERCATOR GRID TYPES -C - ELSE IF (IGDS(3) .EQ. 1) THEN - GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) - GDS( 8) = CHAR(MOD(IGDS(4) ,256)) - GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) - GDS(10) = CHAR(MOD(IGDS(5) ,256)) - LATO = IGDS(6) - IF (LATO .LT. 0) THEN - LATO = -LATO - LATO = IOR(LATO,8388608) - ENDIF - GDS(11) = CHAR(MOD(LATO/65536,256)) - GDS(12) = CHAR(MOD(LATO/ 256,256)) - GDS(13) = CHAR(MOD(LATO ,256)) - LONO = IGDS(7) - IF (LONO .LT. 0) THEN - LONO = -LONO - LONO = IOR(LONO,8388608) - ENDIF - GDS(14) = CHAR(MOD(LONO/65536,256)) - GDS(15) = CHAR(MOD(LONO/ 256,256)) - GDS(16) = CHAR(MOD(LONO ,256)) - LATEXT = IGDS(9) - IF (LATEXT .LT. 0) THEN - LATEXT = -LATEXT - LATEXT = IOR(LATEXT,8388608) - ENDIF - GDS(18) = CHAR(MOD(LATEXT/65536,256)) - GDS(19) = CHAR(MOD(LATEXT/ 256,256)) - GDS(20) = CHAR(MOD(LATEXT ,256)) - LONEXT = IGDS(10) - IF (LONEXT .LT. 0) THEN - LONEXT = -LONEXT - LONEXT = IOR(LONEXT,8388608) - ENDIF - GDS(21) = CHAR(MOD(LONEXT/65536,256)) - GDS(22) = CHAR(MOD(LONEXT/ 256,256)) - GDS(23) = CHAR(MOD(LONEXT ,256)) - GDS(24) = CHAR(MOD(IGDS(13)/65536,256)) - GDS(25) = CHAR(MOD(IGDS(13)/ 256,256)) - GDS(26) = CHAR(MOD(IGDS(13) ,256)) - GDS(27) = CHAR(0) - GDS(28) = CHAR(IGDS(14)) - GDS(29) = CHAR(MOD(IGDS(12)/65536,256)) - GDS(30) = CHAR(MOD(IGDS(12)/ 256,256)) - GDS(31) = CHAR(MOD(IGDS(12) ,256)) - GDS(32) = CHAR(MOD(IGDS(11)/65536,256)) - GDS(33) = CHAR(MOD(IGDS(11)/ 256,256)) - GDS(34) = CHAR(MOD(IGDS(11) ,256)) - GDS(35) = CHAR(0) - GDS(36) = CHAR(0) - GDS(37) = CHAR(0) - GDS(38) = CHAR(0) - GDS(39) = CHAR(0) - GDS(40) = CHAR(0) - GDS(41) = CHAR(0) - GDS(42) = CHAR(0) -C$$ PROCESS LAMBERT CONFORMAL GRID TYPES - ELSE IF (IGDS(3) .EQ. 3) THEN - GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) - GDS( 8) = CHAR(MOD(IGDS(4) ,256)) - GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) - GDS(10) = CHAR(MOD(IGDS(5) ,256)) - LATO = IGDS(6) - IF (LATO .LT. 0) THEN - LATO = -LATO - LATO = IOR(LATO,8388608) - ENDIF - GDS(11) = CHAR(MOD(LATO/65536,256)) - GDS(12) = CHAR(MOD(LATO/ 256,256)) - GDS(13) = CHAR(MOD(LATO ,256)) - LONO = IGDS(7) - IF (LONO .LT. 0) THEN - LONO = -LONO - LONO = IOR(LONO,8388608) - ENDIF - GDS(14) = CHAR(MOD(LONO/65536,256)) - GDS(15) = CHAR(MOD(LONO/ 256,256)) - GDS(16) = CHAR(MOD(LONO ,256)) - LONM = IGDS(9) - IF (LONM .LT. 0) THEN - LONM = -LONM - LONM = IOR(LONM,8388608) - ENDIF - GDS(18) = CHAR(MOD(LONM/65536,256)) - GDS(19) = CHAR(MOD(LONM/ 256,256)) - GDS(20) = CHAR(MOD(LONM ,256)) - GDS(21) = CHAR(MOD(IGDS(10)/65536,256)) - GDS(22) = CHAR(MOD(IGDS(10)/ 256,256)) - GDS(23) = CHAR(MOD(IGDS(10) ,256)) - GDS(24) = CHAR(MOD(IGDS(11)/65536,256)) - GDS(25) = CHAR(MOD(IGDS(11)/ 256,256)) - GDS(26) = CHAR(MOD(IGDS(11) ,256)) - GDS(27) = CHAR(IGDS(12)) - GDS(28) = CHAR(IGDS(13)) - GDS(29) = CHAR(MOD(IGDS(15)/65536,256)) - GDS(30) = CHAR(MOD(IGDS(15)/ 256,256)) - GDS(31) = CHAR(MOD(IGDS(15) ,256)) - GDS(32) = CHAR(MOD(IGDS(16)/65536,256)) - GDS(33) = CHAR(MOD(IGDS(16)/ 256,256)) - GDS(34) = CHAR(MOD(IGDS(16) ,256)) - GDS(35) = CHAR(MOD(IGDS(17)/65536,256)) - GDS(36) = CHAR(MOD(IGDS(17)/ 256,256)) - GDS(37) = CHAR(MOD(IGDS(17) ,256)) - GDS(38) = CHAR(MOD(IGDS(18)/65536,256)) - GDS(39) = CHAR(MOD(IGDS(18)/ 256,256)) - GDS(40) = CHAR(MOD(IGDS(18) ,256)) - GDS(41) = CHAR(0) - GDS(42) = CHAR(0) -C$$ PROCESS POLAR STEREOGRAPHIC GRID TYPES - ELSE IF (IGDS(3) .EQ. 5) THEN - GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) - GDS( 8) = CHAR(MOD(IGDS(4) ,256)) - GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) - GDS(10) = CHAR(MOD(IGDS(5) ,256)) - LATO = IGDS(6) - IF (LATO .LT. 0) THEN - LATO = -LATO - LATO = IOR(LATO,8388608) - ENDIF - GDS(11) = CHAR(MOD(LATO/65536,256)) - GDS(12) = CHAR(MOD(LATO/ 256,256)) - GDS(13) = CHAR(MOD(LATO ,256)) - LONO = IGDS(7) - IF (LONO .LT. 0) THEN - LONO = -LONO - LONO = IOR(LONO,8388608) - ENDIF - GDS(14) = CHAR(MOD(LONO/65536,256)) - GDS(15) = CHAR(MOD(LONO/ 256,256)) - GDS(16) = CHAR(MOD(LONO ,256)) - LONM = IGDS(9) - IF (LONM .LT. 0) THEN - LONM = -LONM - LONM = IOR(LONM,8388608) - ENDIF - GDS(18) = CHAR(MOD(LONM/65536,256)) - GDS(19) = CHAR(MOD(LONM/ 256,256)) - GDS(20) = CHAR(MOD(LONM ,256)) - GDS(21) = CHAR(MOD(IGDS(10)/65536,256)) - GDS(22) = CHAR(MOD(IGDS(10)/ 256,256)) - GDS(23) = CHAR(MOD(IGDS(10) ,256)) - GDS(24) = CHAR(MOD(IGDS(11)/65536,256)) - GDS(25) = CHAR(MOD(IGDS(11)/ 256,256)) - GDS(26) = CHAR(MOD(IGDS(11) ,256)) - GDS(27) = CHAR(IGDS(12)) - GDS(28) = CHAR(IGDS(13)) - GDS(29) = CHAR(0) - GDS(30) = CHAR(0) - GDS(31) = CHAR(0) - GDS(32) = CHAR(0) - ENDIF -C PRINT 10,(GDS(IG),IG=1,32) -C10 FORMAT (' GDS= ',32(1X,Z2.2)) -C -C COMPUTE NUMBER OF POINTS IN GRID BY MULTIPLYING -C IGDS(4) AND IGDS(5) ... NEEDED FOR PACKER -C - IF (IGDS(3).EQ.0.AND.IGDS(1).EQ.0.AND.IGDS(2).NE. - & 255) THEN - NPTS = ISUM - ELSE - NPTS = IGDS(4) * IGDS(5) - ENDIF -C -C 'IOR' ICOMP-BIT 5 RESOLUTION & COMPONENT FLAG FOR WINDS -C WITH IGDS(8) INFO (REST OF RESOLUTION & COMPONENT FLAG DATA) -C - ITEMP = ISHFT(ICOMP,3) - GDS(17) = CHAR(IOR(IGDS(8),ITEMP)) -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi75.f b/external/w3nco/v2.0.6/src/w3fi75.f deleted file mode 100644 index bb5b2732..00000000 --- a/external/w3nco/v2.0.6/src/w3fi75.f +++ /dev/null @@ -1,1619 +0,0 @@ - SUBROUTINE W3FI75 (IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL, - & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI75 GRIB PACK DATA AND FORM BDS OCTETS(1-11) -C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 -C -C ABSTRACT: THIS ROUTINE PACKS A GRIB FIELD AND FORMS OCTETS(1-11) -C OF THE BINARY DATA SECTION (BDS). -C -C PROGRAM HISTORY LOG: -C 92-07-10 M. FARLEY ORIGINAL AUTHOR -C 92-10-01 R.E.JONES CORRECTION FOR FIELD OF CONSTANT DATA -C 92-10-16 R.E.JONES GET RID OF ARRAYS FP AND INT -C 93-08-06 CAVANAUGH ADDED ROUTINES FI7501, FI7502, FI7503 -C TO ALLOW SECOND ORDER PACKING IN PDS. -C 93-07-21 STACKPOLE ASSORTED REPAIRS TO GET 2ND DIFF PACK IN -C 93-10-28 CAVANAUGH COMMENTED OUT NONOPERATIONAL PRINTS AND -C WRITE STATEMENTS -C 93-12-15 CAVANAUGH CORRECTED LOCATION OF START OF FIRST ORDER -C VALUES AND START OF SECOND ORDER VALUES TO -C REFLECT A BYTE LOCATION IN THE BDS INSTEAD -C OF AN OFFSET IN SUBROUTINE FI7501. -C 94-01-27 CAVANAUGH ADDED IGDS AS INPUT ARGUMENT TO THIS ROUTINE -C AND ADDED PDS AND IGDS ARRAYS TO THE CALL TO -C W3FI82 TO PROVIDE INFORMATION NEEDED FOR -C BOUSTROPHEDONIC PROCESSING. -C 94-05-25 CAVANAUGH SUBROUTINE FI7503 HAS BEEN ADDED TO PROVIDE -C FOR ROW BY ROW OR COLUMN BY COLUMN SECOND -C ORDER PACKING. THIS FEATURE CAN BE ACTIVATED -C BY SETTING IBDSFL(7) TO ZERO. -C 94-07-08 CAVANAUGH COMMENTED OUT PRINT STATEMENTS USED FOR DEBUG -C 94-11-22 FARLEY ENLARGED WORK ARRAYS TO HANDLE .5DEGREE GRIDS -C 95-06-01 R.E.JONES CORRECTION FOR NUMBER OF UNUSED BITS AT END -C OF SECTION 4, IN BDS BYTE 4, BITS 5-8. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 2001-06-06 GILBERT CHanged gbyte/sbyte calls to refer to -C Wesley Ebisuzaki's endian independent -C versions gbytec/sbytec. -C Use f90 standard routine bit_size to get -C number of bits in an integer instead of w3fi01. -C -C USAGE: CALL W3FI75 (IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL, -C & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS) -C INPUT ARGUMENT LIST: -C IBITL - 0, COMPUTER COMPUTES PACKING LENGTH FROM POWER -C OF 2 THAT BEST FITS THE DATA. -C 8, 12, ETC. COMPUTER RESCALES DATA TO FIT INTO -C SET NUMBER OF BITS. -C ITYPE - 0 = IF INPUT DATA IS FLOATING POINT (FLD) -C 1 = IF INPUT DATA IS INTEGER (IFLD) -C ITOSS - 0 = NO BIT MAP IS INCLUDED (DON'T TOSS DATA) -C 1 = TOSS NULL DATA ACCORDING TO IBMAP -C FLD - REAL ARRAY OF DATA TO BE PACKED IF ITYPE=0 -C IFLD - INTEGER ARRAY TO BE PACKED IF ITYPE=1 -C IBMAP - BIT MAP SUPPLIED FROM USER -C IBDSFL - INTEGER ARRAY CONTAINING TABLE 11 FLAG INFO -C BDS OCTET 4: -C (1) 0 = GRID POINT DATA -C 1 = SPHERICAL HARMONIC COEFFICIENTS -C (2) 0 = SIMPLE PACKING -C 1 = SECOND ORDER PACKING -C (3) 0 = ORIGINAL DATA WERE FLOATING POINT VALUES -C 1 = ORIGINAL DATA WERE INTEGER VALUES -C (4) 0 = NO ADDITIONAL FLAGS AT OCTET 14 -C 1 = OCTET 14 CONTAINS FLAG BITS 5-12 -C (5) 0 = RESERVED - ALWAYS SET TO 0 -C (6) 0 = SINGLE DATUM AT EACH GRID POINT -C 1 = MATRIX OF VALUES AT EACH GRID POINT -C (7) 0 = NO SECONDARY BIT MAPS -C 1 = SECONDARY BIT MAPS PRESENT -C (8) 0 = SECOND ORDER VALUES HAVE CONSTANT WIDTH -C 1 = SECOND ORDER VALUES HAVE DIFFERENT WIDTHS -C NPTS - NUMBER OF GRIDPOINTS IN ARRAY TO BE PACKED -C IGDS - ARRAY OF GDS INFORMATION -C -C OUTPUT ARGUMENT LIST: -C BDS11 - FIRST 11 OCTETS OF BDS -C PFLD - PACKED GRIB FIELD -C LEN - LENGTH OF PFLD -C LENBDS - LENGTH OF BDS -C IBERR - 1, ERROR CONVERTING IEEE F.P. NUMBER TO IBM370 F.P. -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ -C - REAL FLD(*) -C REAL FWORK(260000) -C -C FWORK CAN USE DYNAMIC ALLOCATION OF MEMORY ON CRAY -C - REAL FWORK(NPTS) - REAL RMIN,REFNCE -C - character(len=1) IPFLD(*) - INTEGER IBDSFL(*) - INTEGER IBMAP(*) - INTEGER IFLD(*),IGDS(*) -C INTEGER IWORK(260000) -C -C IWORK CAN USE DYNAMIC ALLOCATION OF MEMORY ON CRAY -C - INTEGER IWORK(NPTS) -C - LOGICAL CONST -C - CHARACTER * 1 BDS11(11),PDS(*) - CHARACTER * 1 PFLD(*) -C -C 1.0 PACK THE FIELD. -C -C 1.1 TOSS DATA IF BITMAP BEING USED, -C MOVING 'DATA' TO WORK AREA... -C - CONST = .FALSE. - IBERR = 0 - IW = 0 -C - IF (ITOSS .EQ. 1) THEN - IF (ITYPE .EQ. 0) THEN - DO 110 IT=1,NPTS - IF (IBMAP(IT) .EQ. 1) THEN - IW = IW + 1 - FWORK(IW) = FLD(IT) - ENDIF - 110 CONTINUE - NPTS = IW - ELSE IF (ITYPE .EQ. 1) THEN - DO 111 IT=1,NPTS - IF (IBMAP(IT) .EQ. 1) THEN - IW = IW + 1 - IWORK(IW) = IFLD(IT) - ENDIF - 111 CONTINUE - NPTS = IW - ENDIF -C -C ELSE, JUST MOVE DATA TO WORK ARRAY -C - ELSE IF (ITOSS .EQ. 0) THEN - IF (ITYPE .EQ. 0) THEN - DO 112 IT=1,NPTS - FWORK(IT) = FLD(IT) - 112 CONTINUE - ELSE IF (ITYPE .EQ. 1) THEN - DO 113 IT=1,NPTS - IWORK(IT) = IFLD(IT) - 113 CONTINUE - ENDIF - ENDIF -C -C 1.2 CONVERT DATA IF NEEDED PRIOR TO PACKING. -C (INTEGER TO F.P. OR F.P. TO INTEGER) -C ITYPE = 0...FLOATING POINT DATA -C IBITL = 0...PACK IN LEAST # BITS...CONVERT TO INTEGER -C ITYPE = 1...INTEGER DATA -C IBITL > 0...PACK IN FIXED # BITS...CONVERT TO FLOATING POINT -C - IF (ITYPE .EQ. 0 .AND. IBITL .EQ. 0) THEN - DO 120 IF=1,NPTS - IWORK(IF) = NINT(FWORK(IF)) - 120 CONTINUE - ELSE IF (ITYPE .EQ. 1 .AND. IBITL .NE. 0) THEN - DO 123 IF=1,NPTS - FWORK(IF) = FLOAT(IWORK(IF)) - 123 CONTINUE - ENDIF -C -C 1.3 PACK THE DATA. -C - IF (IBDSFL(2).NE.0) THEN -C SECOND ORDER PACKING -C -C PRINT*,' DOING SECOND ORDER PACKING...' - IF (IBITL.EQ.0) THEN -C -C PRINT*,' AND VARIABLE BIT PACKING' -C -C WORKING WITH INTEGER VALUES -C SINCE DOING VARIABLE BIT PACKING -C - MAX = IWORK(1) - MIN = IWORK(1) - DO 300 I = 2, NPTS - IF (IWORK(I).LT.MIN) THEN - MIN = IWORK(I) - ELSE IF (IWORK(I).GT.MAX) THEN - MAX = IWORK(I) - END IF - 300 CONTINUE -C EXTRACT MINIMA - DO 400 I = 1, NPTS -C IF (IWORK(I).LT.0) THEN -C PRINT *,'MINIMA 400',I,IWORK(I),NPTS -C END IF - IWORK(I) = IWORK(I) - MIN - 400 CONTINUE - REFNCE = MIN - IDIFF = MAX - MIN -C PRINT *,'REFERENCE VALUE',REFNCE -C -C WRITE (6,FMT='('' MINIMA REMOVED = '',/, -C & 10(3X,10I10,/))') (IWORK(I),I=1,6) -C WRITE (6,FMT='('' END OF ARRAY = '',/, -C & 10(3X,10I10,/))') (IWORK(I),I=NPTS-5,NPTS) -C -C FIND BIT WIDTH OF IDIFF -C - CALL FI7505 (IDIFF,KWIDE) -C PRINT*,' BIT WIDTH FOR ORIGINAL DATA', KWIDE - ISCAL2 = 0 -C -C MULTIPLICATIVE SCALE FACTOR SET TO 1 -C IN ANTICIPATION OF POSSIBLE USE IN GLAHN 2DN DIFF -C - SCAL2 = 1. -C - ELSE -C -C PRINT*,' AND FIXED BIT PACKING, IBITL = ', IBITL -C FIXED BIT PACKING -C - LENGTH OF FIELD IN IBITL -C - MUST BE REAL DATA -C FLOATING POINT INPUT -C - RMAX = FWORK(1) - RMIN = FWORK(1) - DO 100 I = 2, NPTS - IF (FWORK(I).LT.RMIN) THEN - RMIN = FWORK(I) - ELSE IF (FWORK(I).GT.RMAX) THEN - RMAX = FWORK(I) - END IF - 100 CONTINUE - REFNCE = RMIN -C PRINT *,'100 REFERENCE',REFNCE -C EXTRACT MINIMA - DO 200 I = 1, NPTS - FWORK(I) = FWORK(I) - RMIN - 200 CONTINUE -C PRINT *,'REFERENCE VALUE',REFNCE -C WRITE (6,FMT='('' MINIMA REMOVED = '',/, -C & 10(3X,10F8.2,/))') (FWORK(I),I=1,6) -C WRITE (6,FMT='('' END OF ARRAY = '',/, -C & 10(3X,10F8.2,/))') (FWORK(I),I=NPTS-5,NPTS) -C FIND LARGEST DELTA - IDELT = NINT(RMAX - RMIN) -C DO BINARY SCALING -C FIND OUT WHAT BINARY SCALE FACTOR -C PERMITS CONTAINMENT OF -C LARGEST DELTA - CALL FI7505 (IDELT,IWIDE) -C -C BINARY SCALING -C - ISCAL2 = IWIDE - IBITL -C PRINT *,'SCALING NEEDED TO FIT =',ISCAL2 -C PRINT*,' RANGE OF = ',IDELT -C -C EXPAND DATA WITH BINARY SCALING -C CONVERT TO INTEGER - SCAL2 = 2.0**ISCAL2 - SCAL2 = 1./ SCAL2 - DO 600 I = 1, NPTS - IWORK(I) = NINT(FWORK(I) * SCAL2) - 600 CONTINUE - KWIDE = IBITL - END IF -C -C ***************************************************************** -C -C FOLLOWING IS FOR GLAHN SECOND DIFFERENCING -C NOT STANDARD GRIB -C -C TEST FOR SECOND DIFFERENCE PACKING -C BASED OF SIZE OF PDS - SIZE IN FIRST 3 BYTES -C - CALL GBYTEC(PDS,IPDSIZ,0,24) - IF (IPDSIZ.EQ.50) THEN -C PRINT*,' DO SECOND DIFFERENCE PACKING ' -C -C GLAHN PACKING TO 2ND DIFFS -C -C WRITE (6,FMT='('' CALL TO W3FI82 WITH = '',/, -C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS) -C - CALL W3FI82 (IWORK,FVAL1,FDIFF1,NPTS,PDS,IGDS) -C -C PRINT *,'GLAHN',FVAL1,FDIFF1 -C WRITE (6,FMT='('' OUT FROM W3FI82 WITH = '',/, -C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS) -C -C MUST NOW RE-REMOVE THE MINIMUM VALUE -C OF THE SECOND DIFFERENCES TO ASSURE -C ALL POSITIVE NUMBERS FOR SECOND ORDER GRIB PACKING -C -C ORIGINAL REFERENCE VALUE ADDED TO FIRST POINT -C VALUE FROM THE 2ND DIFF PACKER TO BE ADDED -C BACK IN WHEN THE 2ND DIFF VALUES ARE -C RECONSTRUCTED BACK TO THE BASIC VALUES -C -C ALSO, THE REFERENCE VALUE IS -C POWER-OF-TWO SCALED TO MATCH -C FVAL1. ALL OF THIS SCALING -C WILL BE REMOVED AFTER THE -C GLAHN SECOND DIFFERENCING IS UNDONE. -C THE SCALING FACTOR NEEDED TO DO THAT -C IS SAVED IN THE PDS AS A SIGNED POSITIVE -C TWO BYTE INTEGER -C -C THE SCALING FOR THE 2ND DIF PACKED -C VALUES IS PROPERLY SET TO ZERO -C - FVAL1 = FVAL1 + REFNCE*SCAL2 -C FIRST TEST TO SEE IF -C ON 32 OR 64 BIT COMPUTER -C CALL W3FI01(LW) - IF (bit_size(LW).EQ.32) THEN - CALL W3FI76 (FVAL1,IEXP,IMANT,32) - ELSE - CALL W3FI76 (FVAL1,IEXP,IMANT,64) - END IF - CALL SBYTEC(PDS,IEXP,320,8) - CALL SBYTEC(PDS,IMANT,328,24) -C - IF (bit_size(LW).EQ.32) THEN - CALL W3FI76 (FDIFF1,IEXP,IMANT,32) - ELSE - CALL W3FI76 (FDIFF1,IEXP,IMANT,64) - END IF - CALL SBYTEC(PDS,IEXP,352,8) - CALL SBYTEC(PDS,IMANT,360,24) -C -C TURN ISCAL2 INTO SIGNED POSITIVE INTEGER -C AND STORE IN TWO BYTES -C - IF(ISCAL2.GE.0) THEN - CALL SBYTEC(PDS,ISCAL2,384,16) - ELSE - CALL SBYTEC(PDS,1,384,1) - ISCAL2 = - ISCAL2 - CALL SBYTEC( PDS,ISCAL2,385,15) - ENDIF -C - MAX = IWORK(1) - MIN = IWORK(1) - DO 700 I = 2, NPTS - IF (IWORK(I).LT.MIN) THEN - MIN = IWORK(I) - ELSE IF (IWORK(I).GT.MAX) THEN - MAX = IWORK(I) - END IF - 700 CONTINUE -C EXTRACT MINIMA - DO 710 I = 1, NPTS - IWORK(I) = IWORK(I) - MIN - 710 CONTINUE - REFNCE = MIN -C PRINT *,'710 REFERENCE',REFNCE - ISCAL2 = 0 -C -C AND RESET VALUE OF KWIDE - THE BIT WIDTH -C FOR THE RANGE OF THE VALUES -C - IDIFF = MAX - MIN - CALL FI7505 (IDIFF,KWIDE) -C -C PRINT*,'BIT WIDTH (KWIDE) OF 2ND DIFFS', KWIDE -C -C **************************** END OF GLAHN PACKING ************ - ELSE IF (IBDSFL(2).EQ.1.AND.IBDSFL(7).EQ.0) THEN -C HAVE SECOND ORDER PACKING WITH NO SECOND ORDER -C BIT MAP. ERGO ROW BY ROW - COL BY COL - CALL FI7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, - * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS) - RETURN - END IF -C WRITE (6,FMT='('' CALL TO FI7501 WITH = '',/, -C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS) -C WRITE (6,FMT='('' END OF ARRAY = '',/, -C & 10(3X,10I6,/))') (IWORK(I),I=NPTS-5,NPTS) -C PRINT*,' REFNCE,ISCAL2, KWIDE AT CALL TO FI7501', -C & REFNCE, ISCAL2,KWIDE -C -C SECOND ORDER PACKING -C - CALL FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, - * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE) -C -C BDS COMPLETELY ASSEMBLED IN FI7501 FOR SECOND ORDER -C PACKING. -C - ELSE -C SIMPLE PACKING -C -C PRINT*,' SIMPLE FIRST ORDER PACKING...' - IF (IBITL.EQ.0) THEN -C PRINT*,' WITH VARIABLE BIT LENGTH' -C -C WITH VARIABLE BIT LENGTH, ADJUSTED -C TO ACCOMMODATE LARGEST VALUE -C BINARY SCALING ALWAYS = 0 -C - CALL W3FI58(IWORK,NPTS,IWORK,PFLD,NBITS,LEN,KMIN) - RMIN = KMIN - REFNCE = RMIN - ISCALE = 0 -C PRINT*,' BIT LENGTH CAME OUT AT ...',NBITS -C -C SET CONST .TRUE. IF ALL VALUES ARE THE SAME -C - IF (LEN.EQ.0.AND.NBITS.EQ.0) CONST = .TRUE. -C - ELSE -C PRINT*,' FIXED BIT LENGTH, IBITL = ', IBITL -C -C FIXED BIT LENGTH PACKING (VARIABLE PRECISION) -C VALUES SCALED BY POWER OF 2 (ISCALE) TO -C FIT LARGEST VALUE INTO GIVEN BIT LENGTH (IBITL) -C - CALL W3FI59(FWORK,NPTS,IBITL,IWORK,PFLD,ISCALE,LEN,RMIN) - REFNCE = RMIN -C PRINT *,' SCALING NEEDED TO FIT IS ...', ISCALE - NBITS = IBITL -C -C SET CONST .TRUE. IF ALL VALUES ARE THE SAME -C - IF (LEN.EQ.0) THEN - CONST = .TRUE. - NBITS = 0 - END IF - END IF -C -C COMPUTE LENGTH OF BDS IN OCTETS -C - INUM = NPTS * NBITS + 88 -C PRINT *,'NUMBER OF BITS BEFORE FILL ADDED',INUM -C -C NUMBER OF FILL BITS - NFILL = 0 - NLEFT = MOD(INUM,16) - IF (NLEFT.NE.0) THEN - INUM = INUM + 16 - NLEFT - NFILL = 16 - NLEFT - END IF -C PRINT *,'NUMBER OF BITS AFTER FILL ADDED',INUM -C LENGTH OF BDS IN BYTES - LENBDS = INUM / 8 -C -C 2.0 FORM THE BINARY DATA SECTION (BDS). -C -C CONCANTENATE ALL FIELDS FOR BDS -C -C BYTES 1-3 - CALL SBYTEC (BDS11,LENBDS,0,24) -C -C BYTE 4 -C FLAGS - CALL SBYTEC (BDS11,IBDSFL(1),24,1) - CALL SBYTEC (BDS11,IBDSFL(2),25,1) - CALL SBYTEC (BDS11,IBDSFL(3),26,1) - CALL SBYTEC (BDS11,IBDSFL(4),27,1) -C NR OF FILL BITS - CALL SBYTEC (BDS11,NFILL,28,4) -C -C FILL OCTETS 5-6 WITH THE SCALE FACTOR. -C -C BYTE 5-6 - IF (ISCALE.LT.0) THEN - CALL SBYTEC (BDS11,1,32,1) - ISCALE = - ISCALE - CALL SBYTEC (BDS11,ISCALE,33,15) - ELSE - CALL SBYTEC (BDS11,ISCALE,32,16) - END IF -C -C FILL OCTET 7-10 WITH THE REFERENCE VALUE -C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT -C FLOATING POINT NUMBER -C -C BYTE 7-10 -C REFERENCE VALUE -C FIRST TEST TO SEE IF -C ON 32 OR 64 BIT COMPUTER -C CALL W3FI01(LW) - IF (bit_size(LW).EQ.32) THEN - CALL W3FI76 (REFNCE,IEXP,IMANT,32) - ELSE - CALL W3FI76 (REFNCE,IEXP,IMANT,64) - END IF - CALL SBYTEC (BDS11,IEXP,48,8) - CALL SBYTEC (BDS11,IMANT,56,24) -C -C -C FILL OCTET 11 WITH THE NUMBER OF BITS. -C -C BYTE 11 - CALL SBYTEC (BDS11,NBITS,80,8) - END IF -C - RETURN - END - SUBROUTINE FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, - * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7501 BDS SECOND ORDER PACKING -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-08-06 -C -C ABSTRACT: PERFORM SECONDARY PACKING ON GRID POINT DATA, -C GENERATING ALL BDS INFORMATION. -C -C PROGRAM HISTORY LOG: -C 93-08-06 CAVANAUGH -C 93-12-15 CAVANAUGH CORRECTED LOCATION OF START OF FIRST ORDER -C VALUES AND START OF SECOND ORDER VALUES TO -C REFLECT A BYTE LOCATION IN THE BDS INSTEAD -C OF AN OFFSET. -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, -C * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE) -C INPUT ARGUMENT LIST: -C IWORK - INTEGER SOURCE ARRAY -C NPTS - NUMBER OF POINTS IN IWORK -C IBDSFL - FLAGS -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IPFLD - CONTAINS BDS FROM BYTE 12 ON -C BDS11 - CONTAINS FIRST 11 BYTES FOR BDS -C LEN - NUMBER OF BYTES FROM 12 ON -C LENBDS - TOTAL LENGTH OF BDS -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - CHARACTER*1 BDS11(*),PDS(*) -C - REAL REFNCE -C - INTEGER ISCAL2,KWIDE - INTEGER LENBDS - CHARACTER(len=1) IPFLD(*) - INTEGER LEN,KBDS(22) - INTEGER IWORK(*) -C OCTET NUMBER IN SECTION, FIRST ORDER PACKING -C INTEGER KBDS(12) -C FLAGS - INTEGER IBDSFL(*) -C EXTENDED FLAGS -C INTEGER KBDS(14) -C OCTET NUMBER FOR SECOND ORDER PACKING -C INTEGER KBDS(15) -C NUMBER OF FIRST ORDER VALUES -C INTEGER KBDS(17) -C NUMBER OF SECOND ORDER PACKED VALUES -C INTEGER KBDS(19) -C WIDTH OF SECOND ORDER PACKING - character(len=1) ISOWID(400000) -C SECONDARY BIT MAP - character(len=1) ISOBMP(65600) -C FIRST ORDER PACKED VALUES - character(len=1) IFOVAL(400000) -C SECOND ORDER PACKED VALUES - character(len=1) ISOVAL(800000) -C -C INTEGER KBDS(11) -C BIT WIDTH TABLE - INTEGER IBITS(31) -C - DATA IBITS/1,3,7,15,31,63,127,255,511,1023, - * 2047,4095,8191,16383,32767,65535,131072, - * 262143,524287,1048575,2097151,4194303, - * 8388607,16777215,33554431,67108863, - * 134217727,268435455,536870911, - * 1073741823,2147483647/ -C ---------------------------------- -C INITIALIZE ARRAYS - - DO I = 1, 400000 - IFOVAL(I) = char(0) - ISOWID(I) = char(0) - ENDDO -C - DO 101 I = 1, 65600 - ISOBMP(I) = char(0) - 101 CONTINUE - DO 102 I = 1, 800000 - ISOVAL(I) = char(0) - 102 CONTINUE -C INITIALIZE POINTERS -C SECONDARY BIT WIDTH POINTER - IWDPTR = 0 -C SECONDARY BIT MAP POINTER - IBMP2P = 0 -C FIRST ORDER VALUE POINTER - IFOPTR = 0 -C BYTE POINTER TO START OF 1ST ORDER VALUES - KBDS(12) = 0 -C BYTE POINTER TO START OF 2ND ORDER VALUES - KBDS(15) = 0 -C TO CONTAIN NUMBER OF FIRST ORDER VALUES - KBDS(17) = 0 -C TO CONTAIN NUMBER OF SECOND ORDER VALUES - KBDS(19) = 0 -C SECOND ORDER PACKED VALUE POINTER - ISOPTR = 0 -C ======================================================= -C -C DATA IS IN IWORK -C - KBDS(11) = KWIDE -C -C DATA PACKING -C - ITER = 0 - INEXT = 1 - ISTART = 1 -C ----------------------------------------------------------- - KOUNT = 0 -C DO 1 I = 1, NPTS, 10 -C PRINT *,I,(IWORK(K),K=I, I+9) -C 1 CONTINUE - 2000 CONTINUE - ITER = ITER + 1 -C PRINT *,'NEXT ITERATION STARTS AT',ISTART - IF (ISTART.GT.NPTS) THEN - GO TO 4000 - ELSE IF (ISTART.EQ.NPTS) THEN - KPTS = 1 - MXDIFF = 0 - GO TO 2200 - END IF -C -C LOOK FOR REPITITIONS OF A SINGLE VALUE - CALL FI7502 (IWORK,ISTART,NPTS,ISAME) - IF (ISAME.GE.15) THEN - KOUNT = KOUNT + 1 -C PRINT *,'FI7501 - FOUND IDENTICAL SET OF ',ISAME - MXDIFF = 0 - KPTS = ISAME - ELSE -C -C LOOK FOR SETS OF VALUES IN TREND SELECTED RANGE - CALL FI7513 (IWORK,ISTART,NPTS,NMAX,NMIN,INRNGE) -C PRINT *,'ISTART ',ISTART,' INRNGE',INRNGE,NMAX,NMIN - IEND = ISTART + INRNGE - 1 -C DO 2199 NM = ISTART, IEND, 10 -C PRINT *,' ',(IWORK(NM+JK),JK=0,9) -C2199 CONTINUE - MXDIFF = NMAX - NMIN - KPTS = INRNGE - END IF - 2200 CONTINUE -C PRINT *,' RANGE ',MXDIFF,' MAX',NMAX,' MIN',NMIN -C INCREMENT NUMBER OF FIRST ORDER VALUES - KBDS(17) = KBDS(17) + 1 -C ENTER FIRST ORDER VALUE - IF (MXDIFF.GT.0) THEN - DO 2220 LK = 0, KPTS-1 - IWORK(ISTART+LK) = IWORK(ISTART+LK) - NMIN - 2220 CONTINUE - CALL SBYTEC (IFOVAL,NMIN,IFOPTR,KBDS(11)) - ELSE - CALL SBYTEC (IFOVAL,IWORK(ISTART),IFOPTR,KBDS(11)) - END IF - IFOPTR = IFOPTR + KBDS(11) -C PROCESS SECOND ORDER BIT WIDTH - IF (MXDIFF.GT.0) THEN - DO 2330 KWIDE = 1, 31 - IF (MXDIFF.LE.IBITS(KWIDE)) THEN - GO TO 2331 - END IF - 2330 CONTINUE - 2331 CONTINUE - ELSE - KWIDE = 0 - END IF - CALL SBYTEC (ISOWID,KWIDE,IWDPTR,8) - IWDPTR = IWDPTR + 8 -C PRINT *,KWIDE,' IFOVAL=',NMIN,IWORK(ISTART),KPTS -C IF KWIDE NE 0, SAVE SECOND ORDER VALUE - IF (KWIDE.GT.0) THEN - CALL SBYTESC (ISOVAL,IWORK(ISTART),ISOPTR,KWIDE,0,KPTS) - ISOPTR = ISOPTR + KPTS * KWIDE - KBDS(19) = KBDS(19) + KPTS -C PRINT *,' SECOND ORDER VALUES' -C PRINT *,(IWORK(ISTART+I),I=0,KPTS-1) - END IF -C ADD TO SECOND ORDER BITMAP - CALL SBYTEC (ISOBMP,1,IBMP2P,1) - IBMP2P = IBMP2P + KPTS - ISTART = ISTART + KPTS - GO TO 2000 -C -------------------------------------------------------------- - 4000 CONTINUE -C PRINT *,'THERE WERE ',ITER,' SECOND ORDER GROUPS' -C PRINT *,'THERE WERE ',KOUNT,' STRINGS OF CONSTANTS' -C CONCANTENATE ALL FIELDS FOR BDS -C -C REMAINDER GOES INTO IPFLD - IPTR = 0 -C BYTES 12-13 -C VALUE FOR N1 -C LEAVE SPACE FOR THIS - IPTR = IPTR + 16 -C BYTE 14 -C EXTENDED FLAGS - CALL SBYTEC (IPFLD,IBDSFL(5),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(6),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(7),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(8),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(9),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(10),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(11),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(12),IPTR,1) - IPTR = IPTR + 1 -C BYTES 15-16 -C SKIP OVER VALUE FOR N2 - IPTR = IPTR + 16 -C BYTES 17-18 -C P1 - CALL SBYTEC (IPFLD,KBDS(17),IPTR,16) - IPTR = IPTR + 16 -C BYTES 19-20 -C P2 - CALL SBYTEC (IPFLD,KBDS(19),IPTR,16) - IPTR = IPTR + 16 -C BYTE 21 - RESERVED LOCATION - CALL SBYTEC (IPFLD,0,IPTR,8) - IPTR = IPTR + 8 -C BYTES 22 - ? -C WIDTHS OF SECOND ORDER PACKING - IX = (IWDPTR + 32) / 32 -C CALL SBYTESC (IPFLD,ISOWID,IPTR,32,0,IX) - ijk=IWDPTR/8 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=ISOWID(1:ijk) - IPTR = IPTR + IWDPTR -C SECONDARY BIT MAP - IJ = (IBMP2P + 32) / 32 -C CALL SBYTESC (IPFLD,ISOBMP,IPTR,32,0,IJ) - ijk=(IBMP2P/8)+1 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=ISOBMP(1:ijk) - IPTR = IPTR + IBMP2P - IF (MOD(IPTR,8).NE.0) THEN - IPTR = IPTR + 8 - MOD(IPTR,8) - END IF -C DETERMINE LOCATION FOR START -C OF FIRST ORDER PACKED VALUES - KBDS(12) = IPTR / 8 + 12 -C STORE LOCATION - CALL SBYTEC (IPFLD,KBDS(12),0,16) -C MOVE IN FIRST ORDER PACKED VALUES - IPASS = (IFOPTR + 32) / 32 -C CALL SBYTESC (IPFLD,IFOVAL,IPTR,32,0,IPASS) - ijk=(IFOPTR/8)+1 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=ifoval(1:ijk) - IPTR = IPTR + IFOPTR - IF (MOD(IPTR,8).NE.0) THEN - IPTR = IPTR + 8 - MOD(IPTR,8) - END IF -C PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR -C DETERMINE LOCATION FOR START -C OF SECOND ORDER VALUES - KBDS(15) = IPTR / 8 + 12 -C SAVE LOCATION OF SECOND ORDER VALUES - CALL SBYTEC (IPFLD,KBDS(15),24,16) -C MOVE IN SECOND ORDER PACKED VALUES - IX = (ISOPTR + 32) / 32 -c CALL SBYTESC (IPFLD,ISOVAL,IPTR,32,0,IX) - ijk=(ISOPTR/8)+1 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=isoval(1:ijk) - IPTR = IPTR + ISOPTR - NLEFT = MOD(IPTR+88,16) - IF (NLEFT.NE.0) THEN - NLEFT = 16 - NLEFT - IPTR = IPTR + NLEFT - END IF -C COMPUTE LENGTH OF DATA PORTION - LEN = IPTR / 8 -C COMPUTE LENGTH OF BDS - LENBDS = LEN + 11 -C ----------------------------------- -C BYTES 1-3 -C THIS FUNCTION COMPLETED BELOW -C WHEN LENGTH OF BDS IS KNOWN - CALL SBYTEC (BDS11,LENBDS,0,24) -C BYTE 4 - CALL SBYTEC (BDS11,IBDSFL(1),24,1) - CALL SBYTEC (BDS11,IBDSFL(2),25,1) - CALL SBYTEC (BDS11,IBDSFL(3),26,1) - CALL SBYTEC (BDS11,IBDSFL(4),27,1) -C ENTER NUMBER OF FILL BITS - CALL SBYTEC (BDS11,NLEFT,28,4) -C BYTE 5-6 - IF (ISCAL2.LT.0) THEN - CALL SBYTEC (BDS11,1,32,1) - ISCAL2 = - ISCAL2 - ELSE - CALL SBYTEC (BDS11,0,32,1) - END IF - CALL SBYTEC (BDS11,ISCAL2,33,15) -C -C FILL OCTET 7-10 WITH THE REFERENCE VALUE -C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT -C FLOATING POINT NUMBER -C REFERENCE VALUE -C FIRST TEST TO SEE IF -C ON 32 OR 64 BIT COMPUTER -C CALL W3FI01(LW) - IF (bit_size(LW).EQ.32) THEN - CALL W3FI76 (REFNCE,IEXP,IMANT,32) - ELSE - CALL W3FI76 (REFNCE,IEXP,IMANT,64) - END IF - CALL SBYTEC (BDS11,IEXP,48,8) - CALL SBYTEC (BDS11,IMANT,56,24) -C -C BYTE 11 -C - CALL SBYTEC (BDS11,KBDS(11),80,8) -C - RETURN - END - SUBROUTINE FI7502 (IWORK,ISTART,NPTS,ISAME) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7502 SECOND ORDER SAME VALUE COLLECTION -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-06-23 -C -C ABSTRACT: COLLECT SEQUENTIAL SAME VALUES FOR PROCESSING -C AS SECOND ORDER VALUE FOR GRIB MESSAGES. -C -C PROGRAM HISTORY LOG: -C 93-06-23 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI7502 (IWORK,ISTART,NPTS,ISAME) -C INPUT ARGUMENT LIST: -C IWORK - ARRAY CONTAINING SOURCE DATA -C ISTART - STARTING LOCATION FOR THIS TEST -C NPTS - NUMBER OF POINTS IN IWORK -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ISAME - NUMBER OF SEQUENTIAL POINTS HAVING THE SAME VALUE -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - INTEGER IWORK(*) - INTEGER ISTART - INTEGER ISAME - INTEGER K - INTEGER NPTS -C ------------------------------------------------------------- - ISAME = 0 - DO 100 K = ISTART, NPTS - IF (IWORK(K).NE.IWORK(ISTART)) THEN - RETURN - END IF - ISAME = ISAME + 1 - 100 CONTINUE - RETURN - END - SUBROUTINE FI7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, - * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7501 ROW BY ROW, COL BY COL PACKING -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-05-20 -C -C ABSTRACT: PERFORM ROW BY ROW OR COLUMN BY COLUMN PACKING -C GENERATING ALL BDS INFORMATION. -C -C PROGRAM HISTORY LOG: -C 93-08-06 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, -C * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS) -C INPUT ARGUMENT LIST: -C IWORK - INTEGER SOURCE ARRAY -C NPTS - NUMBER OF POINTS IN IWORK -C IBDSFL - FLAGS -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IPFLD - CONTAINS BDS FROM BYTE 12 ON -C BDS11 - CONTAINS FIRST 11 BYTES FOR BDS -C LEN - NUMBER OF BYTES FROM 12 ON -C LENBDS - TOTAL LENGTH OF BDS -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - CHARACTER*1 BDS11(*),PDS(*),IPFLD(*) -C - REAL REFNCE -C - INTEGER ISCAL2,KWIDE - INTEGER LENBDS - INTEGER IGDS(*) - INTEGER LEN,KBDS(22) - INTEGER IWORK(*) -C OCTET NUMBER IN SECTION, FIRST ORDER PACKING -C INTEGER KBDS(12) -C FLAGS - INTEGER IBDSFL(*) -C EXTENDED FLAGS -C INTEGER KBDS(14) -C OCTET NUMBER FOR SECOND ORDER PACKING -C INTEGER KBDS(15) -C NUMBER OF FIRST ORDER VALUES -C INTEGER KBDS(17) -C NUMBER OF SECOND ORDER PACKED VALUES -C INTEGER KBDS(19) -C WIDTH OF SECOND ORDER PACKING - character(len=1) ISOWID(400000) -C SECONDARY BIT MAP - character(len=1) ISOBMP(65600) -C FIRST ORDER PACKED VALUES - character(len=1) IFOVAL(400000) -C SECOND ORDER PACKED VALUES - character(len=1) ISOVAL(800000) -C -C INTEGER KBDS(11) -C ---------------------------------- -C INITIALIZE ARRAYS -C - DO I = 1, 400000 - IFOVAL(I) = char(0) - ISOWID(I) = char(0) - ENDDO -C - DO 101 I = 1, 65600 - ISOBMP(I) = char(0) - 101 CONTINUE - DO 102 I = 1, 800000 - ISOVAL(I) = char(0) - 102 CONTINUE -C INITIALIZE POINTERS -C SECONDARY BIT WIDTH POINTER - IWDPTR = 0 -C SECONDARY BIT MAP POINTER - IBMP2P = 0 -C FIRST ORDER VALUE POINTER - IFOPTR = 0 -C BYTE POINTER TO START OF 1ST ORDER VALUES - KBDS(12) = 0 -C BYTE POINTER TO START OF 2ND ORDER VALUES - KBDS(15) = 0 -C TO CONTAIN NUMBER OF FIRST ORDER VALUES - KBDS(17) = 0 -C TO CONTAIN NUMBER OF SECOND ORDER VALUES - KBDS(19) = 0 -C SECOND ORDER PACKED VALUE POINTER - ISOPTR = 0 -C ======================================================= -C BUILD SECOND ORDER BIT MAP IN EITHER -C ROW BY ROW OR COL BY COL FORMAT - IF (IAND(IGDS(13),32).NE.0) THEN -C COLUMN BY COLUMN - KOUT = IGDS(4) - KIN = IGDS(5) -C PRINT *,'COLUMN BY COLUMN',KOUT,KIN - ELSE -C ROW BY ROW - KOUT = IGDS(5) - KIN = IGDS(4) -C PRINT *,'ROW BY ROW',KOUT,KIN - END IF - KBDS(17) = KOUT - KBDS(19) = NPTS -C -C DO 4100 J = 1, NPTS, 53 -C WRITE (6,4101) (IWORK(K),K=J,J+52) - 4101 FORMAT (1X,25I4) -C PRINT *,' ' -C4100 CONTINUE -C -C INITIALIZE BIT MAP POINTER - IBMP2P = 0 -C CONSTRUCT WORKING BIT MAP - DO 2000 I = 1, KOUT - DO 1000 J = 1, KIN - IF (J.EQ.1) THEN - CALL SBYTEC (ISOBMP,1,IBMP2P,1) - ELSE - CALL SBYTEC (ISOBMP,0,IBMP2P,1) - END IF - IBMP2P = IBMP2P + 1 - 1000 CONTINUE - 2000 CONTINUE - LEN = IBMP2P / 32 + 1 -C CALL BINARY(ISOBMP,LEN) -C -C PROCESS OUTER LOOP OF ROW BY ROW OR COL BY COL -C - KPTR = 1 - KBDS(11) = KWIDE - DO 6000 I = 1, KOUT -C IN CURRENT ROW OR COL -C FIND FIRST ORDER VALUE - JPTR = KPTR - LOWEST = IWORK(JPTR) - DO 4000 J = 1, KIN - IF (IWORK(JPTR).LT.LOWEST) THEN - LOWEST = IWORK(JPTR) - END IF - JPTR = JPTR + 1 - 4000 CONTINUE -C SAVE FIRST ORDER VALUE - CALL SBYTEC (IFOVAL,LOWEST,IFOPTR,KWIDE) - IFOPTR = IFOPTR + KWIDE -C PRINT *,'FOVAL',I,LOWEST,KWIDE -C SUBTRACT FIRST ORDER VALUE FROM OTHER VALS -C GETTING SECOND ORDER VALUES - JPTR = KPTR - IBIG = IWORK(JPTR) - LOWEST - DO 4200 J = 1, KIN - IWORK(JPTR) = IWORK(JPTR) - LOWEST - IF (IWORK(JPTR).GT.IBIG) THEN - IBIG = IWORK(JPTR) - END IF - JPTR = JPTR + 1 - 4200 CONTINUE -C HOW MANY BITS TO CONTAIN LARGEST SECOND -C ORDER VALUE IN SEGMENT - CALL FI7505 (IBIG,NWIDE) -C SAVE BIT WIDTH - CALL SBYTEC (ISOWID,NWIDE,IWDPTR,8) - IWDPTR = IWDPTR + 8 -C PRINT *,I,'SOVAL',IBIG,' IN',NWIDE,' BITS' -C WRITE (6,4101) (IWORK(K),K=KPTR,KPTR+52) -C SAVE SECOND ORDER VALUES OF THIS SEGMENT - DO 5000 J = 0, KIN-1 - CALL SBYTEC (ISOVAL,IWORK(KPTR+J),ISOPTR,NWIDE) - ISOPTR = ISOPTR + NWIDE - 5000 CONTINUE - KPTR = KPTR + KIN - 6000 CONTINUE -C ======================================================= -C CONCANTENATE ALL FIELDS FOR BDS -C -C REMAINDER GOES INTO IPFLD - IPTR = 0 -C BYTES 12-13 -C VALUE FOR N1 -C LEAVE SPACE FOR THIS - IPTR = IPTR + 16 -C BYTE 14 -C EXTENDED FLAGS - CALL SBYTEC (IPFLD,IBDSFL(5),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(6),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(7),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(8),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(9),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(10),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(11),IPTR,1) - IPTR = IPTR + 1 - CALL SBYTEC (IPFLD,IBDSFL(12),IPTR,1) - IPTR = IPTR + 1 -C BYTES 15-16 -C SKIP OVER VALUE FOR N2 - IPTR = IPTR + 16 -C BYTES 17-18 -C P1 - CALL SBYTEC (IPFLD,KBDS(17),IPTR,16) - IPTR = IPTR + 16 -C BYTES 19-20 -C P2 - CALL SBYTEC (IPFLD,KBDS(19),IPTR,16) - IPTR = IPTR + 16 -C BYTE 21 - RESERVED LOCATION - CALL SBYTEC (IPFLD,0,IPTR,8) - IPTR = IPTR + 8 -C BYTES 22 - ? -C WIDTHS OF SECOND ORDER PACKING - IX = (IWDPTR + 32) / 32 -C CALL SBYTESC (IPFLD,ISOWID,IPTR,32,0,IX) - ijk=IWDPTR/8 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=ISOWID(1:ijk) - IPTR = IPTR + IWDPTR -C PRINT *,'ISOWID',IWDPTR,IX -C CALL BINARY (ISOWID,IX) -C -C NO SECONDARY BIT MAP - -C DETERMINE LOCATION FOR START -C OF FIRST ORDER PACKED VALUES - KBDS(12) = IPTR / 8 + 12 -C STORE LOCATION - CALL SBYTEC (IPFLD,KBDS(12),0,16) -C MOVE IN FIRST ORDER PACKED VALUES - IPASS = (IFOPTR + 32) / 32 -c CALL SBYTESC (IPFLD,IFOVAL,IPTR,32,0,IPASS) - ijk=(IFOPTR/8)+1 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=ifoval(1:ijk) - IPTR = IPTR + IFOPTR -C PRINT *,'IFOVAL',IFOPTR,IPASS,KWIDE -C CALL BINARY (IFOVAL,IPASS) - IF (MOD(IPTR,8).NE.0) THEN - IPTR = IPTR + 8 - MOD(IPTR,8) - END IF -C PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR -C DETERMINE LOCATION FOR START -C OF SECOND ORDER VALUES - KBDS(15) = IPTR / 8 + 12 -C SAVE LOCATION OF SECOND ORDER VALUES - CALL SBYTEC (IPFLD,KBDS(15),24,16) -C MOVE IN SECOND ORDER PACKED VALUES - IX = (ISOPTR + 32) / 32 -C CALL SBYTESC (IPFLD,ISOVAL,IPTR,32,0,IX) - ijk=(ISOPTR/8)+1 - jst=(iptr/8)+1 - ipfld(jst:jst+ijk)=isoval(1:ijk) - IPTR = IPTR + ISOPTR -C PRINT *,'ISOVAL',ISOPTR,IX -C CALL BINARY (ISOVAL,IX) - NLEFT = MOD(IPTR+88,16) - IF (NLEFT.NE.0) THEN - NLEFT = 16 - NLEFT - IPTR = IPTR + NLEFT - END IF -C COMPUTE LENGTH OF DATA PORTION - LEN = IPTR / 8 -C COMPUTE LENGTH OF BDS - LENBDS = LEN + 11 -C ----------------------------------- -C BYTES 1-3 -C THIS FUNCTION COMPLETED BELOW -C WHEN LENGTH OF BDS IS KNOWN - CALL SBYTEC (BDS11,LENBDS,0,24) -C BYTE 4 - CALL SBYTEC (BDS11,IBDSFL(1),24,1) - CALL SBYTEC (BDS11,IBDSFL(2),25,1) - CALL SBYTEC (BDS11,IBDSFL(3),26,1) - CALL SBYTEC (BDS11,IBDSFL(4),27,1) -C ENTER NUMBER OF FILL BITS - CALL SBYTEC (BDS11,NLEFT,28,4) -C BYTE 5-6 - IF (ISCAL2.LT.0) THEN - CALL SBYTEC (BDS11,1,32,1) - ISCAL2 = - ISCAL2 - ELSE - CALL SBYTEC (BDS11,0,32,1) - END IF - CALL SBYTEC (BDS11,ISCAL2,33,15) -C -C FILL OCTET 7-10 WITH THE REFERENCE VALUE -C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT -C FLOATING POINT NUMBER -C REFERENCE VALUE -C FIRST TEST TO SEE IF -C ON 32 OR 64 BIT COMPUTER -C CALL W3FI01(LW) - IF (bit_size(LW).EQ.32) THEN - CALL W3FI76 (REFNCE,IEXP,IMANT,32) - ELSE - CALL W3FI76 (REFNCE,IEXP,IMANT,64) - END IF - CALL SBYTEC (BDS11,IEXP,48,8) - CALL SBYTEC (BDS11,IMANT,56,24) -C -C BYTE 11 -C - CALL SBYTEC (BDS11,KBDS(11),80,8) -C - KLEN = LENBDS / 4 + 1 -C PRINT *,'BDS11 LISTING',4,LENBDS -C CALL BINARY (BDS11,4) -C PRINT *,'IPFLD LISTING' -C CALL BINARY (IPFLD,KLEN) - RETURN - END - SUBROUTINE FI7505 (N,NBITS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7505 DETERMINE NUMBER OF BITS TO CONTAIN VALUE -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-06-23 -C -C ABSTRACT: CALCULATE NUMBER OF BITS TO CONTAIN VALUE N, WITH A -C MAXIMUM OF 32 BITS. -C -C PROGRAM HISTORY LOG: -C 93-06-23 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI7505 (N,NBITS) -C INPUT ARGUMENT LIST: -C N - INTEGER VALUE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C NBITS - NUMBER OF BITS TO CONTAIN N -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - INTEGER N,NBITS - INTEGER IBITS(31) -C - DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, - * 4095,8191,16383,32767,65535,131071,262143, - * 524287,1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727,268435455, - * 536870911,1073741823,2147483647/ -C ---------------------------------------------------------------- -C - DO 1000 NBITS = 1, 31 - IF (N.LE.IBITS(NBITS)) THEN - RETURN - END IF - 1000 CONTINUE - RETURN - END - SUBROUTINE FI7513 (IWORK,ISTART,NPTS,MAX,MIN,INRNGE) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7513 SELECT BLOCK OF DATA FOR PACKING -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-01-21 -C -C ABSTRACT: SELECT A BLOCK OF DATA FOR PACKING -C -C PROGRAM HISTORY LOG: -C 94-01-21 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI7513 (IWORK,ISTART,NPTS,MAX,MIN,INRNGE) -C INPUT ARGUMENT LIST: -C * - RETURN ADDRESS IF ENCOUNTER SET OF SAME VALUES -C IWORK - -C ISTART - -C NPTS - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C MAX - -C MIN - -C INRNGE - -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - INTEGER IWORK(*),NPTS,ISTART,INRNGE,INRNGA,INRNGB - INTEGER MAX,MIN,MXVAL,MAXB,MINB,MXVALB - INTEGER IBITS(31) -C - DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, - * 4095,8191,16383,32767,65535,131071,262143, - * 524287,1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727,268435455, - * 536870911,1073741823,2147483647/ -C ---------------------------------------------------------------- -C IDENTIFY NEXT BLOCK OF DATA FOR PACKING AND -C RETURN TO CALLER -C ******************************************************************** - ISTRTA = ISTART -C -C GET BLOCK A - CALL FI7516 (IWORK,NPTS,INRNGA,ISTRTA, - * MAX,MIN,MXVAL,LWIDE) -C ******************************************************************** -C - ISTRTB = ISTRTA + INRNGA - 2000 CONTINUE -C IF HAVE PROCESSED ALL DATA, RETURN - IF (ISTRTB.GT.NPTS) THEN -C NO MORE DATA TO LOOK AT - INRNGE = INRNGA - RETURN - END IF -C GET BLOCK B - CALL FI7502 (IWORK,ISTRTB,NPTS,ISAME) - IF (ISAME.GE.15) THEN -C PRINT *,'BLOCK B HAS ALL IDENTICAL VALUES' -C PRINT *,'BLOCK A HAS INRNGE =',INRNGA -C BLOCK B CONTAINS ALL IDENTICAL VALUES - INRNGE = INRNGA -C EXIT WITH BLOCK A - RETURN - END IF -C GET BLOCK B -C - ISTRTB = ISTRTA + INRNGA - CALL FI7516 (IWORK,NPTS,INRNGB,ISTRTB, - * MAXB,MINB,MXVALB,LWIDEB) -C PRINT *,'BLOCK A',INRNGA,' BLOCK B',INRNGB -C ******************************************************************** -C PERFORM TREND ANALYSIS TO DETERMINE -C IF DATA COLLECTION CAN BE IMPROVED -C - KTRND = LWIDE - LWIDEB -C PRINT *,'TREND',LWIDE,LWIDEB - IF (KTRND.LE.0) THEN -C PRINT *,'BLOCK A - SMALLER, SHOULD EXTEND INTO BLOCK B' - MXVAL = IBITS(LWIDE) -C -C IF BLOCK A REQUIRES THE SAME OR FEWER BITS -C LOOK AHEAD -C AND GATHER THOSE DATA POINTS THAT CAN -C BE RETAINED IN BLOCK A -C BECAUSE THIS BLOCK OF DATA -C USES FEWER BITS -C - CALL FI7518 (IRET,IWORK,NPTS,ISTRTA,INRNGA,INRNGB, - * MAX,MIN,LWIDE,MXVAL) - IF(IRET.EQ.1) GO TO 8000 -C PRINT *,'18 INRNGA IS NOW ',INRNGA - IF (INRNGB.LT.20) THEN - RETURN - ELSE - GO TO 2000 - END IF - ELSE -C PRINT *,'BLOCK A - LARGER, B SHOULD EXTEND BACK INTO A' - MXVALB = IBITS(LWIDEB) -C -C IF BLOCK B REQUIRES FEWER BITS -C LOOK BACK -C SHORTEN BLOCK A BECAUSE NEXT BLOCK OF DATA -C USES FEWER BITS -C - CALL FI7517 (IRET,IWORK,NPTS,ISTRTB,INRNGA, - * MAXB,MINB,LWIDEB,MXVALB) - IF(IRET.EQ.1) GO TO 8000 -C PRINT *,'17 INRNGA IS NOW ',INRNGA - END IF -C -C PACK UP BLOCK A -C UPDATA POINTERS - 8000 CONTINUE - INRNGE = INRNGA -C GET NEXT BLOCK A - 9000 CONTINUE - RETURN - END - SUBROUTINE FI7516 (IWORK,NPTS,INRNG,ISTART,MAX,MIN,MXVAL,LWIDTH) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7516 SCAN NUMBER OF POINTS -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-01-21 -C -C ABSTRACT: SCAN FORWARD FROM CURRENT POSITION. COLLECT POINTS AND -C DETERMINE MAXIMUM AND MINIMUM VALUES AND THE NUMBER -C OF POINTS THAT ARE INCLUDED. FORWARD SEARCH IS TERMINATED -C BY ENCOUNTERING A SET OF IDENTICAL VALUES, BY REACHING -C THE NUMBER OF POINTS SELECTED OR BY REACHING THE END -C OF DATA. -C -C PROGRAM HISTORY LOG: -C 94-01-21 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL FI7516 (IWORK,NPTS,INRNG,ISTART,MAX,MIN,MXVAL,LWIDTH) -C INPUT ARGUMENT LIST: -C * - RETURN ADDRESS IF ENCOUNTER SET OF SAME VALUES -C IWORK - DATA ARRAY -C NPTS - NUMBER OF POINTS IN DATA ARRAY -C ISTART - STARTING LOCATION IN DATA -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C INRNG - NUMBER OF POINTS SELECTED -C MAX - MAXIMUM VALUE OF POINTS -C MIN - MINIMUM VALUE OF POINTS -C MXVAL - MAXIMUM VALUE THAT CAN BE CONTAINED IN LWIDTH BITS -C LWIDTH - NUMBER OF BITS TO CONTAIN MAX DIFF -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - INTEGER IWORK(*),NPTS,ISTART,INRNG,MAX,MIN,LWIDTH,MXVAL - INTEGER IBITS(31) -C - DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, - * 4095,8191,16383,32767,65535,131071,262143, - * 524287,1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727,268435455, - * 536870911,1073741823,2147483647/ -C ---------------------------------------------------------------- -C - INRNG = 1 - JQ = ISTART + 19 - MAX = IWORK(ISTART) - MIN = IWORK(ISTART) - DO 1000 I = ISTART+1, JQ - CALL FI7502 (IWORK,I,NPTS,ISAME) - IF (ISAME.GE.15) THEN - GO TO 5000 - END IF - INRNG = INRNG + 1 - IF (IWORK(I).GT.MAX) THEN - MAX = IWORK(I) - ELSE IF (IWORK(I).LT.MIN) THEN - MIN = IWORK(I) - END IF - 1000 CONTINUE - 5000 CONTINUE - KRNG = MAX - MIN -C - DO 9000 LWIDTH = 1, 31 - IF (KRNG.LE.IBITS(LWIDTH)) THEN -C PRINT *,'RETURNED',INRNG,' VALUES' - RETURN - END IF - 9000 CONTINUE - RETURN - END - SUBROUTINE FI7517 (IRET,IWORK,NPTS,ISTRTB,INRNGA, - * MAXB,MINB,MXVALB,LWIDEB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7517 SCAN BACKWARD -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-01-21 -C -C ABSTRACT: SCAN BACKWARDS UNTIL A VALUE EXCEEDS RANGE OF GROUP B -C THIS MAY SHORTEN GROUP A -C -C PROGRAM HISTORY LOG: -C 94-01-21 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-06-17 IREDELL REMOVED ALTERNATE RETURN -C -C USAGE: CALL FI7517 (IRET,IWORK,NPTS,ISTRTB,INRNGA, -C * MAXB,MINB,MXVALB,LWIDEB) -C INPUT ARGUMENT LIST: -C IWORK - -C ISTRTB - -C NPTS - -C INRNGA - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IRET - -C JLAST - -C MAXB - -C MINB - -C LWIDTH - NUMBER OF BITS TO CONTAIN MAX DIFF -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - INTEGER IWORK(*),NPTS,ISTRTB,INRNGA - INTEGER MAXB,MINB,LWIDEB,MXVALB - INTEGER IBITS(31) -C - DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, - * 4095,8191,16383,32767,65535,131071,262143, - * 524287,1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727,268435455, - * 536870911,1073741823,2147483647/ -C ---------------------------------------------------------------- - IRET=0 -C PRINT *,' FI7517' - NPOS = ISTRTB - 1 - ITST = 0 - KSET = INRNGA -C - 1000 CONTINUE -C PRINT *,'TRY NPOS',NPOS,IWORK(NPOS),MAXB,MINB - ITST = ITST + 1 - IF (ITST.LE.KSET) THEN - IF (IWORK(NPOS).GT.MAXB) THEN - IF ((IWORK(NPOS)-MINB).GT.MXVALB) THEN -C PRINT *,'WENT OUT OF RANGE AT',NPOS - IRET=1 - RETURN - ELSE - MAXB = IWORK(NPOS) - END IF - ELSE IF (IWORK(NPOS).LT.MINB) THEN - IF ((MAXB-IWORK(NPOS)).GT.MXVALB) THEN -C PRINT *,'WENT OUT OF RANGE AT',NPOS - IRET=1 - RETURN - ELSE - MINB = IWORK(NPOS) - END IF - END IF - INRNGA = INRNGA - 1 - NPOS = NPOS - 1 - GO TO 1000 - END IF -C ---------------------------------------------------------------- -C - 9000 CONTINUE - RETURN - END - SUBROUTINE FI7518 (IRET,IWORK,NPTS,ISTRTA,INRNGA,INRNGB, - * MAXA,MINA,LWIDEA,MXVALA) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI7518 SCAN FORWARD -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-01-21 -C -C ABSTRACT: SCAN FORWARD FROM START OF BLOCK B TOWARDS END OF BLOCK B -C IF NEXT POINT UNDER TEST FORCES A LARGER MAXVALA THEN -C TERMINATE INDICATING LAST POINT TESTED FOR INCLUSION -C INTO BLOCK A. -C -C PROGRAM HISTORY LOG: -C 94-01-21 CAVANAUGH -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-06-17 IREDELL REMOVED ALTERNATE RETURN -C -C USAGE: CALL FI7518 (IRET,IWORK,NPTS,ISTRTA,INRNGA,INRNGB, -C * MAXA,MINA,LWIDEA,MXVALA) -C INPUT ARGUMENT LIST: -C IFLD - -C JSTART - -C NPTS - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IRET - -C JLAST - -C MAX - -C MIN - -C LWIDTH - NUMBER OF BITS TO CONTAIN MAX DIFF -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 -C -C$$$ - INTEGER IWORK(*),NPTS,ISTRTA,INRNGA - INTEGER MAXA,MINA,LWIDEA,MXVALA - INTEGER IBITS(31) -C - DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, - * 4095,8191,16383,32767,65535,131071,262143, - * 524287,1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727,268435455, - * 536870911,1073741823,2147483647/ -C ---------------------------------------------------------------- - IRET=0 -C PRINT *,' FI7518' - NPOS = ISTRTA + INRNGA - ITST = 0 -C - 1000 CONTINUE - ITST = ITST + 1 - IF (ITST.LE.INRNGB) THEN -C PRINT *,'TRY NPOS',NPOS,IWORK(NPOS),MAXA,MINA - IF (IWORK(NPOS).GT.MAXA) THEN - IF ((IWORK(NPOS)-MINA).GT.MXVALA) THEN -C PRINT *,'FI7518A -',ITST,' RANGE EXCEEDS MAX' - IRET=1 - RETURN - ELSE - MAXA = IWORK(NPOS) - END IF - ELSE IF (IWORK(NPOS).LT.MINA) THEN - IF ((MAXA-IWORK(NPOS)).GT.MXVALA) THEN -C PRINT *,'FI7518B -',ITST,' RANGE EXCEEDS MAX' - IRET=1 - RETURN - ELSE - MINA = IWORK(NPOS) - END IF - END IF - INRNGA = INRNGA + 1 -C PRINT *,' ',ITST,INRNGA - NPOS = NPOS +1 - GO TO 1000 - END IF -C ---------------------------------------------------------------- - 9000 CONTINUE - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi76.f b/external/w3nco/v2.0.6/src/w3fi76.f deleted file mode 100644 index 2a1553f5..00000000 --- a/external/w3nco/v2.0.6/src/w3fi76.f +++ /dev/null @@ -1,131 +0,0 @@ - SUBROUTINE W3FI76(PVAL,KEXP,KMANT,KBITS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI76 CONVERT TO IBM370 FLOATING POINT -C PRGMMR: REJONES ORG: NMC421 DATE:92-11-16 -C -C ABSTRACT: CONVERTS FLOATING POINT NUMBER FROM MACHINE -C REPRESENTATION TO GRIB REPRESENTATION (IBM370 32 BIT F.P.). -C -C PROGRAM HISTORY LOG: -C 85-09-15 JOHN HENNESSY ECMWF -C 92-09-23 JONES R. E. CHANGE NAME, ADD DOC BLOCK -C 93-10-27 JONES,R. E. CHANGE TO AGREE WITH HENNESSY CHANGES -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C -C USAGE: CALL W3FI76 (FVAL, KEXP, KMANT, NBITS) -C INPUT ARGUMENT LIST: -C PVAL - FLOATING POINT NUMBER TO BE CONVERTED -C KBITS - NUMBER OF BITS IN COMPUTER WORD (32 OR 64) -C -C OUTPUT ARGUMENT LIST: -C KEXP - 8 BIT SIGNED EXPONENT -C KMANT - 24 BIT MANTISSA (FRACTION) -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM370 VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS 9000, CRAY Y-MP8/864< CRAY Y-MP EL2/256 -C -C$$$ -C -C******************************************************************** -C* -C* NAME : CONFP3 -C* -C* FUNCTION : CONVERT FLOATING POINT NUMBER FROM MACHINE -C* REPRESENTATION TO GRIB REPRESENTATION. -C* -C* INPUT : PVAL - FLOATING POINT NUMBER TO BE CONVERTED. -C* KBITS : KBITS - NUMBER OF BITS IN COMPUTER WORD -C* -C* OUTPUT : KEXP - 8 BIT SIGNED EXPONENT -C* KMANT - 24 BIT MANTISSA -C* PVAL - UNCHANGED. -C* -C* JOHN HENNESSY , ECMWF 18.06.91 -C* -C******************************************************************** -C -C -C IMPLICIT NONE -C - INTEGER IEXP - INTEGER ISIGN -C - INTEGER KBITS - INTEGER KEXP - INTEGER KMANT -C - REAL PVAL - REAL ZEPS - REAL ZREF -C -C TEST FOR FLOATING POINT ZERO -C - IF (PVAL.EQ.0.0) THEN - KEXP = 0 - KMANT = 0 - GO TO 900 - ENDIF -C -C SET ZEPS TO 1.0E-12 FOR 64 BIT COMPUTERS (CRAY) -C SET ZEPS TO 1.0E-8 FOR 32 BIT COMPUTERS -C - IF (KBITS.EQ.32) THEN - ZEPS = 1.0E-8 - ELSE - ZEPS = 1.0E-12 - ENDIF - ZREF = PVAL -C -C SIGN OF VALUE -C - ISIGN = 0 - IF (ZREF.LT.0.0) THEN - ISIGN = 128 - ZREF = - ZREF - ENDIF -C -C EXPONENT -C - IEXP = INT(ALOG(ZREF)*(1.0/ALOG(16.0))+64.0+1.0+ZEPS) -C - IF (IEXP.LT.0 ) IEXP = 0 - IF (IEXP.GT.127) IEXP = 127 -C -C MANTISSA -C -C CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER -C (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER). -C - KMANT = NINT (ZREF/16.0**(IEXP-70)) -C -C CHECK THAT MANTISSA VALUE DOES NOT EXCEED 24 BITS -C 16777215 = 2**24 - 1 -C - IF (KMANT.GT.16777215) THEN - IEXP = IEXP + 1 -C -C CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER -C (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER). -C - KMANT = NINT (ZREF/16.0**(IEXP-70)) -C -C CHECK MANTISSA VALUE DOES NOT EXCEED 24 BITS AGAIN -C - IF (KMANT.GT.16777215) THEN - PRINT *,'BAD MANTISSA VALUE FOR PVAL = ',PVAL - ENDIF - ENDIF -C -C ADD SIGN BIT TO EXPONENT. -C - KEXP = IEXP + ISIGN -C - 900 CONTINUE -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi82.f b/external/w3nco/v2.0.6/src/w3fi82.f deleted file mode 100644 index 56a5ccc3..00000000 --- a/external/w3nco/v2.0.6/src/w3fi82.f +++ /dev/null @@ -1,97 +0,0 @@ - SUBROUTINE W3FI82 (IFLD,FVAL1,FDIFF1,NPTS,PDS,IGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI82 CONVERT TO SECOND DIFF ARRAY -C PRGMMR: CAVANAUGH ORG: NMC421 DATE:93-08-18 -C -C ABSTRACT: ACCEPT AN INPUT ARRAY, CONVERT TO ARRAY OF SECOND -C DIFFERENCES. RETURN THE ORIGINAL FIRST VALUE AND THE FIRST -C FIRST-DIFFERENCE AS SEPARATE VALUES. ALIGN DATA IN -C BOUSTREPHEDONIC STYLE, (ALTERNATE ROW REVERSAL). -C -C PROGRAM HISTORY LOG: -C 93-07-14 CAVANAUGH -C 94-01-27 CAVANAUGH ADDED REVERSAL OF EVEN NUMBERED ROWS -C (BOUSTROPHEDONIC PROCESSING) -C 94-03-02 CAVANAUGH CORRECTED IMPROPER ORDERING OF EVEN -C NUMBERED ROWS -C 99-12-06 EBISUZAKI LINUX PORT -C -C USAGE: CALL W3FI82 (IFLD,FVAL1,FDIFF1,NPTS,PDS,IGDS) -C INPUT ARGUMENT LIST: -C IFLD - INTEGER INPUT ARRAY -C NPTS - NUMBER OF POINTS IN ARRAY -C IGDS(5) - NUMBER OF ROWS IN ARRAY -C IGDS(4) - NUMBER OF COLUMNS IN ARRAY -C PDS(8) - FLAG INDICATING PRESENCE OF GDS SECTION -C -C OUTPUT ARGUMENT LIST: -C IFLD - SECOND DIFFERENCED FIELD -C FVAL1 - FLOATING POINT ORIGINAL FIRST VALUE -C FDIFF1 - " " FIRST FIRST-DIFFERENCE -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: IBM370 VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - REAL FVAL1,FDIFF1 -C - INTEGER IFLD(*),NPTS,NBOUST(300),IGDS(*) -C - CHARACTER*1 PDS(*) -C -C --------------------------------------------- -C TEST FOR PRESENCE OF GDS -C -c looks like an error CALL GBYTE(PDS,IQQ,56,8) - call gbytec(PDS,IQQ,56,1) - IF (IQQ.NE.0) THEN - NROW = IGDS(5) - NCOL = IGDS(4) -C -C LAY OUT DATA BOUSTROPHEDONIC STYLE -C -C PRINT*, ' DATA SET UP BOUSTROPHEDON' -C - DO 210 I = 2, NROW, 2 -C -C REVERSE THE EVEN NUMBERED ROWS -C - DO 200 J = 1, NCOL - NPOS = I * NCOL - J + 1 - NBOUST(J) = IFLD(NPOS) - 200 CONTINUE - DO 201 J = 1, NCOL - NPOS = NCOL * (I-1) + J - IFLD(NPOS) = NBOUST(J) - 201 CONTINUE - 210 CONTINUE -C -C - END IF -C ================================================================= - DO 4000 I = NPTS, 2, -1 - IFLD(I) = IFLD(I) - IFLD(I-1) - 4000 CONTINUE - DO 5000 I = NPTS, 3, -1 - IFLD(I) = IFLD(I) - IFLD(I-1) - 5000 CONTINUE -C -C SPECIAL FOR GRIB -C FLOAT OUTPUT OF FIRST POINTS TO ANTICIPATE -C GRIB FLOATING POINT OUTPUT -C - FVAL1 = IFLD(1) - FDIFF1 = IFLD(2) -C -C SET FIRST TWO POINTS TO SECOND DIFF VALUE FOR BETTER PACKING -C - IFLD(1) = IFLD(3) - IFLD(2) = IFLD(3) -C ----------------------------------------------------------- - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi83.f b/external/w3nco/v2.0.6/src/w3fi83.f deleted file mode 100644 index 510c61e4..00000000 --- a/external/w3nco/v2.0.6/src/w3fi83.f +++ /dev/null @@ -1,108 +0,0 @@ - SUBROUTINE W3FI83 (DATA,NPTS,FVAL1,FDIFF1,ISCAL2, - * ISC10,KPDS,KGDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI83 RESTORE DELTA PACKED DATA TO ORIGINAL -C PRGMMR: CAVANAUGH ORG: NMC421 DATE:93-08-18 -C -C ABSTRACT: RESTORE DELTA PACKED DATA TO ORIGINAL VALUES -C RESTORE FROM BOUSTREPHEDONIC ALIGNMENT -C -C PROGRAM HISTORY LOG: -C 93-07-14 CAVANAUGH -C 93-07-22 STACKPOLE ADDITIONS TO FIX SCALING -C 94-01-27 CAVANAUGH ADDED REVERSAL OF EVEN NUMBERED ROWS -C (BOUSTROPHEDONIC PROCESSING) TO RESTORE -C DATA TO ORIGINAL SEQUENCE. -C 94-03-02 CAVANAUGH CORRECTED REVERSAL OF EVEN NUMBERED ROWS -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL W3FI83(DATA,NPTS,FVAL1,FDIFF1,ISCAL2, -C * ISC10,KPDS,KGDS) -C INPUT ARGUMENT LIST: -C DATA - SECOND ORDER DIFFERENCES -C NPTS - NUMBER OF POINTS IN ARRAY -C FVAL1 - ORIGINAL FIRST ENTRY IN ARRAY -C FDIFF1 - ORIGINAL FIRST FIRST-DIFFERENCE -C ISCAL2 - POWER-OF-TWO EXPONENT FOR UNSCALING -C ISC10 - POWER-OF-TEN EXPONENT FOR UNSCALING -C KPDS - ARRAY OF INFORMATION FOR PDS -C KGDS - ARRAY OF INFORMATION FOR GDS -C -C OUTPUT ARGUMENT LIST: -C DATA - EXPANDED ORIGINAL DATA VALUES -C -C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN -C MACHINE: HDS, CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 -C -C$$$ -C - REAL FVAL1,FDIFF1 - REAL DATA(*),BOUST(200) - INTEGER NPTS,NROW,NCOL,KPDS(*),KGDS(*),ISC10 -C --------------------------------------- -C -C REMOVE DECIMAL UN-SCALING INTRODUCED DURING UNPACKING -C - DSCAL = 10.0 ** ISC10 - IF (DSCAL.EQ.0.0) THEN - DO 50 I=1,NPTS - DATA(I) = 1.0 - 50 CONTINUE - ELSE IF (DSCAL.EQ.1.0) THEN - ELSE - DO 51 I=1,NPTS - DATA(I) = DATA(I) * DSCAL - 51 CONTINUE - END IF -C - DATA(1) = FVAL1 - DATA(2) = FDIFF1 - DO 200 J = 3,2,-1 - DO 100 K = J, NPTS - DATA(K) = DATA(K) + DATA(K-1) - 100 CONTINUE - 200 CONTINUE -C -C NOW REMOVE THE BINARY SCALING FROM THE RECONSTRUCTED FIELD -C AND THE DECIMAL SCALING TOO -C - IF (DSCAL.EQ.0) THEN - SCALE = 0.0 - ELSE - SCALE =(2.0**ISCAL2)/DSCAL - END IF - DO 300 I=1,NPTS - DATA(I) = DATA(I) * SCALE - 300 CONTINUE -C ========================================================== - IF (IAND(KPDS(4),128).NE.0) THEN - NROW = KGDS(3) - NCOL = KGDS(2) -C -C DATA LAID OUT BOUSTROPHEDONIC STYLE -C -C -C PRINT*, ' REVERSE BOUSTROPHEDON' - DO 210 I = 2, NROW, 2 -C -C REVERSE THE EVEN NUMBERED ROWS -C - DO 201 J = 1, NCOL - NPOS = I * NCOL - J + 1 - BOUST(J) = DATA(NPOS) - 201 CONTINUE - DO 202 J = 1, NCOL - NPOS = NCOL * (I-1) + J - DATA(NPOS) = BOUST(J) - 202 CONTINUE - 210 CONTINUE -C -C - END IF -C ================================================================= - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi88.f b/external/w3nco/v2.0.6/src/w3fi88.f deleted file mode 100644 index 72cde8bc..00000000 --- a/external/w3nco/v2.0.6/src/w3fi88.f +++ /dev/null @@ -1,4750 +0,0 @@ - SUBROUTINE W3FI88(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX, - * LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD) -C -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI88 BUFR MESSAGE DECODER -C PRGMMR: KEYSER ORG: NP22 DATE: 2001-02-01 -C -C ABSTRACT: THIS SET OF ROUTINES WILL DECODE A BUFR MESSAGE AND -C PLACE INFORMATION EXTRACTED FROM THE BUFR MESSAGE INTO SELECTED -C ARRAYS FOR THE USER. THE ARRAY KDATA CAN NOW BE SIZED BY THE USER -C BY INDICATING THE MAXIMUM NUMBER OF SUBSETS AND THE MAXIMUM -C NUMBER OF DESCRIPTORS THAT ARE EXPECTED IN THE COURSE OF DECODING -C SELECTED INPUT DATA. THIS ALLOWS FOR REALISTIC SIZING OF KDATA -C AND THE MSTACK ARRAYS. THIS VERSION ALSO ALLOWS FOR THE INCLUSION -C OF THE UNIT NUMBERS FOR TABLES B AND D INTO THE -C ARGUMENT LIST. THIS ROUTINE DOES NOT INCLUDE IFOD PROCESSING. -C -C PROGRAM HISTORY LOG: -C 1988-08-31 CAVANAUGH -C 1990-12-07 CAVANAUGH NOW UTILIZING GBYTE ROUTINES TO GATHER -C AND SEPARATE BIT FIELDS. THIS SHOULD IMPROVE -C (DECREASE) THE TIME IT TAKES TO DECODE ANY -C BUFR MESSAGE. HAVE ENTERED CODING THAT WILL -C PERMIT PROCESSING BUFR EDITIONS 1 AND 2. -C IMPROVED AND CORRECTED THE CONVERSION INTO -C IFOD FORMAT OF DECODED BUFR MESSAGES. -C 1991-01-18 CAVANAUGH PROGRAM/ROUTINES MODIFIED TO PROPERLY HANDLE -C SERIAL PROFILER DATA. -C 1991-04-04 CAVANAUGH MODIFIED TO HANDLE TEXT SUPPLIED THRU -C DESCRIPTOR 2 05 YYY. -C 1991-04-17 CAVANAUGH ERRORS IN EXTRACTING AND SCALING DATA -C CORRECTED. IMPROVED HANDLING OF NESTED -C QUEUE DESCRIPTORS IS ADDED. -C 1991-05-10 CAVANAUGH - ARRAY 'DATA' HAS BEEN ENLARGED TO REAL*8 -C TO BETTER CONTAIN VERY LARGE NUMBERS MORE -C ACCURATELY. THE PREIOUS SIZE REAL*4 COULD NOT -C CONTAIN SUFFICIENT SIGNIFICANT DIGITS. -C - CODING HAS BEEN INTRODUCED TO PROCESS NEW -C TABLE C DESCRIPTOR 2 06 YYY WHICH PERMITS IN -C LINE PROCESSING OF A LOCAL DESCRIPTOR EVEN IF -C THE DESCRIPTOR IS NOT CONTAINED IN THE USERS -C TABLE B. -C - A SECOND ROUTINE TO PROCESS IFOD MESSAGES -C (IFOD0) HAS BEEN REMOVED IN FAVOR OF THE -C IMPROVED PROCESSING OF THE ONE -C REMAINING (IFOD1). -C - NEW CODING HAS BEEN INTRODUCED TO PERMIT -C PROCESSING OF BUFR MESSAGES BASED ON BUFR -C EDITION UP TO AND INCLUDING EDITION 2. -C PLEASE NOTE INCREASED SIZE REQUIREMENTS -C FOR ARRAYS IDENT(20) AND IPTR(40). -C 1991-07-26 CAVANAUGH - ADD ARRAY MTIME TO CALLING SEQUENCE TO -C PERMIT INCLUSION OF RECEIPT/TRANSFER TIMES -C TO IFOD MESSAGES. -C 1991-09-25 CAVANAUGH - ALL PROCESSING OF DECODED BUFR DATA INTO -C IFOD (A LOCAL USE REFORMAT OF BUFR DATA) -C HAS BEEN ISOLATED FROM THIS SET OF ROUTINES. -C FOR THOSE INTERESTED IN THE IFOD FORM, -C SEE W3FL05 IN THE W3LIB ROUTINES. -C PROCESSING OF BUFR MESSAGES CONTAINING -C DELAYED REPLICATION HAS BEEN ALTERED SO THAT -C SINGLE SUBSETS (REPORTS) AND AND A MATCHING -C DESCRIPTOR LIST FOR THAT PARTICULAR SUBSET -C WILL BE PASSED TO THE USER WILL BE PASSED TO -C THE USER ONE AT A TIME TO ASSURE THAT EACH -C SUBSET CAN BE FULLY DEFINED WITH A MINIMUM -C OF REPROCESSING. -C PROCESSING OF ASSOCIATED FIELDS HAS BEEN -C TESTED WITH MESSAGES CONTAINING NON-COMPRESSED -C DATA. -C IN ORDER TO FACILITATE USER PROCESSING -C A MATCHING LIST OF SCALE FACTORS ARE INCLUDED -C WITH THE EXPANDED DESCRIPTOR LIST (MSTACK). -C 1991-11-21 CAVANAUGH - PROCESSING OF DESCRIPTOR 2 03 YYY -C HAS CORRECTED TO AGREE WITH FM94 STANDARDS. -C 1991-12-19 CAVANAUGH - CALLS TO FI8803 AND FI8804 HAVE BEEN -C CORRECTED TO AGREE CALLED PROGRAM ARGUMENT -C LIST. SOME ADDITIONAL ENTRIES HAVE BEEN -C INCLUDED FOR COMMUNICATING WITH DATA ACCESS -C ROUTINES. ADDITIONAL ERROR EXIT PROVIDED FOR -C THE CASE WHERE TABLE B IS DAMAGED. -C 1992-01-24 CAVANAUGH - ROUTINES FI8801, FI8803 AND FI8804 -C HAVE BEEN MODIFIED TO HANDLE ASSOCIATED FIELDS -C ALL DESCRIPTORS ARE SET TO ECHO TO MSTACK(1,N) -C 1992-05-21 CAVANAUGH - FURTHER EXPANSION OF INFORMATION COLLECTED -C FROM WITHIN UPPER AIR SOUNDINGS HAS PRODUCED -C THE NECESSITY TO EXPAND SOME OF THE PROCESSING -C AND OUTPUT ARRAYS. (SEE REMARKS BELOW) -C 1992-06-29 CAVANAUGH - CORRECTED DESCRIPTOR DENOTING HEIGHT OF -C EACH WIND LEVEL FOR PROFILER CONVERSIONS. -C 1992-07-23 CAVANAUGH - EXPANSION OF TABLE B REQUIRES ADJUSTMENT -C OF ARRAYS TO CONTAIN TABLE B VALUES NEEDED TO -C ASSIST IN THE DECODING PROCESS. -C ARRAYS CONTAINING DATA FROM TABLE B -C KFXY1 - DESCRIPTOR -C ANAME1 - DESCRIPTOR NAME -C AUNIT1 - UNITS FOR DESCRIPTOR -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C 1992-09-09 CAVANAUGH - FIRST ENCOUNTER WITH OPERATOR DESCRIPTOR -C 2 05 YYY SHOWED ERROR IN DECODING. THAT ERROR -C IS CORRECTED WITH THIS IMPLEMENTATION. FURTHER -C TESTING OF UPPER AIR DATA HAS ENCOUNTERED -C THE CONDITION OF LARGE (MANY LEVEL) SOUNDINGS -C ARRAYS IN THE DECODER HAVE BEEN EXPANDED (AGAIN) -C TO ALLOW FOR THIS CONDITION. -C 1992-10-02 CAVANAUGH - MODIFIED ROUTINE TO REFORMAT PROFILER DATA -C (FI8809) TO SHOW DESCRIPTORS, SCALE VALUE AND -C DATA IN PROPER ORDER. CORRECTED AN ERROR THAT -C PREVENTED USER FROM ASSIGNING THE SECOND DIMENSION -C OF KDATA(500,*). -C 1992-10-20 CAVANAUGH - REMOVED ERROR THAT PREVENTED FULL -C IMPLEMENTATION OF PREVIOUS CORRECTIONS AND -C MADE CORRECTIONS TO TABLE B TO BRING IT UP TO -C DATE. CHANGES INCLUDE PROPER REFORMAT OF PROFILER -C DATA AND USER CAPABILITY FOR ASSIGNING SECOND -C DIMENSION OF KDATA ARRAY. -C 1992-12-09 CAVANAUGH - THANKS TO DENNIS KEYSER FOR THE SUGGESTIONS -C AND CODING, THIS IMPLEMENTATION WILL ALLOW THE -C INCLUSION OF UNIT NUMBERS FOR TABLES B & D, AND -C IN ADDITION ALLOWS FOR REALISTIC SIZING OF KDATA -C AND MSTACK ARRAYS BY THE USER. AS OF THIS -C IMPLEMENTATION, THE UPPER SIZE LIMIT FOR A BUFR -C MESSAGE ALLOWS FOR A MESSAGE SIZE GREATER THAN -C 15000 BYTES. -C 1993-01-26 CAVANAUGH - ROUTINE FI8810 HAS BEEN ADDED TO PERMIT -C REFORMATTING OF PROFILER DATA IN EDITION 2. -C 1993-05-13 CAVANAUGH - ROUTINE FI8811 HAS BEEN ADDED TO PERMIT -C PROCESSING OF RUN-LINE ENCODING. THIS PROVIDES FOR -C THE HANDLING OF DATA FOR GRAPHICS PRODUCTS. -C PLEASE NOTE THE ADDITION OF TWO ARGUMENTS IN THE -C CALLING SEQUENCE. -C 1993-12-01 CAVANAUGH - ROUTINE FI8803 TO CORRECT HANDLING OF -C ASSOCIATED FIELDS AND ARRAYS ASSOCIATED WITH -C TABLE B ENTRIES ENLARGED TO HANDLE LARGER TABLE B -C 1994-05-25 CAVANAUGH - ROUTINES HAVE BEEN MODIFIED TO CONSTRUCT A -C MODIFIED TABLE B I.E., IT IS TAILORED TO CONTAIN O -C THOSE DESCRIPTORS THAT WILL BE USED TO DECODE -C DATA IN CURRENT AND SUBSEQUENT BUFR MESSAGES. -C TABLE B AND TABLE D DESCRIPTORS WILL BE ISOLATED -C AND MERGED WITH THE MAIN TABLES FOR USE WITH -C FOLLOWING BUFR MESSAGES. -C THE DESCRIPTORS INDICATING THE REPLICATION OF -C DESCRIPTORS AND DATA ARE ACTIVATED WITH THIS -C IMPLEMENTATION. -C 1994-08-30 CAVANAUGH - ADDED STATEMENTS THAT WILL ALLOW USE OF -C THESE ROUTINES DIRECTLY ON THE CRAY WITH NO -C MODIFICATION. HANDLING OD TABLE D ENTRIES HAS BEEN -C MODIFIED TO PREVENT LOSS OF ANCILLARY ENTRIES. -C CODING HAS BEEN ADDED TO ALLOW PROCESSING ON -C EITHER AN 8 BYTE WORD OR 4 BYTE WORD MACHINE. -C -C FOR THOSE USERS OF THE BUFR DECODER THAT ARE -C PROCESSING SETS OF BUFR MESSAGES THAT INCLUDE -C TYPE 11 MESSAGES, CODING HAS BEEN ADDED TO ALLOW -C THE RECOVERY OF THE ADDED OR MODIFIED TABLE B -C ENTRIES BY WRITING THEM TO A DISK FILE AVAILABLE -C TO THE USER. THIS IS ACCOMPLISHED WITH NO CHANGE -C TO THE CALLING SEQUENCE. TABLE B ENTRIES WILL BE -C DESIGNATED AS FOLLOWS: -C -C IUNITB - IS THE UNIT NUMBER FOR THE MASTER -C TABLE B. -C IUNITB+1 - WILL BE THE UNIT NUMBER FOR THE -C TABLE B ENTRIES THAT ARE TO BE USED -C IN THE DECODING OF SUBSEQUENT MESSAGES. -C THIS DEVICE WILL BE FORMATTED THE SAME -C THE DISK FILE ON IUNITB. -C -C 1995-06-07 KEYSER- CORRECTED AN ERROR WHICH REQUIRED INPUT -C ARGUMENT "MAXD" TO BE NEARLY TWICE AS LARGE AS -C NEEDED FOR DECODING WIND PROFILER REPORTS (LIMIT -C UPPER BOUND FOR "IWORK" ARRAY WAS SET TO "MAXD", -C NOW IT IS SET TO 15000). ALSO, A CORRECTION WAS -C MADE IN THE WIND PROFILER PROCESSING TO PREVENT -C UNNECESSARY LOOPING WHEN ALL REQUESTED -C DESCRIPTORS ARE MISSING. ALSO CORRECTED AN -C ERROR WHICH RESULTED IN RETURNED SCALE IN -C "MSTACK(2, ..)" ALWAYS BEING SET TO ZERO FOR -C COMPRESSED DATA. -C 1996-02-15 CAVANAUGH- MODIFIED IDENTIFICATION OF ASCII/EBCDIC -C MACHINE. MODIFIED HANDLING OF TABLE B TO PERMIT -C FASTER PROCESSING OF MULTIPLE MESSAGES WITH -C CHANGING DATA TYPES AND/OR SUBTYPES. -C 1996-04-02 CAVANAUGH- DEACTIVATED EXTRANEOUS WRITE STATEMENT. -C ENLARGED ARRAYS FOR TABLE B ENTRIES TO CONTAIN -C UP TO 1300 ENTRIES IN PREPARATION FOR NEW -C ADDITIONS TO TABLE B. -C 2001-02-01 KEYSER- THE TABLE B FILE WILL NOW BE READ WHENEVER THE -C INPUT ARGUMENT "IUNITB" (TABLE B UNIT NUMBER) -C CHANGES FROM ITS VALUE IN THE PREVIOUS CALL TO -C THIS ROUTINE (NORMALLY IT IS ONLY READ THE -C FIRST TIME THIS ROUTINE IS CALLED) -C 2002-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C -C USAGE: CALL W3FI88(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX, -C LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD) -C -C INPUT ARGUMENT LIST: -C MSGA - ARRAY CONTAINING SUPPOSED BUFR MESSAGE -C SIZE IS DETERMINED BY USER, CAN BE GREATER -C THAN 15000 BYTES. -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C IUNITB - UNIT NUMBER OF DATA SET HOLDING TABLE B, THIS IS THE -C NUMBER OF A PAIR OF DATA SETS -C IUNITB+1 - UNIT NUMBER FOR A DATASET TO CONTAIN TABLE B ENTRIES -C FROM MASTER TABLE B AND TABLE B ENTRIES EXTRACTED -C FROM TYPE 11 BUFR MESSAGES THAT WERE USED TO DECODE -C CURRENT BUFR MESSAGES. -C IUNITD - UNIT NUMBER OF DATA SET HOLDING TABLE D -C -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM -C SOURCE BUFR MESSAGE. -C -C MSTACK(A,B)-LEVEL B - DESCRIPTOR NUMBER (LIMITED TO VALUE OF -C INPUT ARGUMENT MAXD) -C -C LEVEL A = 1 DESCRIPTOR -C = 2 10**N SCALING TO RETURN TO ORIGINAL VALUE -C IPTR - UTILITY ARRAY (SHOULD HAVE AT LAST 42 ENTRIES) -C IPTR( 1)- ERROR RETURN -C IPTR( 2)- BYTE COUNT SECTION 1 -C IPTR( 3)- POINTER TO START OF SECTION 1 -C IPTR( 4)- BYTE COUNT SECTION 2 -C IPTR( 5)- POINTER TO START OF SECTION 2 -C IPTR( 6)- BYTE COUNT SECTION 3 -C IPTR( 7)- POINTER TO START OF SECTION 3 -C IPTR( 8)- BYTE COUNT SECTION 4 -C IPTR( 9)- POINTER TO START OF SECTION 4 -C IPTR(10)- START OF REQUESTED SUBSET, RESERVED FOR DAR -C IPTR(11)- CURRENT DESCRIPTOR PTR IN IWORK -C IPTR(12)- LAST DESCRIPTOR POS IN IWORK -C IPTR(13)- LAST DESCRIPTOR POS IN ISTACK -C IPTR(14)- NUMBER OF MASTER TABLE B ENTRIES -C IPTR(15)- REQUESTED SUBSET POINTER, RESERVED FOR DAR -C IPTR(16)- INDICATOR FOR EXISTANCE OF SECTION 2 -C IPTR(17)- NUMBER OF REPORTS PROCESSED -C IPTR(18)- ASCII/TEXT EVENT -C IPTR(19)- POINTER TO START OF BUFR MESSAGE -C IPTR(20)- NUMBER OF ENTRIES FROM TABLE D -C IPTR(21)- NR TABLE B ENTRIES -C IPTR(22)- NR TABLE B ENTRIES FROM CURRENT MESSAGE -C IPTR(23)- CODE/FLAG TABLE SWITCH -C IPTR(24)- ADITIONAL WORDS ADDED BY TEXT INFO -C IPTR(25)- CURRENT BIT NUMBER -C IPTR(26)- DATA WIDTH CHANGE - ADD TO TABLE B WIDTH -C IPTR(27)- DATA SCALE CHANGE - MODIFIES TABLE B SCALE -C IPTR(28)- DATA REFERENCE VALUE CHANGE - ????????? -C IPTR(29)- ADD DATA ASSOCIATED FIELD -C IPTR(30)- SIGNIFY CHARACTERS -C IPTR(31)- NUMBER OF EXPANDED DESCRIPTORS IN MSTACK -C IPTR(32)- CURRENT DESCRIPTOR SEGMENT F -C IPTR(33)- CURRENT DESCRIPTOR SEGMENT X -C IPTR(34)- CURRENT DESCRIPTOR SEGMENT Y -C IPTR(35)- DATA/DESCRIPTOR REPLICATION IN PROGRESS -C 0 = NO -C 1 = YES -C IPTR(36)- NEXT DESCRIPTOR MAY BE UNDECIPHERABLE -C IPTR(37)- MACHINE TEXT TYPE FLAG -C 0 = EBCIDIC -C 1 = ASCII -C IPTR(38)- DATA/DESCRIPTOR REPLICATION FLAG -C 0 - DOES NOT EXIST IN CURRENT MESSAGE -C 1 - EXISTS IN CURRENT MESSAGE -C IPTR(39)- DELAYED REPLICATION FLAG -C 0 - NO DELAYED REPLICATION -C 1 - MESSAGE CONTAINS DELAYED REPLICATION -C IPTR(40)- NUMBER OF CHARACTERS IN TEXT FOR CURR DESCRIPTOR -C IPTR(41)- NUMBER OF ANCILLARY TABLE B ENTRIES -C IPTR(42)- NUMBER OF ANCILLARY TABLE D ENTRIES -C IPTR(43)- NUMBER OF ADDED TABLE B ENTRIES ENCOUNTERED WHILE -C PROCESSING A BUFR MESSAGE. THESE ENTRIES ONLY -C EXIST DURNG PROCESSING OF CURRENT BUFR MESSAGE -C IPTR(44)- BITS PER WORD -C IPTR(45)- BYTES PER WORD -C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM -C BUFR MESSAGE - -C IDENT(1) -EDITION NUMBER (BYTE 4, SECTION 1) -C IDENT(2) -ORIGINATING CENTER (BYTES 5-6, SECTION 1) -C IDENT(3) -UPDATE SEQUENCE (BYTE 7, SECTION 1) -C IDENT(4) -OPTIONAL SECTION (BYTE 8, SECTION 1) -C IDENT(5) -BUFR MESSAGE TYPE (BYTE 9, SECTION 1) -C 0 = SURFACE DATA (LAND) -C 1 = SURFACE DATA (SHIP) -C 2 = VERTICAL SOUNDINGS (OTHER THAN SATELLITE) -C 3 = VERTICAL SOUNDINGS (SATELLITE) -C 4 = SINGLE LVL UPPER-AIR DATA(OTHER THAN SATELLITE) -C 5 = SINGLE LEVEL UPPER-AIR DATA (SATELLITE) -C 6 = RADAR DATA -C 7 = SYNOPTIC FEATURES -C 8 = PHYSICAL/CHEMICAL CONSTITUENTS -C 9 = DISPERSAL AND TRANSPORT -C 10 = RADIOLOGICAL DATA -C 11 = BUFR TABLES (COMPLETE, REPLACEMENT OR UPDATE) -C 12 = SURFACE DATA (SATELLITE) -C 21 = RADIANCES (SATELLITE MEASURED) -C 31 = OCEANOGRAPHIC DATA -C IDENT(6) -BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) -C TYPE SBTYP -C 2 7 = PROFILER -C IDENT(7) - (BYTES 11-12, SECTION 1) -C IDENT(8) -YEAR OF CENTURY (BYTE 13, SECTION 1) -C IDENT(9) -MONTH OF YEAR (BYTE 14, SECTION 1) -C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) -C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) -C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) -C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) -C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) -C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) -C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) -C IDENT(17)-MASTER TABLE NUMBER(BYTE 4, SECTION 1, ED 2 OR GTR) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C INDEX - POINTER TO AVAILABLE SUBSET -C -C =========================================================== -C ARRAYS CONTAINING DATA FROM TABLE B -C NEW - BASE ARRAYS CONTAINING DATA FROM TABLE B -C KFXY1 - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES -C ANAME1 - DESCRIPTOR NAME -C AUNIT1 - UNITS FOR DESCRIPTOR -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C =========================================================== -C NEW - ANCILLARY ARRAYS CONTAINING DATA FROM TABLE B -C CONTAINING TABLE B ENTRIES EXTRACTED -C FROM TYPE 11 BUFR MESSAGES -C KFXY2 - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES -C ANAME2 - DESCRIPTOR NAME -C AUNIT2 - UNITS FOR DESCRIPTOR -C ISCAL2 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL2 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE2 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C =========================================================== -C NEW - ADDED ARRAYS CONTAINING DATA FROM TABLE B -C CONTAINING TABLE B ENTRIES EXTRACTED -C FROM NON-TYPE 11 BUFR MESSAGES -C THESE EXIST FOR THE LIFE OF CURRENT BUFR MESSAGE -C KFXY3 - DECIMAL DESCRIPTOR VALUE OF F X Y VALUES -C ANAME3 - DESCRIPTOR NAME -C AUNIT3 - UNITS FOR DESCRIPTOR -C ISCAL3 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL3 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE3 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C =========================================================== -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C UNIQUE - FI8801 FI8802 FI8803 FI8804 FI8805 FI8806 -C FI8807 FI8808 FI8809 FI8810 FI8811 FI8812 -C FI8813 FI8814 FI8815 FI8820 -C W3LIB - W3AI39 W3FC05 GBYTE GBYTES -C -C REMARKS: ERROR RETURNS: -C IPTR(1) = 1 'BUFR' NOT FOUND IN FIRST 125 CHARACTERS -C = 2 '7777' NOT FOUND IN LOCATION DETERMINED BY -C BY USING COUNTS FOUND IN EACH SECTION. ONE OR -C MORE SECTIONS HAVE AN ERRONEOUS BYTE COUNT OR -C CHARACTERS '7777' ARE NOT IN TEST MESSAGE. -C = 3 MESSAGE CONTAINS A DESCRIPTOR WITH F=0 THAT DOES -C NOT EXIST IN TABLE B. -C = 4 MESSAGE CONTAINS A DESCRIPTOR WITH F=3 THAT DOES -C NOT EXIST IN TABLE D. -C = 5 MESSAGE CONTAINS A DESCRIPTOR WITH F=2 WITH THE -C VALUE OF X OUTSIDE THE RANGE 1-6. -C = 6 DESCRIPTOR ELEMENT INDICATED TO HAVE A FLAG VALUE -C DOES NOT HAVE AN ENTRY IN THE FLAG TABLE. -C (TO BE ACTIVATED) -C = 7 DESCRIPTOR INDICATED TO HAVE A CODE VALUE DOES -C NOT HAVE AN ENTRY IN THE CODE TABLE. -C (TO BE ACTIVATED) -C = 8 ERROR READING TABLE D -C = 9 ERROR READING TABLE B -C = 10 ERROR READING CODE/FLAG TABLE -C = 11 DESCRIPTOR 2 04 004 NOT FOLLOWED BY 0 31 021 -C = 12 DATA DESCRIPTOR OPERATOR QUALIFIER DOES NOT FOLLOW -C DELAYED REPLICATION DESCRIPTOR. -C = 13 BIT WIDTH ON ASCII CHARACTERS NOT A MULTIPLE OF 8 -C = 14 SUBSETS = 0, NO CONTENT BULLETIN -C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS -C = 21 EXCEEDED COUNT FOR NON-DELAYED REPLICATION PASS -C = 22 EXCEEDED COMBINED BIT WIDTH, BIT WIDTH > 32 -C = 23 NO ELEMENT DESCRIPTORS FOLLOWING 2 03 YYY -C = 27 NON ZERO LOWEST ON TEXT DATA -C = 28 NBINC NOT NR OF CHARACTERS -C = 29 TABLE B APPEARS TO BE DAMAGED -C = 30 TABLE D ENTRY WITH MORE THAN 18 IN SEQUENCE -C BEING ENTERED FROM TYPE 11 MESSAGE -C = 99 NO MORE SUBSETS (REPORTS) AVAILABLE IN CURRENT -C BUFR MESAGE -C -C = 400 NUMBER OF SUBSETS EXCEEDS THE VALUE OF INPUT -C ARGUMENT MAXR; MUST INCREASE MAXR TO VALUE OF -C IDENT(14) IN CALLING PROGRAM -C -C = 401 NUMBER OF PARAMETERS (AND ASSOCIATED FIELDS) -C EXCEEDS LIMITS OF THIS PROGRAM. -C = 500 VALUE FOR NBINC HAS BEEN FOUND THAT EXCEEDS -C STANDARD WIDTH PLUS ANY BIT WIDTH CHANGE. -C CHECK ALL BIT WIDTHS UP TO POINT OF ERROR. -C = 501 CORRECTED WIDTH FOR DESCRIPTOR IS 0 OR LESS -C = 888 NON-NUMERIC CHARACTER IN CONVERSION REQUEST -C = 890 CLASS 0 ELEMENT DESCRIPTOR W/WIDTH OF 0 -C -C ON THE INITIAL CALL TO W3FI88 WITH A BUFR MESSAGE THE ARGUMENT -C INDEX MUST BE SET TO ZERO (INDEX = 0). ON THE RETURN FROM W3FI88 -C 'INDEX' WILL BE SET TO THE NEXT AVAILABLE SUBSET/REPORT. WHEN -C THERE ARE NO MORE SUBSETS AVAILABLE A 99 ERR RETURN WILL OCCUR. -C -C IF THE ORIGINAL BUFR MESSAGE DOES NOT CONTAIN DELAYED REPLICATION -C THE BUFR MESSAGE WILL BE COMPLETELY DECODED AND 'INDEX' WILL POINT -C TO THE FIRST DECODED SUBSET. THE USERS WILL THEN HAVE THE OPTION -C OF INDEXING THROUGH THE SUBSETS ON THEIR OWN OR BY RECALLING THIS -C ROUTINE (WITHOUT RESETTING 'INDEX') TO HAVE THE ROUTINE DO THE -C INDEXING. -C -C IF THE ORIGINAL BUFR MESSAGE DOES CONTAIN DELAYED REPLICATION -C ONE SUBSET/REPORT WILL BE DECODED AT A TIME AND PASSED BACK TO -C THE USER. THIS IS NOT AN OPTION. -C -C ============================================= -C TO USE THIS ROUTINE -C ============================================= -C THE ARRAYS TO CONTAIN THE OUTPUT INFORMATION ARE DEFINED -C AS FOLLOWS: -C -C KDATA(A,B) IS THE A DATA ENTRY (INTEGER VALUE) -C WHERE A IS THE MAXIMUM NUMBER OF REPORTS/SUBSETS -C THAT MAY BE CONTAINED IN THE BUFR MESSAGE (THIS -C IS NOW SET TO "MAXR" WHICH IS PASSED AS AN INPUT -C ARGUMENT TO W3FI88), AND WHERE B IS THE MAXIMUM -C NUMBER OF DESCRIPTOR COMBINATIONS THAT MAY -C BE PROCESSED (THIS IS NOW SET TO "MAXD" WHICH -C IS ALSO PASSED AS AN INPUT ARGUMENT TO W3FI88; -C UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE -C A VALUE FOR MAXD OF 1700, BUT FOR MOST OTHER -C DATA A VALUE FOR MAXD OF 500 WILL SUFFICE) -C MSTACK(1,B) CONTAINS THE DESCRIPTOR THAT MATCHES THE -C DATA ENTRY (MAX. VALUE FOR B IS NOW "MAXD" -C WHICH IS PASSED AS AN INPUT ARGUMENT TO W3FI88) -C MSTACK(2,B) IS THE SCALE (POWER OF 10) TO BE APPLIED TO -C THE DATA (MAX. VALUE FOR B IS NOW "MAXD" -C WHICH IS PASSED AS AN INPUT ARGUMENT TO W3FI88) -C -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C -C -C THE MEMORY REQUIREMENTS FOR LSTACK AND LDATA ARE USED WITH -C RUN-LINE CODING PROVIDING FOR THE HANDLING OF DATA FOR -C GRAPHICS. I.E., RADAR DISPLAYS. IF THE DECODING PROCESS WILL -C NOT BE USED TO PROCESS THOSE TYPE OF MESSAGES, THEN THE -C VARIABLE SIZES FOR THE ARRAYS CAN BE MINIMIZED. -C IF THE DECODING PROCESS WILL BE USED TO DECODE THOSE MESSAGE -C TYPES, THEN MAXD MUST REFLECT THE MAXIMUM NUMBER OF -C DESCRIPTORS (FULLY EXPANDED LIST) TO BE EXPECTED IN THE -C MESSAGE. -C - INTEGER LDATA(MAXD) - INTEGER LSTACK(2,MAXD) -C - INTEGER MSGA(*) - INTEGER IPTR(*),KPTRB(16384),KPTRD(16384) - INTEGER KDATA(MAXR,MAXD) - INTEGER MSTACK(2,MAXD) -C - INTEGER IVALS(1000) - INTEGER KNR(MAXR) - INTEGER IDENT(*) - INTEGER ISTACK(*),IOLD11 -cdak KEYSER fix 02/02/2001 VVVVV - INTEGER IOLDTB -cdak KEYSER fix 02/02/2001 AAAAA - INTEGER IWORK(15000) - INTEGER INDEX -C - INTEGER IIII - CHARACTER*1 BLANK - CHARACTER*4 DIRID(2) -C - LOGICAL SEC2 -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C - INTEGER KFXY1(1300),ISCAL1(1300) - INTEGER IRFVL1(3,1300),IWIDE1(1300) - CHARACTER*40 ANAME1(1300) - CHARACTER*24 AUNIT1(1300) -C .................................................. -C -C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE -C - INTEGER KFXY2(200),ISCAL2(200),IRFVL2(200),IWIDE2(200) - CHARACTER*64 ANAME2(200) - CHARACTER*24 AUNIT2(200) -C .................................................. -C -C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE -C -C INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200) -C CHARACTER*64 ANAME3(200) -C CHARACTER*24 AUNIT3(200) -C .................................................. -C -C NEW BASE TABLE D -C - INTEGER ITBLD(20,400) -C .................................................. -C -C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE -C - INTEGER ITBLD2(20,50) -C .................................................. -C - SAVE - -cdak KEYSER fix 02/02/2001 VVVVV - DATA IOLD11/0/ - DATA IOLDTB/-99/ -cdak KEYSER fix 02/02/2001 AAAAA -C - CALL W3FI01(LW) - IPTR(45) = LW - IPTR(44) = LW * 8 -C - BLANK = ' ' - IF (MOVA2I(BLANK).EQ.32) THEN - IPTR(37) = 1 -C PRINT *,'ASCII MACHINE' - ELSE - IPTR(37) = 0 -C PRINT *,'EBCDIC MACHINE' - END IF -C -C PRINT *,' W3FI88 DECODER' -C INITIALIZE ERROR RETURN - IPTR(1) = 0 - IF (INDEX.GT.0) THEN -C HAVE RE-ENTRY - INDEX = INDEX + 1 -C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX - IF (INDEX.GT.IDENT(14)) THEN -C ALL SUBSETS PROCESSED - IPTR(1) = 99 - IPTR(38) = 0 - IPTR(39) = 0 - ELSE IF (INDEX.LE.IDENT(14)) THEN - IF (IPTR(39).NE.0) THEN - DO 3000 J =1, IPTR(13) - IWORK(J) = ISTACK(J) - 3000 CONTINUE - IPTR(12) = IPTR(13) - CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS, - * MSTACK,KNR,INDEX,MAXR,MAXD, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, - * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3, - * IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD) -C - END IF - END IF - RETURN - ELSE - INDEX = 1 -C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE' - END IF - IPTR(39) = 0 -C FIND 'BUFR' IN FIRST 125 CHARACTERS - DO 1000 KNOFST = 0, 999, 8 - INOFST = KNOFST - CALL GBYTE (MSGA,IVALS,INOFST,8) - IF (IVALS(1).EQ.66) THEN - IPTR(19) = INOFST - INOFST = INOFST + 8 - CALL GBYTE (MSGA,IVALS,INOFST,24) - IF (IVALS(1).EQ.5588562) THEN -C PRINT *,'FOUND BUFR AT',IPTR(19) - INOFST = INOFST + 24 - GO TO 1500 - END IF - END IF - 1000 CONTINUE - PRINT *,'BUFR - START OF BUFR MESSAGE NOT FOUND' - IPTR(1) = 1 - RETURN - 1500 CONTINUE - IDENT(1) = 0 -C TEST FOR EDITION NUMBER -C ====================== - CALL GBYTE (MSGA,IDENT(1),INOFST+24,8) -C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE' -C - IF (IDENT(1).GE.2) THEN -C GET TOTAL COUNT - CALL GBYTE (MSGA,IVALS,INOFST,24) - ITOTAL = IVALS(1) - KENDER = ITOTAL * 8 - 32 + IPTR(19) - CALL GBYTE (MSGA,ILAST,KENDER,32) -C IF (ILAST.EQ.926365495) THEN -C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1) -C END IF - INOFST = INOFST + 32 -C GET SECTION 1 COUNT - IPTR(3) = INOFST - CALL GBYTE (MSGA,IVALS,INOFST,24) -C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1) - INOFST = INOFST + 24 - IPTR( 2) = IVALS(1) -C GET MASTER TABLE - CALL GBYTE (MSGA,IVALS,INOFST,8) - INOFST = INOFST + 8 - IDENT(17) = IVALS(1) -C PRINT *,'BUFR MASTER TABLE NR',IDENT(17) - ELSE - IPTR(3) = INOFST -C GET SECTION 1 COUNT - CALL GBYTE (MSGA,IVALS,INOFST,24) -C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1) - INOFST = INOFST + 32 - IPTR( 2) = IVALS(1) - END IF -C ====================== -C ORIGINATING CENTER - CALL GBYTE (MSGA,IVALS,INOFST,16) - INOFST = INOFST + 16 - IDENT(2) = IVALS(1) -C UPDATE SEQUENCE - CALL GBYTE (MSGA,IVALS,INOFST,8) - INOFST = INOFST + 8 - IDENT(3) = IVALS(1) -C OPTIONAL SECTION FLAG - CALL GBYTE (MSGA,IVALS,INOFST,1) - IDENT(4) = IVALS(1) - IF (IDENT(4).GT.0) THEN - SEC2 = .TRUE. - ELSE -C PRINT *,' NO OPTIONAL SECTION 2' - SEC2 = .FALSE. - END IF - INOFST = INOFST + 8 -C MESSAGE TYPE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(5) = IVALS(1) - INOFST = INOFST + 8 -C MESSAGE SUBTYPE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(6) = IVALS(1) - INOFST = INOFST + 8 -cdak KEYSER fix 02/02/2001 VVVVV - IF (IUNITB.NE.IOLDTB) THEN -C IF HAVE A CHANGE IN TABLE B UNIT NUMBER , READ TABLE B - IF(IOLDTB.NE.-99) PRINT *, 'W3FI88 - NEW TABLE B UNIT NUMBER' - IOLDTB = IUNITB - IPTR(14) = 0 - IPTR(21) = 0 - END IF -cdak KEYSER fix 02/02/2001 AAAAA -C IF HAVE CHANGE IN DATA TYPE , RESET TABLE B - IF (IOLD11.EQ.11) THEN - IOLD11 = IDENT(5) - IOLDSB = IDENT(6) -C JUST CONTINUE PROCESSING - ELSE IF (IOLD11.NE.11) THEN - IF (IDENT(5).EQ.11) THEN - IOLD11 = IDENT(5) - IPTR(21) = 0 - ELSE IF (IDENT(5).NE.IOLD11) THEN - IOLD11 = IDENT(5) - IPTR(21) = 0 - ELSE IF (IDENT(5).EQ.IOLD11) THEN -C IF HAVE A CHANGE IN SUBTYPE, RESET TABLE B - IF (IOLDSB.NE.IDENT(6)) THEN - IOLDSB = IDENT(6) - IPTR(21) = 0 -C ELSE IF - END IF - END IF - END IF -C IF BUFR EDITION 0 OR 1 THEN -C NEXT 2 BYTES ARE BUFR TABLE VERSION -C ELSE -C BYTE 11 IS VER NR OF MASTER TABLE -C BYTE 12 IS VER NR OF LOCAL TABLE - IF (IDENT(1).LT.2) THEN - CALL GBYTE (MSGA,IVALS,INOFST,16) - IDENT(7) = IVALS(1) - INOFST = INOFST + 16 - ELSE -C BYTE 11 IS VER NR OF MASTER TABLE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(18) = IVALS(1) - INOFST = INOFST + 8 -C BYTE 12 IS VER NR OF LOCAL TABLE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(19) = IVALS(1) - INOFST = INOFST + 8 - - END IF -C YEAR OF CENTURY - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(8) = IVALS(1) - INOFST = INOFST + 8 -C MONTH - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(9) = IVALS(1) - INOFST = INOFST + 8 -C DAY -C PRINT *,'DAY AT ',INOFST - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(10) = IVALS(1) - INOFST = INOFST + 8 -C HOUR - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(11) = IVALS(1) - INOFST = INOFST + 8 -C MINUTE - CALL GBYTE (MSGA,IVALS,INOFST,8) - IDENT(12) = IVALS(1) -C RESET POINTER (INOFST) TO START OF -C NEXT SECTION -C (SECTION 2 OR SECTION 3) - INOFST = IPTR(3) + IPTR(2) * 8 - IPTR(4) = 0 - IPTR(5) = INOFST - IF (SEC2) THEN -C SECTION 2 COUNT - CALL GBYTE (MSGA,IPTR(4),INOFST,24) - INOFST = INOFST + 32 -C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4) - KENTRY = (IPTR(4) - 4) / 14 -C PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS' - IF (IDENT(2).EQ.7) THEN - DO 2000 I = 1, KENTRY - CALL GBYTE (MSGA,KDSPL ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,LAT ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,LON ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,KDAHR ,INOFST,16) - INOFST = INOFST + 16 - CALL GBYTE (MSGA,DIRID(1),INOFST,32) - INOFST = INOFST + 32 - CALL GBYTE (MSGA,DIRID(2),INOFST,16) - INOFST = INOFST + 16 -C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2) - 2000 CONTINUE - END IF -C RESET POINTER (INOFST) TO START OF -C SECTION 3 - INOFST = IPTR(5) + IPTR(4) * 8 - END IF -C BIT OFFSET TO START OF SECTION 3 - IPTR( 7) = INOFST -C SECTION 3 COUNT - CALL GBYTE (MSGA,IPTR(6),INOFST,24) -C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6) - INOFST = INOFST + 24 -C SKIP RESERVED BYTE - INOFST = INOFST + 8 -C NUMBER OF DATA SUBSETS - CALL GBYTE (MSGA,IDENT(14),INOFST,16) -C - IF (IDENT(14).GT.MAXR) THEN - PRINT *,'THE NUMBER OF SUBSETS EXCEEDS THE MAXIMUM OF',MAXR - PRINT *,'PASSED INTO W3FI88; MAXR MUST BE INCREASED IN ' - PRINT *,'THE CALLING PROGRAM TO AT LEAST THE VALUE OF' - PRINT *,IDENT(14),'TO BE ABLE TO PROCESS THIS DATA' -C - IPTR(1) = 400 - RETURN - END IF - INOFST = INOFST + 16 -C OBSERVED DATA FLAG - CALL GBYTE (MSGA,IVALS,INOFST,1) - IDENT(15) = IVALS(1) - INOFST = INOFST + 1 -C COMPRESSED DATA FLAG - CALL GBYTE (MSGA,IVALS,INOFST,1) - IDENT(16) = IVALS(1) - INOFST = INOFST + 7 -C CALCULATE NUMBER OF DESCRIPTORS - NRDESC = (IPTR( 6) - 8) / 2 - IPTR(12) = NRDESC - IPTR(13) = NRDESC -C EXTRACT DESCRIPTORS - CALL GBYTES (MSGA,ISTACK,INOFST,16,0,NRDESC) -C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS' - DO 10 L = 1, NRDESC - IWORK(L) = ISTACK(L) -C PRINT *,L,ISTACK(L) - 10 CONTINUE - IPTR(13) = NRDESC -C =============================================================== -C -C CONSTRUCT A TABLE B TO MATCH THE -C LIST OF DESCRIPTORS FOR THIS MESSAGE -C - IF (IPTR(21).EQ.0) THEN - PRINT *,'W3FI88- TABLE B NOT YET ENTERED' - CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD, - * IRF1SW,NEWREF,ITBLD,ITBLD2, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) - ELSE -C PRINT *,'W3FI88- TABLE B ALL READY IN PLACE' - IF (IPTR(41).NE.0) THEN -C PRINT *,'MERGE',IPTR(41),' ENTRIES INTO TABLE B' -C CALL FI8818(IPTR,KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, -C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB) - END IF - END IF - IF (IPTR(1).NE.0) RETURN -C ================================================================ -C RESET POINTER TO START OF SECTION 4 - INOFST = IPTR(7) + IPTR(6) * 8 -C BIT OFFSET TO START OF SECTION 4 - IPTR( 9) = INOFST -C SECTION 4 COUNT - CALL GBYTE (MSGA,IVALS,INOFST,24) -C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1) - IPTR( 8) = IVALS(1) - INOFST = INOFST + 32 -C SET FOR STARTING BIT OF DATA - IPTR(25) = INOFST -C FIND OUT IF '7777' TERMINATOR IS THERE - INOFST = IPTR(9) + IPTR(8) * 8 - CALL GBYTE (MSGA,IVALS,INOFST,32) -C PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1) - IF (IVALS(1).NE.926365495) THEN - PRINT *,'BAD SECTION COUNT' - IPTR(1) = 2 - RETURN - ELSE - IPTR(1) = 0 - END IF -C - CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS, - * MSTACK,KNR,INDEX,MAXR,MAXD, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, - * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3, - * IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD) -C -C PRINT *,'HAVE RETURNED FROM FI8801' - IF (IPTR(1).NE.0) THEN - RETURN - END IF -C FURTHER PROCESSING REQUIRED FOR PROFILER DATA - IF (IDENT(5).EQ.2) THEN - IF (IDENT(6).EQ.7) THEN -C PRINT *,'REFORMAT PROFILER DATA' -C -C DO 7151 I = 1, 40 -C IF (I.LE.20) THEN -C PRINT *,'IPTR(',I,')=',IPTR(I), -C * ' IDENT(',I,')= ',IDENT(I) -C ELSE -C PRINT *,'IPTR(',I,')=',IPTR(I) -C END IF -C7151 CONTINUE -C DO 152 I = 1, IPTR(31) -C PRINT *,MSTACK(1,I),MSTACK(2,I),(KDATA(J,I),J=1,5) -C 152 CONTINUE - IF (IDENT(1).LT.2) THEN - CALL FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) - ELSE - CALL FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) - END IF -C DO 151 I = 1, 40 -C IF (I.LE.20) THEN -C PRINT *,'IPTR(',I,')=',IPTR(I), -C * ' IDENT(',I,')= ',IDENT(I) -C ELSE -C PRINT *,'IPTR(',I,')=',IPTR(I) -C END IF -C 151 CONTINUE - IF (IPTR(1).NE.0) THEN - RETURN - END IF -C -C DO 154 I = 1, IPTR(31) -C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I) -C 154 CONTINUE - END IF - END IF -C IF DATA/DESCRIPTOR REPLICATION FLAG IS ON, -C MUST COMPLETE EXPANSION OF DATA AND -C DESCRIPTORS. - IF (IPTR(38).EQ.1) THEN - CALL FI8811(IPTR,IDENT,MSTACK,KDATA,KNR, - * LDATA,LSTACK,MAXD,MAXR) - END IF -C -C IF HAVE A LIST OF TABLE ENTRIES FROM -C A BUFR MESSAGE TYPE 11 -C PRINT OUT THE ENTRIES -C - IF (IDENT(5).EQ.11) THEN -C DO 100 I = 1, IPTR(31)+IPTR(24) -C PRINT *,I,MSTACK(1,I),(KDATA(J,I),J=1,4) -C 100 CONTINUE - CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,KPTRB, - * ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB) - END IF - RETURN - END - SUBROUTINE FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS, - * MSTACK,KNR,INDEX,MAXR,MAXD, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, - * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3, - * IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD) -C -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8801 DATA EXTRACTION -C PRGMMR: KEYSER ORG: NP22 DATE: 1995-06-07 -C -C ABSTRACT: CONTROL THE EXTRACTION OF DATA FROM SECTION 4 BASED ON -C DATA DESCRIPTORS. -C -C PROGRAM HISTORY LOG: -C 1988-09-01 CAVANAUGH -C 1991-01-18 CAVANAUGH CORRECTIONS TO PROPERLY HANDLE NON-COMPRESSED -C DATA. -C 1991-09-23 CAVANAUGH CODING ADDED TO HANDLE SINGLE SUBSETS WITH -C DELAYED REPLICATION. -C 1992-01-24 CAVANAUGH MODIFIED TO ECHO DESCRIPTORS TO MSTACK(1,N) -C 1995-06-07 KEYSER CORRECTED AN ERROR WHICH REQUIRED INPUT -C ARGUMENT "MAXD" TO BE NEARLY TWICE AS LARGE -C AS NEEDED FOR DECODING WIND PROFILER REPORTS -C (LIMIT UPPER BOUND FOR "IWORK" ARRAY WAS SET -C TO "MAXD", NOW IT IS SET TO 15000) -C -C USAGE: CALL FI8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS, -C * MSTACK,KNR,INDEX,MAXR,MAXD, -C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL, -C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, -C * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3, -C * IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB) -C -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IDENT - SEE W3FI88 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE -C ISTACK - ORIGINAL ARRAY OF DESCRIPTORS EXTRACTED FROM -C SOURCE BUFR MESSAGE. -C MSTACK - WORKING ARRAY OF DESCRIPTORS (EXPANDED)AND SCALING -C FACTOR -C KFXY1 - IMAGE OF CURRENT DESCRIPTOR -C INDEX - -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C IUNITB - UNIT NUMBER OF DATA SET HOLDING TABLE B -C IUNITD - UNIT NUMBER OF DATA SET HOLDING TABLE D -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IWORK - WORKING DESCRIPTOR LIST -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C -C ISTACK - SEE ABOVE -C ARRAYS CONTAINING DATA FROM TABLE B -C KFXY1 - SEE ABOVE -C ANAME1 - DESCRIPTOR NAME -C AUNIT1 - UNITS FOR DESCRIPTOR -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - FI8802 FI8805 FI8806 FI8807 FI8808 -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 8 ERROR READING TABLE B -C = 9 ERROR READING TABLE D -C = 11 ERROR OPENING TABLE B -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C .................................................. -C -C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE -C - INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*) - CHARACTER*64 ANAME2(*) - CHARACTER*24 AUNIT2(*) -C .................................................. -C -C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE -C - INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200) - CHARACTER*64 ANAME3(200) - CHARACTER*24 AUNIT3(200) -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C - INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) - CHARACTER*40 ANAME1(*) - CHARACTER*24 AUNIT1(*) -C .................................................. -C -C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE -C - INTEGER ITBLD2(20,*) -C .................................................. -C -C NEW BASE TABLE D -C - INTEGER ITBLD(20,*) -C .................................................. -C -C - INTEGER MAXD, MAXR -C - INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*) -C - INTEGER KNR(MAXR) - INTEGER LX,LY,LL,J -C INTEGER IHOLD(33) - INTEGER IPTR(*),KPTRB(*),KPTRD(*) - INTEGER IDENT(*) - INTEGER ISTACK(*),IWORK(*) -C - INTEGER MSTACK(2,MAXD) -C - INTEGER JDESC - INTEGER INDEX -C - SAVE -C -C PRINT *,' DECOLL FI8801' - IF (INDEX.GT.1) THEN - GO TO 1000 - END IF -C --------- DECOLL --------------- - IPTR(23) = 0 - IPTR(26) = 0 - IPTR(27) = 0 - IPTR(28) = 0 - IPTR(29) = 0 - IPTR(30) = 0 - IPTR(36) = 0 -C INITIALIZE OUTPUT AREA -C SET POINTER TO BEGINNING OF DATA -C SET BIT - IPTR(17) = 1 - 1000 CONTINUE -C IPTR(12) = IPTR(13) - LL = 0 - IPTR(11) = 1 - IF (IPTR(10).EQ.0) THEN -C RE-ENTRY POINT FOR MULTIPLE -C NON-COMPRESSED REPORTS - ELSE - INDEX = IPTR(15) - IPTR(17) = INDEX - IPTR(25) = IPTR(10) - IPTR(10) = 0 - IPTR(15) = 0 - END IF -C PRINT *,'FI8801 - RPT',IPTR(17),' STARTS AT',IPTR(25) - IPTR(24) = 0 - IPTR(31) = 0 -C POINTING AT NEXT AVAILABLE DESCRIPTOR - MM = 0 - IF (IPTR(21).EQ.0) THEN - NRDESC = IPTR(13) - CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD, - * IRF1SW,NEWREF,ITBLD,ITBLD2, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) - END IF - 10 CONTINUE -C PROCESS THRU THE FOLLOWING -C DEPENDING UPON THE VALUE OF 'F' (LF) - MM = MM + 1 - 12 CONTINUE - IF (MM.GT.MAXD) THEN - GO TO 200 - END IF -C END OF CYCLE TEST (SERIAL/SEQUENTIAL) - IF (IPTR(11).GT.IPTR(12)) THEN -C PRINT *,' HAVE COMPLETED REPORT SEQUENCE' - IF (IDENT(16).NE.0) THEN -C PRINT *,' PROCESSING COMPRESSED REPORTS' -C REFORMAT DATA FROM DESCRIPTOR -C FORM TO USER FORM - RETURN - ELSE -C WRITE (6,1) -C 1 FORMAT (1H1) -C PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25) - IPTR(17) = IPTR(17) + 1 - IF (IPTR(17).GT.IDENT(14)) THEN - IPTR(17) = IPTR(17) - 1 - GO TO 200 - END IF - DO 300 I = 1, IPTR(13) - IWORK(I) = ISTACK(I) - 300 CONTINUE -C RESET POINTERS - LL = 0 - IPTR(1) = 0 - IPTR(11) = 1 - IPTR(12) = IPTR(13) -C IS THIS LAST REPORT ? -C PRINT *,'READY',IPTR(39),INDEX - IF (IPTR(39).GT.0) THEN - IF (INDEX.GT.0) THEN -C PRINT *,'HERE IS SUBSET NR',INDEX - RETURN - END IF - END IF - GO TO 1000 - END IF - END IF - 14 CONTINUE -C GET NEXT DESCRIPTOR - CALL FI8808 (IPTR,IWORK,LF,LX,LY,JDESC) -C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ', -C * IPTR(11),IWORK(IPTR(11)),IPTR(31) -C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY, -C * ' FOR LOC',IPTR(17),IPTR(25) -CVVVVVCHANGE#2 FIX BY KEYSER -- 12/06/1994 -C NOTE: THIS FIX NEEDED BECAUSE IWORK ARRAY DOES NOT HAVE TO BE -C LIMITED TO SIZE OF "MAXD" -- WASTES SPACE BECAUSE "MAXD" -C MUST BECOME OVER TWICE AS LARGE AS NEEDED FOR PROFILERS -C IN ORDER TO AVOID SATISFYING THIS BELOW IF TEST -CDAK IF (IPTR(11).GT.MAXD) THEN - IF (IPTR(11).GT.15000) THEN -CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994 - IPTR(1) = 401 - RETURN - END IF -C - KPRM = IPTR(31) + IPTR(24) - IF (KPRM.GT.MAXD) THEN - IF (KPRM.GT.KOLD) THEN - PRINT *,'EXCEEDED ARRAY SIZE',KPRM,IPTR(31), - * IPTR(24) - KOLD = KPRM - END IF - END IF -C REPLICATION PROCESSING - IF (LF.EQ.1) THEN -C ---------- F1 --------- - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = 0 -C PRINT *,'FI8801-1',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - CALL FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY, - * KDATA,LL,KNR,MSTACK,MAXR,MAXD) -C * KDATA,LL,KNR,MSTACK,MAXR,MAXD) - IF (IPTR(1).NE.0) THEN - RETURN - ELSE - GO TO 12 - END IF -C -C DATA DESCRIPTION OPERATORS - ELSE IF (LF.EQ.2)THEN - IF (LX.EQ.4) THEN - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = 0 -C PRINT *,'FI8801-2',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - END IF - CALL FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD, - * KPTRB) - IF (IPTR(1).NE.0) THEN - RETURN - END IF - GO TO 12 -C DESCRIPTOR SEQUENCE STRINGS - ELSE IF (LF.EQ.3) THEN -C PRINT *,'F3 SEQUENCE DESCRIPTOR' -C READ IN TABLE D, BUT JUST ONCE - IF (IPTR(20).EQ.0) THEN - CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD) - IF (IPTR(1).GT.0) THEN - RETURN - END IF -C ELSE -C IF (IPTR(42).NE.0) THEN -C PRINT *,'MERGE',IPTR(42),' ENTRIES INTO TABLE D' -C CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD) -C END IF - END IF - CALL FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD) - IF (IPTR(1).GT.0) THEN - RETURN - END IF - GO TO 14 -C -C ELEMENT DESCRIPTOR PROCESSING -C - ELSE - KPRM = IPTR(31) + IPTR(24) - CALL FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK, - * AUNIT1,IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD, - * KPTRB) -C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR - IPTR(36) = 0 - IF (IPTR(1).GT.0) THEN - RETURN - ELSE -C -C IF ENCOUNTER CLASS 0 DESCRIPTOR -C NOT CONTAINED WITHIN A BUFR -C MESSAGE OF TYPE 11, THEN COLLECT -C ALL TABLE B ENTRIES FOR USE ON -C CURRENT BUFR MESSAGE -C - IF (JDESC.LE.20.AND.JDESC.GE.10) THEN - IF (IDENT(5).NE.11) THEN -C COLLECT TABLE B ENTRIES - CALL FI8815(IPTR,IDENT,JDESC,KDATA, - * KFXY3,MAXR,MAXD,ANAME3,AUNIT3, - * ISCAL3,IRFVL3,IWIDE3, - * KEYSET,IBFLAG,IERR) - IF (IERR.NE.0) THEN - END IF - IF (IAND(IBFLAG,16).NE.0) THEN - IF (IAND(IBFLAG,8).NE.0) THEN - IF (IAND(IBFLAG,4).NE.0) THEN - IF (IAND(IBFLAG,2).NE.0) THEN - IF (IAND(IBFLAG,1).NE.0) THEN -C HAVE A COMPLETE TABLE B ENTRY - IPTR(43) = IPTR(43) + IDENT(14) - KEYSET = 0 - IBFLAG = 0 - GO TO 1000 - END IF - END IF - END IF - END IF - END IF - END IF - END IF - IF (IDENT(16).EQ.0) THEN - KNR(IPTR(17)) = IPTR(31) - ELSE - DO 310 KJ = 1, MAXR - KNR(KJ) = IPTR(31) - 310 CONTINUE - END IF - GO TO 10 - END IF - END IF -C END IF -C END DO WHILE - 200 CONTINUE -C IF (IDENT(16).NE.0) THEN -C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS' -C ELSE -C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS' -C END IF - RETURN - END - SUBROUTINE FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,AUNIT1, - * IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD,KPTRB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8802 PROCESS ELEMENT DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS AN ELEMENT DESCRIPTOR (F = 0) AND STORE DATA -C IN OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-04 CAVANAUGH CHANGED TO PASS WIDTH OF TEXT FIELDS IN BYTES -C -C USAGE: CALL FI8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,AUNIT1, -C IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD,KPTRB) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IDENT - SEE W3FI88 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C KFXY1 - IMAGE OF CURRENT DESCRIPTOR -C ANAME1 - LIST OF NAME OF DESCRIPTOR CONTENTS -C MSTACK - -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - SEE ABOVE -C KFXY1 - SEE ABOVE -C ARRAYS CONTAINING DATA FROM TABLE B -C AUNIT1 - UNITS FOR DESCRIPTOR -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - FI8803 FI8804 -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 3 - MESSAGE CONTAINS A DESCRIPTOR WITH F=0 -C THAT DOES NOT EXIST IN TABLE B. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C TABLE B ENTRY - CHARACTER*24 ASKEY - INTEGER MSGA(*) - INTEGER IPTR(*) - INTEGER KPTRB(*) - INTEGER IDENT(*) - INTEGER J - INTEGER JDESC - INTEGER MSTACK(2,MAXD) - INTEGER KDATA(MAXR,MAXD),IVALS(*) -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C - INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) -C CHARACTER*40 ANAME1(*) - CHARACTER*24 AUNIT1(*) -C .................................................. - SAVE -C - DATA ASKEY /'CCITT IA5 '/ -C -C PRINT *,' FI8802 - ELEMENT DESCRIPTOR ',JDESC,KPTRB(JDESC) -C FIND TABLE B ENTRY - J = KPTRB(JDESC) -C HAVE A MATCH -C SET FLAG IF TEXT EVENT -C PRINT *,'ASKEY=',ASKEY,'AUNIT1(',J,')=',AUNIT1(J),JDESC - IF (ASKEY(1:9).EQ.AUNIT1(J)(1:9)) THEN - IPTR(18) = 1 - IPTR(40) = IWIDE1(J) / 8 - ELSE - IPTR(18) = 0 - END IF -C PRINT *,'FI8802 - BIT WIDTH =',IWIDE1(J),IPTR(18),' FOR',JDESC - IF (IDENT(16).NE.0) THEN -C COMPRESSED - CALL FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD) -C IF (IPTR(1).NE.0) THEN -C RETURN -C END IF - ELSE -C NOT COMPRESSED -C PRINT *,' FROM FI8802',J - CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD) -C IF (IPTR(1).NE.0) THEN -C RETURN -C END IF - END IF - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8803 PROCESS COMPRESSED DATA -C PRGMMR: KEYSER ORG: NP22 DATE: 1995-06-07 -C -C ABSTRACT: PROCESS COMPRESSED DATA AND PLACE INDIVIDUAL ELEMENTS -C INTO OUTPUT ARRAY. -C -C PROGRAM HISTORY LOG: -C 1988-09-01 CAVANAUGH -C 1991-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE -C MODIFIED TO HANLE WIDTH OF FIELDS IN BYTES. -C 1991-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED -C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS. -C THIS HAS BEEN CORRECTED. -C 1991-06-21 CAVANAUGH PROCESSING OF TEXT DATA HAS BEEN CHANGED TO -C PROVIDE EXACT REPRODUCTION OF ALL CHARACTERS. -C 1994-04-11 CAVANAUGH CORRECTED PROCESSING OF DATA WHEN ALL VALUES -C THE SAME (NBINC = 0). CORRECTED TEST OF LOWEST -C VALUE AGAINST PROPER BIT MASK. -C 1995-06-07 KEYSER CORRECTED AN ERROR WHICH RESULTED IN -C RETURNED SCALE IN "MSTACK(2, ..)" ALWAYS -C BEING SET TO ZERO FOR COMPRESSED DATA. ALSO, -C SCALE CHANGES WERE NOT BEING RECOGNIZED. -C -C USAGE: CALL FI8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK, -C IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IDENT - SEE W3FI88 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE,MSTACK, -C IVALS - ARRAY OF SINGLE PARAMETER VALUES -C J - -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C J - -C ARRAYS CONTAINING DATA FROM TABLE B -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTE GBYTES W3AI39 -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C -C INTEGER KFXY1(*) - INTEGER ISCAL1(*) - INTEGER IRFVL1(3,*) - INTEGER IWIDE1(*) -C CHARACTER*40 ANAME1(*) -C CHARACTER*24 AUNIT1(*) -C .................................................. - INTEGER MAXD,MAXR - INTEGER MSGA(*),JDESC,MSTACK(2,MAXD) - INTEGER IPTR(*),IVALS(*),KDATA(MAXR,MAXD) - INTEGER NRVALS,JWIDE,IDATA - INTEGER IDENT(*) - INTEGER J - INTEGER KLOW(256) -C - LOGICAL TEXT -C - INTEGER MSK(32) -C - SAVE -C - DATA MSK /1, 3, 7, 15, 31, 63, 127, -C 1 2 3 4 5 6 7 - * 255, 511, 1023, 2047, 4095, -C 8 9 10 11 12 - * 8191, 16383, 32767, 65535, -C 13 14 15 16 - * 131071, 262143, 524287, -C 17 18 19 - * 1048575, 2097151, 4194303, -C 20 21 22 - * 8388607, 16777215, 33554431, -C 23 24 25 - * 67108863, 134217727, 268435455, -C 26 27 28 - * 536870911, 1073741823, 2147483647,-1 / -C 29 30 31 32 - CALL W3FI01(LW) - MWDBIT = IPTR(44) - IF (IPTR(45).EQ.8) THEN - I = 2147483647 - MSK(32) = I + I + 1 - END IF -C -C PRINT *,' FI8803 COMPR J=',J,' IWIDE1(J) =',IWIDE1(J), -C * ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25) - IF (IPTR(18).EQ.0) THEN - TEXT = .FALSE. - ELSE - TEXT = .TRUE. - END IF -C PRINT *,'DESCRIPTOR',KPRM,JDESC - IF (.NOT.TEXT) THEN - IF (IPTR(29).GT.0.AND.JDESC.NE.7957) THEN -C PRINT *,'ASSOCIATED FIELD AT',IPTR(25) -C WORKING WITH ASSOCIATED FIELDS HERE - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) -C GET LOWEST - CALL GBYTE (MSGA,LOWEST,IPTR(25),IPTR(29)) - IPTR(25) = IPTR(25) + IPTR(29) -C GET NBINC - CALL GBYTE (MSGA,NBINC,IPTR(25),6) - IPTR(25) = IPTR(25) + 6 -C PRINT *,'LOWEST=',LOWEST,' NBINC=',NBINC - IF (NBINC.GT.32) THEN - IPTR(1) = 22 - RETURN - END IF -C EXTRACT DATA FOR ASSOCIATED FIELD - IF (NBINC.GT.0) THEN - CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,IPTR(21)) - IPTR(25) = IPTR(25) + NBINC * IPTR(21) - DO 50 I = 1, IDENT(14) - KDATA(I,KPRM) = IVALS(I) + LOWEST - IF (NBINC.EQ.32) THEN - IF (KDATA(I,KPRM).EQ.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - END IF - ELSE IF (KDATA(I,KPRM).GE.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - END IF - 50 CONTINUE - ELSE - DO 51 I = 1, IDENT(14) - KDATA(I,KPRM) = LOWEST - IF (NBINC.EQ.32) THEN - IF (LOWEST.EQ.MSK(32)) THEN - KDATA(I,KPRM) = 999999 - END IF - ELSE IF(LOWEST.GE.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - END IF - 51 CONTINUE - END IF - END IF -C SET PARAMETER -C ISOLATE COMBINED BIT WIDTH - JWIDE = IWIDE1(J) + IPTR(26) -C - IF (JWIDE.GT.32) THEN -C TOO MANY BITS IN COMBINED -C BIT WIDTH - PRINT *,'ERR 22 - HAVE EXCEEDED COMBINED BIT WIDTH' - IPTR(1) = 22 - RETURN - END IF -C SINGLE VALUE FOR LOWEST - NRVALS = 1 -C LOWEST -C PRINT *,'PARAM',KPRM - CALL GBYTE (MSGA,LOWEST,IPTR(25),JWIDE) -C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25) - IPTR(25) = IPTR(25) + JWIDE -C ISOLATE COMPRESSED BIT WIDTH - CALL GBYTE (MSGA,NBINC,IPTR(25),6) -C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25) - IF (NBINC.GT.32) THEN -C NBINC TOO LARGE - IPTR(1) = 22 - RETURN - END IF - IF (IPTR(32).EQ.2.AND.IPTR(33).EQ.5) THEN - ELSE - IF (NBINC.GT.JWIDE) THEN -C PRINT *,'FOR DESCRIPTOR',JDESC -C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' IWIDE1(J)=', -C * IWIDE1(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25) -C DO 110 I = 1, KPRM -C WRITE (6,111)I,(KDATA(J,I),J=1,6) -C 110 CONTINUE -C 111 FORMAT (1X,5HDATA ,I3,6(2X,I10)) - IPTR(1) = 500 - PRINT *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE', - * ' B PLUS WIDTH CHANGES' - END IF - END IF - IPTR(25) = IPTR(25) + 6 -C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC -C IF TEXT EVENT, PROCESS TEXT -C GET COMPRESSED VALUES -C PRINT *,'COMPRESSED VALUES - NONTEXT' - NRVALS = IDENT(14) - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - IF (NBINC.NE.0) THEN - CALL GBYTES (MSGA,IVALS,IPTR(25),NBINC,0,NRVALS) - IPTR(25) = IPTR(25) + NBINC * NRVALS -C RECALCULATE TO ORIGINAL VALUES - DO 100 I = 1, NRVALS -C PRINT *,IVALS(I),MSK(NBINC),NBINC - IF (IVALS(I).GE.MSK(NBINC)) THEN - KDATA(I,KPRM) = 999999 - ELSE - IF (IRFVL1(2,J).EQ.0) THEN - JRV = IRFVL1(1,J) - ELSE - JRV = IRFVL1(3,J) - END IF - KDATA(I,KPRM) = IVALS(I) + LOWEST + JRV - END IF - 100 CONTINUE -C PRINT *,I,JDESC,LOWEST,IRFVL1(1,J),IRFVL1(3,J) - ELSE - IF (LOWEST.EQ.MSK(JWIDE)) THEN - DO 105 I = 1, NRVALS - KDATA(I,KPRM) = 999999 - 105 CONTINUE - ELSE - IF (IRFVL1(2,J).EQ.0) THEN - JRV = IRFVL1(1,J) - ELSE - JRV = IRFVL1(3,J) - END IF - ICOMB = LOWEST + JRV - DO 106 I = 1, NRVALS - KDATA(I,KPRM) = ICOMB - 106 CONTINUE - END IF - END IF -C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25) - MSTACK(1,KPRM) = JDESC -C WRITE (6,80) (KDATA(I,KPRM),I=1,10) - 80 FORMAT(2X,10(F10.2,1X)) -CVVVVVCHANGE#3 FIX BY KEYSER -- 12/06/1994 -C NOTE: THIS FIX NEEDED BECAUSE THE RETURNED SCALE IN MSTACK(2,..) -C WAS ALWAYS '0' FOR COMPRESSED DATA, INCL. CHANGED SCALES) - MSTACK(2,KPRM) = ISCAL1(J) + IPTR(27) -CAAAAACHANGE#3 FIX BY KEYSER -- 12/06/1994 - ELSE IF (TEXT) THEN -C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40) -C GET LOWEST -C PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40)) - DO 1906 K = 1, IPTR(40) - CALL GBYTE (MSGA,KLOW,IPTR(25),8) - IPTR(25) = IPTR(25) + 8 - IF (KLOW(K).NE.0) THEN - IPTR(1) = 27 - PRINT *,'NON-ZERO LOWEST ON TEXT DATA' - RETURN - END IF - 1906 CONTINUE -C PRINT *,'TEXT - LOWEST = 0' -C GET NBINC - CALL GBYTE (MSGA,NBINC,IPTR(25),6) - IPTR(25) = IPTR(25) + 6 - IF (NBINC.NE.IPTR(40)) THEN - IPTR(1) = 28 - PRINT *,'NBINC IS NOT THE NUMBER OF CHARACTERS',NBINC - RETURN - END IF -C PRINT *,'TEXT NBINC =',NBINC -C FOR NUMBER OF OBSERVATIONS - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - ISTART = KPRM - I24 = IPTR(24) - DO 1900 N = 1, IDENT(14) - KPRM = ISTART - IPTR(24) = I24 - NBITS = IPTR(40) * 8 - 1700 CONTINUE -C PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS - IF (NBITS.GT.MWDBIT) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT) - IPTR(25) = IPTR(25) + MWDBIT - NBITS = NBITS - MWDBIT - IF (IPTR(37).EQ.0) THEN -C CONVERTS ASCII TO EBCIDIC - CALL W3AI39 (IDATA,LW) - END IF - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM) -C SET FOR NEXT PART - KPRM = KPRM + 1 - IPTR(24) = IPTR(24) + 1 -C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA -C1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,I12) - GO TO 1700 - ELSE IF (NBITS.GT.0) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),NBITS) - IPTR(25) = IPTR(25) + NBITS - IBUF = (IPTR(44) - NBITS) / 8 - IF (IBUF.GT.0) THEN - DO 1750 MP = 1, IBUF - IDATA = IDATA * 256 + 32 - 1750 CONTINUE - END IF -C CONVERTS ASCII TO EBCIDIC - IF (IPTR(37).EQ.0) THEN - CALL W3AI39 (IDATA,LW) - END IF - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM) -C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS - NBITS = 0 - END IF -C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM) -C1800 FORMAT (2X,I4,2X,3A4) - 1900 CONTINUE - END IF - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8804 PROCESS SERIAL DATA -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS DATA THAT IS NOT COMPRESSED -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-01-18 CAVANAUGH MODIFIED TO PROPERLY HANDLE NON-COMPRESSED -C DATA. -C 91-04-04 CAVANAUGH TEXT HANDLING PORTION OF THIS ROUTINE -C MODIFIED TO HANDLE FIELD WIDTH IN BYTES. -C 91-04-17 CAVANAUGH TESTS SHOWED THAT THE SAME DATA IN COMPRESSED -C AND UNCOMPRESSED FORM GAVE DIFFERENT RESULTS. -C THIS HAS BEEN CORRECTED. -C -C USAGE: CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK, -C IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C MSGA - ARRAY CONTAINING BUFR MESSAGE -C IVALS - ARRAY OF SINGLE PARAMETER VALUES -C J - -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C IVALS - SEE ABOVE -C J - SEE ABOVE -C ARRAYS CONTAINING DATA FROM TABLE B -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTE -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 13 - BIT WIDTH ON ASCII CHARS NOT A MULTIPLE OF 8 -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C -C INTEGER KFXY1(*) - INTEGER ISCAL1(*) - INTEGER IRFVL1(3,*) - INTEGER IWIDE1(*) -C CHARACTER*40 ANAME1(*) -C CHARACTER*24 AUNIT1(*) -C .................................................. -C - INTEGER MSGA(*),MAXD,MAXR - INTEGER IPTR(*) - INTEGER JDESC - INTEGER IVALS(*) -C INTEGER LSTBLK(3) - INTEGER KDATA(MAXR,MAXD),MSTACK(2,MAXD) - INTEGER J,LL -C LOGICAL LKEY -C -C - INTEGER ITEST(32) -C - SAVE -C - DATA ITEST /1,3,7,15,31,63,127,255, - * 511,1023,2047,4095,8191,16383, - * 32767, 65535,131071,262143,524287, - * 1048575,2097151,4194303,8388607, - * 16777215,33554431,67108863,134217727, - * 268435455,536870911,1073741823, - * 2147483647,-1/ -C - MWDBIT = IPTR(44) - IF (IPTR(45).NE.4) THEN - I = 2147483647 - ITEST(32) = I + I + 1 - END IF -C -C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25) -C -------- NOCMP -------- -C IF NOT TEXT EVENT, PROCESS - IF (IPTR(18).EQ.0) THEN -C PRINT *,' NOT TEXT' - IF ((IPTR(26)+IWIDE1(J)).LT.1) THEN -C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25) - IPTR(1) = 501 - RETURN - END IF -C ISOLATE BIT WIDTH - JWIDE = IWIDE1(J) + IPTR(26) -C IF ASSOCIATED FIELD SW ON - IF (IPTR(29).GT.0) THEN - IF (JDESC.NE.7957.AND.JDESC.NE.7937) THEN - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = 33792 + IPTR(29) - MSTACK(2,KPRM) = 0 - CALL GBYTE (MSGA,IVALS,IPTR(25),IPTR(29)) - IPTR(25) = IPTR(25) + IPTR(29) - KDATA(IPTR(17),KPRM) = IVALS(1) -C PRINT *,'FI8804-A',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM) - END IF - END IF - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC -C IF (IPTR(27).NE.0) THEN -C MSTACK(2,KPRM) = IPTR(27) -C ELSE - MSTACK(2,KPRM) = ISCAL1(J) + IPTR(27) -C END IF -C GET VALUES -C CALL TO GET DATA OF GIVEN BIT WIDTH - CALL GBYTE (MSGA,IVALS,IPTR(25),JWIDE) -C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25) - IPTR(25) = IPTR(25) + JWIDE -C RETURN WITH SINGLE VALUE - IF (IRFVL1(2,J).EQ.0) THEN - JRV = IRFVL1(1,J) - ELSE - JRV = IRFVL1(3,J) - END IF - IF (JWIDE.EQ.32) THEN - IF (IVALS(1).EQ.ITEST(JWIDE)) THEN - KDATA(IPTR(17),KPRM) = 999999 - ELSE - KDATA(IPTR(17),KPRM) = IVALS(1) + JRV - END IF - ELSE IF (IVALS(1).GE.ITEST(JWIDE)) THEN - KDATA(IPTR(17),KPRM) = 999999 - ELSE - KDATA(IPTR(17),KPRM) = IVALS(1) + JRV - END IF -C PRINT *,'FI8804-B',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM) -C IF(JDESC.EQ.2049) THEN -C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM) -C END IF -C PRINT *,'FI8804 ',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - ELSE -C PRINT *,' TEXT' -C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********' - JWIDE = IPTR(40) * 8 -C PRINT *,' WIDTH =',JWIDE,IPTR(40) - NRCHRS = IPTR(40) - NRBITS = JWIDE -C PRINT *,' CHARS =',NRCHRS,' BITS =',NRBITS - IPTR(31) = IPTR(31) + 1 - KANY = 0 - 1800 CONTINUE - KANY = KANY + 1 -C PRINT *,' NR BITS THIS PASS',NRBITS - IF (NRBITS.GT.MWDBIT) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT) -C PRINT 1801,KANY,IDATA,IPTR(17),KPRM,NRBITS - 1801 FORMAT (1X,I2,4X,Z8,2(4X,I4)) -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - IF (IPTR(37).EQ.0) THEN - CALL W3AI39 (IDATA,IPTR(45)) - END IF - KPRM = IPTR(31) + IPTR(24) - KDATA(IPTR(17),KPRM) = IDATA - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 -C PRINT *,'BODY ',KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM), -C * KDATA(IPTR(17),KPRM) - IPTR(25) = IPTR(25) + MWDBIT - NRBITS = NRBITS - MWDBIT - IPTR(24) = IPTR(24) + 1 - GO TO 1800 - ELSE IF (NRBITS.GT.0) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),NRBITS) - IPTR(25) = IPTR(25) + NRBITS -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - IF (IPTR(37).EQ.0) THEN - CALL W3AI39 (IDATA,IPTR(45)) - END IF - KPRM = IPTR(31) + IPTR(24) - KSHFT = MWDBIT - NRBITS - IF (KSHFT.GT.0) THEN - KTRY = KSHFT / 8 - DO 1722 LAK = 1, KTRY - IF (IPTR(37).EQ.0) THEN - IDATA = IDATA * 256 + 64 - ELSE - IDATA = IDATA * 256 + 32 - END IF -C PRINT 1723,IDATA -C1723 FORMAT (12X,Z8) - 1722 CONTINUE - END IF - KDATA(IPTR(17),KPRM) = IDATA -C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 -C PRINT *,'TAIL ',KPRM,MSTACK(1,KPRM), -C * KDATA(IPTR(17),KPRM) - END IF - END IF - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY, - * KDATA,LL,KNR,MSTACK,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8805 PROCESS A REPLICATION DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: PROCESS A REPLICATION DESCRIPTOR, MUST EXTRACT NUMBER -C OF REPLICATIONS OF N DESCRIPTORS FROM THE DATA STREAM. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8805(IPTR,IDENT,MSGA,IWORK,LX,LY, -C * KDATA,LL,KNR,MSTACK,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IWORK - WORKING DESCRIPTOR LIST -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IDENT - SEE W3FI88 ROUTINE DOCBLOCK -C LX - X PORTION OF CURRENT DESCRIPTOR -C LY - Y PORTION OF CURRENT DESCRIPTOR -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C LX - SEE ABOVE -C LY - SEE ABOVE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - GBYTES FI8808 -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 12 DATA DESCRIPTOR QUALIFIER DOES NOT FOLLOW -C DELAYED REPLICATION DESCRIPTOR -C = 20 EXCEEDED COUNT FOR DELAYED REPLICATION PASS -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C - INTEGER IPTR(*) - INTEGER KNR(MAXR) - INTEGER ITEMP(2000) - INTEGER LL - INTEGER KTEMP(2000) - INTEGER KDATA(MAXR,MAXD) - INTEGER LX,MSTACK(2,MAXD) - INTEGER LY - INTEGER MSGA(*) - INTEGER KVALS(1300) -CVVVVVCHANGE#2 FIX BY KEYSER -- 12/06/1994 -C NOTE: THIS FIX JUST CLEANS UP CODE SINCE IWORK ARRAY IS EARLIER -C DEFINED AS 15000 WORDS - INTEGER IWORK(*) -CDAK INTEGER IWORK(MAXD) -CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994 - INTEGER IDENT(*) -C - SAVE -C -C PRINT *,' REPLICATION FI8805' -C DO 7100 I = 1, IPTR(13) -C PRINT *,I,IWORK(I) -C7100 CONTINUE -C NUMBER OF DESCRIPTORS - NRSET = LX -C NUMBER OF REPLICATIONS - NRREPS = LY - ICURR = IPTR(11) - 1 - IPICK = IPTR(11) - 1 -C - IF (NRREPS.EQ.0) THEN - IPTR(39) = 1 -C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR -C IPTR(31) = IPTR(31) + 1 -C KPRM = IPTR(31) + IPTR(24) -C MSTACK(1,KPRM) = JDESC -C MSTACK(2,KPRM) = 0 -C KDATA(IPTR(17),KPRM) = 0 -C PRINT *,'FI8805-1',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) -C DELAYED REPLICATION - MUST GET NUMBER OF -C REPLICATIONS FROM DATA. -C GET NEXT DESCRIPTOR - CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC) -C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC -C MUST BE DATA DESCRIPTION -C OPERATION QUALIFIER - IF (JDESC.EQ.7937.OR.JDESC.EQ.7947) THEN - JWIDE = 8 - ELSE IF (JDESC.EQ.7938.OR.JDESC.EQ.7948) THEN - JWIDE = 16 - ELSE IF (JDESC.EQ.7936) THEN - JWIDE = 1 - ELSE - IPTR(1) = 12 - RETURN - END IF -C THIS IF BLOCK IS SET TO HANDLE -C DATA/DESCRIPTOR REPLICATION - IF (JDESC.EQ.7947.OR.JDESC.EQ.7948) THEN -C SET DATA/DESCRIPTOR REPLICATION FLAG = ON - IPTR(38) = 1 -C SAVE AS NEXT ENTRY IN KDATA, MSTACK - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE) - IPTR(25) = IPTR(25) + JWIDE - KDATA(IPTR(17),KPRM) = KVALS(1) - RETURN - END IF - -C SET SINGLE VALUE FOR SEQUENTIAL, -C MULTIPLE VALUES FOR COMPRESSED - IF (IDENT(16).EQ.0) THEN - -C NON COMPRESSED - CALL GBYTE (MSGA,KVALS,IPTR(25),JWIDE) -C PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1) - IPTR(25) = IPTR(25) + JWIDE - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = KVALS(1) - NRREPS = KVALS(1) -C PRINT *,'FI8805-2',KPRM,MSTACK(1,KPRM), -C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM) - ELSE - NRVALS = IDENT(14) - CALL GBYTES (MSGA,KVALS,IPTR(25),JWIDE,0,NRVALS) - IPTR(25) = IPTR(25) + JWIDE * NRVALS - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(IPTR(17),KPRM) = KVALS(1) - DO 100 I = 1, NRVALS - KDATA(I,KPRM) = KVALS(I) - 100 CONTINUE - NRREPS = KVALS(1) - END IF - ELSE -C PRINT *,'NOT DELAYED REPLICATION' - END IF -C RESTRUCTURE WORKING STACK W/REPLICATIONS - IF (NRREPS.EQ.0) THEN -C PRINT *,'RESTRUCTURING - NO REPLICATION' - IPTR(11) = IPICK + NRSET + 2 - GO TO 9999 - END IF -C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS' -C PICK UP DESCRIPTORS TO BE REPLICATED - DO 1000 I = 1, NRSET - CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC) - ITEMP(I) = JDESC -C PRINT *,'REPLICATION ',I,ITEMP(I) - 1000 CONTINUE -C MOVE TRAILING DESCRIPTORS TO HOLD AREA - LAX = IPTR(12) - IPTR(11) + 1 -C PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12) - DO 2000 I = 1, LAX - CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC) - KTEMP(I) = JDESC -C PRINT *,' ',I,KTEMP(I) - 2000 CONTINUE -C REPLICATIONS INTO ISTACK -C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES' -C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR - DO 4000 I = 1, NRREPS - DO 3000 J = 1, NRSET - IWORK(ICURR) = ITEMP(J) -C PRINT *,'FI8805 A',ICURR,IWORK(ICURR) - ICURR = ICURR + 1 - 3000 CONTINUE - 4000 CONTINUE -C PRINT *,' TO LOC',ICURR-1 -C RESTORE TRAILING DESCRIPTORS -C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR - DO 5000 I = 1, LAX - IWORK(ICURR) = KTEMP(I) -C PRINT *,'FI8805 B',ICURR,IWORK(ICURR) - ICURR = ICURR + 1 - 5000 CONTINUE - IPTR(12) = ICURR - 1 - IPTR(11) = IPICK - 9999 CONTINUE -C DO 5500 I = 1, IPTR(12) -C PRINT *,'FI8805 B',I,IWORK(I),IPTR(11) -C5500 CONTINUE - RETURN - END - SUBROUTINE FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD,KPTRB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8806 PROCESS OPERATOR DESCRIPTORS -C PRGMMR: CAVANAUGH ORG: W/NMCX42 DATE: 88-09-01 -C -C ABSTRACT: EXTRACT AND SAVE INDICATED CHANGE VALUES FOR USE -C UNTIL CHANGES ARE RESCINDED, OR EXTRACT TEXT STRINGS INDICATED -C THROUGH 2 05 YYY. -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-04 CAVANAUGH MODIFIED TO HANDLE DESCRIPTOR 2 05 YYY -C 91-05-10 CAVANAUGH CODING HAS BEEN ADDED TO PROCESS PROPERLY -C TABLE C DESCRIPTOR 2 06 YYY. -C 91-11-21 CAVANAUGH CODING HAS BEEN ADDED TO PROPERLY PROCESS -C TABLE C DESCRIPTOR 2 03 YYY, THE CHANGE -C TO NEW REFERENCE VALUE FOR SELECTED -C DESCRIPTORS. -C -C USAGE: CALL FI8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK, -C * IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD,KPTRB) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C LX - X PORTION OF CURRENT DESCRIPTOR -C LY - Y PORTION OF CURRENT DESCRIPTOR -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT ARGUMENT LIST: -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C ARRAYS CONTAINING DATA FROM TABLE B -C ISCAL1 - SCALE FOR VALUE OF DESCRIPTOR -C IRFVL1 - REFERENCE VALUE FOR DESCRIPTOR -C IWIDE1 - BIT WIDTH FOR VALUE OF DESCRIPTOR -C -C REMARKS: ERROR RETURN: -C IPTR(1) = 5 - ERRONEOUS X VALUE IN DATA DESCRIPTOR OPERATOR -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C - INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) -C CHARACTER*40 ANAME1(*) -C CHARACTER*24 AUNIT1(*) -C .................................................. - INTEGER IPTR(*),KDATA(MAXR,MAXD),IVALS(*) - INTEGER IDENT(*),IWORK(*),KPTRB(*) - INTEGER MSGA(*),MSTACK(2,MAXD) - INTEGER J,JDESC - INTEGER LL - INTEGER LX - INTEGER LY -C - SAVE -C -C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR' - IF (LX.EQ.1) THEN -C CHANGE BIT WIDTH - IF (LY.EQ.0) THEN -C PRINT *,' RETURN TO NORMAL WIDTH' - IPTR(26) = 0 - ELSE -C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS' - IPTR(26) = LY - 128 - END IF - ELSE IF (LX.EQ.2) THEN -C CHANGE SCALE - IF (LY.EQ.0) THEN -C RESET TO STANDARD SCALE - IPTR(27) = 0 - ELSE -C SET NEW SCALE - IPTR(27) = LY - 128 - END IF - ELSE IF (LX.EQ.3) THEN -C CHANGE REFERENCE VALUE -C FOR EACH OF THOSE DESCRIPTORS BETWEEN -C 2 03 YYY WHERE Y LT 255 AND -C 2 03 255, EXTRACT THE NEW REFERENCE -C VALUE (BIT WIDTH YYY) AND PLACE -C IN TERTIARY TABLE B REF VAL POSITION, -C SET FLAG IN SECONDARY REFVAL POSITION -C THOSE DESCRIPTORS DO NOT HAVE DATA -C ASSOCIATED WITH THEM, BUT ONLY -C IDENTIFY THE TABLE B ENTRIES THAT -C ARE GETTING NEW REFERENCE VALUES. - KYYY = LY - IF (KYYY.GT.0.AND.KYYY.LT.255) THEN -C START CYCLING THRU DESCRIPTORS UNTIL -C TERMINATE NEW REF VALS IS FOUND - 300 CONTINUE - CALL FI8808 (IPTR,IWORK,LF,LX,LY,JDESC) - IF (JDESC.EQ.33791) THEN -C IF 2 03 255 THEN RETURN - RETURN - END IF -C FIND MATCHING TABLE B ENTRY - LJ = KPTRB(JDESC) - IF (LJ.LT.1) THEN -C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR - PRINT *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND' - IPTR(1) = 23 - RETURN - END IF -C TURN ON SWITCH - IRFVL1(2,LJ) = 1 -C INSERT NEW REFERENCE VALUE - CALL GBYTE (MSGA,IRFVL1(3,LJ),IPTR(25),KYYY) - GO TO 300 - ELSE IF (KYYY.EQ.0) THEN -C MUST TURN OFF ALL NEW -C REFERENCE VALUES - DO 400 I = 1, IPTR(21) - IRFVL1(2,I) = 0 - 400 CONTINUE - END IF -C LX = 3 -C MUST BE CONCLUDED WITH Y=255 - ELSE IF (LX.EQ.4) THEN -C ASSOCIATED VALUES - IF (LY.EQ.0) THEN - IPTR(29) = 0 -C PRINT *,'RESET ASSOCIATED VALUES',IPTR(29) - ELSE - IPTR(29) = LY - IF (IWORK(IPTR(11)).NE.7957) THEN - PRINT *,'2 04 YYY NOT FOLLOWED BY 0 31 021' - IPTR(1) = 11 - END IF -C PRINT *,'SET ASSOCIATED VALUES',IPTR(29) - END IF - ELSE IF (LX.EQ.5) THEN - MWDBIT = IPTR(44) -C PROCESS TEXT DATA - IPTR(40) = LY - IPTR(18) = 1 - J = KPTRB(JDESC) - IF (IDENT(16).EQ.0) THEN -C PRINT *,'FROM FI8806 - 2 05 YYY - NONCOMPRESSED TEXT',J - CALL FI8804(IPTR,MSGA,KDATA,IVALS,MSTACK, - * IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD) - ELSE -C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE YYY=',LY -C PRINT *,'TEXT - LOWEST = 0' - IPTR(25) = IPTR(25) + IPTR(40) * 8 -C GET NBINC -C CALL GBYTE (MSGA,NBINC,IPTR(25),6) - IPTR(25) = IPTR(25) + 6 - NBINC = IPTR(40) -C PRINT *,'TEXT NBINC =',NBINC,IPTR(40) -C FOR NUMBER OF OBSERVATIONS - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - ISTART = KPRM - DO 1900 N = 1, IDENT(14) - KPRM = ISTART - NBITS = IPTR(40) * 8 - 1700 CONTINUE -C PRINT *,'1700',KDATA(N,KPRM),N,KPRM,NBITS - IF (NBITS.GT.MWDBIT) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT) - IPTR(25) = IPTR(25) + MWDBIT - NBITS = NBITS - MWDBIT -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - IF (IPTR(37).EQ.0) THEN - CALL W3AI39 (IDATA,IPTR(45)) - END IF - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM) -C SET FOR NEXT PART - KPRM = KPRM + 1 -C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA -C1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X, -C * I10) - GO TO 1700 - ELSE IF (NBITS.EQ.MWDBIT) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),MWDBIT) - IPTR(25) = IPTR(25) + MWDBIT - NBITS = NBITS - MWDBIT -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - IF (IPTR(37).EQ.0) THEN - CALL W3AI39 (IDATA,IPTR(45)) - END IF - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM) -C SET FOR NEXT PART - KPRM = KPRM + 1 -C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA - ELSE IF (NBITS.GT.0) THEN - CALL GBYTE (MSGA,IDATA,IPTR(25),NBITS) - IPTR(25) = IPTR(25) + NBITS - IBUF = (MWDBIT - NBITS) / 8 - IF (IBUF.GT.0) THEN - DO 1750 MP = 1, IBUF - IDATA = IDATA * 256 + 32 - 1750 CONTINUE - END IF -C CONVERTS ASCII TO EBCIDIC -C COMMENT OUT IF NOT IBM370 COMPUTER - IF (IPTR(37).EQ.0) THEN - CALL W3AI39 (IDATA,IPTR(45)) - END IF - MSTACK(1,KPRM) = JDESC - MSTACK(2,KPRM) = 0 - KDATA(N,KPRM) = IDATA -C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM) -C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS - END IF -C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM) -C1800 FORMAT (2X,I4,2X,3A4) - 1900 CONTINUE - - IPTR(24) = IPTR(24) + IPTR(40) / 4 - 1 - IF (MOD(IPTR(40),4).NE.0) IPTR(24) = IPTR(24) + 1 - END IF - IPTR(18) = 0 -C --------------------------- - ELSE IF (LX.EQ.6) THEN -C SKIP NEXT DESCRIPTOR -C SET TO PASS OVER DESCRIPTOR AND DATA -C IF DESCRIPTOR NOT IN TABLE B - IPTR(36) = LY -C PRINT *,'SET TO SKIP',LY,' BIT FIELD' - IPTR(31) = IPTR(31) + 1 - KPRM = IPTR(31) + IPTR(24) - MSTACK(1,KPRM) = 34304 + LY - MSTACK(2,KPRM) = 0 - ELSE - IPTR(1) = 5 - ENDIF - RETURN - END - SUBROUTINE FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8807 PROCESS QUEUE DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-09-01 -C -C ABSTRACT: SUBSTITUTE DESCRIPTOR QUEUE FOR QUEUE DESCRIPTOR -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C 91-04-17 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS -C 91-05-28 CAVANAUGH IMPROVED HANDLING OF NESTED QUEUE DESCRIPTORS -C BASED ON TESTS WITH LIVE DATA. -C -C USAGE: CALL FI8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD) -C INPUT ARGUMENT LIST: -C IWORK - WORKING DESCRIPTOR LIST -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C LAST - INDEX TO LAST DESCRIPTOR -C ITBLD - ARRAY CONTAINING DESCRIPTOR QUEUES -C JDESC - QUEUE DESCRIPTOR TO BE EXPANDED -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ISTACK - SEE ABOVE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - NONE -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C .................................................. -C -C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE -C - INTEGER ITBLD2(20,*) -C .................................................. -C -C NEW BASE TABLE D -C - INTEGER ITBLD(20,*) -C .................................................. -C - INTEGER IPTR(*),JDESC,KPTRD(*) - INTEGER IWORK(*),IHOLD(15000) -C - SAVE -C PRINT *,' FI8807 F3 ENTRY',IPTR(11),IPTR(12) -C SET FOR BINARY SEARCH IN TABLE D - JLO = 1 - JHI = IPTR(20) -C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC,IPTR(11),IPTR(12) -C - JMID = KPTRD(MOD(JDESC,16384)) - IF (JMID.LT.0) THEN - IPTR(1) = 4 - RETURN - END IF -C HAVE TABLE D MATCH -C PRINT *,'D ',(ITBLD(LL,JMID),LL=1,20) -C PRINT *,'TABLE D TO IHOLD' - IK = 0 - JK = 0 - DO 200 KI = 2, 20 - IF (ITBLD(KI,JMID).NE.0) THEN - IK = IK + 1 - IHOLD(IK) = ITBLD(KI,JMID) -C PRINT *,IK,IHOLD(IK) - ELSE - GO TO 300 - END IF - 200 CONTINUE - 300 CONTINUE - KK = IPTR(11) - IF (KK.GT.IPTR(12)) THEN -C NOTHING MORE TO APPEND -C PRINT *,'NOTHING MORE TO APPEND' - ELSE -C APPEND TRAILING IWORK TO IHOLD -C PRINT *,'APPEND FROM ',KK,' TO',IPTR(12) - DO 500 I = KK, IPTR(12) - IK = IK + 1 - IHOLD(IK) = IWORK(I) - 500 CONTINUE - END IF -C RESET IHOLD TO IWORK -C PRINT *,' RESET IWORK STACK' - KK = IPTR(11) - 2 - DO 1000 I = 1, IK - KK = KK + 1 - IWORK(KK) = IHOLD(I) - 1000 CONTINUE - IPTR(12) = KK -C PRINT *,' FI8807 F3 EXIT ',IPTR(11),IPTR(12) -C DO 2000 I = 1, IPTR(12) -C PRINT *,'EXIT IWORK',I,IWORK(I) -C2000 CONTINUE -C RESET POINTERS - IPTR(11) = IPTR(11) - 1 - RETURN - END -C ----------------------------------------------------- - SUBROUTINE FI8808(IPTR,IWORK,LF,LX,LY,JDESC) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8808 -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 89-01-17 -C -C ABSTRACT: -C -C PROGRAM HISTORY LOG: -C 88-09-01 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8808(IPTR,IWORK,LF,LX,LY,JDESC) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IWORK - WORKING DESCRIPTOR LIST -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IPTR - SEE ABOVE -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC - SAVE -C -C PRINT *,' FI8808 NEW DESCRIPTOR PICKUP' - JDESC = IWORK(IPTR(11)) - LY = MOD(JDESC,256) - IPTR(34) = LY - LX = MOD((JDESC/256),64) - IPTR(33) = LX - LF = JDESC / 16384 - IPTR(32) = LF -C PRINT *,' TEST DESCRIPTOR',LF,LX,LY,' AT',IPTR(11) - IPTR(11) = IPTR(11) + 1 - RETURN - END - SUBROUTINE FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8809 REFORMAT PROFILER W HGT INCREMENTS -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 90-02-14 -C -C ABSTRACT: REFORMAT DECODED PROFILER DATA TO SHOW HEIGHTS INSTEAD OF -C HEIGHT INCREMENTS. -C -C PROGRAM HISTORY LOG: -C 90-02-14 CAVANAUGH -C -C USAGE: CALL FI8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM -C BUFR MESSAGE - -C IDENT(1) -EDITION NUMBER (BYTE 4, SECTION 1) -C IDENT(2) -ORIGINATING CENTER (BYTES 5-6, SECTION 1) -C IDENT(3) -UPDATE SEQUENCE (BYTE 7, SECTION 1) -C IDENT(4) - (BYTE 8, SECTION 1) -C IDENT(5) -BUFR MESSAGE TYPE (BYTE 9, SECTION 1) -C IDENT(6) -BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) -C IDENT(7) - (BYTES 11-12, SECTION 1) -C IDENT(8) -YEAR OF CENTURY (BYTE 13, SECTION 1) -C IDENT(9) -MONTH OF YEAR (BYTE 14, SECTION 1) -C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) -C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) -C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) -C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) -C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) -C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) -C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) -C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C KSET2 - INTERIM DATA ARRAY -C KPROFL - INTERIM DESCRIPTOR ARRAY -C IPTR - SEE W3FI88 -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT FILES: -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C ---------------------------------------------------------------- -C - INTEGER ISW - INTEGER IDENT(*),KDATA(MAXR,MAXD) - INTEGER MSTACK(2,MAXD),IPTR(*) - INTEGER KPROFL(1700) - INTEGER KPROF2(1700) - INTEGER KSET2(1700) -C -C ---------------------------------------------------------- - SAVE -C PRINT *,'FI8809' -C LOOP FOR NUMBER OF SUBSETS/REPORTS - DO 3000 I = 1, IDENT(14) -C INIT FOR DATA INPUT ARRAY - MK = 1 -C INIT FOR DESC OUTPUT ARRAY - JK = 0 -C LOCATION - ISW = 0 - DO 200 J = 1, 3 -C LATITUDE - IF (MSTACK(1,MK).EQ.1282) THEN - ISW = ISW + 1 - GO TO 100 -C LONGITUDE - ELSE IF (MSTACK(1,MK).EQ.1538) THEN - ISW = ISW + 2 - GO TO 100 -C HEIGHT ABOVE SEA LEVEL - ELSE IF (MSTACK(1,MK).EQ.1793) THEN - IHGT = KDATA(I,MK) - ISW = ISW + 4 - GO TO 100 - END IF - GO TO 200 - 100 CONTINUE - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 - 200 CONTINUE - IF (ISW.NE.7) THEN - PRINT *,'LOCATION ERROR PROCESSING PROFILER' - IPTR(1) = 200 - RETURN - END IF -C TIME - ISW = 0 - DO 400 J = 1, 7 -C YEAR - IF (MSTACK(1,MK).EQ.1025) THEN - ISW = ISW + 1 - GO TO 300 -C MONTH - ELSE IF (MSTACK(1,MK).EQ.1026) THEN - ISW = ISW + 2 - GO TO 300 -C DAY - ELSE IF (MSTACK(1,MK).EQ.1027) THEN - ISW = ISW + 4 - GO TO 300 -C HOUR - ELSE IF (MSTACK(1,MK).EQ.1028) THEN - ISW = ISW + 8 - GO TO 300 -C MINUTE - ELSE IF (MSTACK(1,MK).EQ.1029) THEN - ISW = ISW + 16 - GO TO 300 -C TIME SIGNIFICANCE - ELSE IF (MSTACK(1,MK).EQ.2069) THEN - ISW = ISW + 32 - GO TO 300 - ELSE IF (MSTACK(1,MK).EQ.1049) THEN - ISW = ISW + 64 - GO TO 300 - END IF - GO TO 400 - 300 CONTINUE - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 - 400 CONTINUE - IF (ISW.NE.127) THEN - PRINT *,'TIME ERROR PROCESSING PROFILER',ISW - IPTR(1) = 201 - RETURN - END IF -C SURFACE DATA - KRG = 0 - ISW = 0 - DO 600 J = 1, 10 -C WIND SPEED - IF (MSTACK(1,MK).EQ.2818) THEN - ISW = ISW + 1 - GO TO 500 -C WIND DIRECTION - ELSE IF (MSTACK(1,MK).EQ.2817) THEN - ISW = ISW + 2 - GO TO 500 -C PRESS REDUCED TO MSL - ELSE IF (MSTACK(1,MK).EQ.2611) THEN - ISW = ISW + 4 - GO TO 500 -C TEMPERATURE - ELSE IF (MSTACK(1,MK).EQ.3073) THEN - ISW = ISW + 8 - GO TO 500 -C RAINFALL RATE - ELSE IF (MSTACK(1,MK).EQ.3342) THEN - ISW = ISW + 16 - GO TO 500 -C RELATIVE HUMIDITY - ELSE IF (MSTACK(1,MK).EQ.3331) THEN - ISW = ISW + 32 - GO TO 500 -C 1ST RANGE GATE OFFSET - ELSE IF (MSTACK(1,MK).EQ.1982.OR. - * MSTACK(1,MK).EQ.1983) THEN -C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE -C VALUE FOR LATER USE - IF (MSTACK(1,MK).EQ.1983) THEN - IHGT = KDATA(I,MK) - MK = MK + 1 - KRG = 1 - ELSE - IF (KRG.EQ.0) THEN - INCRHT = KDATA(I,MK) - MK = MK + 1 - KRG = 1 -C PRINT *,'INITIAL INCR =',INCRHT - ELSE - LHGT = 500 + IHGT - KDATA(I,MK) - ISW = ISW + 64 -C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT - END IF - END IF -C MODE #1 - ELSE IF (MSTACK(1,MK).EQ.8128) THEN - ISW = ISW + 128 - GO TO 500 -C MODE #2 - ELSE IF (MSTACK(1,MK).EQ.8129) THEN - ISW = ISW + 256 - GO TO 500 - END IF - GO TO 600 - 500 CONTINUE -C SAVE DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) -C IF (I.EQ.1) THEN -C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) -C END IF - MK = MK + 1 - 600 CONTINUE - IF (ISW.NE.511) THEN - PRINT *,'SURFACE ERROR PROCESSING PROFILER',ISW - IPTR(1) = 202 - RETURN - END IF -C 43 LEVELS - DO 2000 L = 1, 43 - 2020 CONTINUE - ISW = 0 -C HEIGHT INCREMENT - IF (MSTACK(1,MK).EQ.1982) THEN -C PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK) - INCRHT = KDATA(I,MK) - MK = MK + 1 - IF (LHGT.LT.(9250+IHGT)) THEN - LHGT = IHGT + 500 - INCRHT - ELSE - LHGT = IHGT + 9250 - INCRHT - END IF - END IF -C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA -C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE - LHGT = LHGT + INCRHT -C PRINT *,'LEVEL ',L,LHGT - IF (L.EQ.37) THEN - LHGT = LHGT + INCRHT - END IF - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = 1798 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DATA - KSET2(JK) = LHGT -C IF (I.EQ.10) THEN -C PRINT *,' ' -C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK) -C END IF - ISW = 0 - DO 800 J = 1, 9 - 750 CONTINUE - IF (MSTACK(1,MK).EQ.1982) THEN - GO TO 2020 -C U VECTOR VALUE - ELSE IF (MSTACK(1,MK).EQ.3008) THEN - ISW = ISW + 1 - IF (KDATA(I,MK).GE.2047) THEN - VECTU = 32767 - ELSE - VECTU = KDATA(I,MK) - END IF - MK = MK + 1 - GO TO 800 -C V VECTOR VALUE - ELSE IF (MSTACK(1,MK).EQ.3009) THEN - ISW = ISW + 2 - IF (KDATA(I,MK).GE.2047) THEN - VECTV = 32767 - ELSE - VECTV = KDATA(I,MK) - END IF - MK = MK + 1 -C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF -C DESCRIPTORS AND DATA - IF (IAND(ISW,1).NE.0) THEN - IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DD DATA - KSET2(JK) = 32767 -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 -C SAVE SCALE - KPROF2(JK) = 1 -C SAVE FFF DATA - KSET2(JK) = 32767 - ELSE -C GENERATE DDFFF - CALL W3FC05 (VECTU,VECTV,DIR,SPD) - NDIR = DIR - SPD = SPD - NSPD = SPD -C PRINT *,' ',NDIR,NSPD -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DD DATA - KSET2(JK) = DIR -C IF (I.EQ.1) THEN -C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK) -C END IF -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 -C SAVE SCALE - KPROF2(JK) = 1 -C SAVE FFF DATA - KSET2(JK) = SPD -C IF (I.EQ.1) THEN -C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK) -C END IF - END IF - END IF - GO TO 800 -C W VECTOR VALUE - ELSE IF (MSTACK(1,MK).EQ.3010) THEN - ISW = ISW + 4 - GO TO 700 -C Q/C TEST RESULTS - ELSE IF (MSTACK(1,MK).EQ.8130) THEN - ISW = ISW + 8 - GO TO 700 -C U,V QUALITY IND - ELSE IF(IAND(ISW,16).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN - ISW = ISW + 16 - GO TO 700 -C W QUALITY IND - ELSE IF(IAND(ISW,32).EQ.0.AND.MSTACK(1,MK).EQ.2070) THEN - ISW = ISW + 32 - GO TO 700 -C SPECTRAL PEAK POWER - ELSE IF (MSTACK(1,MK).EQ.5568) THEN - ISW = ISW + 64 - GO TO 700 -C U,V VARIABILITY - ELSE IF (MSTACK(1,MK).EQ.3011) THEN - ISW = ISW + 128 - GO TO 700 -C W VARIABILITY - ELSE IF (MSTACK(1,MK).EQ.3013) THEN - ISW = ISW + 256 - GO TO 700 - ELSE IF ((MSTACK(1,MK)/16384).NE.0) THEN - MK = MK + 1 - GO TO 750 - END IF - GO TO 800 - 700 CONTINUE - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 -C IF (I.EQ.1) THEN -C PRINT *,' ',JK,KPROFL(JK),KSET2(JK) -C END IF - 800 CONTINUE - IF (ISW.NE.511) THEN - PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW - IPTR(1) = 203 - RETURN - END IF - 2000 CONTINUE -C MOVE DATA BACK INTO KDATA ARRAY - DO 4000 LL = 1, JK - KDATA(I,LL) = KSET2(LL) - 4000 CONTINUE - 3000 CONTINUE -C PRINT *,'REBUILT ARRAY' - DO 5000 LL = 1, JK -C DESCRIPTOR - MSTACK(1,LL) = KPROFL(LL) -C SCALE - MSTACK(2,LL) = KPROF2(LL) -C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7) - 5000 CONTINUE -C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY - IPTR(31) = JK - RETURN - END - SUBROUTINE FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8810 REFORMAT PROFILER EDITION 2 DATA -C PRGMMR: KEYSER ORG: NP22 DATE: 1995-06-07 -C -C ABSTRACT: REFORMAT PROFILER DATA IN EDITION 2 -C -C PROGRAM HISTORY LOG: -C 1993-01-27 CAVANAUGH -C 1995-06-07 KEYSER A CORRECTION WAS MADE TO PREVENT -C UNNECESSARY LOOPING WHEN ALL REQUESTED -C DESCRIPTORS ARE MISSING. -C -C USAGE: CALL FI8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD) -C INPUT ARGUMENT LIST: -C IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM -C BUFR MESSAGE - -C IDENT(1) -EDITION NUMBER (BYTE 4, SECTION 1) -C IDENT(2) -ORIGINATING CENTER (BYTES 5-6, SECTION 1) -C IDENT(3) -UPDATE SEQUENCE (BYTE 7, SECTION 1) -C IDENT(4) - (BYTE 8, SECTION 1) -C IDENT(5) -BUFR MESSAGE TYPE (BYTE 9, SECTION 1) -C IDENT(6) -BUFR MSG SUB-TYPE (BYTE 10, SECTION 1) -C IDENT(7) - (BYTES 11-12, SECTION 1) -C IDENT(8) -YEAR OF CENTURY (BYTE 13, SECTION 1) -C IDENT(9) -MONTH OF YEAR (BYTE 14, SECTION 1) -C IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1) -C IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1) -C IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1) -C IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1) -C IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3) -C IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3) -C IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3) -C MSTACK - WORKING DESCRIPTOR LIST AND SCALING FACTOR -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C KSET2 - INTERIM DATA ARRAY -C KPROFL - INTERIM DESCRIPTOR ARRAY -C IPTR - SEE W3FI88 -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C -C OUTPUT FILES: -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - INTEGER ISW - INTEGER IDENT(*),KDATA(MAXR,MAXD) - INTEGER MSTACK(2,MAXD),IPTR(*) - INTEGER KPROFL(1700) - INTEGER KPROF2(1700) - INTEGER KSET2(1700) -C - SAVE -C LOOP FOR NUMBER OF SUBSETS - DO 3000 I = 1, IDENT(14) - MK = 1 - JK = 0 - ISW = 0 -C PRINT *,'IDENTIFICATION' - DO 200 J = 1, 5 - IF (MSTACK(1,MK).EQ.257) THEN -C BLOCK NUMBER - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.258) THEN -C STATION NUMBER - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.1282) THEN -C LATITUDE - ISW = ISW + 4 - ELSE IF (MSTACK(1,MK).EQ.1538) THEN -C LONGITUDE - ISW = ISW + 8 - ELSE IF (MSTACK(1,MK).EQ.1793) THEN -C HEIGHT OF STATION - ISW = ISW + 16 - IHGT = KDATA(I,MK) - ELSE - MK = MK + 1 - GO TO 200 - END IF - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) - KPROF2(JK) = MSTACK(2,MK) - KSET2(JK) = KDATA(I,MK) -C PRINT *,JK,KPROFL(JK),KSET2(JK) - MK = MK + 1 - 200 CONTINUE -C PRINT *,'LOCATION ',ISW - IF (ISW.NE.31) THEN - PRINT *,'LOCATION ERROR PROCESSING PROFILER' - IPTR(10) = 200 - RETURN - END IF -C PROCESS TIME ELEMENTS - ISW = 0 - DO 400 J = 1, 7 - IF (MSTACK(1,MK).EQ.1025) THEN -C YEAR - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.1026) THEN -C MONTH - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.1027) THEN -C DAY - ISW = ISW + 4 - ELSE IF (MSTACK(1,MK).EQ.1028) THEN -C HOUR - ISW = ISW + 8 - ELSE IF (MSTACK(1,MK).EQ.1029) THEN -C MINUTE - ISW = ISW + 16 - ELSE IF (MSTACK(1,MK).EQ.2069) THEN -C TIME SIGNIFICANCE - ISW = ISW + 32 - ELSE IF (MSTACK(1,MK).EQ.1049) THEN -C TIME DISPLACEMENT - ISW = ISW + 64 - ELSE - MK = MK + 1 - GO TO 400 - END IF - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) - KPROF2(JK) = MSTACK(2,MK) - KSET2(JK) = KDATA(I,MK) -C PRINT *,JK,KPROFL(JK),KSET2(JK) - MK = MK + 1 - 400 CONTINUE -C PRINT *,'TIME ',ISW - IF (ISW.NE.127) THEN - PRINT *,'TIME ERROR PROCESSING PROFILER' - IPTR(1) = 201 - RETURN - END IF -C SURFACE DATA - ISW = 0 -C PRINT *,'SURFACE' - DO 600 K = 1, 8 -C PRINT *,MK,MSTACK(1,MK),JK,ISW - IF (MSTACK(1,MK).EQ.2817) THEN - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.2818) THEN - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.2611) THEN - ISW = ISW + 4 - ELSE IF (MSTACK(1,MK).EQ.3073) THEN - ISW = ISW + 8 - ELSE IF (MSTACK(1,MK).EQ.3342) THEN - ISW = ISW + 16 - ELSE IF (MSTACK(1,MK).EQ.3331) THEN - ISW = ISW + 32 - ELSE IF (MSTACK(1,MK).EQ.1797) THEN - INCRHT = KDATA(I,MK) - ISW = ISW + 64 -C PRINT *,'INITIAL INCREMENT = ',INCRHT - MK = MK + 1 -C PRINT *,JK,KPROFL(JK),KSET2(JK),' ISW=',ISW - GO TO 600 - ELSE IF (MSTACK(1,MK).EQ.6433) THEN - ISW = ISW + 128 - END IF - JK = JK + 1 - KPROFL(JK) = MSTACK(1,MK) - KPROF2(JK) = MSTACK(2,MK) - KSET2(JK) = KDATA(I,MK) -C PRINT *,JK,KPROFL(JK),KSET2(JK),'ISW=',ISW - MK = MK + 1 - 600 CONTINUE - IF (ISW.NE.255) THEN - PRINT *,'ERROR PROCESSING PROFILER',ISW - IPTR(1) = 204 - RETURN - END IF - IF (MSTACK(1,MK).NE.1797) THEN - PRINT *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER' - IPTR(1) = 205 - RETURN - END IF -C MUST SAVE THIS HEIGHT VALUE - LHGT = 500 + IHGT - KDATA(I,MK) -C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT - MK = MK + 1 - IF (MSTACK(1,MK).GE.16384) THEN - MK = MK + 1 - END IF -C PROCESS LEVEL DATA -C PRINT *,'LEVEL DATA' - DO 2000 L = 1, 43 - 2020 CONTINUE -C PRINT *,'DESC',MK,MSTACK(1,MK),JK - ISW = 0 -C HEIGHT INCREMENT - IF (MSTACK(1,MK).EQ.1797) THEN - INCRHT = KDATA(I,MK) -C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT - MK = MK + 1 -C IF (LHGT.LT.(9250+IHGT)) THEN -C LHGT = IHGT + 500 - INCRHT -C ELSE -C LHGT = IHGT + 9250 -INCRHT -C END IF - END IF -C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA -C AT THIS POINT - LHGT = LHGT + INCRHT -C PRINT *,'LEVEL ',L,LHGT -C IF (L.EQ.37) THEN -C LHGT = LHGT + INCRHT -C END IF - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = 1798 -C SAVE SCALE - KPROF2(JK) = 0 -C SAVE DATA - KSET2(JK) = LHGT -C PRINT *,KPROFL(JK),KSET2(JK),JK - ISW = 0 - ICON = 1 - DO 800 J = 1, 10 -750 CONTINUE - IF (MSTACK(1,MK).EQ.1797) THEN - GO TO 2020 - ELSE IF (MSTACK(1,MK).EQ.6432) THEN -C HI/LO MODE - ISW = ISW + 1 - ELSE IF (MSTACK(1,MK).EQ.6434) THEN -C Q/C TEST - ISW = ISW + 2 - ELSE IF (MSTACK(1,MK).EQ.2070) THEN - IF (ICON.EQ.1) THEN -C FIRST PASS - U,V CONSENSUS - ISW = ISW + 4 - ICON = ICON + 1 - ELSE -C SECOND PASS - W CONSENSUS - ISW = ISW + 64 - END IF - ELSE IF (MSTACK(1,MK).EQ.2819) THEN -C U VECTOR VALUE - ISW = ISW + 8 - IF (KDATA(I,MK).GE.2047) THEN - VECTU = 32767 - ELSE - VECTU = KDATA(I,MK) - END IF - MK = MK + 1 - GO TO 800 - ELSE IF (MSTACK(1,MK).EQ.2820) THEN -C V VECTOR VALUE - ISW = ISW + 16 - IF (KDATA(I,MK).GE.2047) THEN - VECTV = 32767 - ELSE - VECTV = KDATA(I,MK) - END IF - IF (IAND(ISW,1).NE.0) THEN - IF (VECTU.EQ.32767.OR.VECTV.EQ.32767) THEN -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 - KPROF2(JK) = 0 - KSET2(JK) = 32767 -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 - KPROF2(JK) = 1 - KSET2(JK) = 32767 - ELSE - CALL W3FC05 (VECTU,VECTV,DIR,SPD) - NDIR = DIR - SPD = SPD - NSPD = SPD -C PRINT *,' ',NDIR,NSPD -C SAVE DD DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2817 - KPROF2(JK) = 0 - KSET2(JK) = NDIR -C IF (I.EQ.1) THEN -C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK) -C ENDIF -C SAVE FFF DESCRIPTOR - JK = JK + 1 - KPROFL(JK) = 2818 - KPROF2(JK) = 1 - KSET2(JK) = NSPD -C IF (I.EQ.1) THEN -C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK) -C ENDIF - END IF - MK = MK + 1 - GO TO 800 - END IF - ELSE IF (MSTACK(1,MK).EQ.2866) THEN -C SPEED STD DEVIATION - ISW = ISW + 32 -C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568 - ELSE IF (MSTACK(1,MK).EQ.5568) THEN -C SIGNAL POWER - ISW = ISW + 128 - ELSE IF (MSTACK(1,MK).EQ.2822) THEN -C W COMPONENT - ISW = ISW + 256 - ELSE IF (MSTACK(1,MK).EQ.2867) THEN -C VERT STD DEVIATION - ISW = ISW + 512 -CVVVVVCHANGE#1 FIX BY KEYSER -- 12/06/1994 -C NOTE: THIS FIX PREVENTS UNNECESSARY LOOPING WHEN ALL REQ. DESCR. -C ARE MISSING. WOULD GO INTO INFINITE LOOP EXCEPT EVENTUALLY -C MSTACK ARRAY SIZE IS EXCEEDED AND GET FORTRAN ERROR INTERRUPT -CDAK ELSE - ELSE IF ((MSTACK(1,MK)/16384).NE.0) THEN -CAAAAACHANGE#1 FIX BY KEYSER -- 12/06/1994 - MK = MK + 1 - GO TO 750 - END IF - JK = JK + 1 -C SAVE DESCRIPTOR - KPROFL(JK) = MSTACK(1,MK) -C SAVE SCALE - KPROF2(JK) = MSTACK(2,MK) -C SAVE DATA - KSET2(JK) = KDATA(I,MK) - MK = MK + 1 -C PRINT *,L,'TEST ',JK,KPROFL(JK),KSET2(JK) - 800 CONTINUE - IF (ISW.NE.1023) THEN - PRINT *,'LEVEL ERROR PROCESSING PROFILER',ISW - IPTR(1) = 202 - RETURN - END IF - 2000 CONTINUE -C MOVE DATA BACK INTO KDATA ARRAY - DO 5000 LL = 1, JK -C DATA - KDATA(I,LL) = KSET2(LL) - 5000 CONTINUE - 3000 CONTINUE - DO 5005 LL = 1, JK -C DESCRIPTOR - MSTACK(1,LL) = KPROFL(LL) -C SCALE - MSTACK(2,LL) = KPROF2(LL) -C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP -C PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4) - 5005 CONTINUE - IPTR(31) = JK - RETURN - END - SUBROUTINE FI8811(IPTR,IDENT,MSTACK,KDATA,KNR, - * LDATA,LSTACK,MAXD,MAXR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8811 EXPAND DATA/DESCRIPTOR REPLICATION -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-05-12 -C -C ABSTRACT: EXPAND DATA AND DESCRIPTOR STRINGS -C -C PROGRAM HISTORY LOG: -C 93-05-12 CAVANAUGH -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8811(IPTR,IDENT,MSTACK,KDATA,KNR, -C * LDATA,LSTACK,MAXD,MAXR) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IDENT - SEE W3FI88 ROUTINE DOCBLOCK -C MAXR - MAXIMUM NUMBER OF REPORTS/SUBSETS THAT MAY BE -C CONTAINED IN A BUFR MESSAGE -C MAXD - MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT -C MAY BE PROCESSED; UPPER AIR DATA AND SOME SATELLITE -C DATA REQUIRE A VALUE FOR MAXD OF 1700, BUT FOR MOST -C OTHER DATA A VALUE FOR MAXD OF 500 WILL SUFFICE -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - -C -C REMARKS: ERROR RETURN: -C IPTR(1) = -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ - INTEGER IPTR(*) - INTEGER KNR(MAXR) - INTEGER KDATA(MAXR,MAXD),LDATA(MAXD) - INTEGER MSTACK(2,MAXD),LSTACK(2,MAXD) - INTEGER IDENT(*) -C - SAVE -C -C PRINT *,' DATA/DESCRIPTOR REPLICATION ' - DO 1000 I = 1, KNR(1) -C IF NOT REPLICATION DESCRIPTOR - IF ((MSTACK(1,I)/16384).NE.1) THEN - GO TO 1000 - END IF -C IF DELAYED REPLICATION DESCRIPTOR - IF (MOD(MSTACK(1,I),256).EQ.0) THEN -C SAVE KX VALUE (NR DESC'S TO REPLICATE) - KX = MOD((MSTACK(1,I)/256),64) -C IF NEXT DESC IS NOT 7947 OR 7948 -C (I.E., 0 31 011 OR 0 31 012) - IF (MSTACK(1,I+1).NE.7947.AND.MSTACK(1,I+1).NE.7948) THEN -C SKIP IT - GO TO 1000 - END IF -C GET NR REPS FROM KDATA - NRREPS = KDATA(1,I+1) - LAST = I + 1 + KX -C SAVE OFF TRAILING DESCS AND DATA - KTRAIL = KNR(1) - I - 1 - KX - DO 100 L = 1, KTRAIL - NX = I + L + KX + 1 - LDATA(L) = KDATA(1,NX) - LSTACK(1,L) = MSTACK(1,NX) - LSTACK(2,L) = MSTACK(2,NX) - 100 CONTINUE -C INSERT FX DESCS/DATA NR REPS TIMES - LAST = I + 1 - DO 400 J = 1, NRREPS - NX = I + 2 - DO 300 K = 1, KX - LAST = LAST + 1 - KDATA(1,LAST) = KDATA(1,NX) - MSTACK(1,LAST) = MSTACK(1,NX) - MSTACK(2,LAST) = MSTACK(2,NX) - NX = NX + 1 - 300 CONTINUE - - 400 CONTINUE -C RESTORE TRAILING DATA/DESCS - DO 500 L = 1, KTRAIL - LAST = LAST + 1 - KDATA(1,LAST) = LDATA(L) - MSTACK(1,LAST) = LSTACK(1,L) - MSTACK(2,LAST) = LSTACK(2,L) - 500 CONTINUE -C RESET KNR(1) - KNR(1) = LAST - END IF - 1000 CONTINUE - RETURN - END - SUBROUTINE FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD, - * IRF1SW,NEWREF,ITBLD,ITBLD2, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8812 BUILD TABLE B SUBSET BASED ON BUFR SEC 3 -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-23 -C -C ABSTRACT: BUILD A SUBSET OF TABLE B ENTRIES THAT CORRESPOND TO -C THE DESCRIPTORS NEEDED FOR THIS MESSAGE -C -C PROGRAM HISTORY LOG: -C 93-05-12 CAVANAUGH -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD, -C * IRF1SW,NEWREF,ITBLD,ITBLD2, -C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, -C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2) -C INPUT ARGUMENT LIST: -C IPTR - SEE W3FI88 ROUTINE DOCBLOCK -C IDENT - SEE W3FI88 ROUTINE DOCBLOCK -C ISTACK - LIST OF DESCRIPTORS AND SCALE VALUES -C IUNITB - -C IUNITD - -C ISTACK - -C NRDESC - -C KFXY2 - -C ANAME2 - -C AUNIT2 - -C ISCAL2 - -C IRFVL2 - -C IWIDE2 - -C IRF1SW - -C NEWREF - -C ITBLD2 - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE. -C KDATA(REPORT NUMBER,PARAMETER NUMBER) -C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT -C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT -C ARGUMENT MAXD) -C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES -C KFXY1 - -C ANAME1 - -C AUNIT1 - -C ISCAL1 - -C IRFVL1 - -C IWIDE1 - -C ITBLD - -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - -C -C REMARKS: ERROR RETURN: -C IPTR(1) = -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C - INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) - CHARACTER*40 ANAME1(*) - CHARACTER*24 AUNIT1(*) -C .................................................. -C -C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE -C - INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*) - CHARACTER*64 ANAME2(*) - CHARACTER*24 AUNIT2(*) -C .................................................. -C -C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE -C - INTEGER ITBLD2(20,*) -C .................................................. -C -C NEW BASE TABLE D -C - INTEGER ITBLD(20,*) -C .................................................. - INTEGER IPTR(*),ISTACK(*),NRDESC,NWLIST(200) - INTEGER NEWREF(*),KPTRB(*),KPTRD(*) - INTEGER IUNITB,IUNITD,ICOPY(20000),NRCOPY,IELEM,IPOS - CHARACTER*64 AHLD64 - CHARACTER*24 AHLD24 -C - SAVE -C -C SCAN AND DISCARD REPLICATION AND OPERATOR DESCRIPTORS -C REPLACING SEQUENCE DESCRIPTORS WITH THEIR CORRESPONDING -C SET OF DESCRIPTORS ALSO ELIMINATING DUPLICATES. -C -C----------------------------------------------------------- -C PRINT *,'ENTER FI8812' -C - DO 10 I = 1, 16384 - KPTRB(I) = -1 - 10 CONTINUE -C -C -C - IF (IPTR(14).NE.0) THEN - DO I = 1, IPTR(14) - KPTRB(KFXY1(I)) = I - ENDDO - GO TO 9000 - END IF -C -C READ IN TABLE B - PRINT *,'FI8812 - READING TABLE B' - REWIND IUNITB - I = 1 - 4000 CONTINUE -C - READ(UNIT=IUNITB,FMT=20,ERR=9999,END=9000)MF, - * MX,MY, - * (ANAME1(I)(K:K),K=1,40), - * (AUNIT1(I)(K:K),K=1,24), - * ISCAL1(I),IRFVL1(1,I),IWIDE1(I) - 20 FORMAT(I1,I2,I3,40A1,24A1,I5,I15,1X,I4) - KFXY1(I) = MF*16384 + MX*256 + MY -C PRINT *,MF,MX,MY,KFXY1(I) - 5000 CONTINUE - KPTRB(KFXY1(I)) = I - IPTR(14) = I -C PRINT *,I -C WRITE(6,21) MF,MX,MY,KFXY1(I), -C * (ANAME1(I)(K:K),K=1,40), -C * (AUNIT1(I)(K:K),K=1,24), -C * ISCAL1(I),IRFVL1(1,I),IWIDE1(I) - 21 FORMAT(1X,I1,I2,I3,1X,I6,1X,40A1, - * 2X,24A1,2X,I5,2X,I15,1X,I4) - I = I + 1 - GO TO 4000 -C ====================================================== - 9999 CONTINUE -C ERROR READING TABLE B - PRINT *,'FI8812 - ERROR READING TABLE B - RECORD ',I - IPTR(1) = 9 - 9000 CONTINUE - IPTR(21) = IPTR(14) -C PRINT *,'EXIT FI8812 - IPTR(21) =',IPTR(21),' IPTR(1) =',IPTR(1) - RETURN - END - SUBROUTINE FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,KPTRB, - * ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8813 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04 -C -C ABSTRACT: EXTRACT TABLE A, TABLE B, TABLE D ENTRIES FROM A -C DECODED BUFR MESSAGE. -C -C PROGRAM HISTORY LOG: -C 94-03-04 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD, -C * KPTRB,ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB) -C INPUT ARGUMENT LIST: -C IPTR -C MAXR -C MAXD -C MSTACK -C KDATA -C IDENT -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: -C IUNITB -C ITBLD1 -C ANAME1 -C AUNIT1 -C KFXY1 -C ISCAL1 -C IRFVL1 -C IWIDE1 -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS -C MACHINE: NAS, CYBER, WHATEVER -C -C$$$ -C .................................................. -C -C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE -C - INTEGER KFXY1(*),ISCAL1(*),IRFVL1(*),IWIDE1(*) - CHARACTER*40 ANAME1(*) - CHARACTER*24 AUNIT1(*) -C .................................................. -C -C TABLE D -C - INTEGER ITBLD(20,*) -C .................................................. - CHARACTER*32 SPACES - CHARACTER*8 ASCCHR - CHARACTER*32 AAAA -C - INTEGER I1(20),I2(20),I3(20),KPTRB(*) - INTEGER IPTR(*),MAXR,MAXD,MSTACK(2,MAXD) - INTEGER IXA, IXB, IXD, KDATA(MAXR,MAXD) - INTEGER IEXTRA,KPTRD(*) - INTEGER KEYSET,ISCSGN(200),IRFSGN(200) - INTEGER IDENT(*),IHOLD,JHOLD(8),IUNITB - EQUIVALENCE (IHOLD,ASCCHR),(JHOLD,AAAA) - SAVE - DATA SPACES/' '/ - DATA IEXTRA/0/ - DATA KEYSET/0/ - -C ============================================================== -C PRINT *,'FI8813',IPTR(41),IPTR(42),IPTR(31),IPTR(21) -C BUILD SPACE CONSTANT -C INITIALIZE ENTRY COUNTS - IXA = 0 -C NUMBER IN TABLE B - IXB = IPTR(21) -C -C -C SET FOR COMPRESSED OR NON COMPRESSED -C PROCESSING -C -C PRINT *,'FI8813 - 2',IDENT(16),IDENT(14) - IF (IDENT(16).EQ.0) THEN - JK = 1 - ELSE - JK = IDENT(14) - END IF -C PRINT *,'FI8813 - 3, JK=',JK -C -C -C START PROCESSING ENTRIES -C PRINT *,'START PROCESSING ENTRIES' -C -C DO 995 I = 1, IPTR(31) -C IF (IPTR(45).EQ.4) THEN -C PRINT 9958,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I) -C9958 FORMAT (1X,I5,2X,I5,2X,Z8,2X,A4) -C ELSE -C PRINT 9959,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I) -C9959 FORMAT (1X,I5,2X,I5,2X,Z16,2X,A8) -C END IF -C 995 CONTINUE -C PRINT *,' ' - I = 0 - IEXTRA = 0 - 1000 CONTINUE -C -C SET POINTER TO CORRECT DATA POSITION -C I IS THE NUMBER OF DESCRIPTORS -C IEXTRA IS THE NUMBER OF WORDS ADDED -C FOR TEXT DATA -C - I = I + 1 - IF (I.GT.IPTR(31)) THEN -C RETURN IF COMPLETED SEARCH - GO TO 9000 - END IF - KLK = I + IEXTRA -C PRINT *,'ENTRY',KLK,I,IPTR(31),IEXTRA,MSTACK(1,KLK) -C -C IF TABLE A ENTRY OR EDITION NUMBER -C OR IF DESCRIPTOR IS NOT IN CLASS 0 -C SKIP OVER -C - IF (MSTACK(1,KLK).EQ.1) THEN -C PRINT *,'A ENTRY' - GO TO 1000 - ELSE IF (MSTACK(1,KLK).EQ.2) THEN -C PRINT *,'A ENTRY LINE 1' - IEXTRA = IEXTRA + 32 / IPTR(45) - 1 - GO TO 1000 - ELSE IF (MSTACK(1,KLK).EQ.3) THEN -C PRINT *,'A ENTRY LINE 2' - IEXTRA = IEXTRA + 32 / IPTR(45) - 1 - GO TO 1000 - ELSE IF (MSTACK(1,KLK).GE.34048.AND.MSTACK(1,KLK).LE.34303) THEN - LY = MOD(MSTACK(1,KLK),256) -C PRINT *,'CLASS C - HAVE',LY,' BYTES OF TEXT' - IF (MOD(LY,IPTR(45)).EQ.0) THEN - IWDS = LY / IPTR(45) - ELSE - IWDS = LY / IPTR(45) + 1 - END IF - IEXTRA = IEXTRA + IWDS - 1 - GO TO 1000 - ELSE IF (MSTACK(1,KLK).LT.10.OR.MSTACK(1,KLK).GT.255) THEN -C PRINT *,MSTACK(1,KLK),' NOT CLASS 0' - GO TO 1000 - END IF -C -C MUST FIND F X Y KEY FOR TABLE B -C OR TABLE D ENTRY -C - IZ = 1 - KEYSET = 0 - 10 CONTINUE - IF (I.GT.IPTR(31)) THEN - GO TO 9000 - END IF - KLK = I + IEXTRA - IF (MSTACK(1,KLK).GE.34048.AND.MSTACK(1,KLK).LE.34303) THEN - LY = MOD(MSTACK(1,KLK),256) -C PRINT *,'TABLE C - HAVE',LY,' TEXT BYTES' - IF (MOD(LY,4).EQ.0) THEN - IWDS = LY / IPTR(45) - ELSE - IWDS = LY / IPTR(45) + 1 - END IF - IEXTRA = IEXTRA + IWDS - 1 - I = I + 1 - GO TO 10 - ELSE IF (MSTACK(1,KLK)/16384.NE.0) THEN - IF (MOD(MSTACK(1,KLK),256).EQ.0) THEN - I = I + 1 - END IF - I = I + 1 - GO TO 10 - END IF - IF (MSTACK(1,KLK).GE.10.AND.MSTACK(1,KLK).LE.12) THEN -C PRINT *,'FIND KEY' -C -C MUST INCLUDE PROCESSING FOR COMPRESSED DATA -C -C BUILD DESCRIPTOR SEGMENT -C - IF (MSTACK(1,KLK).EQ.10) THEN - CALL FI8814 (KDATA(IZ,KLK),1,MF,IERR,IPTR) -C PRINT *,'F =',MF,KDATA(IZ,KLK),IPTR(31),I,IEXTRA - KEYSET = IOR(KEYSET,4) - ELSE IF (MSTACK(1,KLK).EQ.11) THEN - CALL FI8814 (KDATA(IZ,KLK),2,MX,IERR,IPTR) -C PRINT *,'X =',MX,KDATA(IZ1,KLK) - KEYSET = IOR(KEYSET,2) - ELSE IF (MSTACK(1,KLK).EQ.12) THEN - CALL FI8814 (KDATA(IZ,KLK),3,MY,IERR,IPTR) -C PRINT *,'Y =',MY,KDATA(IZ,KLK) - KEYSET = IOR(KEYSET,1) - END IF -C PRINT *,' KEYSET =',KEYSET - I = I + 1 - GO TO 10 - END IF - IF (KEYSET.EQ.7) THEN -C PRINT *,'HAVE KEY DESCRIPTOR',MF,MX,MY -C -C TEST NEXT DESCRIPTOR FOR TABLE B -C OR TABLE D ENTRY, PROCESS ACCORDINGLY -C - KLK = I + IEXTRA -C PRINT *,'DESC ',MSTACK(1,KLK),KLK,I,IEXTRA,KDATA(1,KLK) - IF (MSTACK(1,KLK).EQ.30) THEN - IXD = IPTR(20) + 1 - ITBLD(1,IXD) =16384 * MF + 256 * MX + MY -C PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD) - GO TO 300 - ELSE IF (MSTACK(1,KLK).GE.13.AND.MSTACK(1,KLK).LE.20) THEN - KFXY1(IXB+IZ) = 16384 * MF + 256 * MX + MY -C PRINT *,'ELEMENT DESCRIPTOR',MF,MX,MY,KFXY1(IXB+IZ),IXB+IZ - KPTRB(KFXY1(IXB+IZ)) = IXB+IZ - GO TO 200 - ELSE - END IF -C I = I + 1 -C IF (I.GT.IPTR(31)) THEN -C GO TO 9000 -C END IF -C GO TO 10 - END IF - GO TO 1000 -C ================================================================== - 200 CONTINUE - IBFLAG = 1 - 20 CONTINUE - KLK = I + IEXTRA -C PRINT *,'ZZZ',KLK,I,IEXTRA,MSTACK(1,KLK),KDATA(IZ,KLK) - IF (MSTACK(1,KLK).LT.13.OR.MSTACK(1,KLK).GT.20) THEN - PRINT *,'IMPROPER SEQUENCE OF DESCRIPTORS IN LIST' -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.13) THEN -C PRINT *,'13 NAME',KLK -C -C ELEMENT NAME PART 1 - 32 BYTES -C FOR THIS PARAMETER - JJ = IEXTRA - DO 21 LL = 1, 32, IPTR(45) - LLL = LL + IPTR(45) - 1 - KQK = I + JJ - IHOLD = KDATA(IZ,KQK) - IF (IPTR(37).EQ.0) THEN -C CALL W3AI39 (IDATA,IPTR(45)) - END IF - ANAME1(IXB+IZ)(LL:LLL) = ASCCHR - JJ = JJ + 1 - 21 CONTINUE - IEXTRA = IEXTRA + (32 / IPTR(45)) - 1 - IBFLAG = IOR(IBFLAG,64) -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.14) THEN -C PRINT *,'14 NAME2',KLK -C -C ELEMENT NAME PART 2 - 32 BYTES -C -C FOR THIS PARAMETER - JJ = IEXTRA - DO 22 LL = 33, 64, IPTR(45) - LLL = LL + IPTR(45) - 1 - KQK = I + JJ - IHOLD = KDATA(IZ,KQK) - IF (IPTR(37).EQ.0) THEN -C CALL W3AI39 (ASCCHR,IPTR(45)) - END IF - ANAME1(IXB+IZ)(LL:LLL) = ASCCHR - JJ = JJ + 1 - 22 CONTINUE - IEXTRA = IEXTRA + (32 / IPTR(45)) - 1 - IBFLAG = IOR(IBFLAG,32) -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.15) THEN -C PRINT *,'15 UNITS',KLK -C -C UNITS NAME - 24 BYTES -C -C FOR THIS PARAMETER - JJ = IEXTRA - DO 23 LL = 1, 24, IPTR(45) - LLL = LL + IPTR(45) - 1 - KQK = I + JJ - IHOLD = KDATA(IZ,KQK) - IF (IPTR(37).EQ.0) THEN -C CALL W3AI39 (ASCCHR,IPTR(45)) - END IF - AUNIT1(IXB+IZ)(LL:LLL) = ASCCHR - JJ = JJ + 1 - 23 CONTINUE - IEXTRA = IEXTRA + (24 / IPTR(45)) - 1 - IBFLAG = IOR(IBFLAG,16) -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.16) THEN -C PRINT *,'16 SCALE SIGN' -C -C SCALE SIGN - 1 BYTE -C 0 = POS, 1 = NEG - IHOLD = KDATA(IZ,KLK) - KLK = I + IEXTRA - IF (INDEX(ASCCHR,'-').EQ.0) THEN - ISCSGN(IZ) = 1 - ELSE - ISCSGN(IZ) = -1 - END IF -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.17) THEN -C PRINT *,'17 SCALE',KLK -C -C SCALE - 3 BYTES -C - KLK = I + IEXTRA - CALL FI8814(KDATA(IZ,KLK),3,ISCAL1(IXB+IZ),IERR,IPTR) - IF (IERR.NE.0) THEN - PRINT *,'NON-NUMERIC CHAR - CANNOT CONVERT' - IPTR(1) = 888 - GO TO 9000 - END IF - ISCAL1(IXB+IZ) = ISCAL1(IXB+IZ) * ISCSGN(IZ) - IBFLAG = IOR(IBFLAG,8) -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.18) THEN -C PRINT *,'18 REFERENCE SCALE',KLK -C -C REFERENCE SIGN - 1 BYTE -C 0 = POS, 1 = NEG -C - KLK = I + IEXTRA - IHOLD = KDATA(IZ,KLK) - IF (INDEX(ASCCHR,'-').EQ.0) THEN - IRFSGN(IZ) = 1 - ELSE - IRFSGN(IZ) = -1 - END IF -C =============================================================== - ELSE IF (MSTACK(1,KLK).EQ.19) THEN -C PRINT *,'19 REFERENCE VALUE',KLK -C -C REFERENCE VALUE - 10 BYTES/ 3 WDS -C - JJ = IEXTRA - KQK = I + JJ - KM = 0 - DO 26 LL = 1, 12, IPTR(45) - KQK = I + JJ - KM = KM + 1 - JHOLD(KM) = KDATA(IZ,KQK) - JJ = JJ + 1 - 26 CONTINUE - CALL FI8814(AAAA,10,IRFVL1(IXB+IZ),IERR,IPTR) - IF (IERR.NE.0) THEN - PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT' - IPTR(1) = 888 - GO TO 9000 - END IF - IRFVL1(IXB+IZ) = IRFVL1(IXB+IZ) * IRFSGN(IZ) - IEXTRA = IEXTRA + 10 / IPTR(45) -C DO 261 IZ = 1, JK -C PRINT *,'RFVAL',IXB+IZ,JK,IRFVL1(IXB+IZ) -C 261 CONTINUE - IBFLAG = IOR(IBFLAG,4) -C =============================================================== - ELSE -C PRINT *,'20 WIDTH',KLK -C -C ELEMENT DATA WIDTH - 3 BYTES -C -C DO 27 LL = 1, 24, IPTR(45) - KLK = I + IEXTRA -C DO 270 IZ = 1, JK - CALL FI8814(KDATA(IZ,KLK),3,IWIDE1(IXB+IZ),IERR,IPTR) - IF (IERR.NE.0) THEN - PRINT *,'NON-NUMERIC CHAR - CANNOT CONVERT' - IPTR(1) = 888 - GO TO 9000 - END IF - IF (IWIDE1(IXB+IZ).LT.1) THEN - IPTR(1) = 890 -C PRINT *,'CLASS 0 DESCRIPTOR, WIDTH=0',KFXY1(IXB+IZ) - GO TO 9000 - END IF -C 270 CONTINUE -C 27 CONTINUE - IBFLAG = IOR(IBFLAG,2) - END IF -C NO, IT ISN'T -C -C IF THERE ARE ENOUGH OF THE ELEMENTS -C NECESSARY TO ACCEPT A TABLE B ENTRY -C -C PRINT *,' IBFLAG =',IBFLAG - IF (IBFLAG.EQ.127) THEN -C PRINT *,'COMPLETE TABLE B ENTRY' -C HAVE A COMPLETE TABLE B ENTRY - IXB = IXB + 1 -C PRINT *,'B',IXB,JK,KFXY1(IXB),ANAME1(IXB) -C PRINT *,' ',AUNIT1(IXB),ISCAL1(IXB), -C * IRFVL1(IXB),IWIDE1(IXB) - IPTR(21) = IXB - GO TO 1000 - END IF - I = I + 1 -C -C CHECK NEXT DESCRIPTOR -C - IF (I.GT.IPTR(31)) THEN -C RETURN IF COMPLETED SEARCH - GO TO 9000 - END IF - GO TO 20 -C ================================================================== - 300 CONTINUE - ISEQ = 0 - IJK = IPTR(20) + 1 -C PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD),' FOR',IJK - 30 CONTINUE - KLK = I + IEXTRA -C PRINT *,'HAVE A SEQUENCE DESCRIPTOR',KLK,KDATA(IZ,KLK) - IF (MSTACK(1,KLK).EQ.30) THEN -C FROM TEXT FIELD (6 BYTES/2 WDS) -C STRIP OUT NEXT DESCRIPTOR IN SEQUENCE -C -C F - EXTRACT AND CONVERT TO DECIMAL - JJ = IEXTRA - KK = 0 - DO 351 LL = 1, 6, IPTR(45) - KQK = I + JJ - KK = KK + 1 - JHOLD(KK) = KDATA(1,KQK) - JJ = JJ + 1 - IF (LL.GT.1) IEXTRA = IEXTRA + 1 - 351 CONTINUE -C PRINT 349,KDATA(1,KQK) - 349 FORMAT (6X,Z24) -C CONVERT TO INTEGER - CALL FI8814(AAAA,6,IHOLD,IERR,IPTR) -C PRINT *,' ',IHOLD - IF (IERR.NE.0) THEN - PRINT *,'NON NUMERIC CHARACTER FOUND IN F X Y' - IPTR(1) = 888 - GO TO 9000 - END IF -C CONSTRUCT SEQUENCE DESCRIPTOR - IFF = IHOLD / 100000 - IXX = MOD((IHOLD/1300),100) - IYY = MOD(IHOLD,1300) -C INSERT IN PROPER SEQUENCE - ITBLD(ISEQ+2,IJK) = 16384 * IFF + 256 * IXX + IYY -C PRINT *,' SEQUENCE',IZ,AAAA,IHOLD,ITBLD(ISEQ+2,IJK), -C * IFF,IXX,IYY - ISEQ = ISEQ + 1 - IF (ISEQ.GT.18) THEN - IPTR(1) = 30 - RETURN - END IF -C SET TO LOOK AT NEXT DESCRIPTOR - I = I + 1 -C IF (IPTR(45).LT.6) THEN -C IEXTRA = IEXTRA + 1 -C END IF - GO TO 30 - ELSE -C NEXT DESCRIPTOR IS NOT A SEQUENCE DESCRIPTOR - IF (ISEQ.GE.1) THEN -C HAVE COMPLETE TABLE D ENTRY - IPTR(20) = IPTR(20) + 1 -C PRINT *,' INTO LOCATION ',IPTR(20) - LZ = ITBLD(1,IJK) - MZ = MOD(LZ,16384) - KPTRD(MZ) = IJK - I = I - 1 - END IF - END IF -C GO TEST NEXT DESCRIPTOR - GO TO 1000 -C ================================================================== - 9000 CONTINUE -C PRINT *,IPTR(21),' ENTRIES IN ANCILLARY TABLE B' -C PRINT *,IPTR(20),' ENTRIES IN ANCILLARY TABLE D' -C DO 9050 L = 1, 16384 -C IF (KPTRD(L).GT.0) PRINT *,' D',L+32768, KPTRD(L) -C9050 CONTINUE -C IF (I.GE.IPTR(31)) THEN -C -C FILE FOR MODIFIED TABLE B OUTPUT - NUMNUT = IUNITB + 1 - REWIND NUMNUT -C -C PRINT *,' HERE IS THE NEW TABLE B',IPTR(21) - DO 2000 KB = 1, IPTR(21) - JF = KFXY1(KB) / 16384 - JX = MOD((KFXY1(KB) / 256),64) - JY = MOD(KFXY1(KB),256) -C WRITE (6,2001)JF,JX,JY,ANAME1(KB), -C * AUNIT1(KB),ISCAL1(KB),IRFVL1(KB),IWIDE1(KB) - WRITE (NUMNUT,5000)JF,JX,JY,ANAME1(KB)(1:40), - * AUNIT1(KB)(1:24),ISCAL1(KB),IRFVL1(KB),IWIDE1(KB) - 5000 FORMAT(I1,I2,I3,A40,A24,I5,I15,I5) - 2000 CONTINUE - 2001 FORMAT (1X,I1,1X,I2,1X,I3,2X,A40,3X,A24,2X,I5,2X,I12, - * 2X,I4) -C - ENDFILE NUMNUT -C - IF (IPTR(20).NE.0) THEN -C PRINT OUT TABLE -C PRINT *,' HERE IS THE UPGRADED TABLE D' -C DO 3000 KB = 1, IPTR(20) -C PRINT 3001,KB,(ITBLD(K,KB),K=1,15) -C3000 CONTINUE -C3001 FORMAT (16(1X,I5)) - END IF -C EXIT ROUTINE, ALL DONE WITH PASS -C END IF - RETURN - END - SUBROUTINE FI8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8814 CONVERT TEXT TO INTEGER -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04 -C -C ABSTRACT: CONVERT TEXT CHARACTERS TO INTEGER VALUE -C -C PROGRAM HISTORY LOG: -C 94-03-04 CAVANAUGH -C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR) -C INPUT ARGUMENT LIST: -C ASCCHR - -C NPOS - -C NEWVAL - -C IERR - -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM) -C DDNAME1 - GENERIC NAME & CONTENT -C -C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) -C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE -C FT06F001 - INCLUDE IF ANY PRINTOUT -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS -C MACHINE: NAS, CYBER, WHATEVER -C -C$$$ - INTEGER IERR, IHOLD, IPTR(*) - CHARACTER*8 AHOLD - CHARACTER*64 ASCCHR - EQUIVALENCE (IHOLD,AHOLD) - - SAVE -C ---------------------------------------------------------- - IERR = 0 - NEWVAL = 0 - IFLAG = 0 -C - DO 1000 I = 1, NPOS - IHOLD = 0 - AHOLD(IPTR(45):IPTR(45)) = ASCCHR(I:I) - IF (IPTR(37).EQ.1) THEN - IF (IHOLD.EQ.32) THEN - IF (IFLAG.EQ.0) GO TO 1000 - GO TO 2000 - ELSE IF (IHOLD.LT.48.OR.IHOLD.GT.57) THEN -C PRINT*,' ASCII IHOLD =',IHOLD - IERR = 1 - RETURN - ELSE - IFLAG = 1 - NEWVAL = NEWVAL * 10 + IHOLD - 48 - END IF - ELSE - IF (IHOLD.EQ.64) THEN - IF (IFLAG.EQ.0) GO TO 1000 - GO TO 2000 - ELSE IF (IHOLD.LT.240.OR.IHOLD.GT.249) THEN -C PRINT*,' EBCIDIC IHOLD =',IHOLD - IERR = 1 - RETURN - ELSE - IFLAG = 1 - NEWVAL = NEWVAL * 10 + IHOLD - 240 - END IF - END IF - 1000 CONTINUE - 2000 CONTINUE - RETURN - END - SUBROUTINE FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD, - * ANAME3,AUNIT3, - * ISCAL3,IRFVL3,IWIDE3, - * KEYSET,IBFLAG,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8815 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04 -C -C ABSTRACT: EXTRACT TABLE A, TABLE B, ENTRIES FROM ACTIVE BUFR MESSAGE -C TO BE RETAINED FOR USE DURING THE DECODING OF ACTIVE BUFR MESSAGE. -C THESE WILL BE DISCARDED WHEN DECODING OF CURRENT MESSAGE IS COMPLETE -C -C PROGRAM HISTORY LOG: -C 94-03-04 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD, -C * ANAME3,AUNIT3, -C * ISCAL3,IRFVL3,IWIDE3, -C * KEYSET,IBFLAG,IERR) -C INPUT ARGUMENT LIST: -C IPTR - -C MAXR - -C MAXD - -C MSTACK - -C KDATA - -C IDENT - -C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS, -C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE. -C -C OUTPUT ARGUMENT LIST: -C ANAME3 - -C AUNIT3 - -C KFXY3 - -C ISCAL3 - -C IRFVL3 - -C IWIDE3 - -C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. -C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN -C ERRFLAG - EVEN IF MANY LINES ARE NEEDED -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS -C MACHINE: NAS, CYBER -C -C$$$ - CHARACTER*64 ANAME3(*),SPACES - CHARACTER*24 AUNIT3(*) -C - INTEGER IPTR(*),MAXR,MAXD,JDESC - INTEGER IXA, IXB, IXD, KDATA(MAXR,MAXD) - INTEGER IEXTRA - INTEGER KEYSET - INTEGER KFXY3(*),IDENT(*) - INTEGER ISCAL3(*),ISCSGN(150) - INTEGER IRFVL3(*),IRFSGN(150) - INTEGER IWIDE3(*) - - SAVE -C ============================================================== -C PRINT *,'FI8815' - IEXTRA = 0 -C BUILD SPACE CONSTANT - DO 1 I = 1, 64 - SPACES(I:I) = ' ' - 1 CONTINUE -C INITIALIZE ENTRY COUNTS - IXA = 0 - IXB = 0 - IXD = 0 -C -C SET FOR COMPRESSED OR NON COMPRESSED -C PROCESSING -C - IF (IDENT(16).EQ.0) THEN - JK = 1 - ELSE - JK = IDENT(14) - END IF -C -C CLEAR NECESSARY ENTRIES -C - DO 2 IY = 1, JK -C -C CLEAR NEXT TABLE B ENTRY -C - KFXY3(IXB+IY) = 0 - ANAME3(IXB+IY)(1:64) = SPACES(1:64) - AUNIT3(IXB+IY)(1:24) = SPACES(1:24) - ISCAL3(IXB+IY) = 0 - IRFVL3(IXB+IY) = 0 - IWIDE3(IXB+IY) = 0 - ISCSGN(IY) = 1 - IRFSGN(IY) = 1 - 2 CONTINUE -C -C START PROCESSING ENTRIES -C - I = 0 - 1000 CONTINUE -C -C SET POINTER TO CORRECT DATA POSITION -C - K = I + IEXTRA -C -C MUST FIND F X Y KEY FOR TABLE B -C OR TABLE D ENTRY -C - IF (JDESC.GE.10.AND.JDESC.LE.12) THEN - 10 CONTINUE -C -C BUILD DESCRIPTOR SEGMENT -C - DO 20 LY = 1,JK - IF (JDESC.EQ.10) THEN - KFXY3(IXB+LY) = KDATA(K,1) * 16384 + KFXY3(IXB+LY) - KEYSET = IOR(KEYSET,4) - I = I + 1 - GO TO 10 - ELSE IF (JDESC.EQ.11) THEN - KFXY3(IXB+LY) = KDATA(K,1) * 256 + KFXY3(IXB+LY) - KEYSET = IOR(KEYSET,2) - I = I + 1 - GO TO 10 - ELSE IF (JDESC.EQ.12) THEN - KFXY3(IXB+LY) = KDATA(K,1) + KFXY3(IXB+LY) - KEYSET = IOR(KEYSET,1) - END IF - 20 CONTINUE -C ================================================================== - ELSE IF (JDESC.GE.13.AND.JDESC.LE.20) THEN - DO 250 IZ = 1, JK - IF (JDESC.EQ.13) THEN -C -C ELEMENT NAME PART 1 - 32 BYTES/8 WDS -C - CALL GBYTES (ANAME3(IXB+IZ),KDATA(K,IZ),0,32,0,8) - IBFLAG = IOR(IBFLAG,16) - ELSE IF (JDESC.EQ.14) THEN -C -C ELEMENT NAME PART 2 - 32 BYTES/8 WDS -C - CALL GBYTES(ANAME3(IXB+IZ)(33:33),KDATA(K,IZ),0,32,0,8) - ELSE IF (JDESC.EQ.15) THEN -C -C UNITS NAME - 24 BYTES/6 WDS -C - CALL GBYTES (AUNIT3(IXB+IZ)(1:1),KDATA(K,IZ),0,32,0,6) - IBFLAG = IOR(IBFLAG,8) - ELSE IF (JDESC.EQ.16) THEN -C -C UNITS SCALE SIGN - 1 BYTE/ 1 WD -C 0 = POS, 1 = NEG - IF (KDATA(K,1).NE.48) THEN - ISCSGN(IZ) = -1 - ELSE - ISCSGN(IZ) = 1 - END IF - ELSE IF (JDESC.EQ.17) THEN -C -C UNITS SCALE - 3 BYTES/ 1 WD -C - CALL FI8814(KDATA(K,IZ),3,ISCAL3(IXB+IZ),IERR,IPTR) - IF (IERR.NE.0) THEN - PRINT *,'NON-NUMERIC CHARACTER - CANNOT CONVERT' - IPTR(1) = 888 - RETURN - END IF - IBFLAG = IOR(IBFLAG,4) - ELSE IF (JDESC.EQ.18) THEN -C -C UNITS REFERENCE SIGN - 1 BYTE/ 1 WD -C 0 = POS, 1 = NEG -C - IF (KDATA(K,1).EQ.48) THEN - IRFSGN(IZ) = 1 - ELSE - IRFSGN(IZ) = -1 - END IF - ELSE IF (JDESC.EQ.19) THEN -C -C UNITS REFERENCE VALUE - 10 BYTES/ 3 WDS -C - CALL FI8814(KDATA(K,IZ),10,IRFVL3(IXB+IZ),IERR,IPTR) - IF (IERR.NE.0) THEN - PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT' - IPTR(1) = 888 - RETURN - END IF - IBFLAG = IOR(IBFLAG,2) - ELSE -C -C ELEMENT DATA WIDTH - 3 BYTES/ 1 WD -C - CALL FI8814(KDATA(K,1),3,IWIDE3(IXB+1),IERR,IPTR) - IF (IERR.NE.0) THEN - PRINT *,'NON-NUMERIC CHARACTER-CANNOT CONVERT' - IPTR(1) = 888 - RETURN - END IF - IBFLAG = IOR(IBFLAG,1) - END IF - 250 CONTINUE - END IF -C ================================================================== - 9000 RETURN - END - SUBROUTINE FI8818(IPTR, - * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, - * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2, - * KPTRB) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8818 MERGE ANCILLARY & STANDARD B ENTRIES -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD -C -C ABSTRACT: START ABSTRACT HERE AND INDENT TO COLUMN 5 ON THE -C FOLLOWING LINES. SEE NMC HANDBOOK SECTION 3.1.1. FOR DETAILS -C -C PROGRAM HISTORY LOG: -C YY-MM-DD CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8818(IPTR, -C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1, -C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB) -C INPUT ARGUMENT LIST: -C IPTR - -C KFXY1 - -C ANAME1 - -C AUNIT1 - -C ISCAL1 - -C IRFVL1 - -C IWIDE1 - -C KFXY2 - -C ANAME2 - -C AUNIT2 - -C ISCAL2 - -C IRFVL2 - -C IWIDE2 - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IPTR - -C KFXY1 - -C ANAME1 - -C AUNIT1 - -C ISCAL1 - -C IRFVL1 - -C IWIDE1 - -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS -C MACHINE: NAS, CYBER, WHATEVER -C -C$$$ -C .................................................. -C -C NEW BASE TABLE B -C MAY BE A COMBINATION OF MASTER TABLE B -C AND ANCILLARY TABLE B -C - INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*) - CHARACTER*40 ANAME1(*) - CHARACTER*24 AUNIT1(*) -C .................................................. -C -C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE -C - INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*) - CHARACTER*64 ANAME2(*) - CHARACTER*24 AUNIT2(*) -C .................................................. - INTEGER IPTR(*),KPTRB(*) - - SAVE -C -C SET UP POINTERS -C PRINT *,'FI8818-A',IPTR(21),IPTR(41) - KAB = 1 - KB = 1 - 1000 CONTINUE -C PRINT *,KB,KAB,KFXY1(KB),KFXY2(KAB),IPTR(21) - IF (KB.GT.IPTR(21)) THEN -C NO MORE MASTER ENTRIES -C PRINT *,'NO MORE MASTER ENTRIES' - IF (KAB.GT.IPTR(41)) THEN - GO TO 5000 - END IF -C APPEND ANCILLARY ENTRY - GO TO 2000 - ELSE IF (KB.LE.IPTR(21)) THEN -C HAVE MORE MASTER ENTRIES - IF (KAB.GT.IPTR(41)) THEN -C NO MORE ANCILLARY ENTRIES - GO TO 5000 - END IF - IF (KFXY2(KAB).EQ.KFXY1(KB)) THEN -C REPLACE MASTER ENTRY - GO TO 3000 - ELSE IF (KFXY2(KAB).LT.KFXY1(KB)) THEN -C INSERT ANCILLARY ENTRY - GO TO 2000 - ELSE IF (KFXY2(KAB).GT.KFXY1(KB)) THEN -C SKIP MASTER ENTRY - KB = KB + 1 - END IF - END IF - GO TO 1000 - 2000 CONTINUE - IPTR(21) = IPTR(21) + 1 - KPTRB(KFXY2(KAB)) = IPTR(21) -C APPEND ANCILLARY ENTRY - KFXY1(IPTR(21)) = KFXY2(KAB) - ANAME1(IPTR(21))(1:40) = ANAME2(KAB)(1:40) - AUNIT1(IPTR(21)) = AUNIT2(KAB) - ISCAL1(IPTR(21)) = ISCAL2(KAB) - IRFVL1(1,IPTR(21)) = IRFVL2(KAB) - IWIDE1(IPTR(21)) = IWIDE2(KAB) -C PRINT *,IPTR(21),KFXY1(IPTR(21)),' APPENDED' - KAB = KAB + 1 - GO TO 1000 - 3000 CONTINUE -C REPLACE MASTER ENTRY - KFXY1(KB) = KFXY2(KAB) - ANAME1(KB) = ANAME2(KAB)(1:40) - AUNIT1(KB) = AUNIT2(KAB) - ISCAL1(KB) = ISCAL2(KAB) - IRFVL1(1,KB) = IRFVL2(KAB) - IWIDE1(KB) = IWIDE2(KAB) -C PRINT *,KB,KFXY1(KB),'REPLACED',IWIDE1(KB) - KAB = KAB + 1 - KB = KB + 1 - GO TO 1000 - 5000 CONTINUE - IPTR(41) = 0 -C PROCESSING COMPLETE -C PRINT *,'FI8818-B',IPTR(21),IPTR(41) -C DO 6000 I = 1, IPTR(21) -C PRINT *,'FI8818-C',I,KFXY1(I),IWIDE1(I) -C6000 CONTINUE - RETURN - END - SUBROUTINE FI8819(IPTR,ITBLD,ITBLD2,KPTRD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8819 MERGE ANCILLARY & MASTER TABLE D -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD -C -C ABSTRACT: MERGE TABLE D ENTRIES WITH THE ENTRIES FROM THE STANDARD -C TABLE D. ASSURE THAT ENTRIES ARE SEQUENTIAL. -C -C PROGRAM HISTORY LOG: -C YY-MM-DD CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD) -C INPUT ARGUMENT LIST: -C IPTR - -C ITBLD - -C ITBLD2 - -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IPTR - -C ITBLD - -C -C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS, CYBER -C -C$$$ -C .................................................. -C -C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE -C - INTEGER ITBLD2(20,*) -C .................................................. -C -C NEW BASE TABLE D -C - INTEGER ITBLD(20,*) -C .................................................. - INTEGER IPTR(*),KPTRD(*) - - SAVE -C PRINT *,'FI8819-A',IPTR(20),IPTR(42) -C SET UP POINTERS - DO 1000 I = 1, IPTR(42) - IPTR(20) = IPTR(20) + 1 - DO 500 J = 1, 20 - ITBLD(J,IPTR(20)) = ITBLD2(J,I) - MPTRD = MOD(ITBLD(J,IPTR(20)),16384) - KPTRD(MPTRD) = IPTR(20) - 500 CONTINUE - 1000 CONTINUE -C ======================================================= - IPTR(42) = 0 -C PRINT *,'MERGED TABLE D -- FI8819-B',IPTR(20),IPTR(42) -C DO 6000 I = 1, IPTR(20) -C WRITE (6,6001)I,(ITBLD(J,I),J=1,20) -C6001 FORMAT(15(1X,I5)) -C6000 CONTINUE - RETURN - END - SUBROUTINE FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FI8820 READ IN BUFR TABLE D -C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-05-06 -C -C ABSTRACT: READ IN BUFR TABLE D -C -C PROGRAM HISTORY LOG: -C 93-05-06 CAVANAUGH -C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE -C -C USAGE: CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD) -C INPUT ARGUMENT LIST: -C IUNITD - UNIT NUMBER FOR TABLE D INPUT -C IPTR - ARRAY OF WORKING VALUES -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ITBLD - ARRAY TO CONTAIN TABLE D -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: NAS -C -C$$$ -C .................................................. -C -C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE -C - INTEGER ITBLD2(20,*) -C .................................................. -C -C NEW BASE TABLE D -C - INTEGER ITBLD(20,*) -C .................................................. -C - INTEGER IHOLD(33),IPTR(*),KPTRD(*) - LOGICAL MORE - - SAVE -C - MORE = .TRUE. - I = 0 -C -C READ IN TABLE D, BUT JUST ONCE -C PRINT *,'TABLE D SWITCH=',IPTR(20),' ANCILLARY D SW=',IPTR(42) - IF (IPTR(20).EQ.0) THEN - DO 1000 MM = 1, 16384 - KPTRD(MM) = -1 - 1000 CONTINUE - IERR = 0 - PRINT *,'FI8820 - READING TABLE D' - KEY = 0 - 100 CONTINUE -C READ NEXT TABLE D ENTRY - READ(IUNITD,15,ERR=9998,END=9000)(IHOLD(M),M=1,33) - 15 FORMAT(11(I1,I2,I3,1X),3X) -C BUILD KEY FROM MASTER D ENTRY -C INSERT NEW MASTER INTO TABLE B - I = I + 1 - IPTR(20) = IPTR(20) + 1 - DO 25 JJ = 1, 41, 3 - KK = (JJ/3) + 1 - IF (JJ.LE.31) THEN - ITBLD(KK,I) = IHOLD(JJ)*16384 + - * IHOLD(JJ+1)*256 + IHOLD(JJ+2) - IF (ITBLD(KK,I).LT.1.OR.ITBLD(KK,I).GT.65535) THEN - ITBLD(KK,I) = 0 - GO TO 25 - END IF - ELSE - ITBLD(KK,I) = 0 - END IF - 25 CONTINUE - MPTRD = MOD(ITBLD(1,I),16384) - KPTRD(MPTRD) = I - 50 CONTINUE -C WRITE (6,51)I,(ITBLD(L,I),L=1,15) - 51 FORMAT (7H TABLED,16(1X,I5)) - GO TO 100 - ELSE -C PRINT *,'TABLE D IS IN PLACE' - END IF - GO TO 9999 - 9000 CONTINUE - CLOSE(UNIT=IUNITD,STATUS='KEEP') - GO TO 9999 - 9998 CONTINUE - IPTR(1) = 8 -C - 9999 CONTINUE -C PRINT *,'THERE ARE',IPTR(20),' ENTRIES IN TABLE D' - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fi92.f b/external/w3nco/v2.0.6/src/w3fi92.f deleted file mode 100644 index ac1f9cca..00000000 --- a/external/w3nco/v2.0.6/src/w3fi92.f +++ /dev/null @@ -1,216 +0,0 @@ - SUBROUTINE W3FI92 (LOC,TTAAII,KARY,KWBX,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FI92 BUILD 80-CHAR ON295 GRIB QUEUE DESCRIPTOR -C PRGMMR: CAVANAUGH ORG: NMC421 DATE:95-01-31 -C -C ABSTRACT: BUILD 80 CHARACTER QUEUE DESCRIPTOR USING INFORMATION -C SUPPLIED BY USER, PLACING THE COMPLETED QUEUE DESCRIPTOR IN THE -C LOCATION SPECIFIED BY THE USER. (BASED ON OFFICE NOTE 295). -C NOTE - THIS IS A MODIFIED VERSION OF W3FI62 WHICH ADDS THE -C 'KWBX' PARAMETER. THIS VALUE WILL NOW BE ADDED TO -C BYTES 35-38 FOR ALL GRIB PRODUCTS. -C QUEUE DESCIPTORS FOR NON-GRIB PRODUCTS WILL CONTINUE -C TO BE GENERATYED BY W3FI62. -C -C PROGRAM HISTORY LOG: -C 91-06-21 CAVANAUGH -C 94-03-08 CAVANAUGH MODIFIED TO ALLOW FOR BULLETIN SIZES THAT -C EXCEED 20000 BYTES -C 94-04-28 R.E.JONES CHANGE FOR CRAY 64 BIT WORD SIZE AND -C FOR ASCII CHARACTER SET COMPUTERS -C 95-10-16 J.SMITH MODIFIED VERSION OF W3FI62 TO ADD 'KWBX' -C TO BYTES 35-38 OF QUEUE DESCRIPTOR. -C 96-01-29 R.E.JONES PRESET IERR TO ZERO. -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3FI92 (LOC,TTAAII,KARY,KWBX,IERR) -C INPUT ARGUMENT LIST: -C TTAAII - FIRST 6 CHARACTERS OF WMO HEADER -C KARY - INTEGER ARRAY CONTAINING USER INFORMATION -C (1) = DAY OF MONTH -C (2) = HOUR OF DAY -C (3) = HOUR * 100 + MINUTE -C (4) = CATALOG NUMBER -C (5) = NUMBER OF 80 BYTE INCREMENTS -C (6) = NUMBER OF BYTES IN LAST INCREMENT -C (7) = TOTAL SIZE OF MESSAGE -C WMO HEADER + BODY OF MESSAGE IN BYTES -C (NOT INCLUDING QUEUE DESCRIPTOR) -C KWBX - = 4 CHARACTERS, REPRESENTING TH FCST MODEL -C THAT THE BULLETIN WAS DERIVED FROM. -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C LOC - LOCATION TO RECEIVE QUEUE DESCRIPTOR -C KARY - SEE INPUT ARGUMENT LIST -C IERR - ERROR RETURN -C -C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES) -C LIBRARY: -C W3LIB - GBYTE W3FI01 W3AI15 W3AI39 -C -C REMARKS: IF TOTAL SIZE IS ENTERED (KARY(7)) THEN KARY(5) AND -C KARY(6) WILL BE CALCULATED. -C IF KARY(5) AND KARY(6) ARE PROVIDED THEN KARY(7) WILL -C BE IGNORED. -C -C WARNING: EQUIVALENCE ARRAY LOC TO INTEGER ARRAY SO IT STARTS ON -C A WORD BOUNDARY FOR SBYTE SUBROUTINE. -C -C ERROR RETURNS -C IERR = 1 TOTAL BYTE COUNT AND/OR 80 BYTE INCREMENT -C COUNT IS MISSING. ONE OR THE OTHER IS -C REQUIRED TO COMPLETE THE QUEUE DESCRIPTOR. -C IERR = 2 TOTAL SIZE TOO SMALL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 77 -C MACHINE: HDS -C -C$$$ -C - INTEGER IHOLD(2) - INTEGER KARY(7),IERR -C - LOGICAL IBM370 -C - CHARACTER*6 TTAAII,AHOLD - CHARACTER*80 LOC - CHARACTER*1 BLANK - CHARACTER*4 KWBX -C - EQUIVALENCE (AHOLD,IHOLD) -C - SAVE -C -C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE -C COMPUTER, THIS IS THE EBCDIC CHARACTER SET. -C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE -C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER -C SETS TO FIND IBM370 TYPE COMPUTER. -C - DATA BLANK /' '/ -C ---------------------------------------------------------------- -C -C TEST FOR CRAY 64 BIT COMPUTER, LW = 8 -C - CALL W3FI01(LW) -C -C TEST FOR EBCDIC CHARACTER SET -C - IBM370 = .FALSE. - IF (MOVA2I(BLANK).EQ.64) THEN - IBM370 = .TRUE. - END IF -C - INOFST = 0 -C BYTES 1-16 'QUEUE DESCRIPTOR' - CALL SBYTE (LOC,-656095772,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,-985611067,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,-490481207,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,-672934183,INOFST,32) - INOFST = INOFST + 32 -C BYTES 17-20 INTEGER ZEROES - CALL SBYTE (LOC,0,INOFST,32) - INOFST = INOFST + 32 -C IF TOTAL COUNT IS INCLUDED -C THEN WILL DETERMINE THE NUMBER OF -C 80 BYTE INCREMENTS AND WILL DETERMINE -C THE NUMBER OF BYTES IN THE LAST INCREMENT - IERR = 0 - IF (KARY(7).NE.0) THEN - IF (KARY(7).LT.35) THEN -C PRINT *,'LESS THAN MINIMUM SIZE' - IERR = 2 - RETURN - END IF - KARY(5) = KARY(7) / 80 - KARY(6) = MOD(KARY(7),80) - IF (KARY(6).EQ.0) THEN - KARY(6) = 80 - ELSE - KARY(5) = KARY(5) + 1 - END IF - ELSE - IF (KARY(5).LT.1) THEN - IERR = 1 - RETURN - END IF - END IF -C BYTE 21-22 NR OF 80 BYTE INCREMENTS - CALL SBYTE (LOC,KARY(5),INOFST,16) - INOFST = INOFST + 16 -C BYTE 23 NR OF BYTES IN LAST INCREMENT - CALL SBYTE (LOC,KARY(6),INOFST,8) - INOFST = INOFST + 8 -C BYTES 24-28 INTEGER ZEROES - CALL SBYTE (LOC,0,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,0,INOFST,8) - INOFST = INOFST + 8 -C BYTES 29-34 6 CHAR BULLETIN NAME TTAAII - LOC(29:34) = TTAAII(1:6) -C -C IF ON ASCII COMPUTER, CONVERT LAST 6 CHARACTERS TO EBCDIC -C - IF (.NOT.IBM370) CALL W3AI39(LOC(29:29),6) -C - INOFST = INOFST + 48 -C BYTES 35-38 KWBX -C - LOC(35:38) = KWBX(1:4) -C -C IF ON ASCII COMPUTER, CONVERT LAST 4 CHARACTERS TO EBCDIC -C - IF (.NOT.IBM370) CALL W3AI39(LOC(35:35),4) - INOFST = INOFST + 32 -C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION -C TWO BYTES AS 4 BIT BCD - KA = KARY(3) / 1000 - KB = MOD(KARY(3),1000) / 100 - KC = MOD(KARY(3),100) / 10 - KD = MOD(KARY(3),10) - CALL SBYTE (LOC,KA,INOFST,4) - INOFST = INOFST + 4 - CALL SBYTE (LOC,KB,INOFST,4) - INOFST = INOFST + 4 - CALL SBYTE (LOC,KC,INOFST,4) - INOFST = INOFST + 4 - CALL SBYTE (LOC,KD,INOFST,4) - INOFST = INOFST + 4 -C BYTES 41-45 CATALOG NUMBER ELSE (SET TO 55555) - IF (KARY(4).GE.1.AND.KARY(4).LE.99999) THEN - CALL W3AI15 (KARY(4),IHOLD,1,8,'-') - IF (LW.EQ.4) THEN - CALL SBYTE (LOC,IHOLD(1),INOFST,8) - INOFST = INOFST + 8 - CALL SBYTE (LOC,IHOLD(2),INOFST,32) - INOFST = INOFST + 32 -C -C ON CRAY 64 BIT COMPUTER -C - ELSE - CALL SBYTE (LOC,IHOLD,INOFST,40) - INOFST = INOFST + 40 - END IF -C -C IF ON ASCII COMPUTER, CONVERT LAST 5 CHARACTERS TO EBCDIC -C - IF (.NOT.IBM370) CALL W3AI39(LOC(41:41),5) - ELSE - CALL SBYTE (LOC,-168430091,INOFST,32) - INOFST = INOFST + 32 - CALL SBYTE (LOC,245,INOFST,8) - INOFST = INOFST + 8 - END IF -C BYTES 46-80 INTEGER ZEROES - DO 4676 I = 1, 8 - CALL SBYTE (LOC,0,INOFST,32) - INOFST = INOFST + 32 - 4676 CONTINUE - CALL SBYTE (LOC,0,INOFST,24) - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fp11.f b/external/w3nco/v2.0.6/src/w3fp11.f deleted file mode 100644 index c33ec4a2..00000000 --- a/external/w3nco/v2.0.6/src/w3fp11.f +++ /dev/null @@ -1,845 +0,0 @@ - SUBROUTINE W3FP11 (IPDS0, IPDS, TITL, IERR) -C SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FP11 ONE-LINE GRIB TITLER FROM PDS SECTION -C PRGMMR: MCCLEES ORG: NMC421 DATE:88-02-02 -C -C ABSTRACT: CONVERTS GRIB FORMATTED PRODUCT DEFINITION SECTION VERSION -C 1 TO A ONE LINE READABLE TITLE. GRIB SECTION 0 IS ALSO TESTED TO -C VERIFY THAT GRIB DATA IS BEING DECIPHERED. -C -C PROGRAM HISTORY LOG: -C 91-06-19 R.E.JONES -C 92-05-29 R.E.JONES ADD WATER TEMP TO TABLES -C 93-01-19 R.E.JONES ADD MONTGOMARY STREAM FUNCTION TO TABLES -C ADD CODE FOR SURFACE VALUE 113. -C ADD CONDENSATION PRESSURE TO TABLES -C 93-02-19 R.E.JONES ADD CAPE AND TKE (157 & 158) TO TABLES -C 93-02-24 R.E.JONES ADD GRIB TYPE PMSLE (130) TO TABLES -C 93-03-26 R.E.JONES ADD GRIB TYPE SGLYR (175) TO TABLES -C 93-03-27 R.E.JONES CHANGES FOR REVISED O.N.388 MAR. 3,1993 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-04-16 R.E.JONES ADD GRIB TYPE LAT, LON (176,177) TO TABLES -C 93-04-25 R.E.JONES ADD GRIB TYPE 204, 205, 211, 212, 218 -C 93-05-18 R.E.JONES ADD TEST FOR MODEL 70 -C 93-06-26 R.E.JONES ADD GRIB TYPE 128, 129, TAKE OUT TEST FOR -C MODEL 86. -C 93-08-07 R.E.JONES ADD GRIB TYPE 156 (CIN), 150 (CBMZW), -C 151 (CBTZW), 152 (CBTMW) TO TABLES. -C 93-10-14 R.E.JONES CHANGE FOR O.N. 388 REV. OCT. 8,1993 -C 93-10-29 R.E.JONES CHANGE FOR 'L CDC' 'M CDC' 'H CDC' -C 93-10-14 R.E.JONES CHANGE FOR O.N. 388 REV. NOV. 19,1993 -C 94-02-05 R.E.JONES CHANGE FOR O.N. 388 REV. DEC. 14,1993 -C ADD MODEL NUMBER 86 AND 87. -C 94-03-24 R.E.JONES ADD GRIB TYPE 24 (TOTO3), 206 (UVPI) -C 94-06-04 R.E.JONES CHANGE UVPI TO UVI -C 94-06-16 R.E.JONES ADD GRIB TYPE 144,145,146,147,148,149 -C SOILW,PEVPR,CWORK,U-GWD,V-GWD,PV TO TABLES. -C 94-06-22 R.E.JONES ADD NCAR (60) TO CENTERS -C 94-07-25 R.E.JONES CORRECTION FOR 71, 72, 213 (T CDC), (CDCON), -C (CDLYR) -C 94-10-27 R.E.JONES ADD GRIB TYPE 191 (PROB), 192 (PROBN), ADD -C TEST FOR MODEL 90, 91, 92, 93, ADD SUB -C CENTER 2. -C 95-02-09 R.E.JONES CORRECTION FOR CENTURY FOR FNOC -C 95-04-11 R.E.JONES CORRECTION FOR LMH AND LMV -C 95-06-20 R.E.JONES ADD GRIB TYPE 189 (VSTM), 190 (HLCY), 193 -C (POP), 194 (CPOFP), 195 (CPOZP), 196 -C (USTM), 197 (VSTM) TO TABLES. -C 95-08-07 R.E.JONES ADD GRIB TYPE 153 (CLWMR), 154 (O3MR), 221 -C (HPBL), 237 (O3TOT). -C 95-09-07 R.E.JONES TAKE OUT GRIB TYPE 24 (TOTO3), CHANGE TO -C GRIB TYPE 10 (TOZNE). ADD LEVEL 117, -C POTENTIAL VORTITICITY (pv) LEVEL, ADD ETA -C LEVEL 119, ADD 120 LAYER BETWWEN TWO ETA -C LEVELS. CHANGE NAME OF LEVEL 107 TO (SIGL), -C CHANGE NAME OF LEVEL 108 TO (SIGY). -C 95-09-26 R.E.JONES ADD LEVEL 204 (HTFL) HIGHEST TROPSPHERE -C FREEZING LEVEL. -C 95-10-19 R.E.JONES CHANGE SOME OF THE LEVEL ABREVIATIONS. -C 95-12-13 R.E.JONES ADD 8 SUB-CENTERS TO TABLES -C 96-03-04 R.E.JONES CHANGES FOR O.N. 388 JAN 2, 1996 -C 96-03-22 R.E.JONES CHANGE SCUSF TO CSUSF -C 96-10-01 IREDELL RECOGNIZE FORECAST TIME UNITS 1 TO 12 -C AND CORRECT FOR YEAR 2000 -C 96-10-31 R.E.JONES CHANGE ARRAY AND TABLE FOR ICS1 TO 10. -C 96-10-01 IREDELL ALLOW PARAMETER TABLE VERSION UP TO 127 -C 98-05-26 Gilbert ADDED 17 NEW PARAMETERS ( GRIB TABLE 2 ) -C ADDED 6 NEW SPECIAL LEVELS FOR CLOUDS -C ADDED SUBCENTER 11 (TDL) UNDER CENTER 7 (NCEP) -C 98-12-21 Gilbert REPLACED FUNCTION ICHAR WITH MOVA2I. -C 01-01-05 VUONG ADD LEVEL 247 (EHLT) EQUILIBRIUM LEVEL -C 02-05-01 VUONG CHANGES FOR O.N. 388 MAR 21, 2002 -C 02-03-25 VUONG ADD GRIB TABLE VERSION 129 AND 130 -C 03-07-02 Gilbert Added 5 new params to Table version 129 -C 04-14-04 VUONG ADD GRIB TABLE VERSION 131 AND ADDED 12 -C NEW PARAMETER TO TABLE VERSION 129 -C 04-08-09 VUONG ADD PARAMETER (THFLX) TO TABLE VERSION 129 -C 05-02-08 COOKE CORRECTED ENTRY FOR FREEZING RAIN, CRFZR TO -C CFRZR IN THE HHNAM1 ARRAY -C 06-08-11 VUONG ADD LEVELS (235,236,237,238,240,245) AND ADDED -C NEW PARAMETERS TO TABLE VERSION 129 AND ADDED -C ONE PARAMETER 154 TO TABLE VERSION 130 AND -C ADDED TABLE VERSION 128 -C 07-04-05 VUONG ADD PARAMETERS TO TABLE VERSION 128, 129 AND 130 -C 07-05-15 VUONG ADDED TIME RANGE INDICATOR 51 AND NEW TABLE 140 -C -C USAGE: CALL W3FP11 (IPDS0, IPDS, TITL, IERR ) -C INPUT ARGUMENT LIST: -C IPDS0 - GRIB SECTION 0 READ AS CHARACTER*8 -C IPDS - GRIB PDS SECTION READ AS CHARACTER*28 -C -C OUTPUT ARGUMENT LIST: -C TITL - CHARACTER*86 OUTPUT PRINT LINE -C IERR 0 - COMPLETED SATISFACTORILY -C 1 - GRIB SECTION 0, CAN NOT FIND 'GRIB' -C 2 - GRIB IS NOT VERSION 1 -C 3 - LENGTH OF PDS SECTION IS LESS THAN 28 -C 4 - COULD NOT MATCH TYPE INDICATOR -C 5 - COULD NOT MATCH TYPE LEVEL -C 6 - COULD NOT INTERPRET ORIGINATOR OF CODE -C 7 - COULD NOT INTERPRET SUB CENTER 7 ORIGINATOR OF CODE -C 8 - COULD NOT INTERPRET SUB CENTER 9 ORIGINATOR OF CODE -C 9 - PARAMETER TABLE VERSION NOT 1 OR 2 -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM RS/6000 -C - INTEGER CENTER(17) - INTEGER SCNTR1(16) - INTEGER SCNTR2(14) - INTEGER FCSTIM - INTEGER HH(252) - INTEGER HH1(105) - INTEGER HH2(105) - INTEGER HH3(42) - INTEGER HH128(72) - INTEGER HH129(98) - INTEGER HH130(112) - INTEGER HH131(241) - INTEGER HH140(112) - INTEGER HHH(73) - INTEGER IERR - INTEGER P1 - INTEGER P2 - INTEGER TIMERG -C - CHARACTER * 6 HHNAM(252) - CHARACTER * 6 HHNAM1(105) - CHARACTER * 6 HHNAM2(105) - CHARACTER * 6 HHNAM3(42) - CHARACTER * 6 HHNAM128(72) - CHARACTER * 6 HHNAM129(98) - CHARACTER * 6 HHNAM130(112) - CHARACTER * 6 HHNAM140(112) - CHARACTER * 6 HHNAM131(241) - CHARACTER * 4 HHHNAM(73) - CHARACTER * (*) IPDS - CHARACTER * 8 IPDS0 - CHARACTER * 28 IDPDS - CHARACTER * 4 GRIB - CHARACTER * 28 KNAM1(17) - CHARACTER * 28 KNAM2(16) - CHARACTER * 28 KNAM3(14) - CHARACTER * 3 MONTH(12) - CHARACTER * 4 TIMUN(12) - CHARACTER * 2 TIMUN1(12) - CHARACTER * 86 TITL -C - EQUIVALENCE (HH(1),HH1(1)) - EQUIVALENCE (HH(106),HH2(1)) - EQUIVALENCE (HH(211),HH3(1)) - EQUIVALENCE (HHNAM(1),HHNAM1(1)) - EQUIVALENCE (HHNAM(106),HHNAM2(1)) - EQUIVALENCE (HHNAM(211),HHNAM3(1)) -C - SAVE -C - DATA CENTER/ 7, 8, 9, 34, 52, 54, 57, - & 58, 59, 60, 61, 62, 74, 85, - & 97, 98, 99/ -C -C TABLE 3 - TYPE AND VALUE OF LEVELS (PDS OCTETS 10, 11 AND 12) -C - DATA HHH / 1, 2, 3, 4, 5, 6, 7, - & 8, 9, 20, 100, 101, 102, 103, - & 104, 105, 106, 107, 108, 109, 110, - & 111, 112, 113, 114, 115, 116, 117, - & 119, 120, 121, 125, 126, 128, 141, - & 160, 200, 201, 204, 212, 213, 214, - & 222, 223, 224, 232, 233, 234, 209, - & 210, 211, 242, 243, 244, 246, 247, - & 206, 207, 248, 249, 251, 252, 235, - & 236, 237, 238, 215, 220, 239, 240, - & 245, 253, 254/ - DATA HHHNAM/'SFC ','CBL ','CTL ','0DEG','ADCL','MWSL','TRO ', - & 'NTAT','SEAB','TMPL','ISBL','ISBY','MSL ','GPML', - & 'GPMY','HTGL','HTGY','SIGL','SIGY','HYBL','HYBY', - & 'DBLL','DBLY','THEL','THEY','SPDL','SPDY','PVL ', - & 'ETAL','ETAY','IBYH','HGLH','ISBP','SGYH','IBYM', - & 'DBSL','EATM','EOCN','HTFL','LCBL','LCTL','LCY ', - & 'MCBL','MCTL','MCY ','HCBL','HCTL','HCY ','BCBL', - & 'BCTL','BCY ','CCBL','CCTL','CCY ','MTHE','EHLT', - & 'GCBL','GCTL','SCBL','SCTL','DCBL','DCTL','OITL', - & 'OLYR','OBML','OBIL','CEIL','PBLR','S26C','OMXL', - & 'LLTW','LBLS','HTLS'/ -C -C GRIB TABLE VERSION 2 (PDS OCTET 4 = 2) -C - DATA HH1 / - & 1, 2, 3, 5, 6, 7, 8, - & 9, 10, 11, 12, 13, 14, 15, - & 16, 17, 18, 19, 20, 21, 22, - & 23, 24, 25, 26, 27, 28, 29, - & 30, 31, 32, 33, 34, 35, 36, - & 37, 38, 39, 40, 41, 42, 43, - & 44, 45, 46, 47, 48, 49, 50, - & 51, 52, 53, 54, 55, 56, 57, - & 58, 59, 60, 61, 62, 63, 64, - & 65, 66, 67, 68, 69, 70, 71, - & 72, 73, 74, 75, 76, 77, 78, - & 79, 80, 81, 82, 83, 84, 85, - & 86, 87, 88, 89, 90, 91, 92, - & 93, 94, 95, 96, 97, 98, 99, - & 100, 101, 102, 103, 104, 105, 106/ - DATA HH2 / - & 107, 108, 109, 110, 111, 112, 113, - & 114, 115, 116, 117, 121, 122, 123, - & 124, 125, 126, 127, 128, 129, 130, - & 131, 132, 133, 134, 135, 136, 137, - & 138, 139, 140, 141, 142, 143, 144, - & 145, 146, 147, 148, 149, 150, 151, - & 152, 153, 154, 155, 156, 157, 158, - & 159, 160, 161, 162, 163, 164, 165, - & 166, 167, 168, 169, 172, 173, 174, - & 175, 176, 177, 181, 182, 183, 184, - & 189, 190, 191, 192, 193, 194, 195, - & 196, 197, 201, 204, 205, 206, 207, - & 208, 209, 211, 212, 213, 214, 215, - & 216, 217, 218, 219, 220 ,221, 222, - & 223, 226, 227, 228, 229, 231, 232/ - DATA HH3 / - & 233, 234, 235, 237, 238, 239, 241, - & 242, 243, 244, 245, 246, 247, 248, - & 249, 250, 251, 252, 253, 254, 255, - & 4, 118, 119, 120, 170, 171, 178, - & 179, 185, 186, 187, 198, 199, 200, - & 224, 225, 230, 180, 202, 210, 240/ - DATA HHNAM1/ - &' PRES ',' PRMSL',' PTEND',' ICAHT',' GP ',' HGT ',' DIST ', - &' HSTDV',' TOZNE',' TMP ',' VTMP ',' POT ',' EPOT ',' T MAX', - &' T MIN',' DPT ',' DEPR ',' LAPR ',' VIS ',' RDSP1',' RDSP2', - &' RDSP3',' PLI ',' TMP A',' PRESA',' GP A ',' WVSP1',' WVSP2', - &' WVSP3',' WDIR ',' WIND ',' U GRD',' V GRD',' STRM ',' V POT', - &' MNTSF',' SGCVV',' V VEL',' DZDT ',' ABS V',' ABS D',' REL V', - &' REL D',' VUCSH',' VVCSH',' DIR C',' SP C ',' UOGRD',' VOGRD', - &' SPF H',' R H ',' MIXR ',' P WAT',' VAPP ',' SAT D',' EVP ', - &' C ICE',' PRATE',' TSTM ',' A PCP',' NCPCP',' ACPCP',' SRWEQ', - &' WEASD',' SNO D',' MIXHT',' TTHDP',' MTHD ',' MTH A',' T CDC', - &' CDCON',' L CDC',' M CDC',' H CDC',' C WAT',' BLI ',' SNO C', - &' SNO L',' WTMP ',' LAND ',' DSL M',' SFC R',' ALBDO',' TSOIL', - &' SOILM',' VEG ',' SALTY',' DEN ',' WATR ',' ICE C',' ICETK', - &' DICED',' SICED',' U ICE',' V ICE',' ICE G',' ICE D',' SNO M', - &' HTSGW',' WVDIR',' WVHGT',' WVPER',' SWDIR',' SWELL',' SWPER'/ - DATA HHNAM2/ - &' DIRPW',' PERPW',' DIRSW',' PERSW',' NSWRS',' NLWRS',' NSWRT', - &' NLWRT',' LWAVR',' SWAVR',' G RAD',' LHTFL',' SHTFL',' BLYDP', - &' U FLX',' V FLX',' WMIXE',' IMG D',' MSLSA',' MSLMA',' MSLET', - &' LFT X',' 4LFTX',' K X ',' S X ',' MCONV',' VW SH',' TSLSA', - &' BVF2 ',' PV MW',' CRAIN',' CFRZR',' CICEP',' CSNOW',' SOILW', - &' PEVPR',' CWORK',' U-GWD',' V-GWD',' PV ',' COVMZ',' COVTZ', - &' COVTM',' CLWMR',' O3MR ',' GFLUX',' CIN ',' CAPE ',' TKE ', - &' CONDP',' CSUSF',' CSDSF',' CSULF',' CSDLF',' CFNSF',' CFNLF', - &' VBDSF',' VDDSF',' NBDSF',' NDDSF',' M FLX',' LMH ',' LMV ', - &' MLYNO',' NLAT ',' ELON ',' LPS X',' LPS Y',' HGT X',' HGT Y', - &' VPTMP',' HLCY ',' PROB ',' PROBN',' POP ',' CPOFP',' CPOZP', - &' USTM ',' VSTM ',' ICWAT',' DSWRF',' DLWRF',' UVI ',' MSTAV', - &' SFEXC',' MIXLY',' USWRF',' ULWRF',' CDLYR',' CPRAT',' TTDIA', - &' TTRAD',' TTPHY',' PREIX',' TSD1D',' NLGSP',' HPBL ',' 5WAVH', - &' CNWAT',' BMIXL',' AMIXL',' PEVAP',' SNOHF',' MFLUX',' DTRF '/ - DATA HHNAM3/ - &' UTRF ',' BGRUN',' SSRUN',' O3TOT',' SNOWC',' SNO T',' LRGHR', - &' CNVHR',' CNVMR',' SHAHR',' SHAMR',' VDFHR',' VDFUA',' VDFVA', - &' VDFMR',' SWHR ',' LWHR ',' CD ',' FRICV',' RI ',' MISS ', - &' PVORT',' BRTMP',' LWRAD',' SWRAD',' RWMR ',' SNMR ',' ICMR ', - &' GRMR ',' TURB ',' ICNG ',' LTNG ',' NCIP ',' EVBS ',' EVCW ', - &' SOTYP',' VGTYP',' 5WAVA',' GUST ',' CWDI ',' TRANS',' COVTW'/ -C -C GRIB TABLE VERSION 128 (PDS OCTET 4 = 128) -C ( OCEANGRAPHIC PARAMETER ) -C - DATA HH128/ - & 128, 129, 130, 131, 132, 133, 134, - & 135, 136, 137, 138, 139, 140, 141, - & 142, 143, 144, 145, 146, 147, 148, - & 149, 150, 151, 152, 153, 154, 155, - & 156, 157, 158, 159, 160, 161, 162, - & 163, 164, 165, 166, 167, 168, 169, - & 170, 171, 172, 173, 174, 175, 176, - & 177, 178, 179, 180, 181, 182, 183, - & 184, 185, 186, 187, 188, 189, 190, - & 191, 192, 193, 194, 254, 40, 41, - & 42, 43/ - DATA HHNAM128/ - &'ADEPTH',' DEPTH',' ELEV ','MXEL24','MNEL24',' ',' ', - &' O2 ',' PO4 ',' NO3 ',' SIO4 ',' CO2AQ',' HCO3 ',' CO3 ', - &' TCO2 ',' TALK ',' ',' ',' S11 ',' S12 ',' S22 ', - &' INV1 ',' INV2 ',' ',' ',' ',' ',' WVRGH', - &'WVSTRS',' WHITE','SWDIRW','SWFREW',' WVAGE','PWVAGE',' ', - &' ',' ',' LTURB',' ',' ',' ',' ', - &'AIHFLX','AOHFLX','IOHFLX','IOSFLX',' ',' OMLT ',' OMLS ', - &'P2OMLT',' OMLU ',' OMLV ',' ASHFL',' ASSFL',' BOTLD',' UBARO', - &' VBARO',' INTFD',' WTMPC',' SALIN',' EMNP ',' ',' KENG ', - &' ',' LAYTH',' SSTT ',' SSST ',' ','A RAIN','A SNOW', - &'A ICE ','A FRZR'/ -C -C GRIB TABLE VERSION 129 (PDS OCTET 4 = 129) -C - DATA HH129/ - & 128, 129, 130, 131, 132, 133, 134, - & 135, 136, 137, 138, 139, 140, 141, - & 142, 143, 144, 145, 146, 147, 148, - & 149, 150, 151, 152, 153, 154, 155, - & 156, 157, 158, 159, 160, 161, 162, - & 163, 164, 165, 166, 167, 168, 169, - & 170, 171, 172, 173, 174, 175, 176, - & 177, 178, 179, 180, 181, 182, 183, - & 184, 185, 186, 187, 188, 189, 190, - & 191, 192, 193, 194, 195, 196, 197, - & 198, 199, 200, 201, 201, 203, 204, - & 205, 206, 207, 208, 209, 210, 211, - & 212, 213, 214, 215, 216, 217, 218, - & 219, 220, 221, 222, 223, 224, 225/ - DATA HHNAM129/ - &' PAOT ',' PAOP ',' ',' FRAIN',' FICE ',' FRIME',' CUEFI', - &' TCOND',' TCOLW',' TCOLI',' TCOLR',' TCOLS',' TCOLC',' PLPL ', - &' HLPL ',' CEMS ',' COPD ',' PSIZ ',' TCWAT',' TCICE',' WDIF ', - &' WSTP ',' PTAN ',' PTNN ',' PTBN ',' PPAN ',' PPNN ',' PPBN ', - &' PMTC ',' PMTF ',' AETMP',' AEDPT',' AESPH',' AEUWD',' AEVWD', - &' LPMTF',' LIPMF',' REFZR',' REFZI',' REFZC',' TCLSW',' TCOLM', - &' ELRDI',' TSEC ',' TSECA',' NUM ',' AEPRS',' ICSEV',' ICPRB', - &' LAVNI',' HAVNI',' FLGHT',' OZCON',' OZCAT',' VEDH ',' SIGV ', - &' EWGT ',' CICEL',' CIVIS',' CIFLT',' LAVV ',' LOVV ',' USCT ', - &' VSCT ',' LAUV ',' LOUV ',' TCHP ',' DBSS ',' ODHA ',' OHC ', - &' SSHG ',' SLTFL',' DUVB ',' CDUVB',' THFLX',' UVAR ',' VVAR ', - &'UVVCC ',' MCLS ',' LAPP ',' LOPP ',' ',' REFO ',' REFD ', - &' REFC ','SBT122','SBT123','SBT124','SBT125',' MINRH',' MAXRH', - &' CEIL ','PBLREG',' ',' ',' ',' ',' '/ -C -C GRIB TABLE VERSION 130 (PDS OCTET 4 = 130) -C ( FOR LAND MODELING AND LAND DATA ASSIMILATION ) -C - DATA HH130/ - & 144, 145, 146, 147, 148, 149, 150, - & 151, 152, 153, 154, 155, 156, 157, - & 158, 159, 160, 161, 162, 163, 164, - & 165, 166, 167, 168, 169, 170, 171, - & 172, 173, 174, 175, 176, 177, 178, - & 179, 180, 181, 182, 183, 184, 185, - & 186, 187, 188, 189, 190, 191, 192, - & 193, 194, 195, 196, 197, 198, 199, - & 200, 201, 202, 203, 204, 205, 206, - & 207, 208, 209, 210, 211, 212, 213, - & 214, 215, 216, 217, 218, 219, 220, - & 221, 222, 223, 224, 225, 226, 227, - & 228, 229, 230, 231, 232, 233, 234, - & 235, 236, 237, 238, 239, 240, 241, - & 242, 243, 244, 245, 246, 247, 248, - & 249, 250, 251, 252, 253, 254, 255/ - DATA HHNAM130/ - &' SOIL ',' PEVPR',' VEGT ',' BARET',' AVSFT',' RADT ',' SSTOR', - &' LSOIL',' EWATR',' ',' LSPA ',' GFLUX',' CIN ',' CAPE ', - &' TKE ','MXSALB',' SOILL',' ASNOW',' ARAIN',' GWREC',' QREC ', - &' SNOWT',' VBDSF',' VDDSF',' NBDSF',' NDDSF','SNFALB',' ', - &' M FLX',' ',' ',' ',' NLAT ',' ELON ','FLDCAP', - &' ACOND',' SNOAG',' CCOND',' LAI ',' SFCRH',' SALBD',' ', - &' ',' NDVI ',' DRIP ','VBSLAB','VWSALB','NBSALB','NWSALB', - &' ',' ',' ',' ',' ',' SBSNO',' EVBS ', - &' EVCW ',' ',' ',' RSMIN',' DSWRF',' DLWRF',' ', - &' MSTAV',' SFEXC',' ',' TRANS',' USWRF',' ULWRF',' ', - &' ',' ',' ',' ',' ',' WILT ',' FLDCP', - &' HPBL ',' SLTYP',' CNWAT',' SOTYP',' VGTYP',' BMIXL',' AMIXL', - &' PEVAP',' SNOHF',' SMREF',' SMDRY',' ',' ',' BGRUN', - &' SSRUN',' ',' ',' SNOWC',' SNOT ',' POROS',' ', - &' ',' ',' ',' ',' RCS ',' RCT ',' RCQ ', - &' RCSOL',' ',' ',' CD ',' FRICV',' RI ',' '/ -C -C GRIB TABLE VERSION 140 (PDS OCTET 4 = 140) -C ( FOR WORLD AREA FORECAST SYSTEM (WAF/ICAO) -C - DATA HH140/ - & 144, 145, 146, 147, 148, 149, 150, - & 151, 152, 153, 154, 155, 156, 157, - & 158, 159, 160, 161, 162, 163, 164, - & 165, 166, 167, 168, 169, 170, 171, - & 172, 173, 174, 175, 176, 177, 178, - & 179, 180, 181, 182, 183, 184, 185, - & 186, 187, 188, 189, 190, 191, 192, - & 193, 194, 195, 196, 197, 198, 199, - & 200, 201, 202, 203, 204, 205, 206, - & 207, 208, 209, 210, 211, 212, 213, - & 214, 215, 216, 217, 218, 219, 220, - & 221, 222, 223, 224, 225, 226, 227, - & 228, 229, 230, 231, 232, 233, 234, - & 235, 236, 237, 238, 239, 240, 241, - & 242, 243, 244, 245, 246, 247, 248, - & 249, 250, 251, 252, 253, 254, 255/ - DATA HHNAM140/ - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' MEIP ',' MAIP ',' MECTP',' MACTP', - &' MECAT',' MACAT',' CBHE ',' PCBB ',' PCBT ',' PECBB',' PECBT', - &' HCBB ',' HCBT ',' HECBB',' HECBT',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' ', - &' ',' ',' ',' ',' ',' ',' MISS '/ -C -C GRIB TABLE VERSION 131 (PDS OCTET 4 = 131) -C - DATA HH131/ - & 1, 2, 3, 4, 5, 6, 7, - & 8, 9, 10, 11, 12, 13, 14, - & 15, 16, 17, 18, 19, 20, 21, - & 22, 23, 24, 25, 26, 27, 28, - & 29, 30, 31, 32, 33, 34, 35, - & 36, 37, 38, 39, 40, 41, 42, - & 43, 44, 45, 46, 47, 48, 49, - & 50, 51, 52, 53, 54, 55, 56, - & 57, 58, 59, 60, 61, 62, 63, - & 64, 65, 66, 67, 68, 69, 70, - & 71, 72, 73, 74, 75, 76, 77, - & 78, 79, 80, 81, 82, 83, 84, - & 85, 86, 87, 88, 89, 90, 91, - & 92, 93, 94, 95, 96, 97, 98, - & 99, 100, 101, 102, 103, 104, 105, - & 106, 107, 108, 109, 110, 111, 112, - & 113, 114, 115, 116, 117, 118, 119, - & 120, 121, 122, 123, 124, 125, 126, - & 127, 128, 130, 131, 132, 134, 135, - & 136, 139, 140, 141, 142, 143, 144, - & 145, 146, 147, 148, 149, 150, 151, - & 152, 153, 155, 156, 157, 158, 159, - & 160, 161, 162, 163, 164, 165, 166, - & 167, 168, 169, 170, 171, 172, 173, - & 174, 175, 176, 177, 178, 179, 180, - & 181, 182, 183, 184, 187, 188, 189, - & 190, 191, 192, 194, 196, 197, 198, - & 199, 200, 202, 203, 204, 205, 206, - & 207, 208, 210, 211, 212, 213, 214, - & 216, 218, 219, 220, 221, 222, 223, - & 224, 225, 226, 227, 228, 229, 230, - & 231, 232, 233, 234, 235, 237, 238, - & 239, 240, 241, 242, 243, 244, 245, - & 246, 247, 248, 249, 250, 251, 252, - & 253, 254, 255/ - DATA HHNAM131/ - &' PRES ',' PRMSL',' PTEND',' PVORT',' ICAHT',' GP ',' HGT ', - &' DIST ',' HSTDV',' TOZNE',' TMP ',' VTMP ',' POT ',' EPOT ', - &' TMAX ',' TMIN ',' DPT ',' DEPR ',' LAPR ',' VIS ',' RDSP1', - &' RDSP2',' RDSP3',' PLI ',' TMPA ',' PRESA',' GPA ',' WVSP1', - &' WVSP2',' WVSP3',' WDIR ',' WIND ',' UGRD ',' VGRD ',' STRM ', - &' VPOT ',' MNTSF',' SGVCC',' VVEL ',' DZDT ',' ABSV ',' ABSD ', - &' RELV ',' RELD ',' VUCSH',' VVCSH',' DIRC ',' SPC ',' UOGRD', - &' VOGRD',' SPFH ',' RH ',' MIXR ',' PWAT ',' VAPP ',' SATD ', - &' EVP ',' CICE ',' PRATE',' TSTM ',' APCP ',' NCPCP',' ACPCP', - &' SRWEQ',' WEASD',' SNOD ',' MIXHT',' TTHDP',' MTHD ',' MTHA ', - &' TCDC ',' CDCON',' LCDC ',' MCDC ',' HCDC ',' CWAT ',' BLI ', - &' SNOC ',' SNOL ',' WTMP ',' LAND ',' DSLM ',' SFCR ',' ALBDO', - &' TSOIL',' SOILM',' VEG ',' SALTY',' DEN ',' WATR ',' ICEC ', - &' ICETK',' DICED',' SICED',' UICE ',' VICE ',' ICEG ',' ICED ', - &' SNOM ',' HTSGW',' WVDIR',' WVHGT',' WVPER',' SWDIR',' SWELL', - &' SWPER',' DIRPW',' PERPW',' DIRSW',' PERSW',' NSWRS',' NLWRS', - &' NSWRT',' NLWRT',' LWAVR',' SWAVR',' GRAD ',' BRTMP',' LWRAD', - &' SWRAT',' LHTFL',' SHTFL',' BLYDP',' UFLX ',' VFLX ',' WMIXE', - &' IMGD ',' MSLSA',' MSLET',' LFTX ',' 4LFTX',' PRESN',' MCONV', - &' VWSH ',' PVMW ',' CRAIN',' CFRZR',' CICEP',' CSNOW',' SOILW', - &' PEVPR',' VEGT ',' BARET',' AVSFT',' RADT ',' SSTOR',' LSOIL', - &' EWATR',' CLWMR',' GFLUX',' CIN ',' CAPE ',' TKE ','MXSALB', - &' SOILL',' ASNOW',' ARAIN',' GWREC',' QREC ',' SNOWT',' VBDSF', - &' VDDSF',' NBDSF',' NDDSF','SNFALB',' RLYRS',' FLX ',' LMH ', - &' LMV ',' MLYNO',' NLAT ',' ELON ',' ICMR ',' ACOND',' SNOAG', - &' CCOND',' LAI ',' SFCRH',' SALBD',' NDVI ',' DRIP ',' LANDN', - &' HLCY ',' NLATN',' ELONN',' CPOFP',' USTM ',' VSTM ',' SBSNO', - &' EVBS ',' EVCW ',' APCPN',' RSMIN',' DSWRF',' DLWRF','ACPCPN', - &' MSTAV',' SFEXC',' TRANS',' USWRF',' ULWRF',' CDLYR',' CPRAT', - &' TTRAD',' HGTN ',' WILT ',' FLDCP',' HPBL ',' SLTYP',' CNWAT', - &' SOTYP',' VGTYP',' BMIXL',' AMIXL',' PEVAP',' SNOHF',' SMREF', - &' SMDRY',' WVINC',' WCINC',' BGRUN',' SSRUN','MVCONV',' SNOWC', - &' SNOT ',' POROS','WCCONV','WVUFLX','WVVFLX','WCUFLX','WCVFLX', - &' RCS ',' RCT ',' RCQ ',' RCSOL',' SWHR ',' LWHR ',' CD ', - &' FRICV',' RI ',' MISS '/ -C -C ONE LINE CHANGE FOR HDS (IBM370) (ASCII NAME GRIB IN HEX) -C -C DATA GRIB /Z47524942/ -C -C ONE LINE CHANGE FOR CRAY AND WORKSTATIONS -C - DATA GRIB /'GRIB'/ -C -C TABLE O (PDS OCTET 5) NATIONAL/INTERNATIONAL -C ORIGINATING CENTERS -C - DATA KNAM1 / - & ' US NWS - NCEP (WMC) ',' US NWS - NWSTG (WMC) ', - & ' US NWS - Other (WMC)',' JMA - Tokyo (RSMC) ', - & ' TPC (NHC),Miami(RSMC)',' CMS - Montreal (RSMC)', - & ' U.S. Air Force - GWC ',' U.S. Navy - FNOC ', - & ' NOAA FSL, Boulder, CO',' NCAR, Boulder, CO ', - & ' SARGO, Landover, MD ',' US Naval, Oceanograph', - & ' U.K Met. Office RSMC)',' French WS - Toulouse ', - & ' European Space Agency',' ECMWF (RSMC) ', - & ' De Bilt, Netherlands '/ -C -C TABLE C (PDS OCTET 26) NATIONAL SUB-CENTERS -C - DATA KNAM2 / - & ' NCEP RE-ANALYSIS PRO.',' NCEP ENSEMBLE PRODUCT', - & ' NCEP CENTRAL OPS. ',' ENV. MODELING CENTER ', - & ' HYDRO. PRED. CENTER ',' OCEAN PRED. CENTER ', - & ' CLIMATE PRED. CENTER ',' AVIATION WEATHER CEN.', - & ' STORM PRED. CENTER ',' TROPICAL PRED. CENTER', - & ' NWS TECH. DEV. LAB. ',' NESDIS OFF. RES. APP.', - & ' FAA ',' NWS MET. DEV. LAB. ', - & ' NARR PROJECT ',' SPACE ENV. CENTER '/ - DATA KNAM3 / - & ' ABRFC TULSA, OK ',' AKRFC ANCHORAGE, AK ', - & ' CBRFC SALT LAKE, UT ',' CNRFC SACRAMENTO, CA', - & ' LMRFC SLIDEL, LA. ',' MARFC STATE CO., PA ', - & ' MBRFC KANSAS CITY MO',' NCRFC MINNEAPOLIS MN', - & ' NERFC HARTFORD, CT. ',' NWRFC PORTLAND, OR ', - & ' OHRFC CINCINNATI, OH',' SERFC ATLANTA, GA ', - & ' WGRFC FORT WORTH, TX',' OUN NORMAN OK WFO '/ - DATA MONTH /'JAN','FEB','MAR','APR','MAY','JUN', - & 'JUL','AUG','SEP','OCT','NOV','DEC'/ - DATA SCNTR1/ 1, 2, 3, 4, 5, 6, 7, - & 8, 9, 10, 11, 12, 13, 14, - & 15, 16/ - DATA SCNTR2/ 150, 151, 152, 153, 154, 155, 156, - & 157, 158, 159, 160, 161, 162, 170/ - DATA TIMUN /'HRS.','DAYS','MOS.','YRS.','DECS','NORM','CENS', - & 2*'----','3HRS','6HRS','HDYS'/ - DATA TIMUN1/'HR','DY','MO','YR','DC','NO','CN', - & 2*'--','3H','6H','HD'/ -C -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C -C 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM. -C - NO. OF ENTRIES IN TYPE LEVEL -C - NO. OF ENTRIES IN CNTR PROD. DTA. -C - NO. OF ENTRIES IN SUB CNTR1 PROD. DTA. -C - NO. OF ENTRIES IN SUB CNTR2 PROD. DTA. -C - IQ = 252 - IS = 73 - IC = 17 - IH128 = 72 - IH129 = 98 - IH130 = 112 - IH140 = 112 - IH131 = 241 - ICS1 = 16 - ICS2 = 14 - IERR = 0 -C - TITL(1:30) = ' ' - TITL(31:60) = ' ' - TITL(61:86) = ' ' -C -C --------------------------------------------------------------------- -C 2.0 TEST SECTION 0 FOR ASCII 'GRIB' -C - IF (GRIB(1:4) .NE. IPDS0(1:4)) THEN - IERR = 1 - RETURN - ENDIF -C -C TEST SECTION 0 FOR GRIB VERSION 1 -C - IF (MOVA2I(IPDS0(8:8)).NE.1) THEN - IERR = 2 - RETURN - END IF -C -C TEST THE LENGTH OF THE PDS (SECTION 1) -C - LENPDS = MOVA2I(IPDS(1:1)) * 65536 + MOVA2I(IPDS(2:2)) * 256 + - & MOVA2I(IPDS(3:3)) - IF (LENPDS.GE.28) THEN - IDPDS(1:28) = IPDS(1:28) - ELSE - IERR = 3 - RETURN - ENDIF -C -C TEST PDS (OCTET 4) FOR PARAMETER TABLE VERSION -C NUMBER 1 OR 2 OR 128, 129 OR 130 OR 131 OR 140 -C - IVER = MOVA2I(IDPDS(4:4)) - IF (IVER.GT.131) THEN - IERR = 9 - RETURN - END IF -C -C 4.0 FIND THE INDICATOR AND TYPE LEVELS -C - IQQ = MOVA2I (IDPDS(9:9)) - IF (IVER.EQ.128) THEN - DO K = 1, IH128 - IF (IQQ .EQ. HH128(K)) THEN - TITL(21:27) = HHNAM128(K) - GO TO 150 - END IF - END DO - ELSE IF (IVER.EQ.129) THEN - DO K = 1, IH129 - IF (IQQ .EQ. HH129(K)) THEN - TITL(21:27) = HHNAM129(K) - GO TO 150 - END IF - END DO - ELSE IF (IVER.EQ.130) THEN - DO K = 1, IH130 - IF (IQQ .EQ. HH130(K)) THEN - TITL(21:27) = HHNAM130(K) - GO TO 150 - END IF - END DO - ELSE IF (IVER.EQ.131) THEN - DO K = 1, IH131 - IF (IQQ .EQ. HH131(K)) THEN - TITL(21:27) = HHNAM131(K) - GO TO 150 - END IF - END DO - ELSE IF (IVER.EQ.140) THEN - DO K = 1, IH140 - IF (IQQ .EQ. HH140(K)) THEN - TITL(21:27) = HHNAM140(K) - GO TO 150 - END IF - END DO - ELSE - DO II = 1,IQ - IF (IQQ .EQ. HH(II)) GO TO 100 - END DO - IF (IQQ.EQ.77.AND.IVER.EQ.1) GO TO 100 - IF (IQQ.EQ.24) GO TO 100 - IERR = 4 - RETURN - END IF -C - 100 CONTINUE - IF (IQQ .NE. 77 .AND. IQQ .NE. 24) THEN - TITL(21:27) = HHNAM(II) - ELSE IF (IQQ .EQ. 77) THEN - TITL(21:27) = ' CONDP ' -C -C TAKE OUT AFTER ALL PROGRAMS ARE CHANGED THAT USE 24 -C FOR TOTAL OZONE. -C - ELSE IF (IQQ .EQ. 24) THEN - TITL(21:27) = ' TOTO3 ' - END IF - IF (IQQ.EQ.137.AND.IVER.EQ.1) TITL(21:27) = ' VISIB ' - 150 CONTINUE - ISS = MOVA2I (IDPDS(10:10)) -C -C CORRECTION FOR 'NLAT' 'ELON' 'L CDC' 'M CDC', 'H CDC', -C 'T CDC' -C - IF (ISS.EQ.0.AND.(IQQ.EQ.176.OR.IQQ.EQ.177. - & OR.IQQ.EQ.71.OR.IQQ.EQ.73.OR.IQQ.EQ.74. - & OR.IQQ.EQ.72.OR.IQQ.EQ.75.OR.IQQ.EQ.213. - & OR.IQQ.EQ.173.OR.IQQ.EQ.174)) THEN - GO TO 300 - END IF - DO JJ = 1,IS - IF (ISS .EQ. HHH(JJ)) GO TO 200 - END DO - IERR = 5 - RETURN -C - 200 CONTINUE - IF (ISS.EQ.4.OR.ISS.EQ.5.OR.ISS.EQ.20.OR.ISS.EQ.100.OR. - & ISS.EQ.103.OR.ISS.EQ.105.OR.ISS.EQ.107.OR.ISS.EQ.109.OR. - & ISS.EQ.111.OR.ISS.EQ.113.OR.ISS.EQ.115.OR.ISS.EQ.117.OR. - & ISS.EQ.119.OR.ISS.EQ.125.OR.ISS.EQ.126.OR.ISS.EQ.160.OR. - & ISS.EQ.236)THEN - TITL(16:20) = HHHNAM(JJ) - LEVEL = MOVA2I(IDPDS(11:11)) * 256 + MOVA2I(IDPDS(12:12)) - IF (ISS.EQ.107.OR.ISS.EQ.119) THEN - ALEVEL = FLOAT(LEVEL) / 10000.0 - WRITE (TITL(9:15),FMT='(F6.4)') ALEVEL - ELSE IF (ISS.EQ.5) THEN -C DO NOTHING - ELSE - WRITE (TITL(11:15),FMT='(I4)') LEVEL - END IF - ELSE IF (ISS.EQ.1.OR.ISS.EQ.6.OR.ISS.EQ.7.OR.ISS.EQ.8.OR. - & ISS.EQ.9 .OR.ISS.EQ.102.OR.ISS.EQ.200.OR.ISS.EQ.201.OR. - & ISS.EQ.204.OR.ISS.EQ.212.OR.ISS.EQ.213.OR.ISS.EQ.214.OR. - & ISS.EQ.222.OR.ISS.EQ.223.OR.ISS.EQ.224.OR.ISS.EQ.232.OR. - & ISS.EQ.233.OR.ISS.EQ.234.OR.ISS.EQ.209.OR.ISS.EQ.210.OR. - & ISS.EQ.211.OR.ISS.EQ.242.OR.ISS.EQ.243.OR.ISS.EQ.244.OR. - & ISS.EQ.245.OR.ISS.EQ.235.OR.ISS.EQ.237.OR.ISS.EQ.238.OR. - & ISS.EQ.246.OR.ISS.EQ.247.OR.ISS.EQ.206.OR.ISS.EQ.207.OR. - & ISS.EQ.248.OR.ISS.EQ.249.OR.ISS.EQ.251.OR.ISS.EQ.252) THEN - TITL(16:20) = HHHNAM(JJ) - TITL(1:4) = ' ' - TITL(11:15) = ' ' - ELSE IF (ISS.EQ.101.OR.ISS.EQ.104.OR.ISS.EQ.106.OR.ISS.EQ.108. - & OR.ISS.EQ.110.OR.ISS.EQ.112.OR.ISS.EQ.114.OR.ISS.EQ.116.OR. - & ISS.EQ.120.OR.ISS.EQ.121.OR.ISS.EQ.128.OR.ISS.EQ.141) THEN - TITL(6:11) = HHHNAM(JJ) - TITL(16:20) = HHHNAM(JJ) - ITEMP = MOVA2I(IDPDS(11:11)) - WRITE (UNIT=TITL(1:4),FMT='(I4)') ITEMP - JTEMP = MOVA2I(IDPDS(12:12)) - WRITE (UNIT=TITL(11:15),FMT='(I4)') JTEMP - END IF -C -C 5.0 INSERT THE YEAR,DAY,MONTH AND TIME -C - 300 CONTINUE - IHR = MOVA2I (IDPDS(16:16)) - IDAY = MOVA2I (IDPDS(15:15)) - IMON = MOVA2I (IDPDS(14:14)) - IYR = MOVA2I (IDPDS(13:13)) - ICEN = MOVA2I (IDPDS(25:25)) -C -C SUBTRACT 1 FROM CENTURY TO MAKE 4 DIGIT YEAR -C - ICEN = ICEN - 1 -C - IYR = ICEN * 100 + IYR - WRITE (UNIT=TITL(59:62),FMT='(I4)') IYR - WRITE (UNIT=TITL(52:53),FMT='(I2)') IDAY - WRITE (UNIT=TITL(38:49),FMT='(A6,I2.2,A2)') 'AFTER ',IHR,'Z ' - TITL(55:57) = MONTH(IMON) - FCSTIM = MOVA2I (IDPDS(18:18)) - TITL(34:36) = TIMUN(FCSTIM) - P1 = MOVA2I(IDPDS(19:19)) - P2 = MOVA2I(IDPDS(20:20)) - TIMERG = MOVA2I(IDPDS(21:21)) - IF (TIMERG.EQ.10) THEN - P1 = P1 * 256 + P2 - P2 = 0 - END IF -C -C ADD CORRECTION IF BYTE 21 (TIME RANGE) IS 2 -C - IF (TIMERG.EQ.2) THEN - TITL(4:20) = TITL(11:27) - TITL(21:21) = ' ' - WRITE (UNIT=TITL(22:24),FMT='(I3)') P1 - TITL(25:28) = ' TO ' - WRITE (UNIT=TITL(29:32),FMT='(I3)') P2 -C -C PRECIP AMOUNTS -C - ELSE IF (TIMERG.EQ.4) THEN - WRITE (UNIT=TITL(29:32),FMT='(I3)') P2 - MTEMP = P2 - P1 - WRITE (UNIT=TITL(2:4),FMT='(I3)') MTEMP - TITL(6:7) = TIMUN1(FCSTIM) - TITL(8:12) = ' ACUM' -C -C AVERAGE -C - ELSE IF (TIMERG.EQ.3) THEN - WRITE (UNIT=TITL(29:32),FMT='(I3)') P2 - MTEMP = P2 - P1 - WRITE (UNIT=TITL(2:4),FMT='(I3)') MTEMP - TITL(6:7) = TIMUN1(FCSTIM) - TITL(8:12) = ' AVG' -C -C CLIMATOLOGICAL MEAN VALUE -C - ELSE IF (TIMERG.EQ.51) THEN - WRITE (UNIT=TITL(29:32),FMT='(I3)') P2 - MTEMP = P2 - P1 - WRITE (UNIT=TITL(2:4),FMT='(I3)') MTEMP - TITL(6:7) = TIMUN1(FCSTIM) - TITL(8:12) = ' AVG' - ELSE - WRITE (UNIT=TITL(29:32),FMT='(I3)') P1 - ENDIF -C -C TEST FOR ANALYSIS (MAKE CORRECTION IF MODEL IS ANALYSIS) -C - IF (TIMERG.EQ.0.AND.P1.EQ.0) THEN - TITL(29:42) = ' ANALYSIS VT ' - MODEL = MOVA2I(IDPDS(6:6)) - IF (MODEL.EQ.10.OR.MODEL.EQ.39.OR.MODEL.EQ.45.OR. - & MODEL.EQ.53.OR.MODEL.EQ.68.OR.MODEL.EQ.69.OR. - & MODEL.EQ.70.OR.MODEL.EQ.73.OR.MODEL.EQ.74.OR. - & MODEL.EQ.75.OR.MODEL.EQ.76.OR.MODEL.EQ.77.OR. - & MODEL.EQ.78.OR.MODEL.EQ.79.OR.MODEL.EQ.80.OR. - & MODEL.EQ.83.OR.MODEL.EQ.84.OR.MODEL.EQ.85.OR. - & MODEL.EQ.86.OR.MODEL.EQ.87.OR.MODEL.EQ.88.OR. - & MODEL.EQ.90.OR.MODEL.EQ.91.OR.MODEL.EQ.92.OR. - & MODEL.EQ.105.OR.MODEL.EQ.110.OR.MODEL.EQ.150.OR. - & MODEL.EQ.151) THEN - TITL(29:42) = ' 00-HR FCST ' - ENDIF - ENDIF -C -C TEST FOR 00-HR FCST (INITIALIZED ANALYSIS) -C - IF (TIMERG.EQ.1.AND.P1.EQ.0) THEN - TITL(29:42) = ' 00-HR FCST ' - ENDIF -C -C 3.0 FIND WHO GENERATED THE CODE -C CHECK FOR SUB-CENTERS -C - IGENC = MOVA2I (IDPDS(5:5)) - ISUBC = MOVA2I (IDPDS(26:26)) -C -C TEST FOR SUB-CENTERS WHEN CENTER IS 7 -C - - IF (ISUBC.NE.0.AND.IGENC.EQ.7) THEN - DO J = 1,ICS1 - IF (ISUBC .EQ. SCNTR1(J)) THEN - TITL(63:86) = KNAM2(J) - RETURN - END IF - END DO - IERR = 7 - END IF -C -C TEST FOR SUB-CENTERS WHEN CENTER IS 9 -C - IF (ISUBC.NE.0.AND.IGENC.EQ.9) THEN - DO J = 1,ICS2 - IF (ISUBC .EQ. SCNTR2(J)) THEN - TITL(63:86) = KNAM3(J) - RETURN - END IF - END DO - IERR = 8 - END IF -C -C TEST TO SEE IF CENTER IN TABLES -C - DO I = 1,IC - IF (IGENC .EQ. CENTER(I)) THEN - TITL(63:86) = KNAM1(I) - RETURN - END IF - END DO -C - IERR = 6 - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fp12.f b/external/w3nco/v2.0.6/src/w3fp12.f deleted file mode 100644 index 152b92c2..00000000 --- a/external/w3nco/v2.0.6/src/w3fp12.f +++ /dev/null @@ -1,612 +0,0 @@ - SUBROUTINE W3FP12(ID8, IFLAG, IDPDS, ICENT, ISCALE, IER) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FP12 CREATES THE PRODUCT DEFINITION SECTION -C PRGMMR: MCCLEES ORG: NMC421 DATE:92-01-14 -C -C ABSTRACT: FORMATS THE PRODUCT DEFINITION SECTION ACCORDING TO THE -C SPECIFICATIONS SET BY WMO. USING O.N. 84 ID'S (1ST 8 WORDS) -C AS THE INPUT DATA. NEW SUBROUTINE CORRESPONDS TO THE REVISION -C #1 OF THE WMO GRIB STANDARDS MADE MARCH 15, 1991. -C -C PROGRAM HISTORY LOG: -C 91-07-30 MCCLEES,A.J. NEW SUBROUTINE WHICH FORMATS THE PDS -C SECTION FROM THE O.N. 84 ID'S FROM THE GRIB -C EDITION 1 DATED MARCH 15, 1991. -C -C 92-01-06 MCCLEES,A.J. DELETE PARAMATER 202 (ACCUMULATED EVAP) -C AND MAKE PARAMETER 57 (EVAPORATION) THE -C EQUIVALENT OF O.N.84 117. -C 92-11-02 R.E.JONES CORRECTION AT SAME LEVEL AS W3FP12 IN -C V77W3LIB ON HDS 92-09-30 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 93-04-16 R.E.JONES ADD 176, 177 LAT, LON TO TABLES -C 93-08-03 R.E.JONES ADD 156 (CIN), 204 (DSWRF), 205 (DLWRF) -C 211 (USWRF), 212 (ULWRF) TO TABLES -C 95-02-07 R.E.JONES CHANGE PDS BYTE 4, VERSION NUMBER TO 2. -C 95-07-14 R.E.JONES CORRECTION FOR SFC LFT X -C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C 99-02-15 B. FACEY REPLACE W3FS04 WITH W3MOVDAT. -C 1999-03-15 Gilbert Specified 8-byte integer array explicitly for ID8 -C 99-03-22 B. FACEY REMOVE THE DATE RECALCULATION FOR MEAN -C CHARTS. THIS INCLUDES THE PREVIOUS -C CHANGE TO W3MOVDAT. -C -C USAGE: CALL W3FP12 (ID8, IFLAG, IDPDS, ICENT, ISCALE, IER) -C INPUT ARGUMENT LIST: -C ID8 - FIRST 8 ID WORKDS (O.N.84) INTEGER*4 -C ICENT - CENTURY, 2 DIGITS, FOR 1991 IT IS 20. -C IFLAG - INDICATION OF INCLUSION OR OMISSION OF GRID DEFINITION -C AND/OR BIT MAP CODE CHARACTER*1 -C ISCALE - 10 SCALER INTEGER*4 -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C IDPDS - GRIB PRODUCT DEFINITION SECTION CHARACTER*1 (28) -C IER = 0 COMPLETED SMOOTHLY -C = 1 INDICATOR PARAMETER N.A. TO GRIB -C = 2 LEVEL INDICATOR N.A. TO GRIB -C = 3 TIME RANGE N.A. TO GRIB NOTATION -C = 4 LAYERS OR LEVELS N.A. TO GRIB -C OUTPUT FILES: -C FT06F001 - SELF-EXPLANATORY ERROR MESSAGES -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -C - INTEGER E1 - INTEGER E2 - INTEGER F1 - INTEGER F2 - DATA F1/0/, F2/0/ - INTEGER HH (163) - INTEGER(8) ID8 ( 4) - INTEGER(8) IDWK ( 4) - INTEGER(8) MSK1,MSK2,MSK3,MSK4,MSK5,MSK6,MSK7 - INTEGER ISIGN - INTEGER ISCALE - INTEGER ICENT - INTEGER LL (163) - INTEGER L - INTEGER M - INTEGER N - INTEGER Q - INTEGER S1 - INTEGER T - DATA T/0/ -C - CHARACTER*1 IDPDS (28) - CHARACTER*1 IFLAG - CHARACTER*1 IHOLD ( 8) - CHARACTER*1 IPDS1 ( 8) - CHARACTER*1 KDATE ( 8) - CHARACTER*1 LIDWK (32) -C - EQUIVALENCE (IDWK(1),LIDWK(1)) - EQUIVALENCE (L,IPDS1(1)) - EQUIVALENCE (NBYTES,IHOLD(1)) - EQUIVALENCE (JDATE,KDATE(1)) - REAL RINC(5) - INTEGER NDATE(8), MDATE(8) -C - DATA LL / 8, 8, 9, 255, 255, 255, 1, 6, 255, 255, - & 16, 24, 19, 23, 20, 21, 17, 18, 255, 180, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 55, 50, 48, 56, 49, 57, 80, 81, 71, 255, - & 40, 42, 72, 74, 73, 255, 255, 255, 255, 255, - & 304, 305, 95, 88, 101, 89, 104, 255, 117, 255, - & 97, 98, 90, 105, 94, 255, 255, 93, 188, 255, - & 255, 255, 255, 211, 255, 255, 255, 255, 255, 255, - & 255, 384, 161, 255, 255, 169, 22, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 400, 389, 385, 388, 391, 386, 390, 402, 401, - & 404, 403, 204, 255, 255, 255, 255, 255, 255, 255, - & 255, 255, 195, 194, 255, 255, 255, 255, 255, 255, - & 255, 255, 112, 116, 114, 255, 103, 52, 255, 255, - & 255, 255, 119, 157, 158, 159, 255, 176, 177, 392, - & 192, 190, 199, 216, 189, 193, 191, 210, 198, 255, - & 255, 1, 255/ - DATA HH / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, - & 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, - & 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, - & 31, 32, 33, 33, 34, 34, 35, 36, 37, 38, - & 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, - & 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, - & 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, - & 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, - & 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, - & 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, - & 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, - & 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, - & 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, - & 129, 130, 131, 132, 133, 134, 135, 136, 137, 150, - & 151, 152, 156, 157, 158, 159, 175, 176, 177, 201, - & 204, 205, 207, 208, 209, 211, 212, 213, 216, 218, - & 220, 222, 255/ -C DATA MSK1 /Z'00000FFF'/, -C & MSK2 /Z'0FFFFF00'/, -C & MSK3 /Z'0000007F'/, -C & MSK4 /Z'00000080'/, -C & MSK5 /Z'F0000000'/, -C & MSK6 /Z'00000200'/, -C & MSK7 /Z'000000FF'/ -C CHANGE HEX TO DECIMAL TO MAKE SUBROUTINE MORE PORTABLE - DATA MSK1 /4095/, - & MSK2 /268435200/, - & MSK3 /127/, - & MSK4 /128/, - & MSK5 /Z'00000000F0000000'/ - & MSK6 /512/, - & MSK7 /255/ -C -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -C -C 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM. -C - NO. OF ENTRIES IN TYPE LEVEL -C - IQ = 163 -C -C 1.1 COPY O.N. 84 ID'S INTO WORK SPACE -C - DO 100 N = 1,4 - IDWK(N) = ID8(N) - 100 CONTINUE -C --------------------------------------------------------------------- -C 2.0 NO. OF OCTETS IN THE PDS IN THE FIRST 3 -C 2.1 SET CNTR ID, DATA TYPE, GRID DEF AND FLAG -C - NBYTES = 28 - IDPDS(1) = IHOLD(6) - IDPDS(2) = IHOLD(7) - IDPDS(3) = IHOLD(8) - IDPDS(4) = CHAR(2) - IDPDS(5) = CHAR(7) - IDPDS(6) = LIDWK(30) - JSCALE = ISCALE - IF (JSCALE.LT.0) THEN - JSCALE = -JSCALE - IDPDS(27) = CHAR(128) - IDPDS(28) = CHAR(JSCALE) - ELSE - IDPDS(27) = CHAR(0) - IDPDS(28) = CHAR(JSCALE) - END IF -C - IF (LIDWK(30) .EQ. CHAR (69)) THEN - IF (LIDWK(29) .EQ. CHAR(3)) THEN - IDPDS(6) = CHAR(68) - ELSE IF (LIDWK(29) .EQ. CHAR(4)) THEN - IDPDS(6) = CHAR(69) - ENDIF - ENDIF - IF (LIDWK(30) .EQ. CHAR (78)) THEN - IF (LIDWK(29) .EQ. CHAR(3)) THEN - IDPDS(6) = CHAR(77) - ELSE IF (LIDWK(29) .EQ. CHAR(4)) THEN - IDPDS(6) = CHAR(78) - ENDIF - ENDIF - IDPDS(7) = LIDWK(20) - IF (LIDWK(20) .EQ. CHAR (26)) IDPDS(7) = CHAR(6) - IDPDS(8) = IFLAG - IDPDS(24) = CHAR(0) - IDPDS(26) = CHAR(0) -C--------------------------------------------------------------------- -C -C 3.0 FORM INDICATOR PARAMETER -C - Q = ISHFT(IDWK(1),-52_8) - DO 300 I = 1,IQ - II = I - IF (Q .EQ. LL(I)) GO TO 310 - 300 CONTINUE -C - IER = 1 - PRINT 320, IER, Q, ID8 - 320 FORMAT (' W3FP12 (320) - IER = ',I2,', Q = ',I3,/, - & ' OFFICE NOTE 84 PARAMETER N.A. IN GRIB', - & /,1X,4(Z16,' ')) - RETURN -C - 310 I = II - S1 = IAND(ISHFT(IDWK(1),-40_8),MSK1) - C1 = ISHFT(IAND(IDWK(1),MSK2),-8_8) - ISIG1 = IAND(IDWK(1),MSK4) - E1 = IAND(IDWK(1),MSK3) - IF (ISIG1 .NE. 0) E1 = -E1 - M = ISHFT(IAND(ISHFT(IDWK(2),-32_8),MSK5),-28_8) - N = ISHFT(IAND(IDWK(2),MSK5),-28_8) - KS = ISHFT(IAND(ISHFT(IDWK(3),-32_8),MSK6),-8_8) - IF (M.NE.0) THEN - C2 = ISHFT(IAND(IDWK(2),MSK2),-8_8) - ISIG2 = IAND(IDWK(2),MSK4) - E2 = IAND(IDWK(2),MSK3) - IF (ISIG2 .NE. 0) E2 = -E2 - ENDIF - IDPDS(9) = CHAR(HH(I)) -C -C N IS A SPECIAL TEST FOR WAVE HGTS, M AND KS ARE SPECIAL FOR -C ACCUMULATED PRECIP -C - IF (N .EQ. 5 .AND. Q .EQ. 1) THEN - IDPDS(9) = CHAR (222) - ENDIF - IF (KS .EQ. 2) THEN - IF (M .EQ. 0 .AND. Q .EQ. 8) THEN - IDPDS(9) = CHAR (211) - END IF -C - IF (M .EQ. 0 .AND. Q .EQ. 1) THEN - IDPDS(9) = CHAR (210) - ENDIF -C - IF (M .EQ. 1 .AND. Q .EQ. 1) THEN - IER = 1 - PRINT 330, IER, ID8 - 330 FORMAT (' W3FP12 (330) - IER =',I2,/, - & ' OFFICE NOTE 84 PARAMETER N.A. IN GRIB', - & /,1X,4(Z16,' ')) - RETURN - ENDIF - ENDIF -C -C 4.0 DETERMINE IF LAYERS OR LEVEL AND FORM TYPE -C -C ......... M = THE M MARKER FROM O.N.84 CHECK ABOVE -C ......... S1 = S1 TYPE OF SURFACE -C - IF (M .EQ. 0) THEN - IF (S1.EQ.0.AND.(Q.EQ.176.OR.Q.EQ.177)) THEN - IDPDS(10) = CHAR(0) - IDPDS(11) = CHAR(0) - IDPDS(12) = CHAR(0) -C - ELSE IF (S1 .EQ. 8) THEN - IDPDS(10) = CHAR (100) - L = C1 * (10. ** E1) + .5 - IDPDS(11) = IPDS1(7) - IDPDS(12) = IPDS1(8) -C - ELSE IF (S1 .EQ. 1) THEN - IDPDS(10) = CHAR (103) - L = C1 * (10. ** E1) + .5 - IDPDS(11) = IPDS1(7) - IDPDS(12) = IPDS1(8) -C - ELSE IF (S1 .EQ. 6) THEN - IDPDS(10) = CHAR (105) - L = C1 * (10. ** E1) + .5 - IDPDS(11) = IPDS1(7) - IDPDS(12) = IPDS1(8) -C - ELSE IF (S1 .EQ. 7) THEN - IDPDS(10) = CHAR (111) -C CONVERT FROM METERS TO CENTIMETERS - IF (ISIG1 .NE. 0) E1 = E1 + 2 - L = C1 * (10. ** E1) + .5 - IDPDS(11) = IPDS1(7) - IDPDS(12) = IPDS1(8) -C - ELSE IF (S1.EQ.148 .OR. S1 .EQ. 144 .OR. S1 .EQ. 145) THEN - IDPDS(10) = CHAR (107) - L = (C1 * (10. ** E1) * 10**4) + .5 - IDPDS(11) = IPDS1(7) - IDPDS(12) = IPDS1(8) -C - ELSE IF (S1 .EQ. 16) THEN - L = C1 * (10. ** E1) + .5 - IF (L .EQ. 273) THEN - IDPDS(10) = CHAR (4) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) - ELSE - IER = 2 - PRINT 410, IER, S1, ID8 - RETURN - ENDIF -C - ELSE IF (S1 .EQ. 19) THEN - L = C1 * (10. ** E1) + .5 - IDPDS(10) = CHAR (113) - IDPDS(11) = IPDS1(7) - IDPDS(12) = IPDS1(8) -C -C SET LEVEL AND PARAMETER FOR MSL PRESSURE -C - ELSE IF (S1 .EQ. 128) THEN - IF (Q.EQ.8) THEN - IDPDS(9) = CHAR(2) - END IF - IDPDS(10) = CHAR (102) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 129) THEN - IDPDS(10) = CHAR (1) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 130) THEN - IDPDS(10) = CHAR (7) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 131) THEN - IDPDS(10) = CHAR (6) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 133) THEN - IDPDS(10) = CHAR (1) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 136) THEN - IF (Q.EQ.8) THEN - IF (T.EQ.2.AND.F1.EQ.0.AND.F2.EQ.3) THEN - IDPDS(9) = CHAR (137) - ELSE - IDPDS(9) = CHAR (128) - END IF - END IF - IDPDS(10) = CHAR (102) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 137) THEN - IF (Q.EQ.8) THEN - IDPDS(9) = CHAR (129) - END IF - IDPDS(10) = CHAR (102) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE IF (S1 .EQ. 138) THEN - IF (Q.EQ.8) THEN - IDPDS(9) = CHAR (130) - END IF - IDPDS(10) = CHAR (102) - IDPDS(11) = CHAR (0) - IDPDS(12) = CHAR (0) -C - ELSE - IER = 2 - PRINT 410, IER, S1, ID8 - 410 FORMAT (' W3FP12 (410) - IER = ',I2,', S1 = ',I5,/, - & ' SURFACE TYPE N.A. IN GRIB',/,' ID8 = ', - & 4(Z16,' ')) - RETURN - ENDIF -C - ELSE IF (M .EQ. 1) THEN - IF ((S1 .EQ. 8) .AND. (Q .EQ. 1)) THEN - IDPDS(9) = CHAR(101) - IDPDS(10) = CHAR(101) - JJJ = ((C1 * 10. ** E1) * .1) + .5 - IDPDS(11) = CHAR(JJJ) - KKK = ((C2 * 10. ** E2) * .1) + .5 - IDPDS(12) = CHAR(KKK) - END IF -C - ELSE IF (M .EQ. 2) THEN - IF (S1 .EQ. 8) THEN - IDPDS(10) = CHAR(101) - JJJ = ((C1 * 10. ** E1) * .1) + .5 - IDPDS(11) = CHAR(JJJ) - KKK = ((C2 * 10. ** E2) * .1) + .5 - IDPDS(12) = CHAR(KKK) - IF (IDPDS(9) .EQ. CHAR(131)) IDPDS(12) = CHAR(100) -C - ELSE IF (S1 .EQ. 1) THEN - IDPDS(10) = CHAR(104) - JJJ = ((C1 * 10. ** E1) * .1) + .5 - IDPDS(11) = CHAR(JJJ) - KKK = ((C2 * 10. ** E2) * .1) + .5 - IDPDS(12) = CHAR(KKK) -C - ELSE IF (S1 .EQ. 6) THEN - IDPDS(10) = CHAR(106) - JJJ = ((C1 * 10. ** E1) * .1) + .5 - IDPDS(11) = CHAR(JJJ) - KKK = ((C2 * 10. ** E2) * .1) + .5 - IDPDS(12) = CHAR(KKK) -C - ELSE IF (S1.EQ.148 .OR. S1 .EQ. 144 .OR. S1 .EQ. 145) THEN - IDPDS(10) = CHAR(108) - JJJ = ((C1 * 10. ** E1) * 10**2) + .5 - IDPDS(11) = CHAR(JJJ) - KKK = ((C2 * 10. ** E2) * 10**2) + .5 - IDPDS(12) = CHAR(KKK) -C - ELSE - IER = 2 - PRINT 420, IER, S1, ID8 - 420 FORMAT (' W3FP12 (420) - IER = ',I2,', S1 = ',I5,/, - & ' SURFACE LAYERS N.A. IN GRIB', - & /,' ID8= ',4(Z16,' ')) - RETURN - ENDIF - ELSE IF (M .GT. 2) THEN - IER = 4 - PRINT 500, IER, M, ID8 - 500 FORMAT ('W3FP12 (500) - IER = ',I2,', M = ',/, - & ' THE M FROM O.N. 84 N.A. IN GRIB', - & /,' ID8 = ',4(Z16,' ')) - RETURN - ENDIF -C -C 6.0 DATE - YR.,MO,DA,& INITIAL HR AND CENTURY -C - IDPDS(13) = LIDWK(25) - IDPDS(14) = LIDWK(26) - IDPDS(15) = LIDWK(27) - IDPDS(16) = LIDWK(28) - IDPDS(17) = CHAR(0) - IDPDS(25) = CHAR(ICENT) -C--------------------------------------------------------------------- -C -C OCTET (17) N.A. FROM O.N. 84 DATA -C -C 7.0 INDICATOR OF TIME UNIT, TIME RANGE 1 AND 2, AND TIME -C RANGE FLAG -C - T = ISHFT((IAND(IDWK(1),MSK5)),-28_8) - F1 = IAND(ISHFT(IDWK(1),-32_8),MSK7) - F2 = IAND(ISHFT(IDWK(2),-32_8),MSK7) - IF (T .EQ. 0) THEN - IDPDS(18) = CHAR (1) - IDPDS(19) = CHAR (F1) - IDPDS(20) = CHAR (0) - IDPDS(21) = CHAR (0) - IDPDS(22) = CHAR (0) - IDPDS(23) = CHAR (0) -C - ELSE IF (T .EQ. 1) THEN - PRINT 710, T, ID8 - IER = 3 - RETURN -C - ELSE IF (T .EQ. 2) THEN - IF (mova2i(IDPDS(9)).NE.137) THEN - PRINT 710, T, ID8 - IER = 3 - RETURN - END IF -C - ELSE IF (T .EQ. 3) THEN - IF (Q .EQ. 89 .OR. Q .EQ. 90 .OR. Q .EQ. 94 - & .OR. Q .EQ. 105) THEN -C - IDPDS(18) = CHAR (1) -C CORRECTION FOR 00 HR FCST - ITEMP = F1 - F2 - IF (ITEMP.LT.0) ITEMP = 0 -C IDPDS(19) = CHAR (F1 - F2) - IDPDS(19) = CHAR (ITEMP) - IDPDS(20) = CHAR (F1) - IDPDS(21) = CHAR (4) - IDPDS(22) = CHAR (0) - IDPDS(23) = CHAR (0) -C - ELSE - IDPDS(18) = CHAR (1) -C CORRECTION FOR 00 HR FCST - ITEMP = F1 - F2 - IF (ITEMP.LT.0) ITEMP = 0 -C IDPDS(19) = CHAR (F1 - F2) - IDPDS(19) = CHAR (ITEMP) - IDPDS(20) = CHAR (F1) - IDPDS(21) = CHAR (5) - IDPDS(22) = CHAR (0) - IDPDS(23) = CHAR (0) - END IF -C - ELSE IF (T .EQ. 4) THEN -C - IF (F1 .EQ. 0 .AND. F2 .NE. 0) THEN - IDPDS(18) = CHAR (4) - IDPDS(19) = CHAR (0) - IDPDS(20) = CHAR (1) - IDPDS(21) = CHAR (124) - L = F2 - IDPDS(22) = IPDS1(7) - IDPDS(23) = IPDS1(8) -C - ELSE IF (F1 .NE. 0 .AND. F2 .EQ. 0) THEN - IDPDS(18) = CHAR (2) - IDPDS(19) = CHAR (0) - IDPDS(20) = CHAR (1) - IDPDS(21) = CHAR (124) - L = F1 - IDPDS(22) = IPDS1(7) - IDPDS(23) = IPDS1(8) -C - ENDIF -C - ELSE IF (T .EQ. 5) THEN - IDPDS(18) = CHAR (1) -C CORRECTION FOR 00 HR FCST - ITEMP = F1 - F2 - IF (ITEMP.LT.0) ITEMP = 0 -C IDPDS(19) = CHAR (F1 - F2) - IDPDS(19) = CHAR (ITEMP) - IDPDS(20) = CHAR (F1) - IDPDS(21) = CHAR (2) - IDPDS(22) = CHAR (0) - IDPDS(23) = CHAR (0) -C - ELSE IF (T .EQ. 6) THEN - JSIGN = IAND(ISHFT(IDWK(1),-32_8),MSK4) - JSIGO = IAND(ISHFT(IDWK(2),-32_8),MSK4) - F1 = IAND(ISHFT(IDWK(1),-32_8),MSK3) - F2 = IAND(ISHFT(IDWK(2),-32_8),MSK3) - IF (JSIGN .NE. 0) F1 = -F1 - IF (JSIGO .NE. 0) F2 = -F2 - IDPDS(18) = CHAR (1) -C****CALCULATE NEW DATE BASED ON THE BEGINNING OF THE DATA IN MEAN -C INCR = (F1) -C IF (INCR.LT.0) THEN -C RINC=0 -C RINC(2)=INCR -C PRINT *, 'INCR=',INCR -C CALL W3FS04 (IDWK(4),JDATE,INCR,IERR) -C IYR=ICHAR(LIDWK(25)) -C PRINT *, 'IYR = ', IYR -C IF(IYR.LT.20)THEN -C MDATE(1)=2000+IYR -C ELSE -C MDATE(1)=1900+IYR -C ENDIF -C MDATE(2) = ICHAR(LIDWK(26)) -C MDATE(3) = ICHAR(LIDWK(27)) -C MDATE(4) = ICHAR(LIDWK(28)) -C PRINT *, 'CHANGE DATE BY - ', RINC(2) -C CALL W3MOVDAT(RINC,MDATE,NDATE) -C PRINT *,'NEW DATE =',NDATE(1),NDATE(2),NDATE(3),NDATE(5) -C IYEAR = MOD(NDATE(1),100) -C LIDWK(25) = CHAR(IYEAR) -C LIDWK(26) = CHAR(NDATE(2)) -C LIDWK(27) = CHAR(NDATE(3)) -C LIDWK(28) = CHAR(NDATE(4)) -C END IF - IDPDS(13) = LIDWK(25) - IDPDS(14) = LIDWK(26) - IDPDS(15) = LIDWK(27) - IDPDS(16) = LIDWK(28) - IF (F1.LT.0) THEN - IDPDS(19) = CHAR (0) - IDPDS(21) = CHAR (123) - ELSE - NF1 = F1 * 12 - IDPDS(19) = CHAR (NF1) - IDPDS(21) = CHAR (113) - END IF - IDPDS(20) = CHAR (24) -C*****THE NUMBER OF CASES AVERAGED IS ASSUMING ONE TIME A DAY -C L = (F2/2) + 1 -C***THE ABOVE CALCULATION WOULD BE CORR. IF ID8(3) WERE CORR. - L = (F2+1) / 2 - IDPDS(22) = IPDS1(7) - IDPDS(23) = IPDS1(8) -C - ELSE IF (T .EQ. 7) THEN - PRINT 710, T, ID8 - IER = 3 - RETURN -C - ELSE IF (T .EQ. 10) THEN - PRINT 710, T, ID8 - IER = 3 - RETURN -C - 710 FORMAT (' W3FP12 (710) - NOT APPLICABLE (YET) TO GRIB. ', - & ', T = ',I2,/, - & ' O.N. 84 IDS ARE ',/, - & 1X,4(Z16,' ')) -C - ENDIF - IER = 0 - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fp13.f b/external/w3nco/v2.0.6/src/w3fp13.f deleted file mode 100644 index 45a77b7e..00000000 --- a/external/w3nco/v2.0.6/src/w3fp13.f +++ /dev/null @@ -1,920 +0,0 @@ - SUBROUTINE W3FP13 (GRIB, PDS, ID8, IERR ) -C$$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FP13 CONVERT GRIB PDS EDITION 1 TO O.N. 84 ID -C PRGMMR: MCCLEES ORG: NMC421 DATE:91-10-07 -C -C ABSTRACT: CONVERTS GRIB VERSION 1 FORMATTED PRODUCT DEFINITION -C SECTION TO AN OFFICE NOTE 84 ID LABEL. FORMATS ALL THAT IS APPLI- -C CABLE IN THE FIRST 8 WORDS OF O.N. 84. (CAUTION ****SEE REMARKS) -C -C PROGRAM HISTORY LOG: -C 91-10-07 ORIGINAL AUTHOR MCCLEES, A. J. -C 92-01-06 R.E.JONES CONVERT TO SiliconGraphics 3.3 FORTRAN 77 -C 93-03-29 R.E.JONES ADD SAVE STATEMENT -C 94-04-17 R.E.JONES COMPLETE REWRITE TO USE SBYTE, MAKE CODE -C PORTABLE, UPGRADE TO ON388, MAR 24,1994 -C 94-05-05 R.E.JONES CORRECTION IN TWO TABLES -C 96-08-02 R.E.JONES ERROR USING T MARKER -C 96-09-03 R.E.JONES ADD MERCATOR GRIDS 8 AND 53 TO TABLES -C 99-02-15 B. FACEY REPLACE W3FS04 WITH W3MOVDAT. -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3FP13 (GRIB, PDS, ID8, IERR ) -C INPUT ARGUMENT LIST: -C GRIB - GRIB SECTION 0 READ AS CHARACTER*8 -C PDS - GRIB PDS SECTION 1 READ AS CHARACTER*1 PDS(*) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ID8 - 12 INTEGER*4 FORMATTED O.N. 84 ID. -C 6 INTEGER 64 BIT WORDS ON CRAY -C IERR 0 - COMPLETED SATISFACTORILY -C 1 - GRIB BLOCK 0 NOT CORRECT -C 2 - LENGTH OF PDS NOT CORRECT -C 3 - COULD NOT MATCH TYPE INDICATOR -C 4 - GRID TYPE NOT IN TABLES -C 5 - COULD NOT MATCH TYPE LEVEL -C 6 - COULD NOT INTERPRET ORIGINATOR OF CODE -C SUBPROGRAMS CALLED: -C SPECIAL: INDEX, MOVA2I, CHAR, IOR, IAND, ISHFT -C -C LIBRARY: -C W3LIB: W3MOVDAT, W3FI69, W3FI01 -C -C REMARKS: SOME OF THE ID'S WILL NOT BE EXACT TO THE O.N. 84 -C FOR LOCATING FIELD ON THE DATASET. THESE DIFFERENCES -C ARE MAINLY DUE TO TRUNCATION ERRORS WITH LAYERS. -C FOR EXAMPLE: .18019 SIG .47191 SIG R H FOR 36.O HRS -C WILL CONVERT TO: .18000 SIG .47000 SIG R H FOR 36.0 HRS -C !!!!!!!THE ABOVE ID'S NOW FORCED TO BE EXACT!!!!!!!!! -C IF J THE WORD COUNT IS GREATER THEN 32743, J IS STORED -C IN THE 12TH ID WORD. BITS 16-31 OF THE 8TH ID WORD ARE -C SET TO ZERO. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C$$$ -C - INTEGER HH (255) - INTEGER HH1 (127) - INTEGER HH2 (128) - INTEGER LL (255) - INTEGER LL1 (127) - INTEGER LL2 (128) - INTEGER ICXG2 (9) - INTEGER ICXGB2 (9) - INTEGER ICXG1 (7) - INTEGER ICXGB1 (7) -C - INTEGER C1 - INTEGER C2 - INTEGER E1 - INTEGER E2 - INTEGER FTU - INTEGER F1 - INTEGER F2 - INTEGER ID (25) - INTEGER ID8 (12) - INTEGER IDATE - INTEGER JDATE - INTEGER IGEN ( 4) - INTEGER NGRD (34) - INTEGER NPTS (34) - INTEGER P1 - INTEGER P2 - INTEGER S1 -C INTEGER S2 - INTEGER T - INTEGER TR -C - CHARACTER * 8 GRIB - CHARACTER * 8 IGRIB - REAL RINC(5) - INTEGER NDATE(8), MDATE(8) - CHARACTER * 1 IWORK ( 8) - CHARACTER * 1 JWORK ( 8) - CHARACTER * 1 PDS ( *) -C - SAVE -C - EQUIVALENCE (HH(1),HH1(1)) - EQUIVALENCE (HH(128),HH2(1)) - EQUIVALENCE (LL(1),LL1(1)) - EQUIVALENCE (LL(128),LL2(1)) - EQUIVALENCE (IDATE,IWORK(1)) - EQUIVALENCE (JDATE,JWORK(1)) -C - DATA HH1 / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, - & 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, - & 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, - & 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, - & 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, - & 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, - & 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, - & 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, - & 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, - & 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, - & 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, - & 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, - & 121, 122, 123, 124, 125, 126, 127/ - DATA HH2 / 128, 129, 130, - & 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, - & 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, - & 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, - & 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, - & 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, - & 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, - & 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, - & 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, - & 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, - & 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, - & 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, - & 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, - & 251, 252, 253, 254, 255/ -C - DATA IGEN / 7, 58, 66, 98/ -C -C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB LAYER. -C ICXG2 1.0000, .98230, .96470, -C .85000, .84368, .47191, -C .18017, .81573, .25011 -C ################# -C - DATA ICXG2 /Z'00002710', Z'00017FB6', Z'000178D6', - A Z'00014C08', Z'00014990', Z'0000B857', - A Z'00004663', Z'00013EA5', Z'000061B3'/ -C -C ########### NUMBERS CALCULATED BY GRIB LAYER. -C ICXGB2 1.00000, .98000, .96000, -C .85000, .84000, .47000, -C .18000, .82000, .25000 -C ################# -C - DATA ICXGB2/Z'00002710', Z'00017ED0', Z'00017700', - A Z'00014C00', Z'00014820', Z'0000B798', - A Z'00004650', Z'00014050', Z'000061A8'/ -C -C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB SINGLE. -C ICXG1 .98230, .89671, .78483 -C .94316, .84367, .999.00, .25011 -C ################# -C - DATA ICXG1 /Z'00017FB6', Z'00015E47', Z'00013293', - A Z'0001706C', Z'0001498F', Z'0000863C', Z'000061B3'/ -C -C ########### NUMBERS CALCULATED BY GRIB LAYER. -C ICXGB1 .98230, .89670, .78480 -C .94320, .84370, 998.00, .25000 -C ################# -C - DATA ICXGB1/Z'00017FB6', Z'00015E46', Z'00013290', - A Z'00017070', Z'00014992', Z'000185D8', Z'000061A8'/ -C - DATA LL1 / 8, 8, 9, 255, 255, 255, 1, 6, 255, 255, - & 16, 24, 19, 23, 20, 21, 17, 18, 255, 180, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 55, 50, 48, 49, 80, 81, 71, 255, 40, 42, - & 72, 74, 73, 255, 255, 255, 255, 255, 304, 305, - & 95, 88, 101, 89, 104, 255, 117, 255, 97, 98, - & 90, 105, 94, 255, 255, 93, 188, 255, 255, 255, - & 255, 211, 255, 255, 255, 255, 255, 255, 255, 384, - & 161, 255, 255, 169, 22, 255, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 400, - & 389, 385, 388, 391, 386, 390, 402, 401, 404, 403, - & 204, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 195, 194, 255, 255, 255, 255, 255/ - DATA LL2 / 255, 255, 255, - & 112, 116, 114, 255, 103, 52, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 119, 157, 158, 159, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 176, 177, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 392, 255, 255, 192, 190, 255, 199, 216, 189, 255, - & 193, 191, 210, 107, 255, 198, 255, 255, 255, 255, - & 255, 1, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, - & 255, 160, 255, 255, 255/ -C - DATA NPTS / 1679, 259920, 3021, 2385, 5104, 4225, - & 4225, 5365, 5365, 8326, 8326, - & 5967, 6177, 6177, 12321, 12321, 12321, - & 32400, 32400, 5022, 12902, 25803, - & 24162, 48232, 18048, 6889, 10283, - & 3640, 16170, 6889, 19305, 11040, - & 72960, 6693/ -C - DATA NGRD / 1, 4, 5, 6, 8, 27, - & 28, 29, 30, 33, 34, - & 53, 55, 56, 75, 76, 77, - & 85, 86, 87, 90, 91, - & 92, 93, 98, 100, 101, - & 103, 104, 105, 106, 107, - & 126, 214/ -C -C DATA MSK1 /Z0000FFFF/, -C & MSK2 /Z00000080/, -C & MSK3 /Z00000000/, -C & MSK4 /Z00000200/ -C CHANGE HEX TO DECIMAL TO MAKE SUBROUTINE MORE PORTABLE -C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DATA MSK1 /65535/, - & MSK2 /128/, - & MSK3 /0/, - & MSK4 /512/ -C -C MAKE SECTION 0, PUT 'GRIB' IN ASCII -C - IGRIB(1:1) = CHAR(71) - IGRIB(2:2) = CHAR(82) - IGRIB(3:3) = CHAR(73) - IGRIB(4:4) = CHAR(66) - IGRIB(5:5) = CHAR(0) - IGRIB(6:6) = CHAR(0) - IGRIB(7:7) = CHAR(0) - IGRIB(8:8) = CHAR(1) -C -C CONVERT PDS INTO 25 INTEGER NUMBERS -C - CALL W3FI69(PDS,ID) -C -C ID(1) = NUMBER OF BYTES IN PDS -C ID(2) = PARAMETER TABLE VERSION NUMBER -C ID(3) = IDENTIFICATION OF ORIGINATING CENTER -C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER) -C ID(5) = GRID IDENTIFICATION -C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED -C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED -C ID(8) = INDICATOR OF PARAMETER AND UNITS -C ID(9) = INDICATOR OF TYPE OF LEVEL OR LAYER -C ID(10) = LEVEL 1 -C ID(11) = LEVEL 2 -C ID(12) = YEAR OF CENTURY -C ID(13) = MONTH OF YEAR -C ID(14) = DAY OF MONTH -C ID(15) = HOUR OF DAY -C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0) -C ID(17) = FCST TIME UNIT -C ID(18) = P1 PERIOD OF TIME -C ID(19) = P2 PERIOD OF TIME -C ID(20) = TIME RANGE INDICATOR -C ID(21) = NUMBER INCLUDED IN AVERAGE -C ID(22) = NUMBER MISSING FROM AVERAGES OR ACCUMULATIONS -C ID(23) = CENTURY -C ID(24) = IDENTIFICATION OF SUB-CENTER (TABLE 0 - PART 2) -C ID(25) = SCALING POWER OF 10 -C -C THE 1ST 8 32 BIT WORDS WITH THE OFFICE NOTE 84 ID'S ARE -C IN 27 PARTS, SBYTE IS USED WITH BIT COUNTS TO MAKE THIS -C DATA. THIS MAKE IT WORD SIZE INDEPENDENT, AND MAKES THIS -C SUBROUTINE PORTABLE. TABLE WITH STARTING BITS IS NEXT. -C THE STARTING BIT AND NO. OF BITS IS USED AS THE 3RD AND -C 4TH PARAMETER FOR SBYTE. READ GBYTES DOCUMENT FROM NCAR -C FOR INFORMATION ABOUT SBYTE. SEE PAGE 38, FIGURE 1, IN -C OFFICE NOTE 84. -C -C NO. NAME STARTING BIT NO. OF BITS -C ----------------------------------------- -C 1 Q 0 12 -C 2 S1 12 12 -C 3 F1 24 8 -C 4 T 32 4 -C 5 C1 36 20 -C 6 E1 56 8 -C 7 M 64 4 -C 8 X 68 8 -C 9 S2 76 12 -C 10 F2 88 8 -C 11 N 96 4 -C 12 C2 100 20 -C 13 E2 120 8 -C 14 CD 128 8 -C 15 CM 136 8 -C 16 KS 144 8 -C 17 K 152 8 -C 18 GES 160 4 -C 19 164 12 -C 20 NW 176 16 -C 21 YY 192 8 -C 22 MM 200 8 -C 23 DD 208 8 -C 24 II 216 8 -C 25 R 224 8 -C 26 G 232 8 -C 27 J 240 16 -C OR 27 J 352 32 J > 32743 -C---------------------------------------------- -C -C 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM. -C - NO. OF ENTRIES IN TYPE LEVEL -C - NO. OF ENTRIES IN CNTR PROD. DTA. -C - INITIAL ZEROS IN O.N. 84 LABEL -C - IQ = 255 - IC = 4 - IN = 34 -C -C TEST FOR 32 OR 64 BIT COMPUTER (CRAY) -C - CALL W3FI01(LW) - IF (LW.EQ.4) THEN - NWORDS = 12 - ELSE - NWORDS = 6 - END IF -C -C ZERO OUTPUT ARRAY -C - DO N = 1,NWORDS - ID8(N) = 0 - END DO -C -C --------------------------------------------------------------------- -C 2.0 VERIFY GRIB IN SECTION 0 -C - IF (.NOT. GRIB(1:4) .EQ. IGRIB(1:4)) THEN - IERR = 1 - RETURN - END IF -C -C 2.1 VERIFY THE NO. OF OCTETS IN THE PDS -C - IF (ID(1).NE.28) THEN - IERR = 2 - PRINT *,'IERR = ',IERR,',LENGTH OF PDS = ',ID(1) - RETURN - END IF -C -C 3.0 GENERATING MODEL, TYPE GRID, AND NO. OF GRID PTS. -C -C IF CENTER NOT U.S., STORE CENTER IN G MARKER -C IF CENTER U.S. STORE MODEL NO. IN G MARKER -C - IF (ID(3) .NE. 7) THEN - CALL SBYTE(ID8,ID(3),232,8) - ELSE - CALL SBYTE(ID8,ID(4),232,8) - END IF -C - DO KK = 1,IN - IF (ID(5) .EQ. NGRD(KK)) THEN - IGRDPT = NPTS(KK) - IF (ID(5) .EQ. 6) ID(5) = 26 - CALL SBYTE(ID8,ID(5),152,8) - IF (IGRDPT.LE.32743) THEN - CALL SBYTE(ID8,IGRDPT,240,16) - ELSE - CALL SBYTE(ID8,IGRDPT,352,32) - END IF - GO TO 350 - END IF - END DO - IERR = 4 - PRINT *,'IERR = ',IERR,',GRID TYPE = ',ID(5) - RETURN -C - 350 CONTINUE -C -C COMPUTE R MARKER FROM MODEL NUMBERS FOR U.S. CENTER -C -C (ERL) run - IF (ID(3).EQ.7) THEN - IF (ID(4).EQ.19.OR.ID(4).EQ.53.OR.ID(4).EQ.83.OR. - & ID(4).EQ.84.OR.ID(4).EQ.85) THEN - CALL SBYTE(ID8,0,224,8) -C (NMC) run - ELSE IF (ID(4).EQ.25) THEN - CALL SBYTE(ID8,1,224,8) -C (RGL) run - ELSE IF (ID(4).EQ.39.OR.ID(4).EQ.64) THEN - CALL SBYTE(ID8,2,224,8) -C (AVN) run - ELSE IF (ID(4).EQ.10.OR.ID(4).EQ.42.OR. - & ID(4).EQ.68.OR.ID(4).EQ.73.OR. - & ID(4).EQ.74.OR.ID(4).EQ.75.OR. - & ID(4).EQ.77.OR.ID(4).EQ.81.OR. - & ID(4).EQ.88) THEN - CALL SBYTE(ID8,3,224,8) -C (MRF) run - ELSE IF (ID(4).EQ.69.OR.ID(4).EQ.76.OR. - & ID(4).EQ.78.OR.ID(4).EQ.79.OR. - & ID(4).EQ.80.oR.ID(4).EQ.87) THEN - CALL SBYTE(ID8,4,224,8) -C (FNL) run - ELSE IF (ID(4).EQ.43.OR.ID(4).EQ.44.OR. - & ID(4).EQ.82) THEN - CALL SBYTE(ID8,5,224,8) -C (HCN) run - ELSE IF ( ID(4).EQ.70) THEN - CALL SBYTE(ID8,6,224,8) -C (RUC) run - ELSE IF ( ID(4).EQ.86) THEN - CALL SBYTE(ID8,7,224,8) -C Not applicable, set to 255 - ELSE - CALL SBYTE(ID8,255,224,8) - END IF - END IF -C -C 4.0 FORM TYPE DATA PARAMETER -C - DO II = 1,IQ - III = II - IF (ID(8) .EQ. HH(II)) THEN - IF (LL(II).NE.255) GO TO 410 - PRINT *,'PDS PARAMETER HAS NO OFFICE NOTE 84 Q TYPE' - PRINT *,'PDS BYTE 9 PARAMETER = ',ID(8) - IERR = 3 - RETURN - END IF - END DO - IERR = 3 - PRINT *,'PDS BYTE 9, PARAMETER = ',ID(8) - RETURN -C - 410 CONTINUE -C -C Q DATA TYPE, BITS 1-12 -C - CALL SBYTE(ID8,LL(III),0,12) -C -C TEST FOR 32 OR 64 BIT COMPUTER (CRAY) -C - IF (LW.EQ.4) THEN - IF (ID(8) .EQ. 211) ID8(5) = IOR (ID8(5),MSK4) - IF (ID(8) .EQ. 210) ID8(5) = IOR (ID8(5),MSK4) - ELSE - IF (ID(8) .EQ. 211) ID8(3) = IOR (ID8(3),ISHFT(MSK4,32)) - IF (ID(8) .EQ. 210) ID8(3) = IOR (ID8(3),ISHFT(MSK4,32)) - END IF -C -C 5.0 FORM TYPE LEVEL -C - IF (ID(9) .EQ. 100) THEN - M = 0 - S1 = 8 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - LEVEL = ID(11) - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) -C - ELSE IF (ID(9) .EQ. 103) THEN - M = 0 - S1 = 1 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - LEVEL = ID(11) - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) -C - ELSE IF (ID(9) .EQ. 105) THEN - M = 0 - S1 = 6 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - LEVEL = ID(11) - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) -C - ELSE IF (ID(9) .EQ. 111) THEN - M = 0 - S1 = 7 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - LEVEL = ID(11) - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) -C XXXXXXX SCALE FROM CENTIMETERS TO METERS. XXXXXXXXXX - E1 = IOR(E1,MSK2) - E1 = E1 + 2 - IF (C1 .EQ. 0) THEN - E1 = 0 - END IF - CALL SBYTE(ID8,E1,56,8) -C - ELSE IF (ID(9) .EQ. 107) THEN - M = 0 - S1 = 148 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - LEVEL = ID(11) - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - ELSE - E1 = 0 - END IF - C1 = LEVEL * 10 ** E1 - DO ISI = 1,7 - IF (C1 .EQ. ICXGB1(ISI)) THEN - C1 = ICXG1(ISI) - END IF - END DO - CALL SBYTE(ID8,C1,36,20) -C***********SCALING OF .0001 TAKEN INTO ACCOUNT - E1 = E1 + 4 - E1 = IOR(E1,MSK2) - IF (C1 .EQ. 0) THEN - E1 = 0 - END IF - CALL SBYTE(ID8,E1,56,8) -C - ELSE IF (ID(9) .EQ. 4) THEN - M = 0 - S1 = 16 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) -C LEVEL = ID(11) -C******* CONSTANT VALUE OF 273.16 WILL HAVE TO BE INSERTED -C LEVEL = IAND (IPDS(3),MSK1) -C IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN -C E1 = 4 -C ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN -C E1 = 3 -C ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN -C E1 = 2 -C ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN -C E1 = 1 -C END IF - E1 = 2 - C1 = (273.16 * 10 ** E1) + .5 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) -C*************SPECIAL CASES ********************* - ELSE IF (ID(9) .EQ. 102) THEN - M = 0 - S1 = 128 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,0,64,32) -C - ELSE IF (ID(9) .EQ. 1) THEN - M = 0 - S1 = 129 -C***** S1 = 133 ALSO POSSIBILITY - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,0,64,32) -C - ELSE IF (ID(9) .EQ. 7) THEN - M = 0 - S1 = 130 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,0,64,32) -C - ELSE IF (ID(9) .EQ. 6) THEN - M = 0 - S1 = 131 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,0,64,32) -C - ELSE IF (ID(9) .EQ. 101) THEN - M = 2 - S1 = 8 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - CALL SBYTE(ID8,S1,76,12) - LEVEL = ID(10) - LEVEL = (LEVEL * .1) * 10 ** 2 - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) - LEVEL2 = ID(11) - LEVEL2 = (LEVEL2 * .1) * 10 ** 2 - IF (LEVEL2 .GE. 1 .AND. LEVEL2 .LE. 9) THEN - E2 = 4 - ELSE IF (LEVEL2 .GE. 10 .AND. LEVEL2 .LE. 99) THEN - E2 = 3 - ELSE IF (LEVEL2 .GE. 100 .AND. LEVEL2 .LE. 999) THEN - E2 = 2 - ELSE IF (LEVEL2 .GE. 1000 .AND. LEVEL2 .LE. 9999) THEN - E2 = 1 - END IF - C2 = LEVEL2 * 10 ** E2 - CALL SBYTE(ID8,C2,100,20) - IF (C2 .EQ. 0) E2 = 0 - E2 = IOR(E2,MSK2) - CALL SBYTE(ID8,E2,120,8) -C - ELSE IF (ID(9) .EQ. 104) THEN - M = 2 - S1 = 1 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - CALL SBYTE(ID8,S1,76,12) - LEVEL = ID(10) - LEVEL = (LEVEL * .1) * 10 ** 2 - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) - LEVEL2 = ID(11) - LEVEL2 = (LEVEL2 * .1) * 10 ** 2 - IF (LEVEL2 .GE. 1 .AND. LEVEL2 .LE. 9) THEN - E2 = 4 - ELSE IF (LEVEL2 .GE. 10 .AND. LEVEL2 .LE. 99) THEN - E2 = 3 - ELSE IF (LEVEL2 .GE. 100 .AND. LEVEL2 .LE. 999) THEN - E2 = 2 - ELSE IF (LEVEL2 .GE. 1000 .AND. LEVEL2 .LE. 9999) THEN - E2 = 1 - END IF - C2 = LEVEL2 * 10 ** E2 - CALL SBYTE(ID8,C2,100,20) - E2 = IOR(E2,MSK2) - CALL SBYTE(ID8,E2,120,8) -C - ELSE IF (ID(9) .EQ. 106) THEN - M = 2 - S1 = 6 - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - CALL SBYTE(ID8,S1,76,12) - LEVEL = ID(10) - LEVEL = (LEVEL * .1) * 10**2 - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * 10 ** E1 - CALL SBYTE(ID8,C1,36,20) - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) - LEVEL2 = ID(10) - LEVEL2 = (LEVEL2 * .1) * 10 ** 2 - IF (LEVEL2 .GE. 1 .AND. LEVEL2 .LE. 9) THEN - E2 = 4 - ELSE IF (LEVEL2 .GE. 10 .AND. LEVEL2 .LE. 99) THEN - E2 = 3 - ELSE IF (LEVEL2 .GE. 100 .AND. LEVEL2 .LE. 999) THEN - E2 = 2 - ELSE IF (LEVEL2 .GE. 1000 .AND. LEVEL2 .LE. 9999) THEN - E2 = 1 - END IF - C2 = LEVEL2 * 10 ** E2 - CALL SBYTE(ID8,C2,100,20) - E2 = IOR(E2,MSK2) - CALL SBYTE(ID8,E2,120,8) -C - ELSE IF (ID(9) .EQ. 108) THEN - M = 2 - S1 = 148 -C**** S1 = 144 ALSO POSSIBILITY -C**** S1 = 145 ALSO POSSIBILITY - CALL SBYTE(ID8,S1,12,12) - CALL SBYTE(ID8,M,64,4) - CALL SBYTE(ID8,S1,76,12) - LEVEL = ID(10) - LEVEL = LEVEL - IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN - E1 = 4 - ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN - E1 = 3 - ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN - E1 = 2 - ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN - E1 = 1 - END IF - C1 = LEVEL * (10 ** E1) - DO ISI = 1,9 - IF (C1 .EQ. ICXGB2(ISI)) THEN - C1 = ICXG2(ISI) - END IF - END DO - CALL SBYTE(ID8,C1,36,20) - IF (C1 .EQ. 0) THEN - E1 = 0 - CALL SBYTE(ID8,E1,56,8) - GO TO 700 - END IF -C*****TAKE SCALING INTO ACCOUNT .01 - E1 = E1 + 2 - E1 = IOR(E1,MSK2) - CALL SBYTE(ID8,E1,56,8) -C - 700 CONTINUE - LEVEL2 = ID(11) - LEVEL2 = LEVEL2 - IF (LEVEL2 .GE. 1 .AND. LEVEL2 .LE. 9) THEN - E2 = 4 - ELSE IF (LEVEL2 .GE. 10 .AND. LEVEL2 .LE. 99) THEN - E2 = 3 - ELSE IF (LEVEL2 .GE. 100 .AND. LEVEL2 .LE. 999) THEN - E2 = 2 - ELSE IF (LEVEL2 .GE. 1000 .AND. LEVEL2 .LE. 9999) THEN - E2 = 1 - END IF - C2 = LEVEL2 * 10 ** E2 - DO ISI = 1,9 - IF (C2 .EQ. ICXGB2(ISI)) THEN - C2 = ICXG2(ISI) - END IF - END DO - CALL SBYTE(ID8,C2,100,20) - E2 = IOR(E2,MSK2) - CALL SBYTE(ID8,E2,120,8) -C*******TAKE SCALING INTO ACCOUNT .01 - E2 = E2 + 2 - E2 = IOR(E2,MSK2) - CALL SBYTE(ID8,E2,120,8) -C - END IF -C 5.1 FORCAST TIMES ,PLUS THE T MARKER AND CM FIELD -C - TR = ID(20) - IF (TR .EQ. 0) THEN - P1 = ID(18) - CALL SBYTE(ID8,ID(18),24,8) - ELSE IF (TR .EQ. 4) THEN - P2 = ID(19) - CALL SBYTE(ID8,P2,24,8) - P1 = ID(18) - CALL SBYTE(ID8,(P2 - P1),88,8) - T = 3 - CALL SBYTE(ID8,T,32,4) - ELSE IF (TR .EQ. 5) THEN - P2 = ID(19) - CALL SBYTE(ID8,P2,24,8) - P1 = ID(18) - CALL SBYTE(ID8,(P2 - P1),88,8) - T = 3 - CALL SBYTE(ID8,T,32,4) -C - ELSE IF (TR .EQ. 124) THEN - FTU = ID(17) - IF (FTU .EQ. 2) THEN - F1 = ID(21) - CALL SBYTE(ID8,F1,24,8) - T = 4 - CALL SBYTE(ID8,T,32,4) - ELSE IF (FTU .EQ. 4) THEN - F2 = ID(21) - CALL SBYTE(ID8,F2,88,8) - T = 4 - CALL SBYTE(ID8,T,32,4) - END IF -C - ELSE IF (TR .EQ.123) THEN - F1 = 3 - F1 = IOR(F1,MSK2) - CALL SBYTE(ID8,F1,24,8) - F2 = 5 * 2 - CALL SBYTE(ID8,F2,88,8) - T = 6 - CALL SBYTE(ID8,T,32,4) - RINC = 0.0 - RINC(2) = 36.0 - IYR=MOVA2I(PDS(13)) - PRINT *, 'IYR = ', IYR - IF(IYR.LT.20)THEN - MDATE(1)=2000+IYR - ELSE - MDATE(1)=1900+IYR - ENDIF - MDATE(2) = MOVA2I(PDS(14)) - MDATE(3) = MOVA2I(PDS(15)) - MDATE(5) = MOVA2I(PDS(16)) -C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5) -C PRINT *, 'CHANGE DATE BY - ', RINC(2) - CALL W3MOVDAT(RINC,MDATE,NDATE) -C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5) -C CALL W3FS04 (IDATE,JDATE,3,IERR) - IYEAR = MOD(NDATE(1),100) - JWORK(1) = CHAR(IYEAR) - JWORK(2) = CHAR(NDATE(2)) - JWORK(3) = CHAR(NDATE(3)) - JWORK(4) = CHAR(NDATE(5)) - IDATE = JDATE - GO TO 710 -C - ELSE IF (TR .EQ.3) THEN - P1 = ID(18) - P2 = ID(19) - F1 = P1 / 12 - CALL SBYTE(ID8,F1,24,8) -C -C ***** NAVG IS IN BITES 22 23 ***** -C USING BITE 23 ONLY ******* -C FIX LATER ****************************************** -C -C NAVG = MOVA2I(PDS(23)) - F2 = (P2 - P1) / 12 - CALL SBYTE(ID8,F2,88,8) - T = 6 - CALL SBYTE(ID8,T,32,4) - RINC = 0.0 - RINC(2) = -36.0 - IYR=MOVA2I(PDS(13)) - PRINT *, 'IYR = ', IYR - IF(IYR.LT.20)THEN - MDATE(1)=2000+IYR - ELSE - MDATE(1)=1900+IYR - ENDIF - MDATE(2) = MOVA2I(PDS(14)) - MDATE(3) = MOVA2I(PDS(15)) - MDATE(5) = MOVA2I(PDS(16)) -C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5) -C PRINT *, 'CHANGE DATE BY - ', RINC(2) - CALL W3MOVDAT(RINC,MDATE,NDATE) -C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5) -C CALL W3FS04 (IDATE,JDATE,-3,IERR) - IYEAR = MOD(NDATE(1),100) - JWORK(1) = CHAR(IYEAR) - JWORK(2) = CHAR(NDATE(2)) - JWORK(3) = CHAR(NDATE(3)) - JWORK(4) = CHAR(NDATE(5)) - IDATE = JDATE - GO TO 710 - END IF -C -C 7.0 TRANSFER THE DATE -C - IWORK(1) = PDS(13) - IWORK(2) = PDS(14) - IWORK(3) = PDS(15) - IWORK(4) = PDS(16) -C - 710 CONTINUE -C -C TEST FOR 64 BIT COMPUTER (CRAY) -C - IF (LW.EQ.8) IDATE = ISHFT(IDATE,-32) - CALL SBYTE(ID8,IDATE,192,32) -C - IERR = 0 - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fs13.f b/external/w3nco/v2.0.6/src/w3fs13.f deleted file mode 100644 index 8d1fd0ef..00000000 --- a/external/w3nco/v2.0.6/src/w3fs13.f +++ /dev/null @@ -1,52 +0,0 @@ - SUBROUTINE W3FS13(IYR,IMO,IDA,JDY) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FS13 YEAR, MONTH, AND DAY TO DAY OF YEAR -C AUTHOR: CHASE, P. ORG: W345 DATE: 85-07-31 -C -C ABSTRACT: CONVERTS YEAR, MONTH AND DAY TO DAY OF YEAR. -C -C PROGRAM HISTORY LOG: -C 85-07-31 R.E.JONES -C 89-11-02 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FS13(IYR, IMO, IDA, JDY) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IYR ARG LIST INTEGER YEAR OF CENTURY, 00-99 OR YEAR OF ERA, -C 1901-2099 -C IMO ARG LIST INTEGER MONTH OF YEAR, 1-12 -C IDA ARG LIST INTEGER DAY OF MONTH, 1-31 -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C JDY ARG LIST INTEGER DAY OF YEAR, 1-366 -C -C SUBPROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C IAND SYSTEM -C -C REMARKS: THIS PROCEDURE IS VALID ONLY FROM THE YEARS 1901-2099 -C INCLUSIVE. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - INTEGER JTABLE(24) -C - DATA JTABLE/0,0,31,31,60,59,91,90,121,120,152,151, - & 182,181,213,212,244,243,274,273,305,304,335,334/ -C - ISET = 0 - IF (IAND(IYR,3).EQ.0) ISET = 1 - I = IMO * 2 - ISET - JDY = JTABLE(I) + IDA - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fs15.f b/external/w3nco/v2.0.6/src/w3fs15.f deleted file mode 100644 index a6ad1529..00000000 --- a/external/w3nco/v2.0.6/src/w3fs15.f +++ /dev/null @@ -1,212 +0,0 @@ - SUBROUTINE W3FS15(IDATE,JTAU,NDATE) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FS15 UPDATING OFFICE NOTE 85 DATE/TIME WORD -C PRGMMR: REJONES ORG: NMC421 DATE: 89-08-23 -C -C ABSTRACT: UPDATES OR BACKDATES A FULLWORD DATE/TIME WORD (O.N. 84) -C BY A SPECIFIED NUMBER OF HOURS. -C -C PROGRAM HISTORY LOG: -C ??-??-?? R.ALLARD -C 87-02-19 R.E.JONES CLEAN UP CODE -C 87-02-19 R.E.JONES CHANGE TO MICROSOFT FORTRAN 4.10 -C 89-05-12 R.E.JONES CORRECT ORDER OF BYTES IN DATE WORD FOR PC -C 89-08-04 R.E.JONES CLEAN UP CODE, GET RID OF ASSIGN, CORRECTION -C FOR MEMORY SET TO INDEFINITE. -C 89-10-25 R.E.JONES CHANGE TO CRAY CFT77 FORTRAN -C 95-11-15 R.E.JONES ADD SAVE STATEMENT -C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I -C -C USAGE: CALL W3FS15 (IDATE, JTAU, NDATE) -C INPUT ARGUMENT LIST: -C IDATE - PACKED BINARY DATE/TIME AS FOLLOWS: -C BYTE 1 IS YEAR OF CENTURY 00-99 -C BYTE 2 IS MONTH 01-12 -C BYTE 3 IS DAY OF MONTH 01-31 -C BYTE 4 IS HOUR 00-23 -C SUBROUTINE TAKES ADVANTAGE OF FORTRAN ADDRESS -C PASSING, IDATE AND NDATE MAY BE -C A CHARACTER*1 ARRAY OF FOUR, THE LEFT 32 -C BITS OF 64 BIT INTEGER WORD. AN OFFICE NOTE 85 -C LABEL CAN BE STORED IN -C 4 INTEGER WORDS. -C IF INTEGER THE 2ND WORD IS USED. OUTPUT -C IS STORED IN LEFT 32 BITS. FOR A OFFICE NOTE 84 -C LABEL THE 7TH WORD IS IN THE 4TH CRAY 64 BIT -C INTEGER, THE LEFT 32 BITS. -C JTAU - INTEGER NUMBER OF HOURS TO UPDATE (IF POSITIVE) -C OR BACKDATE (IF NEGATIVE) -C -C OUTPUT ARGUMENT LIST: -C NDATE - NEW DATE/TIME WORD RETURNED IN THE -C SAME FORMAT AS 'IDATE'. 'NDATE' AND 'IDATE' MAY -C BE THE SAME VARIABLE. -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - NONE -C -C RESTRICTIONS: THIS ROUTINE IS VALID ONLY FOR THE 20TH CENTURY. -C -C NOTES: THE FORMAT OF THE DATE/TIME WORD IS THE SAME AS THE -C SEVENTH WORD OF THE PACKED DATA FIELD LABEL (SEE O.N. 84) AND -C THE THIRD WORD OF A BINARY DATA SET LABEL (SEE O.N. 85). -C -C EXIT STATES: -C AN ERROR FOUND BY OUT OF RANGE TESTS ON THE GIVEN DATE/TIME -C INFORMATION WILL BE INDICATED BY RETURNING A BINARY ZERO WORD -C IN 'NDATE'. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - INTEGER ITABYR(13) - INTEGER LPTB(13) - INTEGER NOLPTB(13) -C - CHARACTER*1 IDATE(4) - CHARACTER*1 NDATE(4) -C - SAVE -C - DATA LPTB /0000,0744,1440,2184,2904,3648,4368,5112, - & 5856,6576,7320,8040,8784/ - DATA NOLPTB/0000,0744,1416,2160,2880,3624,4344,5088, - & 5832,6552,7296,8016,8760/ - DATA ICENTY/1900/ -C -C ...WHERE ICENTY IS FOR THE 20TH CENTURY ASSUMED FOR THE GIVEN -C ... YEAR WITHIN THE CENTURY -C - IYR = MOVA2I(IDATE(1)) - IMONTH = MOVA2I(IDATE(2)) - IDAY = MOVA2I(IDATE(3)) - IHOUR = MOVA2I(IDATE(4)) -C - IF (IYR .GT. 99) GO TO 1600 - IF (IMONTH .LE. 0) GO TO 1600 - IF (IMONTH .GT. 12) GO TO 1600 - IF (IDAY .LE. 0) GO TO 1600 - IF (IDAY .GT. 31) GO TO 1600 - IF (IHOUR .LT. 0) GO TO 1600 - IF (IHOUR .GT. 24) GO TO 1600 - IF (JTAU .NE. 0) GO TO 100 -C - NDATE(1) = IDATE(1) - NDATE(2) = IDATE(2) - NDATE(3) = IDATE(3) - NDATE(4) = IDATE(4) - RETURN -C - 100 CONTINUE - JAHR = IYR + ICENTY - KABUL = 1 - GO TO 900 -C -C ...WHERE 900 IS SUBROUTINE TO INITIALIZE ITABYR -C ...AND RETURN THRU KABUL -C - 200 CONTINUE - IHRYR = IHOUR + 24 * (IDAY - 1) + ITABYR(IMONTH) - IHRYR2 = IHRYR + JTAU -C -C ...TO TEST FOR BACKDATED INTO PREVIOUS YEAR... -C - 300 CONTINUE - IF (IHRYR2 .LT. 0) GO TO 700 -C - DO 400 M = 2,13 - IF (IHRYR2 .LT. ITABYR(M)) GO TO 600 - 400 CONTINUE -C -C ...IF IT FALLS THRU LOOP TO HERE, IT IS INTO NEXT YEAR... -C - JAHR = JAHR + 1 - IHRYR2 = IHRYR2 - ITABYR(13) - KABUL = 2 - GO TO 900 -C - 600 CONTINUE - MONAT = M - 1 - IHRMO = IHRYR2 - ITABYR(MONAT) - NODAYS = IHRMO / 24 - ITAG = NODAYS + 1 - IUHR = IHRMO - NODAYS * 24 - GO TO 1500 -C -C ...ALL FINISHED. RETURN TO CALLING PROGRAM....................... -C ...COMES TO 700 IF NEG TOTAL HRS. BACK UP INTO PREVIOUS YEAR -C - 700 CONTINUE - JAHR = JAHR - 1 - KABUL = 3 - GO TO 900 -C -C ...WHICH IS CALL TO INITIALIZE ITABYR AND RETURN THRU KABUL -C - 800 CONTINUE - IHRYR2 = ITABYR(13) + IHRYR2 - GO TO 300 -C -C ...SUBROUTINE INITYR... -C ...CALLED BY GO TO 900 AFTER ASSIGNING RETURN NO. TO KABUL... -C ...ITABYR HAS MONTHLY ACCUMULATING TOTAL HRS REL TO BEGIN OF YR. -C ...DEPENDS ON WHETHER JAHR IS LEAP YEAR OR NOT. -C - 900 CONTINUE - IQUOT = JAHR / 4 - IRMNDR = JAHR - 4 * IQUOT - IF (IRMNDR .NE. 0) GO TO 1000 -C -C ...WAS MODULO 4, SO MOST LIKELY A LEAP YEAR, -C - IQUOT = JAHR / 100 - IRMNDR = JAHR - 100 * IQUOT - IF (IRMNDR .NE. 0) GO TO 1200 -C -C ...COMES THIS WAY IF A CENTURY YEAR... -C - IQUOT = JAHR / 400 - IRMNDR = JAHR - 400 * IQUOT - IF (IRMNDR .EQ. 0) GO TO 1200 -C -C ...COMES TO 1000 IF NOT A LEAP YEAR... -C - 1000 CONTINUE - DO 1100 I = 1,13 - ITABYR(I) = NOLPTB(I) - 1100 CONTINUE - GO TO 1400 -C -C ...COMES TO 1200 IF LEAP YEAR -C - 1200 CONTINUE - DO 1300 I = 1,13 - ITABYR(I) = LPTB(I) - 1300 CONTINUE -C - 1400 CONTINUE - GO TO (200,300,800) KABUL -C - 1500 CONTINUE - JAHR = MOD(JAHR,100) - NDATE(1) = CHAR(JAHR) - NDATE(2) = CHAR(MONAT) - NDATE(3) = CHAR(ITAG) - NDATE(4) = CHAR(IUHR) - RETURN -C - 1600 CONTINUE - NDATE(1) = CHAR(0) - NDATE(2) = CHAR(0) - NDATE(3) = CHAR(0) - NDATE(4) = CHAR(0) -C -C ...WHICH FLAGS AN ERROR CONDITION ... -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fs21.f b/external/w3nco/v2.0.6/src/w3fs21.f deleted file mode 100644 index 3593d6ff..00000000 --- a/external/w3nco/v2.0.6/src/w3fs21.f +++ /dev/null @@ -1,77 +0,0 @@ - SUBROUTINE W3FS21(IDATE, NMIN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3FS21 NUMBER OF MINUTES SINCE JAN 1, 1978 -C PRGMMR: REJONES ORG: NMC421 DATE: 89-07-17 -C -C ABSTRACT: CALCULATES THE NUMBER OF MINUTES SINCE 0000, -C 1 JANUARY 1978. -C -C PROGRAM HISTORY LOG: -C 84-06-21 A. DESMARAIS -C 89-07-14 R.E.JONES CONVERT TO CYBER 205 FORTRAN 200, -C CHANGE LOGIC SO IT WILL WORK IN -C 21 CENTURY. -C 89-11-02 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FS21 (IDATE, NMIN) -C INPUT ARGUMENT LIST: -C IDATE - INTEGER SIZE 5 ARRAY CONTAINING YEAR OF CENTURY, -C MONTH, DAY, HOUR AND MINUTE. IDATE(1) MAY BE -C A TWO DIGIT YEAR OR 4. IF 2 DIGITS AND GE THAN 78 -C 1900 IS ADDED TO IT. IF LT 78 THEN 2000 IS ADDED -C TO IT. IF 4 DIGITS THE SUBROUTINE WILL WORK -C CORRECTLY TO THE YEAR 3300 A.D. -C -C OUTPUT ARGUMENT LIST: -C NMIN - INTEGER NUMBER OF MINUTES SINCE 1 JANUARY 1978 -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - IW3JDN -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - INTEGER IDATE(5) - INTEGER NMIN - INTEGER JDN78 -C - DATA JDN78 / 2443510 / -C -C*** IDATE(1) YEAR OF CENTURY -C*** IDATE(2) MONTH OF YEAR -C*** IDATE(3) DAY OF MONTH -C*** IDATE(4) HOUR OF DAY -C*** IDATE(5) MINUTE OF HOUR -C - NMIN = 0 -C - IYEAR = IDATE(1) -C - IF (IYEAR.LE.99) THEN - IF (IYEAR.LT.78) THEN - IYEAR = IYEAR + 2000 - ELSE - IYEAR = IYEAR + 1900 - ENDIF - ENDIF -C -C COMPUTE JULIAN DAY NUMBER FROM YEAR, MONTH, DAY -C - IJDN = IW3JDN(IYEAR,IDATE(2),IDATE(3)) -C -C SUBTRACT JULIAN DAY NUMBER OF JAN 1,1978 TO GET THE -C NUMBER OF DAYS BETWEEN DATES -C - NDAYS = IJDN - JDN78 -C -C*** NUMBER OF MINUTES -C - NMIN = NDAYS * 1440 + IDATE(4) * 60 + IDATE(5) -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3fs26.f b/external/w3nco/v2.0.6/src/w3fs26.f deleted file mode 100644 index bad845d4..00000000 --- a/external/w3nco/v2.0.6/src/w3fs26.f +++ /dev/null @@ -1,87 +0,0 @@ - SUBROUTINE W3FS26(JLDAYN,IYEAR,MONTH,IDAY,IDAYWK,IDAYYR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -C AUTHOR: JONES,R.E. ORG: W342 DATE: 87-03-29 -C -C ABSTRACT: COMPUTES YEAR (4 DIGITS), MONTH, DAY, DAY OF WEEK, DAY -C OF YEAR FROM JULIAN DAY NUMBER. THIS SUBROUTINE WILL WORK -C FROM 1583 A.D. TO 3300 A.D. -C -C PROGRAM HISTORY LOG: -C 87-03-29 R.E.JONES -C 89-10-25 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C -C USAGE: CALL W3FS26(JLDAYN,IYEAR,MONTH,IDAY,IDAYWK,IDAYYR) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C JLDAYN ARG LIST INTEGER JULIAN DAY NUMBER -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IYEAR ARG LIST INTEGER YEAR (4 DIGITS) -C MONTH ARG LIST INTEGER MONTH -C IDAY ARG LIST INTEGER DAY -C IDAYWK ARG LIST INTEGER DAY OF WEEK (1 IS SUNDAY, 7 IS SAT) -C IDAYYR ARG LIST INTEGER DAY OF YEAR (1 TO 366) -C -C REMARKS: A JULIAN DAY NUMBER CAN BE COMPUTED BY USING ONE OF THE -C FOLLOWING STATEMENT FUNCTIONS. A DAY OF WEEK CAN BE COMPUTED -C FROM THE JULIAN DAY NUMBER. A DAY OF YEAR CAN BE COMPUTED FROM -C A JULIAN DAY NUMBER AND YEAR. -C -C IYEAR (4 DIGITS) -C -C JDN(IYEAR,MONTH,IDAY) = IDAY - 32075 -C & + 1461 * (IYEAR + 4800 + (MONTH - 14) / 12) / 4 -C & + 367 * (MONTH - 2 - (MONTH -14) / 12 * 12) / 12 -C & - 3 * ((IYEAR + 4900 + (MONTH - 14) / 12) / 100) / 4 -C -C IYR (4 DIGITS) , IDYR(1-366) DAY OF YEAR -C -C JULIAN(IYR,IDYR) = -31739 + 1461 * (IYR + 4799) / 4 -C & -3 * ((IYR + 4899) / 100) / 4 + IDYR -C -C DAY OF WEEK FROM JULIAN DAY NUMBER, 1 IS SUNDAY, 7 IS SATURDAY. -C -C JDAYWK(JLDAYN) = MOD((JLDAYN + 1),7) + 1 -C -C DAY OF YEAR FROM JULIAN DAY NUMBER AND 4 DIGIT YEAR. -C -C JDAYYR(JLDAYN,IYEAR) = JLDAYN - -C & (-31739+1461*(IYEAR+4799)/4-3*((IYEAR+4899)/100)/4) -C -C THE FIRST FUNCTION WAS IN A LETTER TO THE EDITOR COMMUNICATIONS -C OF THE ACM VOLUME 11 / NUMBER 10 / OCTOBER, 1968. THE 2ND -C FUNCTION WAS DERIVED FROM THE FIRST. THIS SUBROUTINE WAS ALSO -C INCLUDED IN THE SAME LETTER. JULIAN DAY NUMBER 1 IS -C JAN 1,4713 B.C. A JULIAN DAY NUMBER CAN BE USED TO REPLACE A -C DAY OF CENTURY, THIS WILL TAKE CARE OF THE DATE PROBLEM IN -C THE YEAR 2000, OR REDUCE PROGRAM CHANGES TO ONE LINE CHANGE -C OF 1900 TO 2000. JULIAN DAY NUMBERS CAN BE USED FOR FINDING -C RECORD NUMBERS IN AN ARCHIVE OR DAY OF WEEK, OR DAY OF YEAR. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - L = JLDAYN + 68569 - N = 4 * L / 146097 - L = L - (146097 * N + 3) / 4 - I = 4000 * (L + 1) / 1461001 - L = L - 1461 * I / 4 + 31 - J = 80 * L / 2447 - IDAY = L - 2447 * J / 80 - L = J / 11 - MONTH = J + 2 - 12 * L - IYEAR = 100 * (N - 49) + I + L - IDAYWK = MOD((JLDAYN + 1),7) + 1 - IDAYYR = JLDAYN - - & (-31739 +1461 * (IYEAR+4799) / 4 - 3 * ((IYEAR+4899)/100)/4) - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3ft32.f b/external/w3nco/v2.0.6/src/w3ft32.f deleted file mode 100644 index 7614b846..00000000 --- a/external/w3nco/v2.0.6/src/w3ft32.f +++ /dev/null @@ -1,1235 +0,0 @@ - SUBROUTINE W3FT32(FIELD, MAPIN, DATA, MAPOUT, INTERP, IER) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK *** -C -C SUBPROGRAM: W3FT32 GENERAL INTERPOLATOR BETWEEN NMC FLDS -C PRGMMR: KEYSER ORG: NMC22 DATE:93-02-17 -C -C ABSTRACT: INTERPOLATE SCALAR QUANTITY FROM ANY GIVEN NMC -C FIELD (IN OFFICE NOTE 84) TO ANY OTHER FIELD. CAN DO BILINEARLY -C OR BIQUADRATICALLY. WILL NOT ROTATE WIND COMPONENTS. -C INPUT AND OUTPUT FIELDS ARE REAL*4 UNPACKED -C -C PROGRAM HISTORY LOG: -C 74-06-15 JOHN STACKPOLE -C 87-07-15 B. CAVANAUGH ADD GRID TYPE 100, 101 TO TABLES. -C 90-08-08 J. STACKPOLE CORRECT ROTATION ERROR WRT 100, 101 -C 90-08-31 R.E. JONES CHANGE NAME FROM POLATE TO W3FT32 -C 93-01-26 D. A. KEYSER ADDED GRID TYPES 87, 105, 106, 107 TO -C TABLES (AS BOTH INPUT AND OUTPUT). -C -C USAGE: CALL W3FT32(FIELD, MAPIN, DATA, MAPOUT, INTERP, IER) -C INPUT ARGUMENTS: -C FIELD - REAL*4 - TWO DIMENSIONAL ARRAY. -C MAPIN - INTEGER*4 - NMC MAP NUMBER (K) FOR GIVEN INPUT FIELD. -C MAPOUT - INTEGER*4 - NMC MAP NUMBER (K) FOR WANTED OUTPUT FIELD. -C INTERP - INTEGER*4 - SET INTERPOLATION METHOD: -C EQ 1 - LINEAR -C NE 1 - BIQUADRATIC -C INPUT FILES: NONE -C -C OUTPUT ARGUMENTS: -C DATA - REAL*4 - ARRAY TO HOLD OUTPUT MAP (UNPACKED). -C IER - INTEGER*4 - COMPLETION CONDITION FLAG -C -C OUTPUT FILES: NONE -C -C -C RETURN CONDITIONS: -C IER = 0 - NO DIFFICULTIES -C 1 - MAPIN NOT RECOGNIZED -C 2 - MAPOUT NOT RECOGNIZED -C 3 - PARTICULAR POLA MAPOUT NOT RECOGNIZED -C 4 - PARTICULAR LOLA MAPOUT NOT RECOGNIZED -C 5 - PARTICULAR LOLA MAPIN NOT RECOGNIZED -C 6 - PARTICULAR POLA MAPOUT NOT RECOGNIZED -C 7 - PARTICULAR LOLA MAPIN NOT RECOGNIZED -C 8 - PARTICULAR LOLA MAPOUT NOT RECOGNIZED -C THESE FLAGS ARE SET AT VARIOUS TEST LOCATIONS -C PLEASE REFER TO THE CODE LISTING FOR DETAILS -C -C SUBPROGRAMS CALLED: -C UNIQUE : NONE -C -C LIBRARY: W3FB01, W3FB02, W3FB03, W3FB04, W3FT00, W3FT01 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C INFORMATION: SEE COMMENT CARDS FOLLOWING FOR MORE DETAIL -C INCLUDING RECIPES FOR ADDING MORE INPUT AND -C OUTPUT MAPS AS THE NEED ARISES. -C$$$ -C -C INTERPOLATE INFORMATION FROM FIELD (MAP TYPE K = MAPIN) -C TO DATA (MAP TYPE K = MAPOUT) -C INTERP SETS INTERPOLATION METHOD -C = 1 BILINEAR, OTHERWISE BIQUADRATIC -C - REAL DATA(*), FIELD(*) -C -C RESTRICTION AND RULES: -C -C AT PRESENT W3FT32 WILL ACCEPT ONLY THE FOLLOWING TYPES -C POLAR STEREOGRAPHIC -C K = 5 & 26 (LFM ANL & FCST RESPECTIVELY) -C 27 & 28 (65X65) -C 25 (53X57 SOUTHERN HEMISPHERE) -C 49 (129X129 NH; 190.5 KM) -C 50 (129X129 SH; 190.5 KM) -C 55 (87X71 NH; LFM ORIENT; 254 KM) -C 56 (87X71 NA; LFM ORIENT; 174 KM) -C 60 (57X57 ENLARGED LFM 'VLFM') -C 87 (81X62 MAPS ANAL/FCST GRID; 68.153 KM) -C 100 (83X83 NGM C-GRID; 91.452) -C 101 (113X91 NGM BIG C-GRID; 91.452) -C 105 (83X83 NGM SUPER C-GRID SUBSET; 90.75464 KM) -C 106 (165X117 HI RESOLUTION GRID; 45.37732 KM) -C 107 (120X92 HI RESOLUTION GRID SUBSET; 45.37732 KM) -C -C LONGITUDE/LATITUDE: ('LOLA') -C K = 29 & 30 (145X37) -C 33 & 34 (181X46) -C 45 & 46 (97X25 - 3.75 DEG LOLA) -C 21 & 22 (73X19 - 5 DEG LOLA) -C 21 & 22 (73X19 - 5 DEG LOLA) -C -C WILL OUTPUT: -C POLAR STEREO: -C K = 5 (53X57) LFM -C 25 (53X57 SOUTH HEMISPHERE) -C 26 (53X45) LFM -C 27 & 28 (65X65) -C 49 (129X129 NH POLA) (1/2 BEDIENT MESH;ORIENTED 80W) -C 50 (129X129 SH POLA) (1/2 BEDIENT MESH;ORINETED 80W) -C 51 (129X129 NH POLA) (SAME MESHL; ORIENTED AT 105W) -C 55 (NH 87X71 254 KM, LFM ORIENT) -C 56 (NA 87X71 127 KM, LFM ORIENT) -C 60 (57X57 ENLARGED LFM 'VLFM') -C 87 (81X62 MAPS ANAL/FCST GRID; 68.153 KM) -C 100 (83X83 NGM C-GRID) -C 101 (113X91 NGM BIG C-GRID) -C 105 (83X83 NGM SUPER C-GRID SUBSET; 90.75464 KM) -C 106 (165X117 HI RESOLUTION GRID; 45.37732 KM) -C 107 (120X92 HI RESOLUTION GRID SUBSET; 45.37732 KM) -C 400 (39X39 1:40MIL 80 DEG VERTICAL POLA) -C 401 (25X35 1:20MIL U.S. SECTION ROTATED) -C 402 (97X97 1-20MIL N.H. POLA ROTATED TO 105W VERT) -C 403 (97X97 1-20MIL S.H. POLA UNROTATED 80W TOP VERT) -C LOLA: -C K = 29 & 30 (145X37) -C 33 & 34 (181X46) -C 45 & 46 (97X25 - 3.75 DEG LOLA) -C 500 & 501 US SECTIONAL NEP 36 & 45 -C -C FEEL FREE, GENTLE READER, TO AUGMENT THE LIST AS YOU WISH -C AND HERE IS A RECIPE FOR ADDING A NEW OUTPUT GRID -C (POLA IN THIS CASE, BUT I AM SURE YOU CAN DRAW THE ANALOGY) -C STEP1 -C PUT NEW NUMBER IN COMMENT ABOVE -C STEP 2 -C ADD IT TO MAPOUT LIST NEAR STMT 30 -C STEP 3 -C ADD SET OF PARAMETERS AT STMT 2000 (FOR POLA) -C STEP4 -C ADD SET OF PARAMETERS AT STMT 6000 (FOR POLA) -C -C HERE TOO IS A RECIPE FOR ADDING A NEW (POLA) INPUT GRID -C -C STEP 1: -C PUT NEW NUMBER IN COMMENT ABOVE -C STEP2: -C ADD NUMBER TO IF(MAPIN.. ) TEST BELOW -C STEP 3: -C ADD INPUT MAP CHARACTERISTICS AT STMT 1000 -C STEP 4: -C DITTO AT STMT 3000 -C - LOGICAL LOLAIN, POLAIN, LOLAOU, POLAOU -C - SAVE -C -C BEGIN HERE - SET ERROR RETURN TO O.K. -C - IER = 0 -C -C DETERMINE WHETHER INPUT GRID IS LOLA OR POLA -C -C THIS LIST CAN BE AUGMENTED ONLY AT THE COST OF A LOT OF -C WORK ELSEWHERE IN THE PROGRAM -C HAVE AT IT IF YOU WANT OTHER MAPS -C -C POLA MAPS -C - IF (MAPIN.EQ. 5) GO TO 10 - IF (MAPIN.EQ.25) GO TO 10 - IF (MAPIN.EQ.26) GO TO 10 - IF (MAPIN.EQ.27) GO TO 10 - IF (MAPIN.EQ.28) GO TO 10 - IF (MAPIN.EQ.49) GO TO 10 - IF (MAPIN.EQ.50) GO TO 10 - IF (MAPIN.EQ.51) GO TO 10 - IF (MAPIN.EQ.55) GO TO 10 - IF (MAPIN.EQ.56) GO TO 10 - IF (MAPIN.EQ.60) GO TO 10 - IF (MAPIN.EQ.87) GO TO 10 - IF (MAPIN.EQ.100) GO TO 10 - IF (MAPIN.EQ.101) GO TO 10 - IF (MAPIN.EQ.105) GO TO 10 - IF (MAPIN.EQ.106) GO TO 10 - IF (MAPIN.EQ.107) GO TO 10 -C -C LOLA MAPS -C - IF (MAPIN.EQ.21) GO TO 20 - IF (MAPIN.EQ.22) GO TO 20 - IF (MAPIN.EQ.29) GO TO 20 - IF (MAPIN.EQ.30) GO TO 20 - IF (MAPIN.EQ.33) GO TO 20 - IF (MAPIN.EQ.34) GO TO 20 - IF (MAPIN.EQ.45) GO TO 20 - IF (MAPIN.EQ.46) GO TO 20 -C -C IF NO MATCH - ERROR -C - IER = 1 - RETURN -C -C SET LOGICAL FLAGS -C - 10 LOLAIN = .FALSE. - POLAIN = .TRUE. - GO TO 30 -C - 20 LOLAIN = .TRUE. - POLAIN = .FALSE. -C -C DITTO FOR OUTPUT MAP TYPE -C -C POLA MAPS -C - 30 IF (MAPOUT.EQ. 5) GO TO 40 - IF (MAPOUT.EQ.25) GO TO 40 - IF (MAPOUT.EQ.26) GO TO 40 - IF (MAPOUT.EQ.27) GO TO 40 - IF (MAPOUT.EQ.28) GO TO 40 - IF (MAPOUT.EQ.49) GO TO 40 - IF (MAPOUT.EQ.50) GO TO 40 - IF (MAPOUT.EQ.51) GO TO 40 - IF (MAPOUT.EQ.55) GO TO 40 - IF (MAPOUT.EQ.56) GO TO 40 - IF (MAPOUT.EQ.60) GO TO 40 - IF (MAPOUT.EQ.87) GO TO 40 - IF (MAPOUT.EQ.100) GO TO 40 - IF (MAPOUT.EQ.101) GO TO 40 - IF (MAPOUT.EQ.105) GO TO 40 - IF (MAPOUT.EQ.106) GO TO 40 - IF (MAPOUT.EQ.107) GO TO 40 - IF (MAPOUT.EQ.400) GO TO 40 - IF (MAPOUT.EQ.401) GO TO 40 - IF (MAPOUT.EQ.402) GO TO 40 - IF (MAPOUT.EQ.403) GO TO 40 -C -C LOLA MAPS -C - IF (MAPOUT.EQ.21) GO TO 50 - IF (MAPOUT.EQ.22) GO TO 50 - IF (MAPOUT.EQ.29) GO TO 50 - IF (MAPOUT.EQ.30) GO TO 50 - IF (MAPOUT.EQ.33) GO TO 50 - IF (MAPOUT.EQ.34) GO TO 50 - IF (MAPOUT.EQ.45) GO TO 50 - IF (MAPOUT.EQ.46) GO TO 50 - IF (MAPOUT.EQ.500) GO TO 50 - IF (MAPOUT.EQ.501) GO TO 50 -C -C NO MATCH - ERROR -C - IER = 2 - RETURN -C -C SET LOGICAL FLAGS -C - 40 LOLAOU = .FALSE. - POLAOU = .TRUE. - GO TO 60 -C - 50 LOLAOU = .TRUE. - POLAOU = .FALSE. -C -C GO TO DIFFERENT SECTIONS FOR IN/OUT OPTIONS -C - 60 IF (POLAIN) GO TO 1000 - IF (LOLAIN) GO TO 5000 -C -C ################################################################## -C ################################################################## -C -C THIS SECTION FOR POLAR STEREOGRAPHIC INPUT MAPS -C -C SUBDIVIDED FOR OUTPUT TYPE -C - 1000 IF (LOLAOU) GO TO 3000 -C -C POLAR STEREO TO POLAR STEREO -C USE HOWCROFTS FIELD TRANSFORMER -C ORIENT IS DEGREES OF ROTATION FROM NMC STANDARD -C (80 DEG CENTER VERTIVAL) TO INPUT GRID (POSITIVE ANTICLOCKWISE) -C - IF (MAPIN.EQ. 5) GO TO 1005 - IF (MAPIN.EQ.25) GO TO 1025 - IF (MAPIN.EQ.26) GO TO 1026 - IF (MAPIN.EQ.27) GO TO 1027 - IF (MAPIN.EQ.28) GO TO 1027 - IF (MAPIN.EQ.49) GO TO 1049 - IF (MAPIN.EQ.50) GO TO 1049 - IF (MAPIN.EQ.51) GO TO 1051 - IF (MAPIN.EQ.55) GO TO 1055 - IF (MAPIN.EQ.56) GO TO 1056 - IF (MAPIN.EQ.60) GO TO 1060 - IF (MAPIN.EQ.87) GO TO 1087 - IF (MAPIN.EQ.100) GO TO 1100 - IF (MAPIN.EQ.101) GO TO 1101 - IF (MAPIN.EQ.105) GO TO 1105 - IF (MAPIN.EQ.106) GO TO 1106 - IF (MAPIN.EQ.107) GO TO 1107 - IER = 1 - RETURN -C - 1005 IMAXIN =53 - JMAXIN = 57 - COMIIN = 27. - COMJIN = 49. - ORIENT = -25. - XMESH = 190.5 - GO TO 2000 -C - 1025 IMAXIN = 53 - JMAXIN = 57 - COMIIN = 27. - COMJIN = 29. - ORIENT = 0. - XMESH = 381. - GO TO 2000 -C - 1026 IMAXIN = 53 - JMAXIN = 45 - COMIIN = 27. - COMJIN = 49. - ORIENT = -25. - XMESH = 190.5 - GO TO 2000 -C - 1027 IMAXIN = 65 - JMAXIN = 65 - COMIIN = 33. - COMJIN = 33. - ORIENT = 0. - XMESH = 381. - GO TO 2000 -C - 1049 IMAXIN = 129 - JMAXIN = 129 - COMIIN = 65. - COMJIN = 65. - ORIENT = 0. - XMESH = 190.5 - GOTO 2000 -C - 1051 IMAXIN = 129 - JMAXIN = 129 - COMIIN = 65. - COMJIN = 65. - ORIENT = -25. - XMESH = 190.5 - GOTO 2000 -C - 1055 IMAXIN = 87 - JMAXIN = 71 - COMIIN = 44. - COMJIN = 38. - ORIENT = -25. - XMESH = 254. - GOTO 2000 -C - 1056 IMAXIN = 87 - JMAXIN = 71 - COMIIN = 40. - COMJIN = 73. - ORIENT = -25. - XMESH = 127. - GOTO 2000 -C - 1060 IMAXIN= 57 - JMAXIN = 57 - COMIIN = 29. - COMJIN = 49. - ORIENT = -25. - XMESH = 190.5 - GO TO 2000 -C - 1087 IMAXIN= 81 - JMAXIN = 62 - COMIIN = 31.91 - COMJIN = 112.53 - ORIENT = -25. - XMESH = 68.153 - GO TO 2000 -C - 1100 IMAXIN = 83 - JMAXIN = 83 - COMIIN = 40.5 - COMJIN = 88.5 - ORIENT = -25. - XMESH = 91.452 - GO TO 2000 -C - 1101 IMAXIN = 113 - JMAXIN = 91 - COMIIN = 58.5 - COMJIN = 92.5 - ORIENT = -25. - XMESH = 91.452 - GO TO 2000 -C - 1105 IMAXIN = 83 - JMAXIN = 83 - COMIIN = 40.5 - COMJIN = 88.5 - ORIENT = -25. - XMESH = 90.75464 - GO TO 2000 -C - 1106 IMAXIN = 165 - JMAXIN = 117 - COMIIN = 80.0 - COMJIN = 176.0 - ORIENT = -25. - XMESH = 45.37732 - GO TO 2000 -C - 1107 IMAXIN = 120 - JMAXIN = 92 - COMIIN = 46.0 - COMJIN = 167.0 - ORIENT = -25. - XMESH = 45.37732 - GO TO 2000 -C -C SELECT I, J, DILATION, ROTATION, AND COMMON POINT (POLE) OUTPUT -C DILATE = XMESHOUT / XMESHIN -C IN THE FOLLOWING, ROT IS THE ROTATION FROM THE INPUT TO -C THE OUTPUT GRID - NOT THE ORIENTATION OF THE OUT-GRID -C - 2000 IF (MAPOUT.EQ. 5) GO TO 2005 - IF (MAPOUT.EQ.25) GO TO 2025 - IF (MAPOUT.EQ.26) GO TO 2026 - IF (MAPOUT.EQ.27) GO TO 2027 - IF (MAPOUT.EQ.28) GO TO 2027 - IF (MAPOUT.EQ.49) GO TO 2049 - IF (MAPOUT.EQ.50) GO TO 2049 - IF (MAPOUT.EQ.51) GO TO 2051 - IF (MAPOUT.EQ.55) GO TO 2055 - IF (MAPOUT.EQ.56) GO TO 2056 - IF (MAPOUT.EQ.60) GO TO 2060 - IF (MAPOUT.EQ.87) GO TO 2087 - IF (MAPOUT.EQ.100) GO TO 2100 - IF (MAPOUT.EQ.101) GO TO 2101 - IF (MAPOUT.EQ.105) GO TO 2105 - IF (MAPOUT.EQ.106) GO TO 2106 - IF (MAPOUT.EQ.107) GO TO 2107 - IF (MAPOUT.EQ.400) GO TO 2400 - IF (MAPOUT.EQ.401) GO TO 2401 - IF (MAPOUT.EQ.402) GO TO 2402 - IF (MAPOUT.EQ.403) GO TO 2403 - IER = 3 - RETURN -C - 2005 IMAXOU = 53 - JMAXOU = 57 - DILAT = 190.5/XMESH - ROT = -25. - ORIENT - COMIOU = 27. - COMJOU = 49. - GO TO 2700 -C - 2025 IMAXOU = 53 - JMAXOU = 57 - DILAT = 381./XMESH - ROT = 0. - ORIENT - COMIOU = 27. - COMJOU = 29. - GO TO 2700 -C - 2026 IMAXOU = 53 - JMAXOU = 45 - DILAT = 190.5/XMESH - ROT = -25. - ORIENT - COMIOU = 27. - COMJOU = 49. - GO TO 2700 -C - 2027 IMAXOU = 65 - JMAXOU = 65 - DILAT = 381./XMESH - ROT = 0. - ORIENT - COMIOU = 33. - COMJOU = 33. - GO TO 2700 -C - 2049 IMAXOU = 129 - JMAXOU = 129 - DILAT = 190.5/XMESH - ROT = 0. - ORIENT - COMIOU = 65. - COMJOU = 65. - GOTO 2700 -C - 2051 IMAXOU = 129 - JMAXOU = 129 - DILAT = 190.5/XMESH - ROT = -25. - ORIENT - COMIOU = 65. - COMJOU = 65. - GOTO 2700 -C - 2055 IMAXOU = 87 - JMAXOU = 71 - DILAT = 254./XMESH - ROT = -25. - ORIENT - COMIOU = 44. - COMJOU = 38. - GOTO 2700 -C - 2056 IMAXOU = 87 - JMAXOU = 71 - DILAT = 127./XMESH - ROT = -25. - ORIENT - COMIOU = 40. - COMJOU = 73. - GOTO 2700 -C - 2060 IMAXOU = 57 - JMAXOU = 57 - DILAT = 190.5/XMESH - ROT = -25. - ORIENT - COMIOU = 29. - COMJOU = 49. - GO TO 2700 -C - 2087 IMAXOU = 81 - JMAXOU = 62 - DILAT = 68.153/XMESH - ROT = -25. - ORIENT - COMIOU = 31.91 - COMJOU = 112.53 - GO TO 2700 -C - 2100 IMAXOU = 83 - JMAXOU = 83 - DILAT = 91.452/XMESH - ROT = -25. - ORIENT - COMIOU = 40.5 - COMJOU = 88.5 - GO TO 2700 -C - 2101 IMAXOU = 113 - JMAXOU = 91 - DILAT = 91.452/XMESH - ROT = -25. - ORIENT - COMIOU = 58.5 - COMJOU = 92.5 - GO TO 2700 -C - 2105 IMAXOU = 83 - JMAXOU = 83 - DILAT = 90.75464/XMESH - ROT = -25. - ORIENT - COMIOU = 40.5 - COMJOU = 88.5 - GO TO 2700 -C - 2106 IMAXOU = 165 - JMAXOU = 117 - DILAT = 45.37732/XMESH - ROT = -25. - ORIENT - COMIOU = 80.0 - COMJOU = 176.0 - GO TO 2700 -C - 2107 IMAXOU = 120 - JMAXOU = 92 - DILAT = 45.37732/XMESH - ROT = -25. - ORIENT - COMIOU = 46.0 - COMJOU = 167.0 - GO TO 2700 -C - 2400 IMAXOU = 39 - JMAXOU = 39 - DILAT = 508./ XMESH - ROT = 0. - ORIENT - COMIOU = 20. - COMJOU = 20. - GO TO 2700 -C - 2401 IMAXOU = 25 - JMAXOU = 35 - DILAT = 254./XMESH - ROT = -25. + 90. - ORIENT - COMIOU =31.75 - COMJOU = 18. - GO TO 2700 -C - 2402 IMAXOU = 97 - JMAXOU = 97 - DILAT = 254./XMESH - ROT = -25. - ORIENT - COMIOU = 49. - COMJOU = 49. - GOTO 2700 -C - 2403 IMAXOU = 97 - JMAXOU = 97 - DILAT = 254./XMESH - ROT = 0. - ORIENT - COMIOU = 49. - COMJOU = 49. - GOTO 2700 -C - 2700 CALL W3FT00 - 1 (FIELD, DATA, IMAXIN, JMAXIN, IMAXOU, JMAXOU, - 2 COMIIN, COMJIN, COMIOU, COMJOU, - 3 DILAT, ROT, INTERP) - RETURN -C -C ################################################################## -C -C HERE FOR POLAR STEREO TO LO/LA -C - 3000 IF (MAPIN.EQ. 5) GO TO 3005 - IF (MAPIN.EQ.25) GO TO 3025 - IF (MAPIN.EQ.26) GO TO 3026 - IF (MAPIN.EQ.27) GO TO 3027 - IF (MAPIN.EQ.28) GO TO 3027 - IF (MAPIN.EQ.49) GO TO 3049 - IF (MAPIN.EQ.50) GO TO 3049 - IF (MAPIN.EQ.51) GO TO 3051 - IF (MAPIN.EQ.55) GO TO 3055 - IF (MAPIN.EQ.56) GO TO 3056 - IF (MAPIN.EQ.60) GO TO 3060 - IF (MAPIN.EQ.87) GO TO 3087 - IF (MAPIN.EQ.100) GO TO 3100 - IF (MAPIN.EQ.101) GO TO 3101 - IF (MAPIN.EQ.105) GO TO 3105 - IF (MAPIN.EQ.106) GO TO 3106 - IF (MAPIN.EQ.107) GO TO 3107 -C - 3005 XMESH = 190.5 - IMAXIN = 53 - JMAXIN = 57 - NTHSTH = 1 - POLEI = 27. - POLEJ = 49. - ORIENT = 105. - GO TO 4000 -C - 3025 XMESH = 381. - IMAXIN = 53 - JMAXIN = 57 - NTHSTH = 2 - POLEI = 27. - POLEJ = 29. - GO TO 4000 -C - 3026 XMESH = 190.5 - IMAXIN = 53 - JMAXIN = 45 - NTHSTH = 1 - POLEI = 27. - POLEJ = 49. - ORIENT = 105. - GO TO 4000 -C - 3027 XMESH = 381. - IMAXIN = 65 - JMAXIN = 65 - NTHSTH = 1 - IF (MAPIN.EQ.28) NTHSTH = 2 - POLEI = 33. - POLEJ = 33. - ORIENT = 80. - GO TO 4000 -C - 3049 XMESH = 190.5 - IMAXIN = 129 - JMAXIN = 129 - NTHSTH = 1 - IF (MAPIN.EQ.50) NTHSTH=2 - POLEI = 65. - POLEJ = 65. - ORIENT = 80. - GOTO 4000 -C - 3051 XMESH = 190.5 - IMAXIN = 129 - JMAXIN = 129 - NTHSTH = 1 - POLEI = 65. - POLEJ = 65. - ORIENT = 105. - GOTO 4000 -C - 3055 XMESH = 254. - IMAXIN = 87 - JMAXIN = 71 - NTHSTH = 1 - POLEI = 44. - POLEJ = 38. - ORIENT = 105. - GOTO 4000 -C - 3056 XMESH = 127. - IMAXIN = 87 - JMAXIN = 71 - NTHSTH = 1 - POLEI = 40. - POLEJ = 73. - ORIENT = 105. - GOTO 4000 -C - 3060 XMESH = 190.5 - IMAXIN = 57 - JMAXIN = 57 - NTHSTH = 1 - POLEI = 29. - POLEJ = 49. - ORIENT = 105. - GO TO 4000 -C - 3087 XMESH = 68.153 - IMAXIN = 81 - JMAXIN = 62 - NTHSTH = 1 - POLEI = 31.91 - POLEJ = 112.53 - ORIENT = 105. - GO TO 4000 -C - 3100 XMESH = 91.452 - IMAXIN = 83 - JMAXIN = 83 - NTHSTH = 1 - POLEI = 40.5 - POLEJ = 88.5 - ORIENT = 105. - GO TO 4000 -C - 3101 XMESH = 91.452 - IMAXIN = 113 - JMAXIN = 91 - NTHSTH = 1 - POLEI = 58.5 - POLEJ = 92.5 - ORIENT = 105. - GO TO 4000 -C - 3105 XMESH = 90.75464 - IMAXIN = 83 - JMAXIN = 83 - NTHSTH = 1 - POLEI = 40.5 - POLEJ = 88.5 - ORIENT = 105. - GO TO 4000 -C - 3106 XMESH = 45.37732 - IMAXIN = 165 - JMAXIN = 117 - NTHSTH = 1 - POLEI = 80.0 - POLEJ = 176.0 - ORIENT = 105. - GO TO 4000 -C - 3107 XMESH = 45.37732 - IMAXIN = 120 - JMAXIN = 92 - NTHSTH = 1 - POLEI = 46.0 - POLEJ = 167.0 - ORIENT = 105. - GO TO 4000 -C -C SELECT OUTPUT LO/LA VARIATIONS -C - 4000 IF (MAPOUT.EQ.21) GO TO 4021 - IF (MAPOUT.EQ.22) GO TO 4021 - IF (MAPOUT.EQ.29) GO TO 4029 - IF (MAPOUT.EQ.30) GO TO 4029 - IF (MAPOUT.EQ.33) GO TO 4033 - IF (MAPOUT.EQ.34) GO TO 4033 - IF (MAPOUT.EQ.45) GO TO 4045 - IF (MAPOUT.EQ.46) GO TO 4045 - IF (MAPOUT.EQ.500) GO TO 4500 - IF (MAPOUT.EQ.501) GO TO 4501 - IER = 4 - RETURN -C - 4021 IMINOU = 1 - JMINOU = 1 - IMAXOU = 73 - JMAXOU = 19 - DEG = 5.0 - GO TO 4700 -C - 4029 IMINOU = 1 - IMAXOU = 145 - JMINOU = 1 - JMAXOU = 37 - DEG = 2.5 - GO TO 4700 -C - 4033 IMINOU = 1 - IMAXOU = 181 - JMINOU = 1 - JMAXOU = 46 - DEG = 2.0 - GO TO 4700 -C - 4045 IMINOU = 1 - IMAXOU = 97 - JMINOU = 1 - JMAXOU = 25 - DEG = 3.75 - GOTO 4700 -C - 4500 IMINOU = 93 - IMAXOU = 117 - JMINOU = 1 - JMAXOU = 37 - DEG = 2.5 - GO TO 4700 -C - 4501 IMINOU = 116 - IMAXOU = 140 - JMINOU = 1 - JMAXOU = 46 - DEG = 2.0 - GO TO 4700 -C -C FIND INPUT POLA I,J FOR DESIRED LOLA OUTPUT POINTS -C - 4700 IJOUT = 0 - DO 4740 J = JMINOU, JMAXOU - XLAT = (J-1) * DEG - IF (NTHSTH.EQ.2) XLAT = XLAT - 90. - DO 4740 I = IMINOU, IMAXOU - ELON = (I-1) * DEG - WLON = AMOD(360. - ELON, 360.) - GO TO (4710, 4720), NTHSTH - 4710 CALL W3FB04(XLAT, WLON, XMESH, ORIENT, XI, XJ) - GO TO 4730 - 4720 CALL W3FB02(XLAT, WLON, XMESH, XI, XJ) - 4730 XIIN = XI + POLEI - XJIN = XJ + POLEJ -C -C MACDONALDS SUPER GENERAL INTERPOLATOR -C IN WHICH D = FIELD(XIIN, XJIN) -C - CALL W3FT01 - 1 (XIIN, XJIN, FIELD, D, IMAXIN, JMAXIN, 0, INTERP) - IJOUT = IJOUT + 1 - DATA(IJOUT) = D - 4740 CONTINUE - RETURN -C -C ################################################################## -C ################################################################## -C -C THIS SECTION FOR LOLA INPUT MAP -C -C SELCT OUTPUT TYPE -C - 5000 IF (LOLAOU) GO TO 7000 -C -C LOLA TO POLA -C SELECT INPUT INFO -C (THIS PATTERN CAN BE USED WITH POLA INPUT, TOO - TRY IT -C - IF (MAPIN.EQ.21) GO TO 5021 - IF (MAPIN.EQ.22) GO TO 5021 - IF (MAPIN.EQ.29) GO TO 5029 - IF (MAPIN.EQ.30) GO TO 5029 - IF (MAPIN.EQ.33) GO TO 5033 - IF (MAPIN.EQ.34) GO TO 5033 - IF (MAPIN.EQ.45) GO TO 5045 - IF (MAPIN.EQ.46) GO TO 5045 - IER = 5 - RETURN -C - 5021 IMAXIN = 73 - JMAXIN = 19 - DEG = 5.0 - NTHSTH = 1 - IF (MAPIN.EQ.22) NTHSTH = 2 - GO TO 6000 -C - 5029 IMAXIN = 145 - JMAXIN = 37 - DEG = 2.5 - NTHSTH = 1 - IF (MAPIN.EQ.30) NTHSTH = 2 - GO TO 6000 -C - 5033 IMAXIN = 181 - JMAXIN = 46 - DEG = 2.0 - NTHSTH = 1 - IF (MAPIN.EQ.34) NTHSTH = 2 - GO TO 6000 -C - 5045 IMAXIN = 97 - JMAXIN = 25 - DEG = 3.75 - NTHSTH = 1 - IF (MAPIN.EQ.46) NTHSTH = 2 - GOTO 6000 -C -C SELECT OUTPUT POLA VARIETY -C ROT INDICATES HOW MANY DEGREES THE POLA GRID IS TO BE ROTATED -C (POSITIVE COUNTER-CLOCKWISE) FROM THE NMC 'STANDARD' -C OF 80 DEG WEST AT THE BOTTOM (OR TOP IF SOUTHERN HEMISPHERE) -C - 6000 IF (MAPOUT.EQ. 5) GO TO 6005 - IF (MAPOUT.EQ.25) GO TO 6025 - IF (MAPOUT.EQ.26) GO TO 6026 - IF (MAPOUT.EQ.27) GO TO 6027 - IF (MAPOUT.EQ.28) GO TO 6027 - IF (MAPOUT.EQ.49) GO TO 6049 - IF (MAPOUT.EQ.50) GO TO 6049 - IF (MAPOUT.EQ.51) GO TO 6051 - IF (MAPOUT.EQ.55) GO TO 6055 - IF (MAPOUT.EQ.56) GO TO 6056 - IF (MAPOUT.EQ.60) GO TO 6060 - IF (MAPOUT.EQ.87) GO TO 6087 - IF (MAPOUT.EQ.100) GO TO 6100 - IF (MAPOUT.EQ.101) GO TO 6101 - IF (MAPOUT.EQ.105) GO TO 6105 - IF (MAPOUT.EQ.106) GO TO 6106 - IF (MAPOUT.EQ.107) GO TO 6107 - IF (MAPOUT.EQ.400) GO TO 6400 - IF (MAPOUT.EQ.401) GO TO 6401 - IF (MAPOUT.EQ.402) GO TO 6402 - IF (MAPOUT.EQ.403) GO TO 6403 - IER = 6 - RETURN -C - 6005 IMAXOU = 53 - JMAXOU = 57 - XMESH = 190.5 - ROT = -25. - POLEI = 27. - POLEJ = 49. - GO TO 6700 -C - 6025 IMAXOU = 53 - JMAXOU = 57 - XMESH = 381. - ROT = 0. - POLEI = 27. - POLEJ = 29. - GO TO 6700 -C - 6026 IMAXOU = 53 - JMAXOU = 45 - XMESH = 190.5 - ROT = -25. - POLEI = 27. - POLEJ = 49. - GO TO 6700 -C - 6027 IMAXOU = 65 - JMAXOU = 65 - XMESH = 381. - ROT = 0. - POLEI = 33. - POLEJ = 33. - GO TO 6700 -C - 6049 IMAXOU = 129 - JMAXOU = 129 - XMESH = 190.5 - ROT = 0. - POLEI = 65. - POLEJ = 65. - GOTO 6700 -C - 6051 IMAXOU = 129 - JMAXOU = 129 - XMESH = 190.5 - ROT = -25. - POLEI = 65. - POLEJ = 65. - GOTO 6700 -C - 6055 IMAXOU = 87 - JMAXOU = 71 - XMESH = 254. - ROT = -25. - POLEI = 44. - POLEJ = 38. - GOTO 6700 -C - 6056 IMAXOU = 87 - JMAXOU = 71 - XMESH = 127. - ROT = -25. - POLEI = 40. - POLEJ = 73. - GOTO 6700 -C - 6060 IMAXOU = 57 - JMAXOU = 57 - XMESH = 190.5 - ROT = -25. - POLEI = 29. - POLEJ = 49. - GO TO 6700 -C - 6087 IMAXOU = 81 - JMAXOU = 62 - XMESH = 68.153 - ROT = -25. - POLEI = 31.91 - POLEJ = 112.53 - GO TO 6700 -C - 6100 IMAXOU = 83 - JMAXOU = 83 - XMESH = 91.452 - ROT = -25. - POLEI = 40.5 - POLEJ = 88.5 - GO TO 6700 -C - 6101 IMAXOU = 113 - JMAXOU = 91 - XMESH = 91.452 - ROT = -25. - POLEI = 58.5 - POLEJ = 92.5 - GO TO 6700 -C - 6105 IMAXOU = 83 - JMAXOU = 83 - XMESH = 90.75464 - ROT = -25. - POLEI = 40.5 - POLEJ = 88.5 - GO TO 6700 -C - 6106 IMAXOU = 165 - JMAXOU = 117 - XMESH = 45.37732 - ROT = -25. - POLEI = 80.0 - POLEJ = 176.0 - GO TO 6700 -C - 6107 IMAXOU = 120 - JMAXOU = 92 - XMESH = 45.37732 - ROT = -25. - POLEI = 46.0 - POLEJ = 167.0 - GO TO 6700 -C - 6400 IMAXOU = 39 - JMAXOU = 39 - XMESH = 508. - ROT = 0. - POLEI = 20. - POLEJ = 20. - GO TO 6700 -C -C THIS ONE GETS SPECIAL TREATMENT BECAUSE WE ARE -C INTERCHANGING ROWS AND COLUMNS FOR GRIDPRINT AFTER INTERPOLATION -C (ACTUALLY IT IS DONE ALL AT ONCE) -C - 6401 IMAXOU = 25 - JMAXOU = 35 - XMESH = 254. - ROT = -25. - POLEI = 18. - POLEJ = 31.75 -C - IJOUT = 0 - DO 64011 J=1,JMAXOU - XI = JMAXOU - J + 1 - XXI = XI - POLEI - DO 64011 I = 1,IMAXOU - XJ = I - XXJ = XJ - POLEJ - CALL W3FB01(XXI, XXJ, XMESH, XLAT, WLON) - WLON = WLON - ROT - IF (WLON.GT.360.) WLON = WLON - 360. - IF (WLON.LT.0.) WLON = WLON + 360. - XIIN = (360.-WLON)/DEG + 1. - XJIN = XLAT/DEG + 1. - CALL W3FT01 - 1 (XIIN, XJIN, FIELD, D, IMAXIN, JMAXIN, 1, INTERP) - IJOUT = IJOUT + 1 - DATA(IJOUT) = D -64011 CONTINUE - RETURN -C - 6402 IMAXOU = 97 - JMAXOU = 97 - XMESH = 254. - ROT = -25. - POLEI = 49. - POLEJ = 49. - GOTO 6700 -C - 6403 IMAXOU = 97 - JMAXOU = 97 - XMESH = 254. - ROT = 0. - POLEI = 49. - POLEJ = 49. - GOTO 6700 -C -C FIND INPUT LOLA I,J FOR DESIRED POLA OUTPUT POINTS -C - 6700 IJOUT = 0 - DO 6740 J=1,JMAXOU - XJ = J - POLEJ - DO 6740 I=1,IMAXOU - XI = I - POLEI - GOTO (6710, 6720), NTHSTH - 6710 CALL W3FB01(XI, XJ, XMESH, XLAT, WLON) - WLON = WLON - ROT - GO TO 6730 - 6720 CALL W3FB03(XI, XJ, XMESH, XLAT, WLON) - WLON = WLON + ROT - XLAT = XLAT + 90. - 6730 IF (WLON.GT.360.) WLON = WLON - 360. - IF (WLON.LT.0.) WLON = WLON + 360. - XIIN = (360.-WLON)/DEG + 1. - XJIN = XLAT/DEG + 1. - CALL W3FT01 - 1 (XIIN, XJIN, FIELD, D, IMAXIN, JMAXIN, 1, INTERP) - IJOUT = IJOUT + 1 - DATA(IJOUT) = D - 6740 CONTINUE - RETURN -C -C ################################################################## -C -C LOLA TO LOLA -C -C SELECT INPUT GRID INFO -C - 7000 IF (MAPIN.EQ.21) GO TO 7021 - IF (MAPIN.EQ.22) GO TO 7021 - IF (MAPIN.EQ.29) GO TO 7029 - IF (MAPIN.EQ.30) GO TO 7029 - IF (MAPIN.EQ.33) GO TO 7033 - IF (MAPIN.EQ.34) GO TO 7033 - IF (MAPIN.EQ.45) GOTO 7045 - IF (MAPIN.EQ.46) GOTO 7045 - IER = 7 - RETURN -C - 7021 IMAXIN = 73 - JMAXIN = 19 - DEGIN = 5.0 - GO TO 8000 -C - 7029 IMAXIN = 145 - JMAXIN = 37 - DEGIN = 2.5 - GO TO 8000 -C - 7033 IMAXIN = 181 - JMAXIN = 46 - DEGIN = 2.0 - GO TO 8000 -C - 7045 IMAXIN = 97 - JMAXIN = 25 - DEGIN = 3.75 - GOTO 8000 -C -C SELECT OUTPUT LOLA GRID -C - 8000 IF (MAPOUT.EQ.21) GO TO 8021 - IF (MAPOUT.EQ.22) GO TO 8021 - IF (MAPOUT.EQ.29) GO TO 8029 - IF (MAPOUT.EQ.30) GO TO 8029 - IF (MAPOUT.EQ.33) GO TO 8033 - IF (MAPOUT.EQ.34) GO TO 8033 - IF (MAPOUT.EQ.45) GO TO 8045 - IF (MAPOUT.EQ.46) GO TO 8045 - IF (MAPOUT.EQ.500) GO TO 8500 - IF (MAPOUT.EQ.501) GO TO 8501 - IER = 8 - RETURN -C - 8021 IMINOU = 1 - IMAXOU = 73 - JMINOU = 1 - JMAXOU = 19 - DEGOU = 5. - GO TO 8700 -C - 8029 IMINOU = 1 - IMAXOU = 145 - JMINOU = 1 - JMAXOU = 37 - DEGOU = 2.5 - GO TO 8700 -C - 8033 IMINOU = 1 - IMAXOU = 181 - JMINOU = 1 - JMAXOU = 46 - DEGOU = 2.0 - GO TO 8700 -C - 8045 IMINOU = 1 - IMAXOU = 97 - JMINOU = 1 - JMAXOU = 25 - DEGOU = 3.75 - GOTO 8700 -C - 8500 IMINOU = 93 - IMAXOU = 117 - JMINOU = 1 - JMAXOU = 37 - DEGOU = 2.5 - GO TO 8700 -C - 8501 IMINOU = 116 - IMAXOU = 140 - JMINOU = 1 - JMAXOU = 46 - DEGOU = 2.0 - GO TO 8700 -C - 8700 IJOUT = 0 - RDEG = DEGOU/DEGIN - DO 8710 J=JMINOU, JMAXOU - XJIN = (J-1)*RDEG + 1. - DO 8710 I=IMINOU, IMAXOU - XIIN = (I-1)*RDEG + 1. - CALL W3FT01 - 1 (XIIN, XJIN, FIELD, D, IMAXIN, JMAXIN, 1, INTERP) - IJOUT = IJOUT + 1 - DATA(IJOUT) = D - 8710 CONTINUE - RETURN -C - END diff --git a/external/w3nco/v2.0.6/src/w3kind.f b/external/w3nco/v2.0.6/src/w3kind.f deleted file mode 100644 index 53487942..00000000 --- a/external/w3nco/v2.0.6/src/w3kind.f +++ /dev/null @@ -1,34 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3kind(kindreal,kindint) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3KIND RETURN THE real kind and integer kind used -! in w3 lib -! AUTHOR: Jun Wang DATE: 11-06-24 -! -! ABSTRACT: THIS SUBPROGRAM RETURNS THE REAL KIND AND THE INTEGER KIND -! THAT THE W3 LIB IS COMPILED WITH. -! -! PROGRAM HISTORY LOG: -! 2011-06-24 Jun Wang -! -! USAGE: CALL W3KIND(kindreal,kindint) -! -! OUTPUT VARIABLES: -! KINDREAL INTEGER KIND OF REAL NUMBER IN W3 LIB -! KINDINTL INTEGER KIND OF INTEGER NUMBER IN W3 LIB -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - IMPLICIT NONE -! - integer,intent(out) :: kindreal,kindint -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! get real kind from a real number - kindreal=kind(1.0) - kindint=kind(1) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end - diff --git a/external/w3nco/v2.0.6/src/w3locdat.f b/external/w3nco/v2.0.6/src/w3locdat.f deleted file mode 100644 index d88094ea..00000000 --- a/external/w3nco/v2.0.6/src/w3locdat.f +++ /dev/null @@ -1,43 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3locdat(idat) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3LOCDAT RETURN THE LOCAL DATE AND TIME -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM RETURNS THE LOCAL DATE AND TIME -! IN THE NCEP ABSOLUTE DATE AND TIME DATA STRUCTURE. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! 1999-04-28 Gilbert - added a patch to check for the proper -! UTC offset. Needed until the IBM bug -! in date_and_time is fixed. The patch -! can then be removed. See comments in -! the section blocked with "&&&&&&&&&&&". -! 1999-08-12 Gilbert - Changed so that czone variable is saved -! and the system call is only done for -! first invocation of this routine. -! -! USAGE: CALL W3LOCDAT(IDAT) -! -! OUTPUT VARIABLES: -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! SUBPROGRAMS CALLED: -! DATE_AND_TIME FORTRAN 90 SYSTEM DATE INTRINSIC -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer idat(8) - character cdate*8,ctime*10,czone*5 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! get local date and time but use the character time zone - call date_and_time(cdate,ctime,czone,idat) - read(czone,'(i5)') idat(4) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/external/w3nco/v2.0.6/src/w3movdat.f b/external/w3nco/v2.0.6/src/w3movdat.f deleted file mode 100644 index 8959198f..00000000 --- a/external/w3nco/v2.0.6/src/w3movdat.f +++ /dev/null @@ -1,53 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3movdat(rinc,idat,jdat) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3MOVDAT RETURN A DATE FROM A TIME INTERVAL AND DATE -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM RETURNS THE DATE AND TIME THAT IS A GIVEN -! NCEP RELATIVE TIME INTERVAL FROM AN NCEP ABSOLUTE DATE AND TIME. -! THE OUTPUT IS IN THE NCEP ABSOLUTE DATE AND TIME DATA STRUCTURE. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: CALL W3MOVDAT(RINC,IDAT,JDAT) -! -! INPUT VARIABLES: -! RINC REAL (5) NCEP RELATIVE TIME INTERVAL -! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! OUTPUT VARIABLES: -! JDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! (JDAT IS LATER THAN IDAT IF TIME INTERVAL IS POSITIVE.) -! -! SUBPROGRAMS CALLED: -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -! W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - real rinc(5) - integer idat(8),jdat(8) - real rinc1(5),rinc2(5) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! add the interval to the input time of day and put into reduced form -! and then compute new date using julian day arithmetic. - rinc1(1)=rinc(1) - rinc1(2:5)=rinc(2:5)+idat(5:8) - call w3reddat(-1,rinc1,rinc2) - jldayn=iw3jdn(idat(1),idat(2),idat(3))+nint(rinc2(1)) - call w3fs26(jldayn,jdat(1),jdat(2),jdat(3),jdow,jdoy) - jdat(4)=idat(4) - jdat(5:8)=nint(rinc2(2:5)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/external/w3nco/v2.0.6/src/w3nogds.f b/external/w3nco/v2.0.6/src/w3nogds.f deleted file mode 100644 index f08d3d9e..00000000 --- a/external/w3nco/v2.0.6/src/w3nogds.f +++ /dev/null @@ -1,446 +0,0 @@ - SUBROUTINE W3NOGDS(ITYPE,FLD,IFLD,IBITL, - & IPFLAG,ID,PDS, - & IGFLAG,IGRID,IGDS,ICOMP, - & IBFLAG,IBMAP,IBLEN,IBDSFL, - & NPTS,KBUF,ITOT,JERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3NOGDS MAKE A COMPLETE GRIB MESSAGE -C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 -C -C ABSTRACT: MAKES A COMPLETE GRIB MESSAGE FROM A USER SUPPLIED -C ARRAY OF FLOATING POINT OR INTEGER DATA. THE USER HAS THE -C OPTION OF SUPPLYING THE PDS OR AN INTEGER ARRAY THAT WILL BE -C USED TO CREATE A PDS (WITH W3FI68). THE USER MUST ALSO -C SUPPLY OTHER NECESSARY INFO; SEE USAGE SECTION BELOW. -C -C PROGRAM HISTORY LOG: -C 97-02-24 M. FARLEY MODIFIED W3FI72 - this routine allows for -C NO GDS (errors in W3FI71 for GRIB grids -C 21-26, 61-64 forced the need for this routine). -C 98-06-24 Gilbert Added number of gridpoint values for grids -C 61-64, needed when igflag=2 ( no gds ). -C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. -C -C USAGE: CALL W3NOGDS(ITYPE,FLD,IFLD,IBITL, -C & IPFLAG,ID,PDS, -C & IGFLAG,IGRID,IGDS,ICOMP, -C & IBFLAG,IBMAP,IBLEN,IBDSFL, -C & IBDSFL, -C & NPTS,KBUF,ITOT,JERR) -C -C INPUT ARGUMENT LIST: -C ITYPE - 0 = FLOATING POINT DATA SUPPLIED IN ARRAY 'FLD' -C 1 = INTEGER DATA SUPPLIED IN ARRAY 'IFLD' -C FLD - REAL ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE -C CONVERTED TO GRIB FORMAT IF ITYPE=0. -C SEE REMARKS #1 & 2. -C IFLD - INTEGER ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE -C CONVERTED TO GRIB FORMAT IF ITYPE=1. -C SEE REMARKS #1 & 2. -C IBITL - 0 = COMPUTER COMPUTES LENGTH FOR PACKING DATA FROM -C POWER OF 2 (NUMBER OF BITS) BEST FIT OF DATA -C USING 'VARIABLE' BIT PACKER W3FI58. -C 8, 12, ETC. COMPUTER RESCALES DATA TO FIT INTO THAT -C 'FIXED' NUMBER OF BITS USING W3FI59. -C SEE REMARKS #3. -C -C IPFLAG - 0 = MAKE PDS FROM USER SUPPLIED ARRAY (ID) -C 1 = USER SUPPLYING PDS -C NOTE: IF PDS IS GREATER THAN 30, USE IPLFAG=1. -C THE USER COULD CALL W3FI68 BEFORE HE CALLS -C W3NOGDS. THIS WOULD MAKE THE FIRST 30 BYTES OF -C THE PDS, USER THEN WOULD MAKE BYTES AFTER 30. -C ID - INTEGER ARRAY OF VALUES THAT W3FI68 WILL USE -C TO MAKE AN EDITION 1 PDS IF IPFLAG=0. (SEE THE -C DOCBLOCK FOR W3FI68 FOR LAYOUT OF ARRAY) -C PDS - CHARACTER ARRAY OF VALUES (VALID PDS SUPPLIED -C BY USER) IF IPFLAG=1. LENGTH MAY EXCEED 28 BYTES -C (CONTENTS OF BYTES BEYOND 28 ARE PASSED -C THROUGH UNCHANGED). -C -C IGFLAG - 0 = MAKE GDS BASED ON 'IGRID' VALUE. -C 1 = MAKE GDS FROM USER SUPPLIED INFO IN 'IGDS' -C AND 'IGRID' VALUE. -C SEE REMARKS #4. -C 2 = NO GDS WILL BE INCLUDED...for international grids -C *** THIS IS AN EXCEPTION TO REMARKS #4!!!! -C IGRID - # = GRID IDENTIFICATION (TABLE B) -C 255 = IF USER DEFINED GRID; IGDS MUST BE SUPPLIED -C AND IGFLAG MUST =1. -C IGDS - INTEGER ARRAY CONTAINING USER GDS INFO (SAME -C FORMAT AS SUPPLIED BY W3FI71 - SEE DOCKBLOCK FOR -C LAYOUT) IF IGFLAG=1. -C ICOMP - RESOLUTION AND COMPONENT FLAG FOR BIT 5 OF GDS(17) -C 0 = EARTH ORIENTED WINDS -C 1 = GRID ORIENTED WINDS -C -C IBFLAG - 0 = MAKE BIT MAP FROM USER SUPPLIED DATA -C # = BIT MAP PREDEFINED BY CENTER -C SEE REMARKS #5. -C IBMAP - INTEGER ARRAY CONTAINING BIT MAP -C IBLEN - LENGTH OF BIT MAP WILL BE USED TO VERIFY LENGTH -C OF FIELD (ERROR IF IT DOESN'T MATCH). -C -C IBDSFL - INTEGER ARRAY CONTAINING TABLE 11 FLAG INFO -C BDS OCTET 4: -C (1) 0 = GRID POINT DATA -C 1 = SPHERICAL HARMONIC COEFFICIENTS -C (2) 0 = SIMPLE PACKING -C 1 = SECOND ORDER PACKING -C (3) ... SAME VALUE AS 'ITYPE' -C 0 = ORIGINAL DATA WERE FLOATING POINT VALUES -C 1 = ORIGINAL DATA WERE INTEGER VALUES -C (4) 0 = NO ADDITIONAL FLAGS AT OCTET 14 -C 1 = OCTET 14 CONTAINS FLAG BITS 5-12 -C (5) 0 = RESERVED - ALWAYS SET TO 0 -C BYTE 6 OPTION 1 NOT AVAILABLE (AS OF 5-16-93) -C (6) 0 = SINGLE DATUM AT EACH GRID POINT -C 1 = MATRIX OF VALUES AT EACH GRID POINT -C BYTE 7 OPTION 0 WITH SECOND ORDER PACKING N/A (AS OF 5-16-93) -C (7) 0 = NO SECONDARY BIT MAPS -C 1 = SECONDARY BIT MAPS PRESENT -C (8) 0 = SECOND ORDER VALUES HAVE CONSTANT WIDTH -C 1 = SECOND ORDER VALUES HAVE DIFFERENT WIDTHS -C -C OUTPUT ARGUMENT LIST: -C NPTS - NUMBER OF GRIDPOINTS IN ARRAY FLD OR IFLD -C KBUF - ENTIRE GRIB MESSAGE ('GRIB' TO '7777') -C EQUIVALENCE TO INTEGER ARRAY TO MAKE SURE IT -C IS ON WORD BOUNARY. -C ITOT - TOTAL LENGTH OF GRIB MESSAGE IN BYTES -C JERR - = 0, COMPLETED MAKING GRIB FIELD WITHOUT ERROR -C 1, IPFLAG NOT 0 OR 1 -C 2, IGFLAG NOT 0 OR 1 OR 2 -C 3, ERROR CONVERTING IEEE F.P. NUMBER TO IBM370 F.P. -C 4, W3FI71 ERROR/IGRID NOT DEFINED -C 5, W3FK74 ERROR/GRID REPRESENTATION TYPE NOT VALID -C 6, GRID TOO LARGE FOR PACKER DIMENSION ARRAYS -C SEE AUTOMATION DIVISION FOR REVISION! -C 7, LENGTH OF BIT MAP NOT EQUAL TO SIZE OF FLD/IFLD -C 8, W3FI73 ERROR, ALL VALUES IN IBMAP ARE ZERO -C -C OUTPUT FILES: -C FT06F001 - STANDARD FORTRAN OUTPUT PRINT FILE -C -C SUBPROGRAMS CALLED: -C LIBRARY: -C W3LIB - W3FI58, W3FI59, W3FI68, W3FI71, W3FI73, W3FI74 -C W3FI75, W3FI76, W3FI01 -C -C REMARKS: -C 1) IF BIT MAP TO BE INCLUDED IN MESSAGE, NULL DATA SHOULD -C BE INCLUDED IN FLD OR IFLD. THIS ROUTINE WILL TAKE CARE -C OF 'DISCARDING' ANY NULL DATA BASED ON THE BIT MAP. -C 2) UNITS MUST BE THOSE IN GRIB DOCUMENTATION: NMC O.N. 388 -C OR WMO PUBLICATION 306. -C 3) IN EITHER CASE, INPUT NUMBERS WILL BE MULTIPLIED BY -C '10 TO THE NTH' POWER FOUND IN ID(25) OR PDS(27-28), -C THE D-SCALING FACTOR, PRIOR TO BINARY PACKING. -C 4) ALL NMC PRODUCED GRIB FIELDS WILL HAVE A GRID DEFINITION -C SECTION INCLUDED IN THE GRIB MESSAGE. ID(6) WILL BE -C SET TO '1'. -C - GDS WILL BE BUILT BASED ON GRID NUMBER (IGRID), UNLESS -C IGFLAG=1 (USER SUPPLYING IGDS). USER MUST STILL SUPPLY -C IGRID EVEN IF IGDS PROVIDED. -C 5) IF BIT MAP USED THEN ID(7) OR PDS(8) MUST INDICATE THE -C PRESENCE OF A BIT MAP. -C 6) ARRAY KBUF SHOULD BE EQUIVALENCED TO AN INTEGER VALUE OR -C ARRAY TO MAKE SURE IT IS ON A WORD BOUNDARY. -C 7) SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY C916/256, Y-MP8/864, Y-MP EL92/256, J916/2048 -C -C$$$ -C - PARAMETER (MXSIZE=260000) -C ALLOW UP TO 24 BITS PER POINT - PARAMETER (MXSIZ3=MXSIZE*3) - PARAMETER (MXSIZB=MXSIZE/8+6) -C FOR 64 BIT CRAY - PARAMETER (MXSIZI=MXSIZ3/8) -C FOR 32 BIT WORKSTATIONS AND HDS -C PARAMETER (MXSIZI=MXSIZ3/4) -C - REAL FLD(*) -C - INTEGER IBDSFL(*) - INTEGER IBMAP(*) - INTEGER ID(*) - INTEGER IFLD(*) - INTEGER IGDS(*) - INTEGER IPFLD(MXSIZI) - INTEGER IB(4) -C - CHARACTER * 1 BDS11(11) - CHARACTER * 1 KBUF(*) - CHARACTER * 1 PDS(*) - CHARACTER * 1 GDS(200) - CHARACTER * 1 BMS(MXSIZB) - CHARACTER * 1 PFLD(MXSIZ3) - CHARACTER * 1 SEVEN - CHARACTER * 1 ZERO -C - EQUIVALENCE (IPFLD(1),PFLD(1)) - EQUIVALENCE (BDS11(1),IDUMMY) -C -C ASCII REP OF /'G', 'R', 'I', 'B'/ -C - DATA IB / 71, 82, 73, 66/ -C - IER = 0 - IBERR = 0 - JERR = 0 - IGRIBL = 8 - IPDSL = 0 - LENGDS = 0 - LENBMS = 0 - LENBDS = 0 - ITOSS = 0 -C -C 1.0 PRODUCT DEFINITION SECTION(PDS). -C -C SET ID(6) TO 1 ...OR... MODIFY PDS(8) ... -C REGARDLESS OF USER SPECIFICATION... -C NMC GRIB FIELDS WILL ALWAYS HAVE A GDS -C ***** exception for international GRIB GRIDS 21-26, 61-64 -C ***** which will NOT contain a GDS until subroutine W3FI71 is fixed! -C - IF (IPFLAG .EQ.0) THEN - ID(6) = 1 - if (igflag .eq. 2) then - id(6) = 0 - endif - CALL W3FI68(ID,PDS) - ELSE IF (IPFLAG .EQ. 1) THEN - IF (IAND(mova2i(PDS(8)),64) .EQ. 64) THEN -C BOTH GDS AND BMS - PDS(8) = CHAR(192) - ELSE IF (mova2i(PDS(8)) .EQ. 0) THEN -C GDS ONLY - PDS(8) = CHAR(128) - END IF - CONTINUE - ELSE -C PRINT *,' W3NOGDS ERROR, IPFLAG IS NOT 0 OR 1 IPFLAG = ',IPFLAG - JERR = 1 - GO TO 900 - END IF -C -C GET LENGTH OF PDS -C - IPDSL = mova2i(PDS(1)) * 65536 + mova2i(PDS(2)) * 256 + - & mova2i(PDS(3)) -C -C 2.0 GRID DEFINITION SECTION (GDS). -C -C IF IGFLAG=1 THEN USER IS SUPPLYING THE IGDS INFORMATION -C IF IGFLAG=2 THEN USER doesn't want a GDS and this section -C will be skipped...LENGDS=0 -C - IF (IGFLAG .EQ. 0) THEN - CALL W3FI71(IGRID,IGDS,IGERR) - IF (IGERR .EQ. 1) THEN -C PRINT *,' W3FI71 ERROR, GRID TYPE NOT DEFINED...',IGRID - JERR = 4 - GO TO 900 - END IF - END IF - IF (IGFLAG .EQ. 0 .OR. IGFLAG .EQ.1) THEN - CALL W3FI74(IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR) - IF (IGERR .EQ. 1) THEN -C PRINT *,' W3FI74 ERROR, GRID REP TYPE NOT VALID...',IGDS(3) - JERR = 5 - GO TO 900 - ELSE - END IF - IF (NPTS .GT. MXSIZE) THEN -C PRINT *,' W3NOGDS ERROR, GRID TOO LARGE FOR PACKER ARRAY', -C & ' DIMENSIONS' - JERR = 6 - GO TO 900 - END IF - else if (igflag .eq. 2) then - lengds = 0 - if (igrid.eq.21) then - npts=1333 - else if (igrid.eq.22) then - npts=1333 - else if (igrid.eq.23) then - npts=1333 - else if (igrid.eq.24) then - npts=1333 - else if (igrid.eq.25) then - npts=1297 - else if (igrid.eq.26) then - npts=1297 - else if ((igrid.ge.61).and.(igrid.le.64)) then - npts=4096 - end if - ELSE -C PRINT *,' W3NOGDS ERROR, IGFLAG IS NOT 0-2 IGFLAG = ',IGFLAG - GO TO 900 - END IF -C -C 3.0 BIT MAP SECTION (BMS). -C -C SET ITOSS=1 IF BITMAP BEING USED. W3FI75 WILL TOSS DATA -C PRIOR TO PACKING. LATER CODING WILL BE NEEDED WHEN THE -C 'PREDEFINED' GRIDS ARE FINALLY 'DEFINED'. -C - IF (mova2i(PDS(8)) .EQ. 64 .OR. - & mova2i(PDS(8)) .EQ. 192) THEN - ITOSS = 1 - IF (IBFLAG .EQ. 0) THEN - IF (IBLEN .NE. NPTS) THEN -C PRINT *,' W3NOGDS ERROR, IBLEN .NE. NPTS = ',IBLEN,NPTS - JERR = 7 - GO TO 900 - END IF - CALL W3FI73(IBFLAG,IBMAP,IBLEN,BMS,LENBMS,IER) - IF (IER .NE. 0) THEN -C PRINT *,' W3FI73 ERROR, IBMAP VALUES ARE ALL ZERO' - JERR = 8 - GO TO 900 - END IF - ELSE -C PRINT *,' BIT MAP PREDEFINED BY CENTER, IBFLAG = ',IBFLAG - END IF - END IF -C -C 4.0 BINARY DATA SECTION (BDS). -C -C 4.1 SCALE THE DATA WITH D-SCALE FROM PDS(27-28) -C - JSCALE = mova2i(PDS(27)) * 256 + mova2i(PDS(28)) - IF (IAND(JSCALE,32768).NE.0) THEN - JSCALE = - IAND(JSCALE,32767) - END IF - SCALE = 10.0 ** JSCALE - IF (ITYPE .EQ. 0) THEN - DO 410 I = 1,NPTS - FLD(I) = FLD(I) * SCALE - 410 CONTINUE - ELSE - DO 411 I = 1,NPTS - IFLD(I) = NINT(FLOAT(IFLD(I)) * SCALE) - 411 CONTINUE - END IF -C -C 4.2 CALL W3FI75 TO PACK DATA AND MAKE BDS. -C - CALL W3FI75(IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL, - & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS) - IF (IBERR .EQ. 1) THEN - JERR = 3 - GO TO 900 - END IF -C 4.3 IF D-SCALE NOT 0, RESCALE INPUT FIELD TO -C ORIGINAL VALUE -C - IF (JSCALE.NE.0) THEN - DSCALE = 1.0 / SCALE - IF (ITYPE.EQ.0) THEN - DO 412 I = 1, NPTS - FLD(I) = FLD(I) * DSCALE - 412 CONTINUE - ELSE - DO 413 I = 1, NPTS - FLD(I) = NINT(FLOAT(IFLD(I)) * DSCALE) - 413 CONTINUE - END IF - END IF -C -C 5.0 OUTPUT SECTION. -C -C 5.1 ZERO OUT THE OUTPUT ARRAY KBUF. -C - ZERO = CHAR(00) - ITOT = IGRIBL + IPDSL + LENGDS + LENBMS + LENBDS + 4 -C PRINT *,'IGRIBL =',IGRIBL -C PRINT *,'IPDSL =',IPDSL -C PRINT *,'LENGDS =',LENGDS -C PRINT *,'LENBMS =',LENBMS -C PRINT *,'LENBDS =',LENBDS -C PRINT *,'ITOT =',ITOT -C -C KBUF MUST BE ON A WORD BOUNDRY, EQUIVALENCE TO AN -C INTEGER ARRAY IN THE MAIN PROGRAM TO MAKE SURE IT IS. -C THIS IS BOTH COMPUTER AND COMPILER DEPENDENT, W3FI01 -C IS USED TO FILL OUT IF THE COMPUTER IS A 64 BIT OR -C 32 BIT WORD SIZE COMPUTER. LW IS SET TO 4 FOR 32 BIT -C COMPUTER, 8 FOR 64 BIT COMPUTER. -C - CALL W3FI01(LW) - IWORDS = ITOT / LW - CALL XSTORE(KBUF,0,IWORDS) - IF (MOD(ITOT,LW).NE.0) THEN - IBYTES = ITOT - IWORDS * LW - DO 510 I = 1,IBYTES - KBUF(IWORDS * LW + I) = ZERO - 510 CONTINUE - END IF -C -C 5.2 MOVE SECTION 0 - 'IS' INTO KBUF (8 BYTES). -C - ISTART = 0 - DO 520 I = 1,4 - KBUF(I) = CHAR(IB(I)) - 520 CONTINUE -C - KBUF(5) = CHAR(MOD(ITOT / 65536,256)) - KBUF(6) = CHAR(MOD(ITOT / 256,256)) - KBUF(7) = CHAR(MOD(ITOT ,256)) - KBUF(8) = CHAR(1) -C -C 5.3 MOVE SECTION 1 - 'PDS' INTO KBUF (28 BYTES). -C - ISTART = ISTART + IGRIBL - IF (IPDSL.GT.0) THEN - CALL XMOVEX(KBUF(ISTART+1),PDS,IPDSL) - ELSE -C PRINT *,'LENGTH OF PDS LESS OR EQUAL 0, IPDSL = ',IPDSL - END IF -C -C 5.4 MOVE SECTION 2 - 'GDS' INTO KBUF. -C - ISTART = ISTART + IPDSL - IF (LENGDS .GT. 0) THEN - CALL XMOVEX(KBUF(ISTART+1),GDS,LENGDS) - END IF -C -C 5.5 MOVE SECTION 3 - 'BMS' INTO KBUF. -C - ISTART = ISTART + LENGDS - IF (LENBMS .GT. 0) THEN - CALL XMOVEX(KBUF(ISTART+1),BMS,LENBMS) - END IF -C -C 5.6 MOVE SECTION 4 - 'BDS' INTO KBUF. -C -C MOVE THE FIRST 11 OCTETS OF THE BDS INTO KBUF. -C - ISTART = ISTART + LENBMS - CALL XMOVEX(KBUF(ISTART+1),BDS11,11) -C -C MOVE THE PACKED DATA INTO THE KBUF -C - ISTART = ISTART + 11 - IF (LEN.GT.0) THEN - CALL XMOVEX(KBUF(ISTART+1),PFLD,LEN) - END IF -C -C ADD '7777' TO END OFF KBUF -C NOTE THAT THESE 4 OCTETS NOT INCLUDED IN ACTUAL SIZE OF BDS. -C - SEVEN = CHAR(55) - ISTART = ITOT - 4 - DO 562 I = 1,4 - KBUF(ISTART+I) = SEVEN - 562 CONTINUE -C - 900 CONTINUE - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3pradat.f b/external/w3nco/v2.0.6/src/w3pradat.f deleted file mode 100644 index d89c1e18..00000000 --- a/external/w3nco/v2.0.6/src/w3pradat.f +++ /dev/null @@ -1,78 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3pradat(idat,cdat) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3PRADAT FORMAT A DATE AND TIME INTO CHARACTERS -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM FORMS VARIOUS CHARACTER STRINGS USEFUL -! IN DESCRIBING AN NCEP ABSOLUTE DATE AND TIME. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: CALL W3PRADAT(IDAT,CDAT) -! -! INPUT VARIABLES: -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! OUTPUT VARIABLES: -! CDAT CHARACTER*10 (8) STRINGS DESCRIBING DATE AND TIME -! (CDAT(1) IS THE NAME OF THE DAY OF THE WEEK; -! CDAT(2) IS THE NAME OF THE MONTH; -! CDAT(3) IS THE DAY OF MONTH, YEAR; -! CDAT(4) IS THE DATE IN YYYY-MM-DD FORMAT; -! CDAT(5) IS THE DATE IN YYYY.DOY FORMAT; -! CDAT(6) IS THE TIME IN HH:MM:SS FORMAT; -! CDAT(7) IS THE MILLISECONDS IN .XXX FORMAT; -! CDAT(8) IS THE TIME ZONE.) -! -! SUBPROGRAMS CALLED: -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer idat(8) - character*(*) cdat(8) - character*10 ctmp(8) - character*10 cmon(12) - data cmon/'January ','February ','March ', - & 'April ','May ','June ', - & 'July ','August ','September ', - & 'October ','November ','December '/ - character*10 cdow(7) - data cdow/'Sunday ','Monday ','Tuesday ', - & 'Wednesday ','Thursday ','Friday ', - & 'Saturday '/ -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! get day of week and day of year, convert day of week and month -! to english names, write other formats of date and time, and -! write time zone differential in one of three ways. - jldayn=iw3jdn(idat(1),idat(2),idat(3)) - call w3fs26(jldayn,jy,jm,jd,jdow,jdoy) - ctmp(1)=cdow(jdow) - ctmp(2)='********' - if(idat(2).ge.1.and.idat(2).le.12) ctmp(2)=cmon(idat(2)) - write(ctmp(3),'(i2,", ",i4)') idat(3),idat(1) - write(ctmp(4),'(i4,"-",i2.2,"-",i2.2)') idat(1),idat(2),idat(3) - write(ctmp(5),'(i4,".",i3.3)') idat(1),jdoy - write(ctmp(6),'(i2.2,":",i2.2,":",i2.2)') idat(5),idat(6),idat(7) - write(ctmp(7),'(".",i3.3)') idat(8) - if(idat(4).eq.0) then - write(ctmp(8),'("UTC")') - elseif(mod(idat(4),100).eq.0) then - kh=idat(4)/100 - write(ctmp(8),'("UTC",sp,i3.2,"h")') kh - else - kh=idat(4)/100 - km=abs(mod(idat(4),100)) - write(ctmp(8),'("UTC",sp,i3.2,"h",ss,i2.2,"m")') kh,km - endif - cdat=ctmp -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/external/w3nco/v2.0.6/src/w3reddat.f b/external/w3nco/v2.0.6/src/w3reddat.f deleted file mode 100644 index d15d5293..00000000 --- a/external/w3nco/v2.0.6/src/w3reddat.f +++ /dev/null @@ -1,142 +0,0 @@ - subroutine w3reddat(it,rinc,dinc) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM REDUCES AN NCEP RELATIVE TIME INTERVAL -! INTO ONE OF SEVEN CANONICAL FORMS, DEPENDING ON THE INPUT IT VALUE. -! -! First reduced format type (IT=-1): -! RINC(1) is an arbitrary integer. -! RINC(2) is an integer between 00 and 23, inclusive. -! RINC(3) is an integer between 00 and 59, inclusive. -! RINC(4) is an integer between 00 and 59, inclusive. -! RINC(5) is an integer between 000 and 999, inclusive. -! If RINC(1) is negative, then the time interval is negative. -! -! Second reduced format type (IT=0): -! If the time interval is not negative, then the format is: -! RINC(1) is zero or a positive integer. -! RINC(2) is an integer between 00 and 23, inclusive. -! RINC(3) is an integer between 00 and 59, inclusive. -! RINC(4) is an integer between 00 and 59, inclusive. -! RINC(5) is an integer between 000 and 999, inclusive. -! Otherwise if the time interval is negative, then the format is: -! RINC(1) is zero or a negative integer. -! RINC(2) is an integer between 00 and -23, inclusive. -! RINC(3) is an integer between 00 and -59, inclusive. -! RINC(4) is an integer between 00 and -59, inclusive. -! RINC(5) is an integer between 000 and -999, inclusive. -! -! Days format type (IT=1): -! RINC(1) is arbitrary. -! RINC(2) is zero. -! RINC(3) is zero. -! RINC(4) is zero. -! RINC(5) is zero. -! -! Hours format type (IT=2): -! RINC(1) is zero. -! RINC(2) is arbitrary. -! RINC(3) is zero. -! RINC(4) is zero. -! RINC(5) is zero. -! (This format should not express time intervals longer than 300 years.) -! -! Minutes format type (IT=3): -! RINC(1) is zero. -! RINC(2) is zero. -! RINC(3) is arbitrary. -! RINC(4) is zero. -! RINC(5) is zero. -! (This format should not express time intervals longer than five years.) -! -! Seconds format type (IT=4): -! RINC(1) is zero. -! RINC(2) is zero. -! RINC(3) is zero. -! RINC(4) is arbitrary. -! RINC(5) is zero. -! (This format should not express time intervals longer than one month.) -! -! Milliseconds format type (IT=5): -! RINC(1) is zero. -! RINC(2) is zero. -! RINC(3) is zero. -! RINC(4) is zero. -! RINC(5) is arbitrary. -! (This format should not express time intervals longer than one hour.) -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: CALL W3REDDAT(IT,RINC,DINC) -! -! INPUT VARIABLES: -! IT INTEGER RELATIVE TIME INTERVAL FORMAT TYPE -! (-1 FOR FIRST REDUCED TYPE (HOURS ALWAYS POSITIVE), -! 0 FOR SECOND REDUCED TYPE (HOURS CAN BE NEGATIVE), -! 1 FOR DAYS ONLY, 2 FOR HOURS ONLY, 3 FOR MINUTES ONLY, -! 4 FOR SECONDS ONLY, 5 FOR MILLISECONDS ONLY) -! RINC REAL (5) NCEP RELATIVE TIME INTERVAL -! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) -! -! OUTPUT VARIABLES: -! DINC REAL (5) NCEP RELATIVE TIME INTERVAL -! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) -! -! SUBPROGRAMS CALLED: -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - real rinc(5),dinc(5) -! parameters for number of units in a day -! and number of milliseconds in a unit -! and number of next smaller units in a unit, respectively - integer,dimension(5),parameter:: itd=(/1,24,1440,86400,86400000/), - & itm=itd(5)/itd - integer,dimension(4),parameter:: itn=itd(2:5)/itd(1:4) - integer,parameter:: np=16 - integer iinc(4),jinc(5),kinc(5) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! first reduce to the first reduced form - iinc=floor(rinc(1:4)) -! convert all positive fractional parts to milliseconds -! and determine canonical milliseconds - jinc(5)=nint(dot_product(rinc(1:4)-iinc,real(itm(1:4)))+rinc(5)) - kinc(5)=modulo(jinc(5),itn(4)) -! convert remainder to seconds and determine canonical seconds - jinc(4)=iinc(4)+(jinc(5)-kinc(5))/itn(4) - kinc(4)=modulo(jinc(4),itn(3)) -! convert remainder to minutes and determine canonical minutes - jinc(3)=iinc(3)+(jinc(4)-kinc(4))/itn(3) - kinc(3)=modulo(jinc(3),itn(2)) -! convert remainder to hours and determine canonical hours - jinc(2)=iinc(2)+(jinc(3)-kinc(3))/itn(2) - kinc(2)=modulo(jinc(2),itn(1)) -! convert remainder to days and compute milliseconds of the day - kinc(1)=iinc(1)+(jinc(2)-kinc(2))/itn(1) - ms=dot_product(kinc(2:5),itm(2:5)) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! next reduce to either single value canonical form -! or to one of the two reduced forms - if(it.ge.1.and.it.le.5) then -! ensure that exact multiples of 1./np are expressed exactly -! (other fractions may have precision errors) - rp=(np*ms)/itm(it)+mod(np*ms,itm(it))/real(itm(it)) - dinc=0 - dinc(it)=real(kinc(1))*itd(it)+rp/np - else -! the reduced form is done except the second reduced form is modified -! for negative time intervals with fractional days - dinc=kinc - if(it.eq.0.and.kinc(1).lt.0.and.ms.gt.0) then - dinc(1)=dinc(1)+1 - dinc(2:5)=mod(ms-itm(1),itm(1:4))/itm(2:5) - endif - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/external/w3nco/v2.0.6/src/w3tagb.f b/external/w3nco/v2.0.6/src/w3tagb.f deleted file mode 100644 index 8b4deef6..00000000 --- a/external/w3nco/v2.0.6/src/w3tagb.f +++ /dev/null @@ -1,121 +0,0 @@ - SUBROUTINE W3TAGB(PROG,KYR,JD,LF,ORG) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3TAGB OPERATIONAL JOB IDENTIFIER -C PRGMMR: FARLEY ORG: NP11 DATE: 1998-03-17 -C -C ABSTRACT: PRINTS IDENTIFYING INFORMATION FOR OPERATIONAL -C codes. CALLED AT THE BEGINNING OF A code, W3TAGB PRINTS -C THE program NAME, THE YEAR AND JULIAN DAY OF ITS -C COMPILATION, AND THE RESPONSIBLE ORGANIZATION. ON A 2ND -C LINE IT PRINTS THE STARTING DATE-TIME. CALLED AT THE -C END OF A JOB, entry routine, W3TAGE PRINTS A LINE WITH THE -C ENDING DATE-TIME AND A 2ND LINE STATING THE program name -C AND THAT IT HAS ENDED. -C -C PROGRAM HISTORY LOG: -C 85-10-29 J.NEWELL -C 89-10-20 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN -C 91-03-01 R.E.JONES ADD MACHINE NAME TO ENDING LINE -C 92-12-02 R.E.JONES ADD START-ENDING TIME-DATE -C 93-11-16 R.E.JONES ADD DAY OF YEAR, DAY OF WEEK, AND JULIAN DAY -C NUMBER. -C 97-12-24 M.FARLEY PRINT STATEMENTS MODIFIED FOR 4-DIGIT YR -C 98-03-17 M.FARLEY REPLACED DATIMX WITH CALLS TO W3LOCDAT/W3DOXDAT -C 99-01-29 B. VUONG CONVERTED TO IBM RS/6000 SP -C -C 99-06-17 A. Spruill ADJUSTED THE SIZE OF PROGRAM NAME TO ACCOMMODATE -C THE 20 CHARACTER NAME CONVENTION ON THE IBM SP. -C 1999-08-24 Gilbert added call to START() in W3TAGB and a call -C to SUMMARY() in W3TAGE to print out a -C resource summary list for the program using -C W3TAGs. -C 2012-10-18 Vuong REMOVE PRINT STATEMENT 604 -C 2013-02-06 Vuong MODIFIED PRINT STATEMENT 604 -C -C USAGE: CALL W3TAGB(PROG, KYR, JD, LF, ORG) -C CALL W3TAGE(PROG) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C PROG ARG LIST PROGRAM NAME CHARACTER*1 -C KYR ARG LIST YEAR OF COMPILATION INTEGER -C JD ARG LIST JULIAN DAY OF COMPILATION INTEGER -C LF ARG LIST HUNDRETHS OF JULIAN DAY OF COMPILATION -C INTEGER (RANGE IS 0 TO 99 INCLUSIVE) -C ORG ARG LIST ORGANIZATION CODE (SUCH AS WD42) -C CHARACTER*1 -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ---------------------------------------------------------------- -C DDATE PRINT YEAR AND JULIAN DAY (NEAREST HUNDRETH) -C FILE OF COMPILATION REAL -C -C SUBPROGRAMS CALLED: CLOCK, DATE -C -C REMARKS: FULL WORD USED IN ORDER TO HAVE AT LEAST -C SEVEN DECIMAL DIGITS ACCURACY FOR VALUE OF DDATE. -C SUBPROGRAM CLOCK AND DATE MAY DIFFER FOR EACH TYPE -C COMPUTER. YOU MAY HAVE TO CHANGE THEM FOR ANOTHER -C TYPE OF COMPUTER. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C -C$$$ -C - CHARACTER *(*) PROG,ORG - CHARACTER * 3 JMON(12) - CHARACTER * 3 DAYW(7) -C - INTEGER IDAT(8), JDOW, JDOY, JDAY -C - SAVE -C - DATA DAYW/'SUN','MON','TUE','WEN','THU','FRI','SAT'/ - DATA JMON /'JAN','FEB','MAR','APR','MAY','JUN', - & 'JUL','AUG','SEP','OCT','NOV','DEC'/ -C - CALL START() - - DYR = KYR - DYR = 1.0E+03 * DYR - DJD = JD - DLF = LF - DLF = 1.0E-02 * DLF - DDATE = DYR + DJD + DLF - PRINT 600 - 600 FORMAT(//,10('* . * . ')) - PRINT 601, PROG, DDATE, ORG - 601 FORMAT(5X,'PROGRAM ',A,' HAS BEGUN. COMPILED ',F10.2, - & 5X, 'ORG: ',A) -C - CALL W3LOCDAT(IDAT) - CALL W3DOXDAT(IDAT,JDOW,JDOY,JDAY) - PRINT 602, JMON(IDAT(2)),IDAT(3),IDAT(1),IDAT(5),IDAT(6), - & IDAT(7),IDAT(8),JDOY,DAYW(JDOW),JDAY - 602 FORMAT(5X,'STARTING DATE-TIME ',A3,1X,I2.2,',', - & I4.4,2X,2(I2.2,':'),I2.2,'.',I3.3,2X,I3,2X,A3,2X,I8,//) - RETURN -C - ENTRY W3TAGE(PROG) -C - CALL W3LOCDAT(IDAT) - CALL W3DOXDAT(IDAT,JDOW,JDOY,JDAY) - PRINT 603, JMON(IDAT(2)),IDAT(3),IDAT(1),IDAT(5),IDAT(6), - & IDAT(7),IDAT(8),JDOY,DAYW(JDOW),JDAY - 603 FORMAT(//,5X,'ENDING DATE-TIME ',A3,1X,I2.2,',', - & I4.4,2X,2(I2.2,':'),I2.2,'.',I3.3,2X,I3,2X,A3,2X,I8) - PRINT 604, PROG - 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED.') -C 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED. CRAY J916/2048') -C 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED. CRAY Y-MP EL2/256') - PRINT 605 - 605 FORMAT(10('* . * . ')) - - CALL SUMMARY() -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3trnarg.f b/external/w3nco/v2.0.6/src/w3trnarg.f deleted file mode 100644 index 7a97df55..00000000 --- a/external/w3nco/v2.0.6/src/w3trnarg.f +++ /dev/null @@ -1,172 +0,0 @@ - SUBROUTINE W3TRNARG(SUBDIR,LSUBDR,TANKID,LTNKID,APPCHR,LAPCHR, - 1 TLFLAG,IYMDHB,IYMDHE,IERR) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3TRNARG TRANSLATES ARG LINE FROM STANDARD INPUT -C PRGMMR: KEYSER ORG: NP22 DATE: 2002-02-11 -C -C ABSTRACT: READS ARGUMENT LINES FROM STANDARD INPUT AND OBTAINS , -C SUBDIRECTORY, BUFR TANKNAME, CHARACTERS TO APPEND FOR ADDING -C AN ORBIT, AND OPTIONS FOR LIMITING THE TIME WINDOW. -C -C PROGRAM HISTORY LOG: -C 1996-09-03 B. KATZ -- ORIGINAL AUTHOR -C 1998-11-27 B. KATZ -- CHANGES FOR Y2K AND FORTRAN 90 COMPLIANCE -C 2002-02-11 D. KEYSER -- IF "TLFLAG" IS NOT SPECIFIED, IT DEFAULTS -C TO "NOTIMLIM" RATHER THAN "TIMLIM" AND -C GROSS TIME LIMITS WILL NOT BE CALCULATED -C AND RETURNED IN "IYMDHB" AND "IYMDHE" -C -C USAGE: CALL W3TRNARG(SUBDIR,LSUBDR,TANKID,LTNKID,APPCHR,LAPCHR, -C TLFLAG,IYMDHB,IYMDHE,IERR) -C OUTPUT ARGUMENT LIST: -C SUBDIR - NAME OF SUB-DIRECTORY INCLUDING BUFR DATA TYPE WHERE -C BUFR DATA TANK IS LOCATED. -C LSUBDR - NUMBER OF CHARACTERS IN 'SUBDIR'. -C TANKID - NAME OF FILE INCLUDING BUFR DATA SUB-TYPE CONTAINING -C BUFR DATA TANK. -C LTNKID - NUMBER OF CHARACTERS IN 'TANKID'. -C APPCHR - CHARACTERS TO BE APPENDED TO 'TANKID' GIVING A -C UNIQUELY NAMED FILE TO CONTAIN THE ORIGINAL TANK -C WITH ONE ORBIT APPENDED TO IT. -C LAPCHR - NUMBER OF CHARACTERS IN 'APPCHR'. -C TLFLAG - 8 CHARACTER FLAG INDICATING WHETHER TIME ACCEPTANCE -C CHECKS ATRE TO BE PERFORMED. -C = 'TIMLIM ' : PERFORM TIME ACCEPTANCE CHECKS. -C = 'NOTIMLIM' : DO NOT PERFORM TIME ACCEPTANCE CHECKS. -C JDATE AND KDATE ARE DISREGARDED. -C IYMDHB - START OF TIME ACCEPTANCE WINDOW, IN FORM YYYYMMDDHH. -C IYMDHE - END OF TIME ACCEPTANCE WINDOW, IN FORM YYYYMMDDHH. -C -C INPUT FILES : -C UNIT 05 - STANDARD INPUT FOR PASSING IN ARGUMENTS. ARGUMENTS -C (FOR LIST-DIRECTED I/O) ARE AS FOLLOWS : -C RECORD 1 - (1) SUBDIRECTORY. CONTAINS BUFR DATA TYPE -C (2) TANKFILE. CONTAINS BUFR DATA SUB-TYPE -C (3) APPEND CHARACTERS. APPENDED TO TANKFILE -C TO GIVE UNIQUE OUTPUT FILE NAME. -C (4) DATE IN YYYYMMDDHH FORMAT. -C NEXT THREE RECORDS ARE OPTIONAL : -C RECORD 2 - (1) TIME LIMIT FLAG. MAY BE EITHER -C 'TIMLIM ' OR 'NOTIMLIM'. SEE -C DESCRIPTION OF 'TLFLAG' ABOVE. -C (DEFAULT IS 'NOTIMLIM') -C RECORD 3 - (1) HOURS BEFORE CURRENT TIME. -C RECORD 4 - (1) HOURS AFTER CURRENT TIME. -C IF 'TIMLIM ' IS SPECIFIED IN RECORD 2, THE -C QUANTITIES IN RECORDS 3 AND 4 ARE USED TO -C COMPUTE THE LIMITS OF THE TIME ACCEPTANCE WINDOW. -C IF RECORDS 3 AND 4 ARE OMITTED, THE VALUES -C DEFAULT TO -48 (48 HOURS BEFORE CURRENT TIME) -C AND +12 (12 HOURS AFTER CURRENT TIME). -C IF 'NOTIMLIM ' IS SPECIFIED IN RECORD 2, THEN -C THESE QUANTITIES ARE NOT USED REGARDLESS OF WHETHER -C OR NOT THEY WERE SPECIFIED. -C -C SUBPROGRAMS CALLED : -C W3LIB - W3MOVDAT -C -C REMARKS: -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - CHARACTER*(*) SUBDIR,TANKID,APPCHR,TLFLAG - INTEGER IDATIN(8),IDTOUT(8) - REAL TIMINC(5) - READ(5,*,END=9999) SUBDIR,TANKID,APPCHR,IYMDH - MSUBDR = LEN(SUBDIR) - DO LSUBDR=0,MSUBDR-1 - IF(SUBDIR(LSUBDR+1:LSUBDR+1).EQ.' ') GO TO 10 - ENDDO - LSUBDR = MSUBDR - 10 CONTINUE - IF(LSUBDR.LT.4) THEN - WRITE(6,'(1X,I2,'' CHARACTERS IN SUBDIRECTORY ARGUMENT'', - 1 '' AT LEAST 4 CHARACTERS ARE REQUIRED'')') LSUBDR - IERR = 2 - RETURN - ENDIF - MTNKID = LEN(TANKID) - DO LTNKID=0,MTNKID-1 - IF(TANKID(LTNKID+1:LTNKID+1).EQ.' ') GO TO 20 - ENDDO - LTNKID = MTNKID - 20 CONTINUE - IF(LTNKID.LT.4) THEN - WRITE(6,'(1X,I2,'' CHARACTERS IN TANKFILE ARGUMENT'', - 1 '' AT LEAST 4 CHARACTERS ARE REQUIRED'')') LTNKID - IERR = 2 - RETURN - ENDIF - MAPCHR = LEN(APPCHR) - DO LAPCHR=0,MAPCHR-1 - IF(APPCHR(LAPCHR+1:LAPCHR+1).EQ.' ') GO TO 30 - ENDDO - LAPCHR = MAPCHR - 30 CONTINUE - TLFLAG = 'NOTIMLIM' ! The default is to NOT perform time checks - READ(5,*,END=40) TLFLAG - 40 CONTINUE - IF(TLFLAG(1:6).NE.'TIMLIM') THEN - TLFLAG = 'NOTIMLIM' - PRINT 123, IYMDH,SUBDIR(1:LSUBDR),TANKID(1:LTNKID) - 123 FORMAT(/'RUN ON ',I10/'WRITE TO ',A,'/',A/'GROSS TIME LIMIT ', - 1 'CHECKS ARE NOT PERFORMED HERE - SUBSEQUENT PROGRAM ', - 1 'BUFR_TRANJB WILL TAKE CARE OF THIS'/) - IYMDHB = 0000000000 - IYMDHE = 2100000000 - IERR = 0 - RETURN - ENDIF - TLFLAG(7:8) = ' ' - READ(5,*,END=60) IHRBEF - GO TO 70 - 60 CONTINUE - IHRBEF = -48 - IHRAFT = 12 - GO TO 100 - 70 CONTINUE - READ(5,*,END=80) IHRAFT - GO TO 90 - 80 CONTINUE - IHRAFT = 12 - GO TO 100 - 90 CONTINUE - IF(IHRBEF.GT.0 .AND. IHRAFT.LT.0) THEN - ITEMP = IHRBEF - IHRBEF = IHRAFT - IHRAFT = ITEMP - ELSE IF(IHRBEF.GT.0) THEN - IHRBEF = -1 * IHRBEF - ENDIF - 100 CONTINUE - IDATIN(1) = IYMDH / 1000000 - IDATIN(2) = MOD(IYMDH,1000000) / 10000 - IDATIN(3) = MOD(IYMDH,10000) / 100 - IDATIN(4) = 0 - IDATIN(5) = MOD(IYMDH,100) - IDATIN(6:8) = 0 - TIMINC(1) = 0.0 - TIMINC(2) = FLOAT(IHRBEF) - TIMINC(3:5) = 0.0 - CALL W3MOVDAT(TIMINC,IDATIN,IDTOUT) - IYMDHB = ((IDTOUT(1) * 100 + IDTOUT(2)) * 100 + IDTOUT(3)) * - 1 100 + IDTOUT(5) - TIMINC(2) = FLOAT(IHRAFT) - CALL W3MOVDAT(TIMINC,IDATIN,IDTOUT) - IYMDHE = ((IDTOUT(1) * 100 + IDTOUT(2)) * 100 + IDTOUT(3)) * - 1 100 + IDTOUT(5) - PRINT 124, IYMDH,SUBDIR(1:LSUBDR),TANKID(1:LTNKID),IYMDHB,IYMDHE - 124 FORMAT(/'RUN ON ',I10/'WRITE TO ',A,'/',A/'ACCEPT BETWEEN ',I10, - 1 ' AND ',I10/) - IERR = 0 - RETURN - 9999 CONTINUE - WRITE(6,'('' INSUFFICIENT NO. OF ARGUMENTS TO BUFR '', - 1 ''TRANSLATION PROCEDURE - AT LEAST 4 ARE NEEDED'')') - IERR = 1 - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3unpk77.f b/external/w3nco/v2.0.6/src/w3unpk77.f deleted file mode 100644 index e8e2669d..00000000 --- a/external/w3nco/v2.0.6/src/w3unpk77.f +++ /dev/null @@ -1,2580 +0,0 @@ -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: W3UNPK77 DECODES SINGLE REPORT FROM BUFR MESSAGES -C PRGMMR: KEYSER ORG: NP22 DATE: 2002-03-05 -C -C ABSTRACT: THIS SUBROUTINE DECODES A SINGLE REPORT FROM BUFR MESSAGES -C IN A JBUFR-TYPE DATA FILE. CURRENTLY WIND PROFILER, NEXRAD (VAD) -C WIND AND GOES SOUNDING/RADIANCE DATA TYPES ARE VALID. REPORT IS -C RETURNED IN QUASI-OFFICE NOTE 29 UNPACKED FORMAT (SEE REMARKS 4.). -C -C PROGRAM HISTORY LOG: -C 1996-12-16 KEYSER -- ORIGINAL AUTHOR (BASED ON W3LIB ROUTINE W3FI77) -C 1997-06-02 KEYSER -- ADDED NEXRAD (VAD) WIND DATA TYPE -C 1997-06-16 KEYSER -- ADDED GOES SOUNDING/RADIANCE DATA TYPE -C 1997-09-18 KEYSER -- ADDED INSTRUMENT DATA USED IN PROCESSING, -C SOLAR ZENITH ANGLE, AND SATELLITE ZENITH ANGLE -C TO LIST OF PARAMETERS RETURNED FROM GOES -C SOUNDING/RADIANCE DATA TYPE -C 1998-07-09 KEYSER -- MODIFIED WIND PROFILER CAT. 11 (HEIGHT, HORIZ. -C SIGNIFICANCE, VERT. SIGNIFICANCE) TO ACCOUNT -C FOR UPDATES TO BUFRTABLE MNEMONICS IN /dcom; -C CHANGED CHAR. 6 OF GOES STNID TO BE UNIQUE FOR -C TWO DIFFERENT EVEN OR ODD SATELLITE ID'S -C (EVERY OTHER EVEN OR ODD SAT. ID NOW GETS SAME -C CHAR. 6 TAG) -C 1998-08-19 KEYSER -- SUBROUTINE NOW Y2K AND FORTRAN 90 COMPLIANT -C 1999-03-16 KEYSER -- INCORPORATED BOB KISTLER'S CHANGES NEEDED -C TO PORT THE CODE TO THE IBM SP -C 1999-05-17 KEYSER -- MADE CHANGES NECESSARY TO PORT THIS ROUTINE TO -C THE IBM SP -C 1999-09-26 KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE -C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND -C PROFILER) BUFR DUMP FILE AFTER 3/2002: CAT. 10 -C SURFACE DATA NOW ALL MISSING (MNEMONICS "PMSL", -C "WDIR1","WSPD1", "TMDB", "REHU", "REQV" NO -C LONGER AVAILABLE); CAT. 11 MNEMONICS "ACAVH", -C "ACAVV", "SPP0", AND "NPHL" NO LONGER -C AVAILABLE; HEADER MNEMONIC "NPSM" IS NO LONGER -C AVAILABLE, HEADER MNEMONIC "TPSE" REPLACES -C "TPMI" (AVG. TIME IN MINUTES STILL OUTPUT); -C NUMBER OF UPPER-AIR LEVELS INCR. FROM 43 TO UP -C TO 64 (SIZE OF OUTPUT "RDATA" ARRAY INCR. FROM -C 600 TO 1200 TO ACCOUNT FOR THIS) (WILL STILL -C WORK PROPERLY FOR INPUT PROFLR DUMP FILES PRIOR -C TO 3/2002) -C -C -C USAGE: CALL W3UNPK77(IDATE,IHE,IHL,LUNIT,RDATA,IRET) -C INPUT ARGUMENT LIST: -C IDATE - 4-WORD ARRAY HOLDING "CENTRAL" DATE TO PROCESS -C - (YYYY, MM, DD, HH) -C IHE - NUMBER OF WHOLE HOURS RELATIVE TO "IDATE" FOR DATE OF -C - EARLIEST BUFR MESSAGE THAT IS TO BE DECODED; EARLIEST -C - DATE IS "IDATE" + "IHE" HOURS (IF "IHE" IS POSITIVE, -C - LATEST MESSAGE DATE IS AFTER "IDATE"; IF "IHE" IS -C - NEGATIVE LATEST MESSAGE DATE IS PRIOR TO "IDATE") -C - EXAMPLE: IF IHE=1, THEN EARLIEST DATE IS 1-HR AFTER -C - IDATE; IF IHE=-3, THEN EARLIEST DATE IS 3-HR PRIOR -C - TO IDATE -C IHL - NUMBER OF WHOLE HOURS RELATIVE TO "IDATE" FOR DATE OF -C - LATEST BUFR MESSAGE THAT IS TO BE DECODED; LATEST -C - DATE IS "IDATE" + ("IHL" HOURS PLUS 59 MIN) IF "IHL" -C - IS POSITIVE (LATEST MESSAGE DATE IS AFTER "IDATE"), -C - AND "IDATE" + ("IHL"+1 HOURS MINUS 1 MIN) IF "IHL" -C - IS NEGATIVE (LATEST MESSAGE DATE IS PRIOR TO "IDATE") -C - EXAMPLE: IF IHL=3, THEN LATEST DATE IS 3-HR 59-MIN -C - AFTER IDATE; IF IHL=-2, THEN LATEST DATE IS 1-HR 1-MIN -C - PRIOR TO IDATE -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C IRET - CONTROLS DEGREE OF UNIT 6 PRINTOUT (.GE. 0 -LIMITED -C - PRINTOUT; = -1 SOME ADDITIONAL DIAGNOSTIC PRINTOUT; -C = .LT. -1 -EXTENSIVE PRINTOUT) (SEE REMARKS 3.) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE REPORT RETURNED AN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT (SEE REMARKS 4.) (MINIMUM SIZE IS -C - 1200 WORDS) -C IRET - RETURN CODE AS FOLLOWS: -C IRET = 0 ---> REPORT SUCCESSFULLY RETURNED -C IRET > 0 ---> NO REPORT RETURNED DUE TO: -C = 1 ---> ALL REPORTS READ IN, END -C = 2 ---> LAT AND/OR LON DATA MISSING -C = 3 ---> RESERVED -C = 4 ---> SOME/ALL DATE INFORMATION MISSING -C = 5 ---> NO DATA LEVELS PROCESSED (ALL LEVELS ARE MISSING) -C = 6 ---> NUMBER OF LEVELS IN REPORT HEADER IS NOT 1 -C = 7 ---> NUMBER OF LEVELS IN ANOTHER SINGLE LEVEL SEQUENCE -C IS NOT 1 -C -C INPUT FILES: -C UNIT AA - (WHERE AA IS LUNIT ABOVE) FILE HOLDING THE DATA -C - IN THE FORM OF BUFR MESSAGES -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C SUBPROGRAMS CALLED: -C UNIQUE - UNPK7701 UNPK7702 UNPK7703 UNPK7704 UNPK7705 -C - UNPK7706 UNPK7707 UNPK7708 UNPK7709 -C LIBRARY: -C W3LIB - W3FI04 W3MOVDAT W3DIFDAT ERREXIT -C BUFRLIB - DATELEN DUMPBF OPENBF READMG UFBCNT -C - READSB UFBINT CLOSBF -C -C REMARKS: 1) A CONDITION CODE (STOP) OF 15 WILL OCCUR IF THE INPUT -C DATES FOR START AND/OR STOP TIME ARE SPECIFIED INCORRECTLY. -C 2) A CONDITION CODE (STOP) OF 22 WILL OCCUR IF THE -C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII NOR EBCDIC. -C 3) THE INPUT ARGUMENT "IRET" SHOULD BE SET PRIOR TO EACH -C CALL TO THIS SUBROUTINE. -C -C *************************************************************** -C 4) -C BELOW IS THE FORMAT OF AN UNPACKED REPORT IN OUTPUT ARRAY RDATA -C (EACH WORD REPRESENTS A FULL-WORD ACCORDING TO THE MACHINE) -C N O T E : THIS IS THE SAME FORMAT AS FOR W3LIB ROUTINE W3FI77 -C EXCEPT WHERE NOTED -C *************************************************************** -C -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C FORMAT FOR WIND PROFILER REPORTS -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C HEADER -C WORD CONTENT UNIT FORMAT -C ---- ---------------------- ------------------- --------- -C 1 LATITUDE 0.01 DEGREES REAL -C 2 LONGITUDE 0.01 DEGREES WEST REAL -C 3 TIME SIGNIFICANCE (BUFR CODE TABLE "0 08 021") INTEGER -C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL -cvvvvvdak port -C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER -caaaaadak port -C LEFT-JUSTIFIED -C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER -C 7 STATION ELEVATION METERS REAL -C 8 SUBMODE/EDITION NO. (SM X 10) + ED. NO. INTEGER -C (ED. NO.=2, CONSTANT; SEE &,~) -C 9 REPORT TYPE 71 (CONSTANT) INTEGER -C 10 AVERAGING TIME MINUTES INTEGER -C (NEGATIVE MEANS PRIOR TO OBS. TIME) -C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER -C LEFT-JUSTIFIED -C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER -C LEFT-JUSTIFIED -C -C 13-34 ZEROED OUT - NOT USED INTEGER -C 35 CATEGORY 10, NO. LEVELS COUNT INTEGER -C 36 CATEGORY 10, DATA INDEX COUNT INTEGER -C 37 CATEGORY 11, NO. LEVELS COUNT INTEGER -C 38 CATEGORY 11, DATA INDEX COUNT INTEGER -C 39-42 ZEROED OUT - NOT USED INTEGER -C -C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL -C -C CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C(SEE @)1 SEA-LEVEL PRESSURE 0.1 MILLIBARS REAL -C(SEE *)2 STATION PRESSURE 0.1 MILLIBARS REAL -C(SEE @)3 HORIZ. WIND DIR. DEGREES REAL -C(SEE @)4 HORIZ. WIND SPEED 0.1 M/S REAL -C(SEE @)5 AIR TEMPERATURE 0.1 DEGREES K REAL -C(SEE @)6 RELATIVE HUMIDITY PERCENT REAL -C(SEE @)7 RAINFALL RATE 0.0000001 M/S REAL -C -C CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) -C (EACH LEVEL, SEE WORD 37 ABOVE) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 HEIGHT ABOVE SEA-LVL METERS REAL -C 2 HORIZ. WIND DIR. DEGREES REAL -C 3 HORIZ. WIND SPEED 0.1 M/S REAL -C 4 QUALITY CODE (SEE %) INTEGER -C 5 VERT. WIND COMP. (W) 0.01 M/S REAL -C(SEE @)6 HORIZ. CONSENSUS NO. (SEE $) INTEGER -C(SEE @)7 VERT. CONSENSUS NO. (SEE $) INTEGER -C(SEE @)8 SPECTRAL PEAK POWER DB REAL -C 9 HORIZ. WIND SPEED 0.1 M/S REAL -C STANDARD DEVIATION 0.1 M/S REAL -C 10 VERT. WIND COMPONENT 0.1 M/S REAL -C STANDARD DEVIATION 0.1 M/S REAL -C(SEE @)11 MODE (SEE #) INTEGER -C -C *- ALWAYS MISSING -C &- THIS IS A CHANGE FROM FORMAT IN W3LIB ROUTINE W3FI77 -C %- 0 - MEDIAN AND SHEAR CHECKS BOTH PASSED -C 2 - MEDIAN AND SHEAR CHECK RESULTS INCONCLUSIVE -C 4 - MEDIAN CHECK PASSED; SHEAR CHECK FAILED -C 8 - MEDIAN CHECK FAILED; SHEAR CHECK PASSED -C 12 - MEDIAN AND SHEAR CHECKS BOTH FAILED -C $- NO. OF INDIVIDUAL 6-MINUTE AVERAGE MEASUREMENTS THAT WERE -C INCLUDED IN FINAL ESTIMATE OF AVERAGED WIND (RANGE: 0, 2-10) -C (BASED ON A ONE-HOUR AVERAGE) -C #- 1 - DATA FROM LOW MODE -C 2 - DATA FROM HIGH MODE -C 3 - MISSING -C @- THIS PARAMETER IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET -C TO MISSING (99999 FOR INTEGER OR 99999. FOR REAL) -C ~- SUBMODE IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET TO 3 -C (ITS MISSING VALUE) -C -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C FORMAT FOR GOES SOUNDING/RADIANCE REPORTS -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C HEADER -C WORD CONTENT UNIT FORMAT -C ---- ---------------------- ------------------- --------- -C 1 LATITUDE 0.01 DEGREES REAL -C 2 LONGITUDE 0.01 DEGREES WEST REAL -C 3 FIELD OF VIEW NUMBER NUMERIC INTEGER -C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL -cvvvvvdak port -C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER -caaaaadak port -C LEFT-JUSTIFIED -C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER -C 7 STATION ELEVATION METERS REAL -C 8 PROCESS. TECHNIQUE (=21-CLEAR; INTEGER -C 8 PROCESS. TECHNIQUE =23-CLOUD-CORRECTED) -C 9 REPORT TYPE 61 (CONSTANT) INTEGER -C 10 QUALITY FLAG (BUFR CODE TABLE "0 33 002") INTEGER -C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER -C LEFT-JUSTIFIED -C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER -C LEFT-JUSTIFIED (SEE %) -C -C 13-26 ZEROED OUT - NOT USED -C 27 CATEGORY 08, NO. LEVELS COUNT INTEGER -C 28 CATEGORY 08, DATA INDEX COUNT INTEGER -C 29-38 ZEROED OUT - NOT USED -C 39 CATEGORY 12, NO. LEVELS COUNT INTEGER -C 40 CATEGORY 12, DATA INDEX COUNT INTEGER -C 41 CATEGORY 13, NO. LEVELS COUNT INTEGER -C 42 CATEGORY 13, DATA INDEX COUNT INTEGER -C -C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL -C -C CATEGORY 12 - SATELLITE SOUNDING LEVEL DATA (FIRST LEVEL IS SURFACE; -C EACH LEVEL, SEE 39 ABOVE) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 PRESSURE 0.1 MILLIBARS REAL -C 2 GEOPOTENTIAL METERS REAL -C 3 TEMPERATURE 0.1 DEGREES C REAL -C 4 DEWPOINT TEMPERATURE 0.1 DEGREES C REAL -C 5 NOT USED SET TO MISSING REAL -C 6 NOT USED SET TO MISSING REAL -C 7 QUALITY MARKERS 4-CHARACTERS CHARACTER -C LEFT-JUSTIFIED (SEE &) -C -C CATEGORY 13 - SATELLITE RADIANCE "LEVEL" DATA (EACH "LEVEL", SEE -C 41 ABOVE) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 CHANNEL NUMBER NUMERIC INTEGER -C 2 BRIGHTNESS TEMP. 0.01 DEG. KELVIN REAL -C 3 QUALITY MARKERS 4-CHARACTERS CHARACTER -C LEFT-JUSTIFIED (SEE &&) -C -C CATEGORY 08 - ADDITIONAL (MISCELLANEOUS) DATA (EACH LEVEL, SEE @ -C BELOW) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 VARIABLE SEE @ BELOW REAL -C 2 CODE FIGURE SEE @ BELOW REAL -C 3 MARKERS 2-CHARACTERS CHARACTER -C LEFT-JUSTIFIED (SEE #) -C -C %- SIXTH CHARACTER OF STATION ID IS A TAGGED AS FOLLOWS: -C "I" - GOES-EVEN-1 (252, 256, ...) SAT. , CLEAR COLUMN RETR. -C "J" - GOES-EVEN-1 (252, 256, ...) SAT. , CLD-CORRECTED RETR. - -C "L" - GOES-ODD-1 (253, 257, ...) SAT. , CLEAR COLUMN RETR. -C "M" - GOES-ODD-1 (253, 257, ...) SAT. , CLD-CORRECTED RETR. - -C "O" - GOES-EVEN-2 (254, 258, ...) SAT. , CLEAR COLUMN RETR. -C "P" - GOES-EVEN-2 (254, 258, ...) SAT. , CLD-CORRECTED RETR. - -C "Q" - GOES-ODD-2 (251, 255, ...) SAT. , CLEAR COLUMN RETR. -C "R" - GOES-ODD-2 (251, 255, ...) SAT. , CLD-CORRECTED RETR. - -C "?" - EITHER SATELLITE AND/OR RETRIEVAL TYPE UNKNOWN - -C &- FIRST CHARACTER IS Q.M. FOR GEOPOTENTIAL -C SECOND CHARACTER IS Q.M. FOR TEMPERATURE -C THIRD CHARACTER IS Q.M. FOR DEWPOINT TEMPERATURE -C FOURTH CHARACTER IS NOT USED -C " " - INDICATES DATA NOT SUSPECT -C "Q" - INDICATES DATA ARE SUSPECT -C "F" - INDICATES DATA ARE BAD -C &&- FIRST CHARACTER IS Q.M. FOR BRIGHTNESS TEMPERATURE -C SECOND-FOURTH CHARACTERS ARE NOT USED -C " " - INDICATES DATA NOT SUSPECT -C "Q" - INDICATES DATA ARE SUSPECT -C "F" - INDICATES DATA ARE BAD -C @- NUMBER OF "LEVELS" FROM WORD 27. MAXIMUM IS 12, AND ARE ORDERED -C AS FOLLOWS (IF A DATUM ARE MISSING THAT LEVEL NOT STORED) -C 1 - LIFTED INDEX ---------- .01 DEG. KELVIN -- C. FIG. 250. -C 2 - TOTAL PRECIP. WATER -- .01 MILLIMETERS -- C. FIG. 251. -C 3 - 1. TO .9 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 252. -C 4 - .9 TO .7 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 253. -C 5 - .7 TO .3 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 254. -C 6 - SKIN TEMPERATURE ----- .01 DEG. KELVIN -- C. FIG. 255. -C 7 - CLOUD TOP TEMPERATURE- .01 DEG. KELVIN -- C. FIG. 256. -C 8 - CLOUD TOP PRESSURE --- .1 MILLIBARS ----- C. FIG. 257. -C 9 - CLOUD AMOUNT (BUFR TBL. C.T. 0-20-011) -- C. FIG. 258. -C 10 - INSTR. DATA USED IN PROC. -C (BUFR TBL. C.T. 0-02-021) -- C. FIG. 259. -C 11 - SOLAR ZENITH ANGLE --- .01 DEGREE ------- C. FIG. 260. -C 12 - SAT. ZENITH ANGLE ---- .01 DEGREE ------- C. FIG. 261. -C #- FIRST CHARACTER IS Q.M. FOR THE DATUM -C " " - INDICATES DATA NOT SUSPECT -C "Q" - INDICATES DATA ARE SUSPECT -C "F" - INDICATES DATA ARE BAD -C SECOND CHARACTER IS NOT USED -C -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C FORMAT FOR NEXRAD (VAD) WIND REPORTS -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C HEADER -C WORD CONTENT UNIT FORMAT -C ---- ---------------------- ------------------- --------- -C 1 LATITUDE 0.01 DEGREES REAL -C 2 LONGITUDE 0.01 DEGREES WEST REAL -C 3 ** RESERVED ** SET TO 99999 INTEGER -C 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL -cvvvvvdak port -C 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER -caaaaadak port -C LEFT-JUSTIFIED -C 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER -C 7 STATION ELEVATION METERS REAL -C 8 ** RESERVED ** SET TO 99999 INTEGER -C -C 9 REPORT TYPE 72 (CONSTANT) INTEGER -C 10 ** RESERVED ** SET TO 99999 INTEGER -C 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER -C LEFT-JUSTIFIED -C 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER -C LEFT-JUSTIFIED -C -C 13-18 ZEROED OUT - NOT USED INTEGER -C 19 CATEGORY 04, NO. LEVELS COUNT INTEGER -C 20 CATEGORY 04, DATA INDEX COUNT INTEGER -C 21-42 ZEROED OUT - NOT USED INTEGER -C -C 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL -C -C CATEGORY 04 - UPPER-AIR WINDS-BY-HEIGHT DATA(FIRST LEVEL IS SURFACE) -C (EACH LEVEL, SEE WORD 19 ABOVE) -C WORD PARAMETER UNITS FORMAT -C ---- --------- ----------------- ------------- -C 1 HEIGHT ABOVE SEA-LVL METERS REAL -C 2 HORIZ. WIND DIR. DEGREES REAL -C 3 HORIZ. WIND SPEED 0.1 M/S (SEE *) REAL -C 4 QUALITY MARKERS 4-CHARACTERS CHARACTER -C LEFT-JUSTIFIED (SEE %) -C -C *- UNITS HERE DIFFER FROM THOSE IN TRUE UNPACKED OFFICE NOTE 29 -C (WHERE UNITS ARE KNOTS) -C %- THE FIRST THREE CHARACTERS ARE ALWAYS BLANK, THE FOURTH -C CHARACTER IS A "CONFIDENCE LEVEL" WHICH IS RELATED TO THE ROOT- -C MEAN-SQUARE VECTOR ERROR FOR THE HORIZONTAL WIND. IT IS -C DEFINED AS FOLLOWS: -C 'A' = RMS OF 1.9 KNOTS -C 'B' = RMS OF 3.9 KNOTS -C 'C' = RMS OF 5.8 KNOTS -C 'D' = RMS OF 7.8 KNOTS -C 'E' = RMS OF 9.7 KNOTS -C 'F' = RMS OF 11.7 KNOTS -C 'G' = RMS > 13.6 KNOTS -CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -C -C FOR ALL REPORT TYPES, MISSING VALUES ARE: -C 99999. FOR REAL -C 99999 FOR INTEGER -C 9'S FOR CHARACTERS IN WORD 5, 6 OF HEADER -C BLANK FOR CHARACTERS IN WORD 11, 12 OF HEADER -C AND FOR CHARACTERS IN ANY CATEGORY LEVEL -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE W3UNPK77(IDATE,IHE,IHL,LUNIT,RDATA,IRET) - CHARACTER*4 CBUFR - INTEGER IDATE(4),LSDATE(4),jdate(8),IDATA(1200) - dimension rinc(5) - REAL RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - COMMON /PK77CC/INDEX - COMMON /PK77DD/LSHE,LSHL,ICDATE(5),IDDATE(5) - COMMON /PK77FF/IFOV(3),KNTSAT(250:260) - - SAVE - - EQUIVALENCE (RDATX,IDATA) - DATA ITM/0/,LUNITL/-99/,KOUNT/0/ - IPRINT = 0 - IF(IRET.LT.0) IPRINT = IABS(IRET) - IRET = 0 - IF(ITM.EQ.0) THEN -C----------------------------------------------------------------------- - -C FIRST AND ONLY TIME INTO THIS SUBROUTINE DO A FEW THINGS.... - - ITM = 1 - IFOV = 0 - KNTSAT = 0 -C DETERMINE MACHINE WORD LENGTH IN BYTES (=8 FOR CRAY) AND TYPE OF -C CHARACTER SET {ASCII(ICHTP=0) OR EBCDIC(ICHTP=1)} - CALL W3FI04(IENDN,ICHTP,LW) - PRINT 2213, LW, ICHTP, IENDN - 2213 FORMAT(/' ---> W3UNPK77: CALL TO W3FI04 RETURNS: LW = ',I3, - $ ', ICHTP = ',I3,', IENDN = ',I3/) - IF(ICHTP.GT.1) THEN -C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC!! -- STOP 22 - PRINT 217 - 217 FORMAT(' *** W3UNPK77 ERROR: CHARACTERS ON THIS MACHINE ', - $ 'ARE NEITHER ASCII NOR EBCDIC - STOP 22'/) - CALL ERREXIT(22) - END IF -C----------------------------------------------------------------------- - END IF - IF(LUNIT.NE.LUNITL) THEN -C----------------------------------------------------------------------- - -C IF THE INPUT DATA UNIT NUMBER ARGUMENT IS DIFFERENT THAT THE LAST TIME -C THIS SUBR. WAS CALLED, PRINT NEW HEADER, SET JRET = 1 - - LUNITL = LUNIT - JRET = 1 - PRINT 101, LUNIT - 101 FORMAT(//' ---> W3UNPK77: VERSION 03/05/2002: JBUFR DATA SET ', - $ 'READ FROM UNIT ',I4/) -C----------------------------------------------------------------------- - ELSE - -C FOR SUBSEQUENT TIMES INTO THIS SUBR. W/ SAME LUNIT AS LAST TIME, -C TEST INPUT DATE & HR RANGE ARGUMENTS AGAINST THEIR VALUES THE LAST -C TIME SUBR. CALLED -- IF THEY ARE DIFFERENT, SET JRET = 1 (ELSE -C JRET = 0), WILL TEST JRET SOON - - JRET = 1 - DO I = 4,1,-1 - IF(IDATE(I).NE.LSDATE(I)) GO TO 88 - ENDDO - IF(IHE.NE.LSHE.OR.IHL.NE.LSHL) GO TO 88 - JRET = 0 - 88 CONTINUE -C----------------------------------------------------------------------- - END IF - IF(JRET.EQ.1) THEN - PRINT 6680 - 6680 FORMAT(/' JRET = 1 - REWIND DATA FILE & SET-UP TO DO DATE CHECK'/) -C----------------------------------------------------------------------- - -C COME HERE IF FIRST CALL TO SUBROUTINE OR IF INPUT DATA UNIT NUMBER OR -C IF INPUT DATE/TIME OR RANGE IN TIME HAS BEEN CHANGED FROM LAST CALL - -C CLOSE BUFR DATA SET (IN CASE OPEN FROM PREVIOUS RUN) -C REWIND INPUT BUFR DATA SET, GET CENTER TIME AND DUMP TIME, -C OPEN BUFR DATA SET - -C SET-UP TO DETERMINE IF BUFR MESSAGE IS WITHIN REQUESTED DATES - -C (ALSO SET INDEX=0, FORCES BUFR MSG TO BE READ BEFORE RPTS ARE DECODED) - -C----------------------------------------------------------------------- - - CALL CLOSBF(LUNIT) - - REWIND LUNIT - - READ(LUNIT,END=9999,ERR=9999) CBUFR - IF(CBUFR.NE.'BUFR') GO TO 9999 - - call datelen(10) - - CALL DUMPBF(LUNIT,ICDATE,IDDATE) -cppppp - print *,'CENTER DATE (ICDATE) = ',icdate - print *,'DUMP DATE (IDDATE) = ',iddate -cppppp - - if(icdate(1).le.0) then -C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE -C - RETURN WITH IRET = 1 - print *, ' *** W3UNPK77 ERROR: CENTER DATE COULD NOT BE ', - $ 'OBTAINED FROM INPUT FILE ON UNIT ',lunit - go to 9998 - end if - if(iddate(1).le.0) then -C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE -C - RETURN WITH IRET = 1 - print *, ' *** W3UNPK77 ERROR: DUMP DATE COULD NOT BE ', - $ 'OBTAINED FROM INPUT FILE ON UNIT ',lunit - go to 9998 - end if - IF(ICDATE(1).LT.100) THEN - -C If 2-digit year returned in ICDATE(1), must use "windowing" technique -C to create a 4-digit year - -C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS -C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT -C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) - - PRINT *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ', - $ 'HAPPEN!!!!!' - PRINT *, '##W3UNPK77 - 2-DIGIT YEAR IN ICDATE(1) ', - $ 'RETURNED FROM DUMPBF (ICDATE IS: ',ICDATE,') - USE ', - $ 'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR' - IF(ICDATE(1).GT.20) THEN - ICDATE(1) = 1900 + ICDATE(1) - ELSE - ICDATE(1) = 2000 + ICDATE(1) - ENDIF - PRINT *, '##WW3UNPK77 - CORRECTED ICDATE(1) WITH 4-DIGIT ', - $ 'YEAR, ICDATE NOW IS: ',ICDATE - ENDIF - - IF(IDDATE(1).LT.100) THEN - -C If 2-digit year returned in IDDATE(1), must use "windowing" technique -C to create a 4-digit year - -C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS -C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT -C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) - - PRINT *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ', - $ 'HAPPEN!!!!!' - PRINT *, '##W3UNPK77 - 2-DIGIT YEAR IN IDDATE(1) ', - $ 'RETURNED FROM DUMPBF (IDDATE IS: ',IDDATE,') - USE ', - $ 'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR' - IF(IDDATE(1).GT.20) THEN - IDDATE(1) = 1900 + IDDATE(1) - ELSE - IDDATE(1) = 2000 + IDDATE(1) - ENDIF - PRINT *, '##W3UNPK77 - CORRECTED IDDATE(1) WITH 4-DIGIT ', - $ 'YEAR, IDDATE NOW IS: ',IDDATE - END IF - -C OPEN BUFR FILE - READ IN DICTIONARY MESSAGES (TABLE A, B, D ENTRIES) - - CALL OPENBF(LUNIT,'IN',LUNIT) - PRINT 100, LUNIT - 100 FORMAT(/5X,'===> BUFR DATA SET IN UNIT',I3,' SUCCESSFULLY ', - $ 'OPENED FOR INPUT; DCTNY MESSAGES CONTAIN BUFR TABLES A,B,D'/) - INDEX = 0 - KOUNT = 0 - jdate(1:3) = idate(1:3) - jdate(4) = 0 - jdate(5) = idate(4) - jdate(6:8) = 0 - PRINT 6681, IDATE - 6681 FORMAT(/' %%% REQUESTED "CENTRAL" DATE IS :',I5,3I3,' 0'/) -C DETERMINE EARLIEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING - call w3movdat((/0.,real(ihe),0.,0.,0./),jdate,kdate) - print 6682, (kdate(i),i=1,3),kdate(5),kdate(6) - 6682 FORMAT(/' --> EARLIEST DATE FOR ACCEPTING BUFR MSGS IS:',I5,4I3/) -C DETERMINE LATEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING - if(ihl.ge.0) then - xminl = (ihl * 60) + 59 - else - xminl = ((ihl + 1) * 60) - 1 - end if - call w3movdat((/0.,0.,xminl,0.,0./),jdate,ldate) - print 6683, (ldate(i),i=1,3),ldate(5),ldate(6) - 6683 FORMAT(/' --> LATEST DATE FOR ACCEPTING BUFR MSGS IS:',I5,4I3/) - call w3difdat(ldate,kdate,3,rinc) - IF(rinc(3).LT.0) THEN - PRINT 104 - 104 FORMAT(' *** W3UNPK77 ERROR: DATES SPECIFIED INCORRECTLY -', - $ ' STOP 15'/) - CALL ERREXIT(15) - END IF -C----------------------------------------------------------------------- - END IF -C SUBR. UNPK7701 RETURNS A SINGLE DECODED REPORT FROM BUFR MESSAGE - CALL UNPK7701(LUNIT,ITP,IRET) -C IRET=1 MEANS ALL DATA HAVE BEEN DECODED FOR SPECIFIED TIME PERIOD -C (REWIND DATA FILE AND RETURN W/ IRET=1) -C IRET.GE.2 MEANS REPORT NOT RETURNED DUE TO ERROR IN DECODING (RETURN) -C (ACTUALLY IRET.GE.2 CURRENTLY CANNOT HAPPEN OUT OF UNPK7701) - IF(IRET.GE.1) THEN - IF(IRET.EQ.1) THEN - REWIND LUNIT - IF(ITP.EQ.2) THEN - PRINT 8101, IFOV - 8101 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED', - $ ' BY F-O-V NO. (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/15X, - $ '# WITH F-O-V NO. 00 TO 02:',I6,' - GET "BAD" Q.MARK'/15X, - $ '# WITH F-O-V NO. 03 TO 09:',I6,' - GET "SUSPECT" Q.MARK'/15X, - $ '# WITH F-O-V NO. 10 TO 25:',I6,' - GET "NEUTRAL" Q.MARK'/20X, - $ '(NOTE: RADIANCES ALWAYS HAVE NEUTRAL Q.MARK)'/) - PRINT 8102 - 8102 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED', - $ ' BY SATELLITE ID (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/) - DO IDSAT = 250,259 - IF(KNTSAT(IDSAT).GT.0) PRINT 8103, IDSAT,KNTSAT(IDSAT) - ENDDO - 8103 FORMAT(15X,'NUMBER FROM SAT. ID',I4,4X,':',I6) - IF(KNTSAT(260).GT.0) PRINT 8104 - 8104 FORMAT(15X,'NUMBER FROM UNKNOWN SAT. ID:',I6) - PRINT 8105 - 8105 FORMAT(/) - END IF - END IF - GO TO 99 - END IF - KOUNT = KOUNT + 1 -C INITIALIZE THE OUTPUT ON29 ARRAY - CALL UNPK7702(RDATA,ITP) - IF(ITP.EQ.1) THEN -C----------------------------------------------------------------------- -C THE FOLLOWING PERTAINS TO WIND PROFILER REPORTS -C----------------------------------------------------------------------- -C STORE THE HEADER INFORMATION INTO ON29 FORMAT - CALL UNPK7703(LUNIT,RDATA,IRET) -C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN) - IF(IRET.GE.2) GO TO 99 -C STORE THE SURFACE DATA INTO ON29 FORMAT (CATEGORY 10) - CALL UNPK7704(LUNIT,RDATA) -C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 11) - CALL UNPK7705(LUNIT,RDATA) - RDATX(1:1200) = RDATA(1:1200) - IF(IDATA(35)+IDATA(37).EQ.0) IRET = 5 - ELSE IF(ITP.EQ.2) THEN -C----------------------------------------------------------------------- -C THE FOLLOWING PERTAINS TO GOES SOUNDING/RADIANCE REPORTS -C----------------------------------------------------------------------- -C STORE THE HEADER INFORMATION INTO ON29 FORMAT - CALL UNPK7708(LUNIT,RDATA,KOUNT,IRET) -C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN) - IF(IRET.GE.2) GO TO 99 -C STORE THE UPPER-AIR DATA/RADIANCE INTO ON29 FORMAT (CATEGORY 12, 13) - CALL UNPK7709(LUNIT,RDATA,IRET) - ELSE IF(ITP.EQ.3) THEN -C----------------------------------------------------------------------- -C THE FOLLOWING PERTAINS TO NEXRAD (VAD) WIND REPORTS -C----------------------------------------------------------------------- -C STORE THE HEADER INFORMATION INTO ON29 FORMAT - CALL UNPK7706(LUNIT,RDATA,IRET) -C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN) - IF(IRET.GE.2) GO TO 99 -C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 4) - CALL UNPK7707(LUNIT,RDATA,IRET) -C----------------------------------------------------------------------- - END IF - 99 CONTINUE -C PRIOR TO RETURNING SAVE INPUT DATE & HR RANGE ARGUMENTS FROM THIS CALL - lsdate = idate - LSHE = IHE - LSHL = IHL - RETURN -C----------------------------------------------------------------------- - 9999 CONTINUE -C COME HERE IF NULL OR NON-BUFR FILE IS INPUT - RETURN WITH IRET = 1 - PRINT *, ' *** W3UNPK77 ERROR: INPUT FILE IN UNIT ',LUNIT,' IS ', - $ 'EITHER A NULL OR NON-BUFR FILE' - 9998 continue - REWIND LUNIT - IRET = 1 - lsdate = idate - LSHE = IHE - LSHL = IHL - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7701 READS A SINGLE REPORT OUT OF BUFR DATASET -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1996-12-16 -C -C ABSTRACT: CALLS BUFRLIB ROUTINES TO READ IN A BUFR MESSAGE AND THEN -C READ A SINGLE REPORT (SUBSET) OUT OF THE MESSAGE. -C -C PROGRAM HISTORY LOG: -C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C -C USAGE: CALL UNPK7701(LUNIT,ITP,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 - -C - WIND PROFILER, =2 - GOES SNDG, =3 - NEXRAD(VAD) WIND} -C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK -C -C INPUT FILES: -C UNIT AA - (WHERE AA IS LUNIT ABOVE) FILE HOLDING THE DATA -C - IN THE FORM OF BUFR MESSAGES -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7701(LUNIT,ITP,IRET) - CHARACTER*8 SUBSET - integer mdate(4),ndate(8) - dimension rinc(5) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - COMMON /PK77CC/INDEX - COMMON /PK77DD/LSHE,LSHL,ICDATE(5),IDDATE(5) - - SAVE - - DATA IREC/0/ - - 10 CONTINUE -C======================================================================= - IF(INDEX.EQ.0) THEN - -C READ IN NEXT BUFR MESSAGE - - CALL READMG(LUNIT,SUBSET,IBDATE,JRET) - IF(JRET.NE.0) THEN -C----------------------------------------------------------------------- - PRINT 101 - 101 FORMAT(' ---> W3UNPK77: ALL BUFR MESSAGES READ IN AND DECODED'/) - IRET = 1 - RETURN -C----------------------------------------------------------------------- - END IF - if(ibdate.lt.100000000) then -c If input BUFR file does not return messages with a 4-digit year, -c something is wrong (even non-compliant BUFR messages should -c construct a 4-digit year as long as datelen(10) has been called - print *, '##W3UNP777/UNPK7701 - A 10-digit Sect. 1 BUFR ', - $ 'message date was not returned in unit ',lunit,' - ', - $ 'problem with BUFR file - ier = 1' - iret = 1 - return - end if - CALL UFBCNT(LUNIT,IREC,ISUB) - MDATE(1) = IBDATE/1000000 - MDATE(2) = MOD((IBDATE/10000),100) - MDATE(3) = MOD((IBDATE/100),100) - MDATE(4) = MOD(IBDATE,100) -C ALL JBUFR MESSAGES CURRENTLY HAVE "00" FOR MINUTES IN SECTION 1 - ndate(1:3) = mdate(1:3) - ndate(4) = 0 - ndate(5) = mdate(4) - ndate(6:8) = 0 - IF(IPRINT.GE.1) THEN - PRINT *,'HAVE SUCCESSFULLY READ IN A BUFR MESSAGE' - PRINT 103 - 103 FORMAT(' BUFR FOUND BEGINNING AT BYTE 1 OF MESSAGE') - PRINT 105, IREC,MDATE,SUBSET - 105 FORMAT(8X,'HAVE READ IN A BUFR MESSAGE NO.',I3,', DATE: ', - $ I6,3I4,' 0; TABLE A ENTRY = ',A8,' AND EDIT. NO. = 2'/) - END IF - IF(SUBSET.EQ.'NC002007') THEN - IF(IPRINT.GE.1) PRINT *, 'THIS MESSAGE CONTAINS WIND ', - $ 'PROFILER REPORTS' - ITP = 1 - ELSE IF(SUBSET.EQ.'NC002008') THEN - IF(IPRINT.GE.1) PRINT *, 'THIS MESSAGE CONTAINS NEXRAD ', - $ '(VAD) WIND REPORTS' - ITP = 3 - ELSE IF(SUBSET.EQ.'NC003001') THEN - IF(IPRINT.GE.1) PRINT *, 'THIS MESSAGE CONTAINS GOES ', - $ 'SOUNDING/RADIANCE REPORTS' - ITP = 2 - ELSE - PRINT 107, IREC - 107 FORMAT(' *** W3UNPK77 WARNING: BUFR MESSAGE NO.',I3,' CONTAINS ', - $ 'REPORTS THAT CANNOT BE DECODED BY W3UNPK77, TRY READING NEXT ', - $ 'MSG'/) - INDEX = 0 - GO TO 10 - END IF - call w3difdat(kdate,ndate,3,rinc) - kmin = rinc(3) - call w3difdat(ldate,ndate,3,rinc) - lmin = rinc(3) -C CHECK DATE OF MESSAGE AGAINST SPECIFIED TIME RANGES - if((kmin.gt.0.or.lmin.lt.0).AND.IREC.GT.2) then - PRINT 106, IREC,MDATE - 106 FORMAT(' BUFR MESSAGE NO.',I3,' WITH DATE:',I5,3I3,' 0 NOT W/I', - $ ' REQ. TIME RANGE, TRY READING NEXT MSG'/) - INDEX = 0 - GO TO 10 - END IF - END IF -C======================================================================= -C READ NEXT SUBSET (REPORT) IN MESSAGE - - IF(IPRINT.GT.1) PRINT *,'CALL READSB' - CALL READSB(LUNIT,JRET) - IF(IPRINT.GT.1) PRINT *,'BACK FROM READSB' - IF(JRET.NE.0) THEN - IF(INDEX.GT.0) THEN - -C ALL SUBSETS IN THIS MESSAGE PROCESSED, READ IN NEXT MESSAGE (IF ALL -C MESSAGES READ IN NO MORE DATA TO PROCESS) - - IF(IPRINT.GT.1) PRINT *, 'ALL REPORTS IN THIS MESSAGE ', - $ 'DECODED, GO ON TO NEXT MESSAGE' - ELSE - -C THERE WERE NO SUBSETS FOUND IN THIS BUFR MESSAGE, GOOD CHANCE IT IS -C ONE OF TWO DUMMY MESSAGES AT TOP OF FILE INDICATING CENTER TIME AND -C DATA DUMP TIME ONLY; READ IN NEXT MESSAGE - - IF(IREC.EQ.1) THEN - PRINT 4567, ICDATE - 4567 FORMAT(/'===> BUFR MESSAGE NO. 1 IS A DUMMY MESSAGE CONTAINING ', - $ 'ONLY CENTER DATE (',I5,4I3,') - NO DATA - GO ON TO NEXT ', - $ 'MESSAGE'/) - ELSE IF(IREC.EQ.2) THEN - PRINT 4568, IDDATE - 4568 FORMAT(/'===> BUFR MESSAGE NO. 2 IS A DUMMY MESSAGE CONTAINING ', - $ 'ONLY DUMP DATE (',I5,4I3,') - NO DATA - GO ON TO NEXT ', - $ 'MESSAGE'/) - ELSE - PRINT 4569, IREC,MDATE - 4569 FORMAT(/'===> BUFR MESSAGE NO.',I3,' (DATE:',I5,3I3,' 0) ', - $ 'CONTAINS ZERO REPORTS FOR SOME UNEXPLAINED REASON - GO ON TO ', - $ 'NEXT MESSAGE'/) - END IF - END IF - INDEX = 0 - GO TO 10 - END IF -C----------------------------------------------------------------------- - IF(IPRINT.GT.1) PRINT *, 'READY TO PROCESS NEW DECODED REPORT' -C*********************************************************************** -C A SINGLE REPORT HAS BEEN SUCCESSFULLY DECODED -C*********************************************************************** - INDEX = INDEX + 1 - IF(IPRINT.GE.1) PRINT *, 'WORKING WITH SUBSET NUMBER ',INDEX - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7702 INITIALIZES THE OUTPUT ARRAY FOR A REPORT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1996-12-16 -C -C ABSTRACT: INITIALIZES THE OUTPUT ARRAY WHICH HOLDS A SINGLE REPORT -C IN THE QUASI-OFFICE NOTE 29 UNPACKED FORMAT TO ALL MISSING. -C -C PROGRAM HISTORY LOG: -C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C -C USAGE: CALL UNPK7702(RDATA,ITP) -C INPUT ARGUMENT LIST: -C ITP - THE TYPE OF REPORT THAT HAS BEEN DECODED {=1 - -C - WIND PROFILER, =2 - GOES SNDG, =3 - NEXRAD(VAD) WIND} -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE REPORT RETURNED AN A QUASI-OFFICE NOTE 29 -C UNPACKED FORMAT; ALL DATA ARE MISSING -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7702(RDATA,ITP) - REAL RDATA(*),RDATX(1200) - INTEGER IDATA(1200),IRTYP(3) - CHARACTER*8 COB -C - SAVE -C - EQUIVALENCE (RDATX,IDATA),(COB,IOB) - DATA XMSG/99999./,IMSG/99999/,IRTYP/71,61,72/ - RDATX(1) = XMSG - RDATX(2) = XMSG - IDATA(3) = IMSG - RDATX(4) = XMSG - COB = '999999 ' - IDATA(5) = IOB - COB = '9999 ' - IDATA(6) = IOB - RDATX(7) = XMSG - IDATA(8) = IMSG - IDATA(9) = IRTYP(ITP) - IDATA(10) = IMSG - COB = ' ' - IDATA(11) = IOB - IDATA(12) = IOB -C -C ALL TYPES -- LOAD ZEROS INTO THE DEFINING WORD PAIRS -C - IDATA(13:42) = 0 -C -C ALL TYPES -- LOAD MISSINGS INTO THE DATA PORTION -C - RDATX(43:1200) = XMSG - IF(ITP.EQ.1) THEN -C -C PROFILER -- LOAD INTEGER MISSING WHERE APPROPRIATE -C (Current limit of 104 Cat. 11 levels) -C - IDATA(53:1200:11) = IMSG - IDATA(55:1200:11) = IMSG - IDATA(56:1200:11) = IMSG - IDATA(60:1200:11) = IMSG - ELSE IF(ITP.EQ.2) THEN -C -C GOES -- LOAD DEFAULT OF BLANK CHARACTERS INTO CAT. 12 -C LEVEL QUALITY MARKERS -C (Current limit of 50 Cat. 12 levels) -C (could be expanded if need be) -C - IDATA(49:392:7) = IOB -C -C GOES -- LOAD DEFAULT OF BLANK CHARACTER INTO FIRST CAT. 08 -C LEVEL QUALITY MARKER -C (Current limit of 9 Cat. 08 levels) -C (could be expanded if need be) -C - IDATA(395:419:3) = IOB -C GOES -- LOAD INTEGER MISSING INTO CAT. 13 LEVEL CHANNEL NUMBER -C -- LOAD DEFAULT OF BLANK CHARACTER INTO CAT. 13 LEVEL -C QUALITY MARKER -C (Current limit of 60 Cat. 13 levels) -C (could be expanded if need be) -C - IDATA(420:599:3) = IMSG - IDATA(422:599:3) = IOB - ELSE IF(ITP.EQ.3) THEN -C -C VADWND -- LOAD DEFAULT OF BLANK CHARACTER INTO HGHT CAT. 04 -C LEVEL QUALITY MARKER -C (Current limit of 70 Cat. 04 levels) -C (could be expanded if need be) -C - IDATA(46:1200:4) = IOB - END IF - RDATA(1:1200) = RDATX(1:1200) - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7703 FILLS IN HEADER IN O-PUT ARRAY - PFLR RPT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C HEADER DATA FOR WIND PROFILER REPORT. HEADER IS THEN FILLED INTO -C THE OUTPUT ARRAY WHICH HOLDS A SINGLE WIND PROFILER REPORT IN THE -C QUASI-OFFICE NOTE 29 UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND -C PROFILER) BUFR DUMP FILE AFTER 3/2002: MNEMONIC -C "NPSM" IS NO LONGER AVAILABLE, MNEMONIC "TPSE" -C REPLACES "TPMI" (AVG. TIME IN MINUTES STILL -C OUTPUT) (WILL STILL WORK PROPERLY FOR INPUT -C PROFLR DUMP FILES PRIOR TO 3/2002) -C -C USAGE: CALL UNPK7703(LUNIT,RDATA,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN -C - (ALL OTHER DATA REMAINS MISSING) -C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7703(LUNIT,RDATA,IRET) - CHARACTER*6 STNID - CHARACTER*8 COB - CHARACTER*35 HDR1,HDR2 - INTEGER IDATA(1200) - REAL(8) HDR_8(16) - REAL HDR(16),RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - - SAVE - - EQUIVALENCE (RDATX,IDATA),(COB,IOB) - DATA XMSG/99999./,IMSG/99999/ - DATA HDR1/'CLAT CLON TSIG SELV NPSM TPSE WMOB '/ - DATA HDR2/'WMOS YEAR MNTH DAYS HOUR MINU TPMI '/ - RDATX(1:1200) = RDATA(1:1200) - HDR_8 = 10.0E10 - CALL UFBINT(LUNIT,HDR_8,16,1,NLEV,HDR1//HDR2);HDR=HDR_8 - IF(NLEV.NE.1) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- -C SET IRET = 6 AND RETURN - PRINT 217, NLEV - 217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', - $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/) - IRET = 6 - RETURN -C....................................................................... - END IF - -C LATITUDE (STORED AS REAL) - - M = 1 - IF(IPRINT.GT.1) PRINT 199, HDR(1),M - 199 FORMAT(5X,'HDR HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(HDR(1).LT.XMSG) THEN - RDATX(1) = NINT(HDR(1) * 100.) - NNNNN = 1 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - 198 FORMAT(5X,'DATA(',I5,') STORED AS: ',F10.2) - ELSE - IRET = 2 - PRINT 102 - 102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR WIND PROFILER ', - $ 'REPORT'/) - RETURN - END IF - -C LONGITUDE (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, HDR(2),M - IF(HDR(2).LT.XMSG) THEN - RDATX(2) = NINT(MOD((36000.-(HDR(2)*100.)),36000.)) - NNNNN = 2 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - ELSE - IRET = 2 - PRINT 104 - 104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR WIND PROFILER ', - $ 'REPORT'/) - RETURN - END IF - -C TIME SIGNIFICANCE (STORED AS INTEGER) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, HDR(3),M - IF(HDR(3).LT.XMSG) IDATA(3) = NINT(HDR(3)) - NNNNN = 3 - IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) - 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) - -C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT) -C (STORED AS REAL) - - M = 4 - IF(IPRINT.GT.1) PRINT 199, HDR(4),M - IF(HDR(4).LT.XMSG) RDATX(7) = NINT(HDR(4)) - NNNNN = 7 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - -C SUBMODE INFORMATION -C EDITION NUMBER (ALWAYS = 2) -C (PACKED AS SUBMODE TIMES 10 PLUS EDITION NUMBER - INTEGER) -C {NOTE: After 3/2002, the submode information is no longer -C available and is stored as missing (3).} - - M = 5 - IEDTN = 2 - IDATA(8) = (3 * 10) + IEDTN - IF(IPRINT.GT.1) PRINT 199, HDR(5),M - IF(HDR(5).LT.XMSG) IDATA(8) = (NINT(HDR(5)) * 10) + IEDTN - NNNNN = 8 - IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) - -C AVERAGING TIME (STORED AS INTEGER) -C (NOTE: Prior to 3/2002, this is decoded in minutes, after -C 3/2002 this is decoded in seconds - in either case -C it is stored in minutes) - - M = 6 - IF(IPRINT.GT.1) PRINT 199, HDR(6),M - IF(IPRINT.GT.1) PRINT 199, HDR(14),M - IF(HDR(6).LT.XMSG) THEN - IDATA(10) = NINT(HDR(6)/60.) - ELSE IF(HDR(14).LT.XMSG) THEN - IDATA(10) = NINT(HDR(14)) - END IF - NNNNN = 10 - IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) -C----------------------------------------------------------------------- - -C STATION IDENTIFICATION (STORED AS CHARACTER) -C (OBTAINED FROM ENCODED WMO BLOCK/STN NUMBERS) - - STNID = ' ' - -C WMO BLOCK NUMBER (STORED AS CHARACTER) - - M = 7 - IF(IPRINT.GT.1) PRINT 199, HDR(7),M - IF(HDR(7).LT.XMSG) WRITE(STNID(1:2),'(I2.2)') NINT(HDR(7)) - -C WMO STATION NUMBER (STORED AS CHARACTER) - - M = 8 - IF(IPRINT.GT.1) PRINT 199, HDR(8),M - IF(HDR(8).LT.XMSG) WRITE(STNID(3:5),'(I3.3)') NINT(HDR(8)) - COB(1:4) = STNID(1:4) - IDATA(11) = IOB - NNNNN = 11 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') - COB(1:4) = STNID(5:6)//' ' - IDATA(12) = IOB - NNNNN = 12 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - -cvvvvvdak port -C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM) -caaaaadak port - - M = 9 - IF(IPRINT.GT.1) PRINT 199, HDR(9),M - IYEAR = IMSG - IF(HDR(9).LT.XMSG) IYEAR = NINT(HDR(9)) - M = 10 - IF(IPRINT.GT.1) PRINT 199, HDR(10),M - IF(HDR(10).LT.XMSG.AND.IYEAR.LT.IMSG) THEN -cvvvvvdak port - IYEAR = MOD(IYEAR,100) -caaaaadak port - IYEAR = NINT(HDR(10)) + (IYEAR * 100) -cvvvvvdak port -cdak WRITE(COB,'(I6.6,2X)') IYEAR - WRITE(COB,'(I4.4,4X)') IYEAR -caaaaadak port - IDATA(5) = IOB - NNNNN = 5 - IF(IPRINT.GT.1) PRINT 9196, NNNNN,COB(1:6) - 9196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A6,'"') - ELSE - GO TO 30 - END IF - -C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH) -C AND THE OBSERVATION TIME (STORED AS REAL) - - M = 11 - IF(IPRINT.GT.1) PRINT 199, HDR(11),M - IDAY = IMSG - IF(HDR(11).LT.XMSG) IDAY = NINT(HDR(11)) - M = 12 - IF(IPRINT.GT.1) PRINT 199, HDR(12),M - IF(HDR(12).LT.XMSG.AND.IDAY.LT.IMSG) THEN - IHRT = NINT(HDR(12)) - M = 13 - IF(IPRINT.GT.1) PRINT 199, HDR(13),M - IF(HDR(13).GE.XMSG) GO TO 30 - RMNT = HDR(13) - RDATX(4) = NINT((IHRT * 100.) + (RMNT * 100.)/60.) - NNNNN = 4 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - IHRT = IHRT + (IDAY * 100) - WRITE(COB(1:4),'(I4.4)') IHRT - IDATA(6) = IOB - NNNNN = 6 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - ELSE - GO TO 30 - END IF - RDATA(1:1200) = RDATX(1:1200) - RETURN - 30 CONTINUE - IRET = 4 - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7704 FILLS CAT.10 INTO O-PUT ARRAY - PFLR RPT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C SURFACE DATA FOR WIND PROFILER REPORT. SURFACE DATA ARE THEN -C FILLED INTO THE OUTPUT ARRAY AS CATEGORY 10. THE OUPUT ARRAY -C HOLDS A SINGLE WIND PROFILER REPORT IN THE QUASI-OFFICE NOTE 29 -C UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND -C PROFILER) BUFR DUMP FILE AFTER 3/2002: SURFACE -C DATA NOW ALL MISSING (MNEMONICS "PMSL", -C "WDIR1","WSPD1", "TMDB", "REHU", "REQV" NO -C LONGER AVAILABLE) (WILL STILL WORK PROPERLY FOR -C INPUT PROFLR DUMP FILES PRIOR TO 3/2002) -C -C USAGE: CALL UNPK7704(LUNIT,RDATA) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED -C - IN (ALL OTHER DATA REMAINS MISSING) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH SURFACE INFORMATION FILLED IN -C - (AS WELL AS THE HEADER; ALL OTHER DATA REMAINS -C - MISSING) -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPKB7. AFTER 3/2002, THERE IS -C NO SURFACE DATA AVAILABLE. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7704(LUNIT,RDATA) - CHARACTER*40 SRFC - INTEGER IDATA(1200) - REAL(8) SFC_8(8) - REAL SFC(8),RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - - SAVE - - EQUIVALENCE (RDATX,IDATA) - DATA XMSG/99999./ - DATA SRFC/'PMSL WDIR1 WSPD1 TMDB REHU REQV '/ - RDATX(1:1200) = RDATA(1:1200) - SFC_8 = 10.0E10 - CALL UFBINT(LUNIT,SFC_8,8,1,NLEV,SRFC);SFC=SFC_8 - IF(NLEV.NE.1) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- - PRINT 217, NLEV - 217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', - $ 'IS NOT WHAT IS EXPECTED (1) - NO SFC DATA PROCESSED'/) - GO TO 99 -C....................................................................... - END IF - -C MSL PRESSURE (STORED AS REAL) - - M = 1 - IF(IPRINT.GT.1) PRINT 199, SFC(1),M - 199 FORMAT(5X,'SFC HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF((SFC(1)*0.1).LT.XMSG) RDATX(43) = NINT(SFC(1) * 0.1) - NNNNN = 43 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43) - 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) - -C SURFACE HORIZONTAL WIND DIRECTION (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, SFC(2),M - IF(SFC(2).LT.XMSG) RDATX(43+2) = NINT(SFC(2)) - NNNNN = 43 + 2 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+2) - -C SURFACE HORIZONTAL WIND SPEED (STORED AS REAL) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, SFC(3),M - IF(SFC(3).LT.XMSG) RDATX(43+3) = NINT(SFC(3) * 10.) - NNNNN = 43 + 3 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+3) - -C SURFACE TEMPERATURE (STORED AS REAL) - - M = 4 - IF(IPRINT.GT.1) PRINT 199, SFC(4),M - IF(SFC(4).LT.XMSG) RDATX(43+4) = NINT(SFC(4) * 10.) - NNNNN = 43 + 4 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+4) - -C RELATIVE HUMIDITY (STORED AS REAL) - - M = 5 - IF(IPRINT.GT.1) PRINT 199, SFC(5),M - IF(SFC(5).LT.XMSG) RDATX(43+5) = NINT(SFC(5)) - NNNNN = 43 + 5 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+5) - -C RAINFALL RATE (STORED AS REAL) - - M = 6 - IF(IPRINT.GT.1) PRINT 199, SFC(6),M - IF(SFC(6).LT.XMSG) RDATX(43+6) = NINT(SFC(6) * 1.E7) - NNNNN = 43 + 6 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(43+6) - -C SET CATEGORY COUNTERS FOR SURFACE DATA - - IDATA(35) = 1 - IDATA(36) = 43 - 99 CONTINUE - IF(IPRINT.GT.1) PRINT *, 'IDATA(35)=',IDATA(35),'; IDATA(36)=', - $ IDATA(36) - RDATA(1:1200) = RDATX(1:1200) - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7705 FILLS CAT.11 INTO O-PUT ARRAY - PFLR RPT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-03-05 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C UPPER-AIR DATA FOR WIND PROFILER REPORT. UPPER-AIR DATA ARE THEN -C FILLED INTO THE OUTPUT ARRAY AS CATEGORY 11. THE OUPUT ARRAY -C HOLDS A SINGLE WIND PROFILER REPORT IN THE QUASI-OFFICE NOTE 29 -C UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1996-12-16 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C 1998-07-09 KEYSER -- MODIFIED WIND PROFILER CAT. 11 (HEIGHT, HORIZ. -C SIGNIFICANCE, VERT. SIGNIFICANCE) PROCESSING -C TO ACCOUNT FOR UPDATES TO BUFRTABLE MNEMONICS -C IN /dcom -C 2002-03-05 KEYSER -- ACCOUNTS FOR CHANGES IN INPUT PROFLR (WIND -C PROFILER) BUFR DUMP FILE AFTER 3/2002: -C MNEMONICS "ACAVH", "ACAVV", "SPP0", AND "NPHL" -C NO LONGER AVAILABLE; (WILL STILL WORK PROPERLY -C FOR INPUT PROFLR DUMP FILES PRIOR TO 3/2002) -C -C USAGE: CALL UNPK7705(LUNIT,RDATA) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ONLY HEADER AND SURFACE -C - INFORMATION FILLED IN (UPPER-AIR DATA MISSING) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE WIND PROFILER REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH UPPER-AIR INFORMATION FILLED -C - IN (ALL DATA FOR REPORT NOW FILLED) -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7705(LUNIT,RDATA) - CHARACTER*31 UAIR1,UAIR2 - CHARACTER*16 UAIR3 - INTEGER IDATA(1200) - REAL(8) UAIR_8(16,255) - REAL UAIR(16,255),RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - - SAVE - - EQUIVALENCE (RDATX,IDATA) - DATA XMSG/99999./ - DATA UAIR1/'HEIT WDIR WSPD NPQC WCMP ACAVH '/ - DATA UAIR2/'ACAVV SPP0 SDHS SDVS NPHL '/ - DATA UAIR3/'HAST ACAV1 ACAV2'/ - RDATX(1:1200) = RDATA(1:1200) - NSFC = 0 - ILVL = 0 - ILC = 0 -C FIRST UPPER-AIR LEVEL IS THE SURFACE INFORMATION - IF(IPRINT.GT.1) PRINT 1078, ILC,ILVL - 1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',I5,'; NO. LEVELS ', - $ 'PROCESSED TO NOW =',I5) - RDATX(50+ILC) = RDATX(7) - IF(IPRINT.GT.1) PRINT 198, 50+ILC,RDATX(50+ILC) - 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) - IF(RDATX(50+ILC).LT.XMSG) NSFC = 1 - IF(IDATA(35).GE.1) THEN - RDATX(50+ILC+1) = RDATX(IDATA(36)+2) - RDATX(50+ILC+2) = RDATX(IDATA(36)+3) - END IF - IF(IPRINT.GT.1) PRINT 198, 50+ILC+1,RDATX(50+ILC+1) - IF(RDATX(50+ILC+1).LT.XMSG) NSFC = 1 - IF(IPRINT.GT.1) PRINT 198, 50+ILC+2,RDATX(50+ILC+2) - IF(RDATX(50+ILC+2).LT.XMSG) NSFC = 1 - ILVL = ILVL + 1 - ILC = ILC + 11 - IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL,' WITH ', - $ 'NSFC=',NSFC,'; GOING INTO NEXT LEVEL WITH ILC=',ILC - UAIR_8 = 10.0E10 - CALL UFBINT(LUNIT,UAIR_8,16,255,NLEV,UAIR1//UAIR2//UAIR3) - UAIR=UAIR_8 - IF(NLEV.EQ.0) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- - IF(NSFC.EQ.0) THEN -C ... NO UPPER AIR DATA PROCESSED - PRINT 217 - 217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS', - $ ' REPORT -- NLEV = 0 AND NSFC = 0'/) - GO TO 99 - ELSE -C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED - PRINT 218 - 218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ', - $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/) - GO TO 98 - END IF -C....................................................................... - END IF - IF(IPRINT.GT.1) PRINT 1068, NLEV - 1068 FORMAT(' THIS REPORT CONTAINS ',I3,' LEVELS OF DATA (NOT ', - $ 'INCLUDING BOTTOM -SURFACE- LEVEL)') - DO I = 1,NLEV - IF(IPRINT.GT.1) PRINT 1079, ILC,ILVL - 1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',I5,'; NO. LEVELS ', - $ 'PROCESSED TO NOW =',I5) - -C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL) -C (NOTE: At one time, possibly even now, the height above sea -C level was erroneously stored under mnemonic "HAST" -C when it should have been stored under mnemonic "HEIT". -C ("HAST" is defined as the height above the station.) -C Will test first for valid data in "HEIT" - if missing, -C then will use data in "HAST" - this will allow this -C routine to transition w/o change when the fix is made.) - - IF(UAIR(1,I).LT.XMSG) THEN - M = 1 - IF(IPRINT.GT.1) PRINT 199, UAIR(1,I),M - 199 FORMAT(5X,'UAIR HERE IS: ',F17.4,'; INDEX IS: ',I3) - RDATX(50+ILC) = NINT(UAIR(1,I)) - ELSE - M = 12 - IF(IPRINT.GT.1) PRINT 199, UAIR(12,I),M - IF(UAIR(12,I).LT.XMSG) RDATX(50+ILC) = NINT(UAIR(12,I)) - END IF - IF(IPRINT.GT.1) PRINT 198, 50+ILC,RDATX(50+ILC) - ILVL = ILVL + 1 - -C HORIZONTAL WIND DIRECTION (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M - IF(UAIR(2,I).LT.XMSG) RDATX(50+ILC+1) = NINT(UAIR(2,I)) - IF(IPRINT.GT.1) PRINT 198, 50+ILC+1,RDATX(50+ILC+1) - -C HORIZONTAL WIND SPEED (STORED AS REAL) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M - IF(UAIR(3,I).LT.XMSG) RDATX(50+ILC+2) =NINT(UAIR(3,I) * 10.) - IF(IPRINT.GT.1) PRINT 198, 50+ILC+2,RDATX(50+ILC+2) - -C QUALITY CODE (STORED AS INTEGER) - - M = 4 - IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M - IF(UAIR(4,I).LT.XMSG) IDATA(50+ILC+3) = NINT(UAIR(4,I)) - IF(IPRINT.GT.1) PRINT 197, 50+ILC+3,IDATA(50+ILC+3) - 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) - -C VERTICAL WIND COMPONENT (W) (STORED AS REAL) - - M = 5 - IF(IPRINT.GT.1) PRINT 199, UAIR(5,I),M - IF(UAIR(5,I).LT.XMSG) RDATX(50+ILC+4) = NINT(UAIR(5,I) * 100.) - IF(IPRINT.GT.1) PRINT 198, 50+ILC+4,RDATX(50+ILC+4) - -C HORIZONTAL CONSENSUS NUMBER (STORED AS INTEGER) -C (NOTE: Prior to 2/18/1999, the horizonal consensus number was -C stored under mnemonic "ACAV1". -C From 2/18/1999 through 3/2002, the horizontal consensus -C number was stored under mnemonic "ACAVH". -C After 3/2002, the horizontal consensus number is no -C longer stored. -C Will test first for valid data in "ACAVH" - if missing, -C then will test for data in "ACAV1" - this will allow -C this routine to work properly with historical data.) - - IF(IPRINT.GT.1) PRINT 199, UAIR(6,I),M - IF(IPRINT.GT.1) PRINT 199, UAIR(13,I),M - IF(UAIR(6,I).LT.XMSG) THEN - M = 6 - IDATA(50+ILC+5) = NINT(UAIR(6,I)) - ELSE - M = 13 - IF(UAIR(13,I).LT.XMSG) IDATA(50+ILC+5) = NINT(UAIR(13,I)) - END IF - IF(IPRINT.GT.1) PRINT 197, 50+ILC+5,IDATA(50+ILC+5) - -C VERTICAL CONSENSUS NUMBER (STORED AS INTEGER) -C (NOTE: Prior to 2/18/1999, the vertical consensus number was -C stored under mnemonic "ACAV2". -C From 2/18/1999 through 3/2002, the vertical consensus -C number was stored under mnemonic "ACAVV". -C After 3/2002, the vertical consensus number is no -C longer stored. -C Will test first for valid data in "ACAVV" - if missing, -C then will test for data in "ACAV2" - this will allow -C this routine to work properly with historical data.) - - IF(IPRINT.GT.1) PRINT 199, UAIR(7,I),M - IF(IPRINT.GT.1) PRINT 199, UAIR(14,I),M - IF(UAIR(7,I).LT.XMSG) THEN - M = 7 - IDATA(50+ILC+6) = NINT(UAIR(7,I)) - ELSE - M = 14 - IF(UAIR(14,I).LT.XMSG) IDATA(50+ILC+6) = NINT(UAIR(14,I)) - END IF - IF(IPRINT.GT.1) PRINT 197, 50+ILC+6,IDATA(50+ILC+6) - -C SPECTRAL PEAK POWER (STORED AS REAL) -C (NOTE: After 3/2002, the spectral peak power is no longer -C stored.) - - M = 8 - IF(IPRINT.GT.1) PRINT 199, UAIR(8,I),M - IF(UAIR(8,I).LT.XMSG) RDATX(50+ILC+7) = NINT(UAIR(8,I)) - IF(IPRINT.GT.1) PRINT 198, 50+ILC+7,RDATX(50+ILC+7) - -C HORIZONTAL WIND SPEED STANDARD DEVIATION (STORED AS REAL) - - M = 9 - IF(IPRINT.GT.1) PRINT 199, UAIR(9,I),M - IF(UAIR(9,I).LT.XMSG) RDATX(50+ILC+8)=NINT(UAIR(9,I) * 10.) - IF(IPRINT.GT.1) PRINT 198, 50+ILC+8,RDATX(50+ILC+8) - -C VERTICAL WIND COMPONENT STANDARD DEVIATION (STORED AS REAL) - - M = 10 - IF(IPRINT.GT.1) PRINT 199, UAIR(10,I),M - IF(UAIR(10,I).LT.XMSG) RDATX(50+ILC+9) =NINT(UAIR(10,I) * 10.) - IF(IPRINT.GT.1) PRINT 198, 50+ILC+9,RDATX(50+ILC+9) - -C MODE INFORMATION (STORED AS INTEGER) -C (NOTE: After 3/2002, the mode information is no longer stored.) - - M = 11 - IF(IPRINT.GT.1) PRINT 199, UAIR(11,I),M - IF(UAIR(11,I).LT.XMSG) IDATA(50+ILC+10) = NINT(UAIR(11,I)) - IF(IPRINT.GT.1) PRINT 197, 50+ILC+10,IDATA(50+ILC+10) -C....................................................................... - ILC = ILC + 11 - IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL, - $ '; GOING INTO NEXT LEVEL WITH ILC=',ILC - ENDDO - -C SET CATEGORY COUNTERS FOR UPPER-AIR DATA - - 98 CONTINUE - IDATA(37) = ILVL - IDATA(38) = 50 - 99 CONTINUE - IF(IPRINT.GT.1) PRINT *, 'NSFC=',NSFC,'; IDATA(37)=',IDATA(37), - $ '; IDATA(38)=',IDATA(38) - RDATA(1:1200) = RDATX(1:1200) - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7706 FILLS IN HEADER IN O-PUT ARRAY - VADW RPT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-02 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C HEADER DATA FOR NEXRAD (VAD) WIND REPORT. HEADER IS THEN FILLED -C INTO THE OUTPUT ARRAY WHICH HOLDS A SINGLE VAD WIND REPORT IN THE -C QUASI-OFFICE NOTE 29 UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1997-06-02 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C -C USAGE: CALL UNPK7706(LUNIT,RDATA,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN -C - (ALL OTHER DATA REMAINS MISSING) -C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7706(LUNIT,RDATA,IRET) - CHARACTER*8 STNID,COB - CHARACTER*45 HDR1 - INTEGER IDATA(1200) - REAL(8) HDR_8(9) - REAL HDR(9),RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - - SAVE - - EQUIVALENCE (RDATX,IDATA),(STNID,HDR_8(4)),(COB,IOB) - DATA XMSG/99999./,IMSG/99999/ - DATA HDR1/'CLAT CLON SELV RPID YEAR MNTH DAYS HOUR MINU '/ - RDATX(1:1200) = RDATA(1:1200) - HDR_8 = 10.0E10 - CALL UFBINT(LUNIT,HDR_8,9,1,NLEV,HDR1);HDR=HDR_8 - IF(NLEV.NE.1) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- -C SET IRET = 6 AND RETURN - PRINT 217, NLEV - 217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', - $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/) - IRET = 6 - RETURN -C....................................................................... - END IF - -C LATITUDE (STORED AS REAL) - - M = 1 - IF(IPRINT.GT.1) PRINT 199, HDR(1),M - 199 FORMAT(5X,'HDR HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(HDR(1).LT.XMSG) THEN - RDATX(1) = NINT(HDR(1) * 100.) - NNNNN = 1 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) - ELSE - IRET = 2 - PRINT 102 - 102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR VAD WIND REPORT'/) - RETURN - END IF - -C LONGITUDE (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, HDR(2),M - IF(HDR(2).LT.XMSG) THEN - RDATX(2) = NINT(MOD((36000.-(HDR(2)*100.)),36000.)) - NNNNN = 2 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - ELSE - IRET = 2 - PRINT 104 - 104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR VAD WIND REPORT'/) - RETURN - END IF - -C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT) -C (STORED AS REAL) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, HDR(3),M - IF(HDR(3).LT.XMSG) RDATX(7) = NINT(HDR(3)) - NNNNN = 7 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - -C STATION IDENTIFICATION (STORED AS CHARACTER) -C ('99'//LAST 3-CHARACTERS OF PRODUCT SOURCE ID//' ') - - M = 4 - IF(IPRINT.GT.1) PRINT 299, STNID,M - 299 FORMAT(5X,'HDR HERE IS: ',9X,A8,'; INDEX IS: ',I3) - COB(1:4) = '99'//STNID(2:3) - IDATA(11) = IOB - NNNNN = 11 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') - COB(1:4) = STNID(4:4)//' ' - IDATA(12) = IOB - NNNNN = 12 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - -cvvvvvdak port -C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM) -caaaaadak port - - M = 5 - IF(IPRINT.GT.1) PRINT 199, HDR(5),M - IYEAR = IMSG - IF(HDR(5).LT.XMSG) IYEAR = NINT(HDR(5)) - M = 6 - IF(IPRINT.GT.1) PRINT 199, HDR(6),M - IF(HDR(6).LT.XMSG.AND.IYEAR.LT.IMSG) THEN -cvvvvvdak port - IYEAR = MOD(IYEAR,100) -caaaaadak port - IYEAR = NINT(HDR(6)) + (IYEAR * 100) -cvvvvvdak port -cdak WRITE(COB,'(I6.6,2X)') IYEAR - WRITE(COB,'(I4.4,4X)') IYEAR -caaaaadak port - IDATA(5) = IOB - NNNNN = 5 - IF(IPRINT.GT.1) PRINT 9196, NNNNN,COB(1:6) - 9196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A6,'"') - ELSE - GO TO 30 - END IF - -C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH) -C AND THE OBSERVATION TIME (STORED AS REAL) - - M = 7 - IF(IPRINT.GT.1) PRINT 199, HDR(7),M - IDAY = IMSG - IF(HDR(7).LT.XMSG) IDAY = NINT(HDR(7)) - M = 8 - IF(IPRINT.GT.1) PRINT 199, HDR(8),M - IF(HDR(8).LT.XMSG.AND.IDAY.LT.IMSG) THEN - IHRT = NINT(HDR(8)) - M = 9 - IF(IPRINT.GT.1) PRINT 199, HDR(9),M - IF(HDR(9).GE.XMSG) GO TO 30 - RMNT = HDR(9) - RDATX(4) = NINT((IHRT * 100.) + (RMNT * 100.)/60.) - NNNNN = 4 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - IHRT = IHRT + (IDAY * 100) - WRITE(COB(1:4),'(I4.4)') IHRT - IDATA(6) = IOB - NNNNN = 6 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - ELSE - GO TO 30 - END IF - RDATA(1:1200) = RDATX(1:1200) - RETURN - 30 CONTINUE - IRET = 4 - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7707 FILLS CAT. 4 INTO O-PUT ARRAY - VADW RPT -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-02 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C UPPER-AIR DATA FOR NEXRAD (VAD) WIND REPORT. UPPER-AIR DATA ARE -C THEN FILLED INTO THE OUTPUT ARRAY AS CATEGORY 4. THE OUPUT ARRAY -C HOLDS A SINGLE VAD WIND REPORT IN THE QUASI-OFFICE NOTE 29 -C UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1997-06-02 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C -C USAGE: CALL UNPK7707(LUNIT,RDATA,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED -C - IN (CATEGORY 4 DATA MISSING) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE NEXRAD (VAD) REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH CATEGORY 4 INFORMATION FILLED IN -C - (ALL DATA FOR REPORT NOW FILLED) -C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7707(LUNIT,RDATA,IRET) - CHARACTER*1 CRMS(0:12) - CHARACTER*8 COB - CHARACTER*25 UAIR1 - INTEGER IDATA(1200) - REAL(8) UAIR_8(5,255) - REAL UAIR(5,255),RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - - SAVE - - EQUIVALENCE (RDATX,IDATA),(COB,IOB) - DATA XMSG/99999./ - DATA UAIR1/'HEIT WDIR WSPD RMSW QMWN '/ - DATA CRMS/' ','A',' ','B',' ','C',' ','D',' ','E',' ','F',' '/ - RDATX(1:1200) = RDATA(1:1200) - NSFC = 0 - ILVL = 0 - ILC = 0 -C FIRST CATEGORY 4 LEVEL UPPER-AIR LEVEL CONTAINS ONLY HEIGHT (ELEV) - IF(IPRINT.GT.1) PRINT 1078, ILC,ILVL - 1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',I5,'; NO. LEVELS ', - $ 'PROCESSED TO NOW =',I5) - RDATX(43+ILC) = RDATX(7) - IF(IPRINT.GT.1) PRINT 198, 43+ILC,RDATX(43+ILC) - 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) - IF(RDATX(43+ILC).LT.XMSG) NSFC = 1 -C NOTE: The following was added because of a problem on the sgi-ha -C platform related to equivalencing character and non-character -C -- for now the addition of these two lines will set the quality -C mark for sfc. cat . 4 level to the correct value of " " -C rather than to "9999" - Mary McCann notified SGI of this -C problem on 08-21-1998 - cob = ' ' - idata(43+ilc+3) = iob - ILVL = ILVL + 1 - ILC = ILC + 4 - IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL,' WITH ', - $ 'NSFC=',NSFC,'; GOING INTO NEXT LEVEL WITH ILC=',ILC - UAIR_8 = 10.0E10 - CALL UFBINT(LUNIT,UAIR_8,5,255,NLEV,UAIR1);UAIR=UAIR_8 - IF(NLEV.EQ.0) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- - IF(NSFC.EQ.0) THEN -C ... NO UPPER AIR DATA PROCESSED - PRINT 217 - 217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS', - $ ' REPORT -- NLEV = 0 AND NSFC = 0'/) - GO TO 99 - ELSE -C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED - PRINT 218 - 218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ', - $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/) - GO TO 98 - END IF -C....................................................................... - END IF - IF(IPRINT.GT.1) PRINT 1068, NLEV - 1068 FORMAT(' THIS REPORT CONTAINS ',I3,' LEVELS OF DATA (NOT ', - $ 'INCLUDING BOTTOM -SURFACE- LEVEL)') - DO I = 1,NLEV - IF(IPRINT.GT.1) PRINT 1079, ILC,ILVL - 1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',I5,'; NO. LEVELS ', - $ 'PROCESSED TO NOW =',I5) - -C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL) - - M = 1 - IF(IPRINT.GT.1) PRINT 199, UAIR(1,I),M - 199 FORMAT(5X,'UAIR HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(UAIR(1,I).LT.XMSG) THEN - RDATX(43+ILC) = NINT(UAIR(1,I)) - -C ... WE HAVE A VALID CATEGORY 4 LEVEL -- THERE IS A VALID HEIGHT - - ILVL = ILVL + 1 - ELSE - -C ... WE DO NOT HAVE A VALID CATEGORY 4 LEVEL -- THERE IS NO VALID -C HEIGHT GO ON TO NEXT INPUT LEVEL - - IF(IPRINT.GT.1) PRINT *, 'HEIGHT MISSING ON INPUT ', - $ ' LEVEL ',I,', ALL OTHER DATA SET TO MSG ON THIS LEVEL' - GO TO 10 - END IF - IF(IPRINT.GT.1) PRINT 198, 43+ILC,RDATX(43+ILC) - -C HORIZONTAL WIND DIRECTION (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M - IF(UAIR(2,I).LT.XMSG) RDATX(43+ILC+1) = NINT(UAIR(2,I)) - IF(IPRINT.GT.1) PRINT 198, 43+ILC+1,RDATX(43+ILC+1) - -C HORIZONTAL WIND SPEED (STORED AS REAL) (OUTPUT STORED -C AS METERS/SECOND TIMES TEN, NOT IN KNOTS AS ON29 WOULD -C INDICATE FOR CAT. 4 WIND SPEED) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M - IF(UAIR(3,I).LT.XMSG) RDATX(43+ILC+2) =NINT(UAIR(3,I) * 10.) - IF(IPRINT.GT.1) PRINT 198, 43+ILC+2,RDATX(43+ILC+2) - -C CONFIDENCE LEVEL (BASED ON RMS VECTOR WIND ERROR) -C (NOTE: CONVERTED TO ORIGINAL LETTER INDICATOR AND PACKED -C IN BYTE 4 OF CATEGORY 4 QUALITY MARKER LOCATION -- SEE -C W3UNPK77 DOCBLOCK REMARKS 5. FOR UNPACKED VAD WIND REPORT -C LAYOUT FOR VALUES - - M = 4 - IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M - IF(UAIR(4,I).LT.XMSG) THEN - -C ... CONVERT FROM M/S TO KNOTS - -CDAKCDAK KRMS = INT(1.93333 * UAIR(4,I)) - KRMS = INT(1.9425 * UAIR(4,I)) - COB = ' ' - IF(KRMS.LT.13) THEN - COB(4:4) = CRMS(KRMS) - ELSE - COB(4:4) = 'G' - END IF - IDATA(43+ILC+3) = IOB - END IF - IF(IPRINT.GT.1) PRINT 196, 43+ILC+3,COB(1:4) - 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') - -C ON29 WIND QUALITY MARKER (CURRENTLY NOT STORED) - - M = 5 - IF(IPRINT.GT.1) PRINT 199, UAIR(5,I),M -C....................................................................... - ILC = ILC + 4 - IF(IPRINT.GT.1) PRINT *,'HAVE COMPLETED LEVEL ',ILVL, - $ '; GOING INTO NEXT LEVEL WITH ILC=',ILC - - 10 CONTINUE - ENDDO - -C SET CATEGORY COUNTERS FOR UPPER-AIR DATA - - 98 CONTINUE - IDATA(19) = ILVL - 99 CONTINUE - IF(IDATA(19).EQ.0) THEN - IDATA(20) = 0 - IRET = 5 - ELSE - IDATA(20) = 43 - END IF - IF(IPRINT.GT.1) PRINT *, 'NSFC=',NSFC,'; IDATA(37)=',IDATA(37), - $ '; IDATA(38)=',IDATA(38) - RDATA(1:1200) = RDATX(1:1200) - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7708 FILLS IN HEADER IN O-PUT ARRAY - GOES SND -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1998-07-09 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C HEADER DATA FOR GOES SOUNDING REPORT. HEADER IS THEN FILLED INTO -C THE OUTPUT ARRAY WHICH HOLDS A SINGLE GOES SOUNDING REPORT IN THE -C QUASI-OFFICE NOTE 29 UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1997-06-05 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C 1998-07-09 KEYSER -- CHANGED CHAR. 6 OF GOES STNID TO BE UNIQUE FOR -C TWO DIFFERENT EVEN OR ODD SATELLITE ID'S -C (EVERY OTHER EVEN OR ODD SAT. ID NOW GETS SAME -C CHAR. 6 TAG) -C -C USAGE: CALL UNPK7708(LUNIT,RDATA,KOUNT,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ALL DATA INITIALIZED AS MISSING -C KOUNT - NUMBER OF REPORTS PROCESSED INCLUDING THIS ONE -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH HEADER INFORMATION FILLED IN -C - (ALL OTHER DATA REMAINS MISSING) -C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7708(LUNIT,RDATA,KOUNT,IRET) - CHARACTER*1 C6TAG(3,0:3) - CHARACTER*8 STNID,COB - CHARACTER*35 HDR1,HDR2 - INTEGER IDATA(1200) - REAL(8) HDR_8(12) - REAL HDR(12),RDATA(*),RDATX(1200) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - COMMON /PK77FF/IFOV(3),KNTSAT(250:260) - - SAVE - - EQUIVALENCE (RDATX,IDATA),(COB,IOB) - DATA XMSG/99999./,IMSG/99999/ - DATA HDR1/'CLAT CLON ACAV GSDP QMRK SAID YEAR '/ - DATA HDR2/'MNTH DAYS HOUR MINU SECO '/ - - -C CURRENT LIST OF SATELLITE IDENTIFIERS (BUFR C.F. 0-01-007) -C ----------------------------------------------------------- - -C GOES 6 -- 250 GOES 9 -- 253 GOES 12 -- 256 -C GOES 7 -- 251 GOES 10 -- 254 GOES 13 -- 257 -C GOES 8 -- 252 GOES 11 -- 255 GOES 14 -- 258 - -C IDSAT = -- EVEN1 -- --- ODD1 -- -- EVEN2 -- --- ODD2 -- -C Sat. No. - 252,256,... 253,257,... 250,254,... 251,255,... -C IRTYP = CLR COR UNKN CLR COR UNKN CLR COR UNKN CLR COR UNKN -C --- --- ---- --- --- ---- --- --- ---- --- --- ---- - - DATA C6TAG/'I','J','?', 'L','M','?', 'O','P','?', 'Q','R','?' / - - RDATX(1:1200) = RDATA(1:1200) - HDR_8 = 10.0E10 - CALL UFBINT(LUNIT,HDR_8,12,1,NLEV,HDR1//HDR2);HDR=HDR_8 - IF(NLEV.NE.1) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- -C SET IRET = 6 AND RETURN - PRINT 217, NLEV - 217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', - $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/) - IRET = 6 - RETURN -C....................................................................... - END IF - -C LATITUDE (STORED AS REAL) - - M = 1 - IF(IPRINT.GT.1) PRINT 199, HDR(1),M - 199 FORMAT(5X,'HDR HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(HDR(1).LT.XMSG) THEN - RDATX(1) = NINT(HDR(1) * 100.) - NNNNN = 1 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) - ELSE - IRET = 2 - PRINT 102 - 102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR GOES SOUNDING'/) - RETURN - END IF - -C LONGITUDE (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, HDR(2),M - IF(HDR(2).LT.XMSG) THEN - RDATX(2) = NINT(MOD((36000.-(HDR(2)*100.)),36000.)) - NNNNN = 2 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - ELSE - IRET = 2 - PRINT 104 - 104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR GOES SOUNDING'/) - RETURN - END IF - -C NUMBER OF FIELDS OF VIEW - SAMPLE SIZE (STORED AS INTEGER) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, HDR(3),M - IF(HDR(3).LT.XMSG) IDATA(3) = NINT(HDR(3)) - NNNNN = 3 - IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) - 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) - -C STATION ELEVATION (FROM HEIGHT OF FIRST -SURFACE- LEVEL) -C (STORED AS REAL) -- STORED IN SUBROUTINE UNPK7709 - - -C RETRIEVAL TYPE (GEOSTATIONARY SATELLITE DATA-PROCESSING -C TECHNIQUE USED) (STORED AS INTEGER) - - M = 4 - IF(IPRINT.GT.1) PRINT 199, HDR(4),M - IF(HDR(4).LT.XMSG) IDATA(8) = NINT(HDR(4)) - IRTYP = 3 - IF(IDATA(8).EQ.21) THEN - IRTYP = 1 - ELSE IF(IDATA(8).EQ.23) THEN - IRTYP = 2 - END IF - NNNNN = 8 - IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) - -C PRODUCT QUALITY BIT FLAGS - QUALITY INFO. (STORED AS INTEGER) - - M = 5 - IF(IPRINT.GT.1) PRINT 199, HDR(5),M - IF(HDR(5).LT.XMSG) IDATA(10) = NINT(HDR(5)) - NNNNN = 10 - IF(IPRINT.GT.1) PRINT 197, NNNNN,IDATA(NNNNN) - -C STATION IDENTIFICATION (STORED AS CHARACTER) -C (FIRST 5-CHARACTERS OBTAINED FROM 5-DIGIT COUNT NUMBER, -C 6'TH CHARACTER OBTAINED FROM SAT. ID/RETRIEVAL TYPE TAG) - - WRITE(STNID(1:5),'(I5.5)') MIN(KOUNT,99999) - -C DECODE THE SATELLITE ID - - M = 6 - IDSAT = 2 - IF(IPRINT.GT.1) PRINT 199, HDR(6),M - IF(HDR(6).LT.XMSG) THEN - IDSAT = MOD(NINT(HDR(6)),4) - IF(NINT(HDR(6)).GT.249.AND.NINT(HDR(6)).LT.260) THEN - KNTSAT(NINT(HDR(6))) = KNTSAT(NINT(HDR(6))) + 1 - ELSE - KNTSAT(260) = KNTSAT(260) + 1 - END IF - END IF - IF(IPRINT.GT.1) PRINT 2197, IDSAT,IRTYP - 2197 FORMAT(5X,'IDSAT IS: ',I10,', IRTYP IS: ',I10) - STNID(6:6) = C6TAG(IRTYP,IDSAT) - COB(1:4) = STNID(1:4) - IDATA(11) = IOB - NNNNN = 11 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') - COB(1:4) = STNID(5:6)//' ' - IDATA(12) = IOB - NNNNN = 12 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - -cvvvvvdak port -C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM) -caaaaadak port - - M = 7 - IF(IPRINT.GT.1) PRINT 199, HDR(7),M - IYEAR = IMSG - IF(HDR(7).LT.XMSG) IYEAR = NINT(HDR(7)) - M = 8 - IF(IPRINT.GT.1) PRINT 199, HDR(8),M - IF(HDR(8).LT.XMSG.AND.IYEAR.LT.IMSG) THEN -cvvvvvdak port - IYEAR = MOD(IYEAR,100) -caaaaadak port - IYEAR = NINT(HDR(8)) + (IYEAR * 100) -cvvvvvdak port -cdak WRITE(COB,'(I6.6,2X)') IYEAR - WRITE(COB,'(I4.4,4X)') IYEAR -caaaaadak port - IDATA(5) = IOB - NNNNN = 5 - IF(IPRINT.GT.1) PRINT 9196, NNNNN,COB(1:6) - 9196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A6,'"') - ELSE - GO TO 30 - END IF - -C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH) -C AND THE OBSERVATION TIME (STORED AS REAL) - - M = 9 - IF(IPRINT.GT.1) PRINT 199, HDR(9),M - M = 10 - IF(IPRINT.GT.1) PRINT 199, HDR(10),M - IF(HDR(10).LT.XMSG.AND.HDR(9).LT.IMSG) THEN - M = 11 - IF(IPRINT.GT.1) PRINT 199, HDR(11),M - IF(HDR(11).GE.XMSG) GO TO 30 - M = 12 - IF(IPRINT.GT.1) PRINT 199, HDR(12),M - IF(HDR(12).GE.XMSG) GO TO 30 - RDATX(4) = NINT(((HDR(10) + ((HDR(11) * 60.) + HDR(12))/3600.) - $ * 100.) + 0.0000000001) - NNNNN = 4 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - IDAYHR = NINT(HDR(10)) + (NINT(HDR(9)) * 100) - WRITE(COB(1:4),'(I4.4)') IDAYHR - IDATA(6) = IOB - NNNNN = 6 - IF(IPRINT.GT.1) PRINT 196, NNNNN,COB(1:4) - ELSE - GO TO 30 - END IF - RDATA(1:1200) = RDATX(1:1200) - RETURN - 30 CONTINUE - IRET = 4 - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: UNPK7709 FILLS CAT. 12,8 TO O-PUT ARRAY -GOES SNDG -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1997-06-05 -C -C ABSTRACT: FOR REPORT (SUBSET) READ OUT OF BUFR MESSAGE (PASSED IN -C INTERNALLY VIA BUFRLIB STORAGE), CALLS BUFRLIB ROUTINE TO DECODE -C UPPER-AIR (SOUNDING) AND ADDITIONAL DATA FOR GOES SOUNDING. UPPER- -C AIR DATA ARE THEN FILLED INTO THE OUTPUT ARRAY AS CATEGORY 12 -C (SATELLITE SOUNDING) AND ADDITIONAL DATA ARE FILLED AS CATEGORY 8. -C THE OUPUT ARRAY HOLDS A SINGLE GOES SOUNDING IN THE QUASI-OFFICE -C NOTE 29 UNPACKED FORMAT. -C -C PROGRAM HISTORY LOG: -C 1997-06-05 D. A. KEYSER NP22 - ORIGINAL AUTHOR -C -C USAGE: CALL UNPK7709(LUNIT,RDATA,IRET) -C INPUT ARGUMENT LIST: -C LUNIT - FORTRAN UNIT NUMBER FOR INPUT DATA FILE -C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH ONLY HEADER INFORMATION FILLED -C - IN (CATEGORY 12 AND 8 DATA MISSING) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C RDATA - SINGLE GOES SNDG REPORT IN A QUASI-OFFICE NOTE 29 -C - UNPACKED FORMAT WITH CATEGORY 12 AND 8 INFORMATION -C - FILLED IN (ALL DATA FOR REPORT NOW FILLED) -C IRET - RETURN CODE AS DESCRIBED IN W3UNPK77 DOCBLOCK -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY SUBROUTINE W3UNPK77. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP, CRAY, SGI -C -C$$$ - SUBROUTINE UNPK7709(LUNIT,RDATA,IRET) - CHARACTER*1 CQMFLG - CHARACTER*8 COB - CHARACTER*37 CAT8A,CAT8B - CHARACTER*48 UAIR1,RAD1 - INTEGER IDATA(1200),ICDFG(12) - REAL(8) UAIR_8(4,255),CAT8_8(12),RTCSF_8,RAD_8(2,255) - REAL UAIR(4,255),CAT8(12),RDATA(*),RDATX(1200),SC8(12),RAD(2,255) - COMMON /PK77BB/kdate(8),ldate(8),IPRINT - COMMON /PK77FF/IFOV(3),KNTSAT(250:260) - - SAVE - - EQUIVALENCE (RDATX,IDATA),(COB,IOB) - DATA XMSG/99999./,YMSG/99999.8/ - DATA UAIR1/'PRLC HGHT TMDB TMDP '/ - DATA RAD1 /'CHNM TMBR '/ - DATA CAT8A/'GLFTI PH2O PH2O19 PH2O97 PH2O73 TMSK '/ - DATA CAT8B/'GCDTT CDTP CLAM SIDU SOEL ELEV '/ - DATA ICDFG/ 50 , 51 , 52 , 53 , 54 , 55 , 56 ,57 ,58,59, 60 , 61 / - DATA SC8/100.,100.,100.,100.,100.,100.,100.,10.,1.,1.,100.,100./ - RDATX(1:1200) = RDATA(1:1200) - -C ALL NON-RADIANCE DATA WILL BE Q.C.'D ACCORDING TO NUMBER OF FIELDS-OF- -C VIEW FOR RETRIEVAL: 0-2 --> BAD, 3-9 --> SUSPECT, 10-25 OR MISSING -C --> NEUTRAL - - CQMFLG = ' ' - IF(IDATA(3).LT.3) THEN - CQMFLG = 'F' - IFOV(1) = IFOV(1) + 1 - ELSE IF(IDATA(3).LT.10.OR.IDATA(10).EQ.1) THEN - CQMFLG = 'Q' - IF(IDATA(3).LT.10) IFOV(2) = IFOV(2) + 1 - END IF - IF(IDATA(3).GT.9) IFOV(3) = IFOV(3) + 1 - -C*********************************************************************** -C FILL CATEGORY 12 PART OF OUTPUT -C*********************************************************************** - - ILVL = 0 - ILC = 0 - UAIR_8 = 10.0E10 - CALL UFBINT(LUNIT,UAIR_8,4,255,NLEV,UAIR1);UAIR=UAIR_8 - IF(NLEV.EQ.0) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- - PRINT 217 - 217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ', - $ 'FOR THIS REPORT -- NLEV = 0'/) - GO TO 98 - ELSE IF(NLEV.GT.50) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 50 -- - PRINT 218 - 218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ', - $ 'FOR THIS REPORT -- NLEV > 50'/) - GO TO 98 -C....................................................................... - END IF - IF(IPRINT.GT.1) PRINT 1068, NLEV - 1068 FORMAT(' THIS REPORT CONTAINS',I4,' INPUT LEVELS OF SOUNDING ', - $ 'DATA') - DO I = 1,NLEV - IF(IPRINT.GT.1) PRINT 1079, I,ILC,ILVL - 1079 FORMAT(' ATTEMPTING NEW CAT. 12 INPUT LEVEL NUMBER',I4,' WITH ', - $ 'ILC =',I5,'; NO. LEVELS PROCESSED TO NOW =',I5) - -C LEVEL PRESSURE (STORED AS REAL) - - M = 1 - IF(IPRINT.GT.1) PRINT 199, UAIR(1,I),M - 199 FORMAT(5X,'UAIR HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(I.EQ.1) THEN - PSFC = UAIR(1,I) * 0.1 - ELSE IF(UAIR(1,I)*0.1.GE.YMSG) THEN -C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THERE IS NO VALID PRESSURE -C -- GO ON TO NEXT INPUT LEVEL (IF SFC LEVEL MSG, CONTINUE PROCESSING) - IF(IPRINT.GT.1) PRINT *, 'PRESSURE MISSING ON INPUT', - $ ' LEVEL ',I,', SKIP THE PROCESSING OF THIS LEVEL' - GO TO 10 - ELSE IF(UAIR(1,I)*0.1.GE.PSFC) THEN -C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THE INPUT LEVEL PRESSURE -C IS BELOW THE SURFACE PRESSURE -- GO ON TO THE NEXT INPUT LEVEL - IF(IPRINT.GT.1) PRINT *,'PRESSURE ON INPUT LEVEL ',I, - $ ' IS BELOW GROUND, SKIP THE PROCESSING OF THIS LEVEL' - GO TO 10 - END IF - -C WE HAVE A VALID CATEGORY 12 LEVEL -- THERE IS A VALID PRESSURE - - IF(UAIR(1,I)*0.1.LT.XMSG) RDATX(43+ILC) = NINT(UAIR(1,I)*0.1) - ILVL = ILVL + 1 - IF(IPRINT.GT.1) PRINT 198, 43+ILC,RDATX(43+ILC) - 198 FORMAT(5X,'RDATA(',I5,') STORED AS: ',F10.2) - -C GEOPOTENTIAL HEIGHT (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 199, UAIR(2,I),M - IF(UAIR(2,I).LT.XMSG) RDATX(43+ILC+1) = NINT(UAIR(2,I)) - IF(IPRINT.GT.1) PRINT 198, 43+ILC+1,RDATX(43+ILC+1) - IF(I.EQ.1) THEN - IF(IPRINT.GT.1) PRINT *, 'THIS IS SURFACE LEVEL, SO ', - $ 'STORE HEIGHT ALSO AS ELEVATION IN HEADER' - IF(UAIR(2,1).LT.XMSG) RDATX(7) = NINT(UAIR(2,1)) - NNNNN = 7 - IF(IPRINT.GT.1) PRINT 198, NNNNN,RDATX(NNNNN) - END IF - -C TEMPERATURE (STORED AS REAL) - - M = 3 - IF(IPRINT.GT.1) PRINT 199, UAIR(3,I),M - ITMP = NINT(UAIR(3,I)*100.) - IF(UAIR(3,I).LT.XMSG) - $ RDATX(43+ILC+2) = NINT((ITMP - 27315) * 0.1) - IF(IPRINT.GT.1) PRINT 198, 43+ILC+2,RDATX(43+ILC+2) - -C DEWPOINT TEMPERATURE (STORED AS REAL) - - M = 4 - IF(IPRINT.GT.1) PRINT 199, UAIR(4,I),M - ITMP = NINT(UAIR(4,I)*100.) - IF(UAIR(4,I).LT.XMSG) - $ RDATX(43+ILC+3) = NINT((ITMP - 27315) * 0.1) - IF(IPRINT.GT.1) PRINT 198, 43+ILC+3,RDATX(43+ILC+3) - -C QUALITY MARKERS (STORED AS CHARACTER) - - COB = CQMFLG//CQMFLG//CQMFLG//' ' - IDATA(43+ILC+6) = IOB - IF(IPRINT.GT.1) PRINT 196, 43+ILC+6,COB(1:4) - 196 FORMAT(5X,'IDATA(',I5,') STORED IN CHARACTER AS: "',A4,'"') -C....................................................................... - ILC = ILC + 7 - IF(I+1.LE.NLEV.AND.IPRINT.GT.1) PRINT *,'HAVE COMPLETED ', - $ 'LEVEL ',ILVL,'; GOING INTO NEXT LEVEL WITH ILC=',ILC - - 10 CONTINUE - ENDDO - -C SET CATEGORY COUNTERS FOR CATEGORY 12 (SOUNDING) DATA - - IDATA(39) = ILVL - 98 CONTINUE - IF(IPRINT.GT.1) PRINT *, IDATA(39),' CAT. 12 LEVELS PROCESSED' - IF(IDATA(39).GT.0) IDATA(40) = 43 - -C*********************************************************************** -C FILL CATEGORY 8 PART OF OUTPUT -C WILL ATTEMPT TO FILL 12 "LEVELS" -C LVL 1- LIFTED INDEX (DEG. K X 100 - RELATIVE) -------- CODE FIG. 250. -C LVL 2- TOTAL COLUMN PRECIPITABLE WATER (MM X 100) ---- CODE FIG. 251. -C LVL 3- 1. TO .9 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 252. -C LVL 4- .9 TO .7 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 253. -C LVL 5- .7 TO .3 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 254. -C LVL 6- SKIN TEMPERATURE (DEG. K X 100) --------------- CODE FIG. 255. -C LVL 7- CLOUD TOP TEMPERATURE (DEG. K X 100) ---------- CODE FIG. 256. -C LVL 8- CLOUD TOP PRESSURE (MB X 10) ------------------ CODE FIG. 257. -C LVL 9- CLOUD AMOUNT (C. FIG. BUFR TABLE 0-20-011) ---- CODE FIG. 258. -C LVL 10- INSTR. DATA USED IN PROC. -C (C. FIG. BUFR TABLE 0-02-021) --- CODE FIG. 259. -C LVL 11- SOLAR ZENITH ANGLE (SOLAR ELEV) (DEG. X 100) -- CODE FIG. 260. -C LVL 12- SATELLITE ZENITH ANGLE (ELEV) (DEG. X 100) --- CODE FIG. 261. -C -C IF DATA ONE ANY LEVEL ARE MISSING, THAT LEVEL IS NOT PROCESSED -C*********************************************************************** - - ILVL = 0 - ILC = 0 - CAT8_8 = 10.0E10 - CALL UFBINT(LUNIT,CAT8_8,12,1,NLEV8,CAT8A//CAT8B);CAT8=CAT8_8 - IF(NLEV8.NE.1) THEN - IF(NLEV8.EQ.0) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- - PRINT 318 - 318 FORMAT(/' ##W3UNPK77: NO ADDITIONAL (CAT. 8) DATA PROCESSED FOR ', - $ 'THIS REPORT -- NLEV8 = 0'/) - GO TO 99 -C....................................................................... - ELSE -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED -- -C SET IRET = 7 AND RETURN - PRINT 219, NLEV8 - 219 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',I5,') ', - $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 7'/) - IRET = 7 - RETURN -C....................................................................... - END IF - END IF - -C THE TEMPERATURE CHANNEL SELECTION FLAG WILL BE USED LATER TO -C DETERMINE Q. MARK FOR SKIN TEMPERATURE (IF 0 - OK, OTHERWISE - BAD) - - RTCSF_8 = 10.0E10 - CALL UFBINT(LUNIT,RTCSF_8,1,1,NLEV0,'TCSF');RTCSF=RTCSF_8 - ITCSF = 1 - M = 1 - IF(IPRINT.GT.1) PRINT 299, RTCSF,M - 299 FORMAT(5X,'RTCSF HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(RTCSF.LT.XMSG) ITCSF = NINT(RTCSF) - IF(IPRINT.GT.1) PRINT 1798, ITCSF - 1798 FORMAT(5X,'ITCSF IS: ',I10) - -C LOOP THROUGH THE 12 POSSIBLE ADDITIONAL DATA - - DO M = 1,12 - IF(IPRINT.GT.1) PRINT 6079, M,ILC,ILVL - 6079 FORMAT(' ATTEMPTING MISCEL. INPUT',I5,' WITH ILC =',I5,'; NO. ', - $ 'OUTPUT CAT. 8 LVLS PROCESSED TO NOW =',I5) - IF(IPRINT.GT.1) PRINT 399, CAT8(M),M - 399 FORMAT(5X,'CAT8 HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(CAT8(M).LT.XMSG) THEN - -C WE HAVE A VALID CATEGORY 8 "LEVEL" - - ILVL = ILVL + 1 - -C STORE THE DATUM IN WORD 1 OF THE CAT. 8 LEVEL - - RDATX(393+ILC) = NINT(CAT8(M) * SC8(M)) - IF(IPRINT.GT.1) PRINT 198, 393+ILC,RDATX(393+ILC) - -C STORE THE CAT. 8 CODE FIGURE IN WORD 2 OF THE CAT. 8 LEVEL - - RDATX(393+ILC+1) = REAL(200+ICDFG(M)) - IF(IPRINT.GT.1) PRINT 198, 393+ILC+1,RDATX(393+ILC+1) - -C STORE THE QUALITY MARKER IN BYTE 1 OF WORD 3 OF THE CAT. 8 LEVEL - - COB = CQMFLG//' ' - -C IF THIS DATUM IS SKIN TEMPERATURE AND THE TEMPERATURE CHANNEL -C SELECTION FLAG IS BAD (.NE. 0), SET QUALITY MARKER TO "F" - - IF(M.EQ.6.AND.ITCSF.NE.0) COB(1:1) = 'F' - IDATA(393+ILC+2) = IOB - IF(IPRINT.GT.1) PRINT 196, 393+ILC+2,COB(1:4) - ILC = ILC + 3 - IF(M.LT.12.AND.IPRINT.GT.1) PRINT *,'HAVE COMPLETED OUTPUT', - $ ' LVL',ILVL,'; GOING INTO NEXT INPUT DATUM WITH ILC=',ILC - ELSE - IF(IPRINT.GT.1) PRINT *, 'DATUM MISSING ON INPUT ',M, - $ ', GO ON TO NEXT INPUT DATUM (NO. LVLS PROCESSED SO ', - $ 'FAR=',ILVL,'; ILC=',ILC,')' - END IF - ENDDO - -C SET CATEGORY COUNTERS FOR CATEGORY 8 (ADDITIONAL) DATA - - IDATA(27) = ILVL - 99 CONTINUE - IF(IPRINT.GT.1) PRINT *, IDATA(27),' CAT. 08 LEVELS PROCESSED' - IF(IDATA(27).GT.0) IDATA(28) = 393 - -C*********************************************************************** -C FILL CATEGORY 13 PART OF OUTPUT (RADIANCES) -C*********************************************************************** - - ILVL = 0 - ILC = 0 - RAD_8 = 10.0E10 - CALL UFBINT(LUNIT,RAD_8,2,255,NLEV13,RAD1);RAD=RAD_8 - IF(NLEV13.EQ.0) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO -- - PRINT 417 - 417 FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ', - $ 'REPORT -- NLEV13 = 0'/) - GO TO 100 - ELSE IF(NLEV13.GT.60) THEN -C....................................................................... -C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 60 -- - PRINT 418 - 418 FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ', - $ 'REPORT -- NLEV13 > 60'/) - GO TO 100 -C....................................................................... - END IF - IF(IPRINT.GT.1) PRINT 2068, NLEV13 - 2068 FORMAT(' THIS REPORT CONTAINS',I4,' INPUT LEVELS (CHANNELS) OF ', - $ 'RADIANCE DATA') - DO I = 1,NLEV13 - IF(IPRINT.GT.1) PRINT 2079, I,ILC,ILVL - 2079 FORMAT(' ATTEMPTING NEW CAT. 13 INPUT "LEVEL" NUMBER',I4,' WITH ', - $ 'ILC =',I5,'; NO. LEVELS (CHANNELS) PROCESSED TO NOW =',I5) - -C CHANNEL NUMBER (STORED AS INTEGER) - - M = 1 - IF(IPRINT.GT.1) PRINT 499, RAD(1,I),M - 499 FORMAT(5X,'RAD HERE IS: ',F17.4,'; INDEX IS: ',I3) - IF(RAD(1,I).GE.YMSG) THEN -C WE DO NOT HAVE A VALID CATEGORY 13 LEVEL -- THERE IS NO VALID CHANNEL -C NUMBER -- GO ON TO NEXT INPUT LEVEL - IF(IPRINT.GT.1) PRINT *, 'CHANNEL NUMBER MISSING ON INPUT', - $ ' LEVEL ',I,', SKIP THE PROCESSING OF THIS LEVEL' - GO TO 210 - END IF - -C WE HAVE A VALID CATEGORY 13 LEVEL -- THERE IS A VALID CHANNEL NUMBER - - IDATA(429+ILC) = NINT(RAD(1,I)) - ILVL = ILVL + 1 - IF(IPRINT.GT.1) PRINT 197, 429+ILC,IDATA(429+ILC) - 197 FORMAT(5X,'IDATA(',I5,') STORED AS: ',I10) - -C BRIGHTNESS TEMPERATURE (STORED AS REAL) - - M = 2 - IF(IPRINT.GT.1) PRINT 499, RAD(2,I),M - IF(RAD(2,I).LT.XMSG) RDATX(429+ILC+1) = NINT(RAD(2,I) * 100.) - IF(IPRINT.GT.1) PRINT 198, 429+ILC+1,RDATX(429+ILC+1) - -C QUALITY MARKERS (STORED AS CHARACTER) - - COB = ' ' - IDATA(429+ILC+2) = IOB - IF(IPRINT.GT.1) PRINT 196, 429+ILC+2,COB(1:4) -C....................................................................... - ILC = ILC + 3 - IF(I+1.LE.NLEV13.AND.IPRINT.GT.1) PRINT *,'HAVE COMPLETED ', - $ 'LEVEL ',ILVL,'; GOING INTO NEXT LEVEL WITH ILC=',ILC - - 210 CONTINUE - ENDDO - -C SET CATEGORY COUNTERS FOR CATEGORY 13 (RADIANCE) DATA - - IDATA(41) = ILVL - 100 CONTINUE - IF(IPRINT.GT.1) PRINT *, IDATA(41),' CAT. 13 LEVELS PROCESSED' - IF(IDATA(41).GT.0) IDATA(42) = 429 - - IF(IDATA(27)+IDATA(39)+IDATA(41).EQ.0) IRET = 5 - - IF(IPRINT.GT.1) PRINT *,'IDATA(39)=',IDATA(39),'; IDATA(40)=', - $ IDATA(40),'; IDATA(27)=',IDATA(27),'; IDATA(28)=',IDATA(28), - $ '; IDATA(41)=',IDATA(41),'; IDATA(42)=',IDATA(42) - - RDATA(1:1200) = RDATX(1:1200) - RETURN - END diff --git a/external/w3nco/v2.0.6/src/w3utcdat.f b/external/w3nco/v2.0.6/src/w3utcdat.f deleted file mode 100644 index 600f573b..00000000 --- a/external/w3nco/v2.0.6/src/w3utcdat.f +++ /dev/null @@ -1,67 +0,0 @@ -!----------------------------------------------------------------------- - subroutine w3utcdat(idat) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3UTCDAT RETURN THE UTC DATE AND TIME -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS SUBPROGRAM RETURNS THE UTC (GREENWICH) DATE AND TIME -! IN THE NCEP ABSOLUTE DATE AND TIME DATA STRUCTURE. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! 1999-04-28 Gilbert - added a patch to check for the proper -! UTC offset. Needed until the IBM bug -! in date_and_time is fixed. The patch -! can then be removed. See comments in -! the section blocked with "&&&&&&&&&&&". -! 1999-08-12 Gilbert - Changed so that czone variable is saved -! and the system call is only done for -! first invocation of this routine. -! -! USAGE: CALL W3UTCDAT(IDAT) -! -! OUTPUT VARIABLES: -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! SUBPROGRAMS CALLED: -! DATE_AND_TIME FORTRAN 90 SYSTEM DATE INTRINSIC -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer idat(8) - character cdate*8,ctime*10,czone*5 -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! get local date and time but use the character time zone - call date_and_time(cdate,ctime,czone,idat) - read(czone,'(i5)') idat(4) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! convert to hours and minutes to UTC time -! and possibly adjust the date as well - idat(6)=idat(6)-mod(idat(4),100) - idat(5)=idat(5)-idat(4)/100 - idat(4)=0 - if(idat(6).lt.00) then - idat(6)=idat(6)+60 - idat(5)=idat(5)-1 - elseif(idat(6).ge.60) then - idat(6)=idat(6)-60 - idat(5)=idat(5)+1 - endif - if(idat(5).lt.00) then - idat(5)=idat(5)+24 - jldayn=iw3jdn(idat(1),idat(2),idat(3))-1 - call w3fs26(jldayn,idat(1),idat(2),idat(3),idaywk,idayyr) - elseif(idat(5).ge.24) then - idat(5)=idat(5)-24 - jldayn=iw3jdn(idat(1),idat(2),idat(3))+1 - call w3fs26(jldayn,idat(1),idat(2),idat(3),idaywk,idayyr) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/external/w3nco/v2.0.6/src/w3valdat.f b/external/w3nco/v2.0.6/src/w3valdat.f deleted file mode 100644 index 6fa99f31..00000000 --- a/external/w3nco/v2.0.6/src/w3valdat.f +++ /dev/null @@ -1,50 +0,0 @@ -!----------------------------------------------------------------------- - logical function w3valdat(idat) -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! -! SUBPROGRAM: W3VALDAT DETERMINE THE VALIDITY OF A DATE AND TIME -! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 -! -! ABSTRACT: THIS LOGICAL FUNCTION RETURNS TRUE IF THE INPUT IS A VALID -! NCEP ABSOLUTE DATE AND TIME. -! -! PROGRAM HISTORY LOG: -! 98-01-05 MARK IREDELL -! -! USAGE: ...=W3VALDAT(IDAT) -! -! INPUT VARIABLES: -! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME -! (YEAR, MONTH, DAY, TIME ZONE, -! HOUR, MINUTE, SECOND, MILLISECOND) -! -! OUTPUT VARIABLES: -! W3VALDAT LOGICAL TRUE IF IDAT IS A VALID NCEP DATE AND TIME -! -! SUBPROGRAMS CALLED: -! IW3JDN COMPUTE JULIAN DAY NUMBER -! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER -! W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! -!$$$ - integer idat(8) - real rinc1(5),rinc2(5) - integer jdat(8) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! essentially move the date and time by a zero time interval -! and see if the same date and time is returned - rinc1(1)=0 - rinc1(2:5)=idat(5:8) - call w3reddat(-1,rinc1,rinc2) - jldayn=iw3jdn(idat(1),idat(2),idat(3))+nint(rinc2(1)) - call w3fs26(jldayn,jdat(1),jdat(2),jdat(3),jdow,jdoy) -! the time zone is valid if it is in signed hhmm format -! with hh between -23 and 23 and mm equal to 00 or 30 - jdat(4)=mod(idat(4)/100,24)*100+mod(mod(idat(4),100),60)/30*30 - jdat(5:8)=nint(rinc2(2:5)) - w3valdat=all(idat.eq.jdat) -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end diff --git a/external/w3nco/v2.0.6/src/w3ymdh4.f b/external/w3nco/v2.0.6/src/w3ymdh4.f deleted file mode 100644 index 44a0f788..00000000 --- a/external/w3nco/v2.0.6/src/w3ymdh4.f +++ /dev/null @@ -1,119 +0,0 @@ - SUBROUTINE W3YMDH4 (IDATE,IYEAR,MONTH,IDAY,IHOUR,NN) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: W3YMDH4 4-BYTE DATE WORD UNPACKER AND PACKER -C AUTHOR: Brill,K.F. ORG: NP/22 DATE: 98-07-29 -C -C ABSTRACT: OBTAINS THE COMPONENTS OF THE NMC DATE WORD (NCEP Y2K -C COMPLIANT FORM), OR GIVEN ITS COMPONENTS, FORMS AN NMC TYPE DATE -C WORD. THE PACKING IS DONE USING BASE 32. -C -C If the first byte of IDATE is less than 101, then the old -C Office Note 84 packing is assumed. A four-digit year is -C always returned. To pack the "old" way, pass in a 2-digit -C year. -C -C This program will work for the years ranging from A.D. 101 -C through 79359. -C -C On unpacking, years less than or equal to 100 are returned -C as follows: -C -C 0-50 2000--2050 -C 51-100 1951--2000 -C -C -C PROGRAM HISTORY LOG: -C 98-07-29 K.F.BRILL -C 1999-03-15 Gilbert - Removed Call to W3FS11 and put its -C processing inline. W3FS11 was deleted -C from the W3LIB. -C -C USAGE: CALL W3YMDH4 (IDATE, IYEAR, MONTH, IDAY, IHOUR, NN) -C -C INPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IDATE ARG LIST LEFT 4 BYTES OF INTEGER 64 BIT WORD, OR CAN BE -C CHARACTER*1 IDATE(4) OR CHARACTER*4 IDATE. -C IYEAR ARG LIST INTEGER YEAR (4 DIGITS or 2 DIGITS for ON84) -C MONTH ARG LIST INTEGER MONTH -C IDAY ARG LIST INTEGER DAY -C IHOUR ARG LIST INTEGER HOUR -C NN ARG LIST INTEGER CODE: -C .EQ. 0 PACK IYEAR, MONTH, IDAY, IHOUR INTO IDATE -C .NE. 0 UNPACK IDATE INTO IYEAR, MONTH, IDAY, IHOUR -C -C OUTPUT VARIABLES: -C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES -C ------ --------- ----------------------------------------------- -C IDATE ARG LIST LEFT 4 BYTES OF INTEGER 64 BIT WORD, OR CAN BE -C CHARACTER*1 IDATE(4) OR CHARACTER*4 IDATE. -C IYEAR ARG LIST INTEGER YEAR (4 DIGITS) -C MONTH ARG LIST INTEGER MONTH -C IDAY ARG LIST INTEGER DAY -C IHOUR ARG LIST INTEGER HOUR -C -C SUBROGRAMS CALLED: -C NAMES LIBRARY -C ------------------------------------------------------- -------- -C CHAR F90 -C MOVA2I W3 -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT90 FORTRAN -C MACHINE: CRAY Y-MP8/832 -C -C$$$ -C - CHARACTER IDATE(4) -C - IF (NN.NE.0) THEN -C - ITEMP = MOVA2I(IDATE(1)) - IF ( ITEMP .lt. 101 ) THEN - IYEAR = MOVA2I(IDATE(1)) - MONTH = MOVA2I(IDATE(2)) - IDAY = MOVA2I(IDATE(3)) - IHOUR = MOVA2I(IDATE(4)) - IF(IYEAR.LE.100) IYEAR=2050-MOD(2050-IYEAR,100) - RETURN - END IF - ITEMP = ITEMP - 101 - ITEMP = ITEMP * 256 + MOVA2I(IDATE(2)) - ITEMP = ITEMP * 256 + MOVA2I(IDATE(3)) - ITEMP = ITEMP * 256 + MOVA2I(IDATE(4)) - IHOUR = MOD ( ITEMP, 32 ) - ITEMP = ITEMP / 32 - IDAY = MOD ( ITEMP, 32 ) - ITEMP = ITEMP / 32 - MONTH = MOD ( ITEMP, 32 ) - IYEAR = ITEMP / 32 -C - ELSE -C - ITEMP = IYEAR - IF ( ITEMP .lt. 101 ) THEN - IDATE(1) = CHAR(IYEAR) - IDATE(2) = CHAR(MONTH) - IDATE(3) = CHAR(IDAY) - IDATE(4) = CHAR(IHOUR) - RETURN - END IF - ITEMP = ITEMP * 32 + MONTH - ITEMP = ITEMP * 32 + IDAY - ITEMP = ITEMP * 32 + IHOUR -C* - IDATE(4)=CHAR(MOD(ITEMP,256)) - ITEMP = ITEMP / 256 - IDATE(3)=CHAR(MOD(ITEMP,256)) - ITEMP = ITEMP / 256 - IDATE(2)=CHAR(MOD(ITEMP,256)) - ITEMP = ITEMP / 256 - ITEMP = ITEMP + 101 - IDATE(1)=CHAR(ITEMP) -C - ENDIF -C - RETURN - END diff --git a/external/w3nco/v2.0.6/src/xmovex.f b/external/w3nco/v2.0.6/src/xmovex.f deleted file mode 100644 index 58c0aa08..00000000 --- a/external/w3nco/v2.0.6/src/xmovex.f +++ /dev/null @@ -1,20 +0,0 @@ - SUBROUTINE XMOVEX(OUT,IN,IBYTES) -C -C THIS SUBROUTINE MAY NOT BE NEEDED, ITS WAS IN -C ASSEMBLER LANGUAGE TO MOVE DATA, IT RAN ABOUT THREE -C TIMES FASTER THAN A FORTAN DO LOOP, IT WAS USED TO -C MAKE SURE THE DATA TO BE UNPACKED WAS ON A WORD BOUNDARY, -C THIS MAY NOT BE NEEDED ON SOME BRANDS OF COMPUTERS. -C - CHARACTER*1 OUT(*) - CHARACTER*1 IN(*) -C - INTEGER IBYTES -C - DO 100 I = 1,IBYTES - OUT(I) = IN(I) - 100 CONTINUE -C - RETURN - END - diff --git a/external/w3nco/v2.0.6/src/xstore.f b/external/w3nco/v2.0.6/src/xstore.f deleted file mode 100644 index a23b1f80..00000000 --- a/external/w3nco/v2.0.6/src/xstore.f +++ /dev/null @@ -1,44 +0,0 @@ - SUBROUTINE XSTORE(COUT,CON,MWORDS) -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: XSTORE STORES A CONSTANT VALUE INTO AN ARRAY -C PRGMMR: KEYSER ORG: W/NMC22 DATE: 07-02-92 -C -C ABSTRACT: STORES AN 8-BYTE (FULLWORD) VALUE THROUGH CONSECUTIVE -C STORAGE LOCATIONS. (MOVING IS ACCOMPLISHED WITH A DO LOOP.) -C -C PROGRAM HISTORY LOG: -C 92-07-02 D. A. KEYSER (W/NMC22) -C 95-10-31 IREDELL REMOVED SAVES AND PRINTS -C -C USAGE: CALL XSTORE(COUT,CON,MWORDS) -C INPUT ARGUMENT LIST: -C CON - CONSTANT TO BE STORED INTO "MWORDS" CONSECUTIVE -C FULLWORDS BEGINNING WITH "COUT" ARRAY -C MWORDS - NUMBER OF FULLWORDS IN "COUT" ARRAY TO STORE "CON"; -C MUST BE .GT. ZERO (NOT CHECKED FOR THIS) -C -C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) -C COUT - STARTING ADDRESS FOR ARRAY OF "MWORDS" FULLWORDS -C SET TO THE CONTENTS OF THE VALUE "CON" -C -C REMARKS: THE VERSION OF THIS SUBROUTINE ON THE HDS COMMON LIBRARY -C IS NAS-SPECIFIC SUBR. WRITTEN IN ASSEMBLY LANG. TO ALLOW FAST -C COMPUTATION TIME. SUBR. PLACED IN CRAY W3LIB TO ALLOW CODES TO -C COMPILE ON BOTH THE HDS AND CRAY MACHINES. -C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. -C -C ATTRIBUTES: -C LANGUAGE: CRAY CFT77 FORTRAN -C MACHINE: CRAY Y-MP8/864 -C -C$$$ -C - DIMENSION COUT(*) -C - DO 1000 I = 1,MWORDS - COUT(I) = CON -1000 CONTINUE -C - RETURN - END diff --git a/scm/doc/TechGuide/chap_quick.tex b/scm/doc/TechGuide/chap_quick.tex index 747d9139..aad19321 100644 --- a/scm/doc/TechGuide/chap_quick.tex +++ b/scm/doc/TechGuide/chap_quick.tex @@ -66,12 +66,26 @@ \section{System Requirements, Libraries, and Tools} Because these tools and libraries are typically the purview of system administrators to install and maintain, they are considered part of the basic system requirements. -There are several utility libraries provided in the SCM bundle, as external packages. These are built during the compilation phase, and include +Further, there are several utility libraries as part of the NCEPlibs package that must be installed prior to building the SCM. \begin{itemize} \item bacio - Binary I/O Library \item sp - Spectral Transformation Library \item w3nco - GRIB decoder and encoder library \end{itemize} +These libraries are prebuilt on most NOAA machines using the Intel compiler. For those needing to build the libraries themselves, GMTB recommends using the source code from GitHub at \url{https://github.com/NCAR/NCEPlibs.git}, which includes build files for various compilers and machines using OpenMP flags and which are threadsafe. Instructions for installing NCEPlibs are included on the GitHub repository webpage, but for the sake of example, execute the following for obtaining and building from source in \execout{/usr/local/NCEPlibs} on a Mac: +\begin{lstlisting} + mkdir /usr/local/NCEPlibs + cd /usr/local/src + git clone https://github.com/NCAR/NCEPlibs.git + cd NCEPlibs + ./make_ncep_libs.sh -s macosx -c gnu -d /usr/local/NCEPlibs -o 1 +\end{lstlisting} +Once NCEPlibs is built, the \execout{NCEPLIBS\_DIR} environment variable must be set to the location of the installation. For example, if NCEPlibs was installed in \execout{/usr/local/NCEPlibs}, one would execute +\begin{lstlisting} +export NCEPLIB_DIR=/usr/local/NCEPlibs +\end{lstlisting} +If using Theia or Cheyenne HPC systems, this environment variable is automatically set to an appropriate installation of NCEPlibs on those machines through use of one of the setup scripts described in section \ref{section: compiling}. + \subsection{Compilers} The CCPP and SCM have been tested on a variety of diff --git a/scm/doc/TechGuide/chap_repo.tex b/scm/doc/TechGuide/chap_repo.tex index a1bf7b51..5b5c488d 100644 --- a/scm/doc/TechGuide/chap_repo.tex +++ b/scm/doc/TechGuide/chap_repo.tex @@ -34,10 +34,6 @@ \section{What is included in the repository?} .3 config/\DTcomment{contains the CCPP prebuild config}. .3 suites/\DTcomment{contains suite definition files}. .3 physics\_namelists\DTcomment{contains physics namelist files associated with suites}. - .2 external/. - .3 bacio\DTcomment{NCEP library bacio (needed for GFS physics)}. - .3 sp\DTcomment{NCEP library sp (needed for GFS physics)}. - .3 w3nco\DTcomment{NCEP library w3 (needed for GFS physics and SCM infrastructure)}. .2 scm/. .3 bin/\DTcomment{build directory (initially empty; populated by cmake)}. .3 data/. diff --git a/scm/doc/TechGuide/main.pdf b/scm/doc/TechGuide/main.pdf index 8a816df6..e02ffc86 100644 Binary files a/scm/doc/TechGuide/main.pdf and b/scm/doc/TechGuide/main.pdf differ diff --git a/scm/etc/Cheyenne_setup_gnu.csh b/scm/etc/Cheyenne_setup_gnu.csh index a4904486..733e34d9 100755 --- a/scm/etc/Cheyenne_setup_gnu.csh +++ b/scm/etc/Cheyenne_setup_gnu.csh @@ -16,6 +16,10 @@ setenv CC gcc setenv CXX g++ setenv FC gfortran +echo "Setting NCEPLIBS_DIR environment variable" +set NCEPLIBS_DIR = "/glade/p/ral/jntp/GMTB/tools/NCEPlibs/20190307/gnu-8.1.0/mpt-2.19" +setenv NCEPLIBS_DIR $NCEPLIBS_DIR + #install f90nml for the local user #check to see if f90nml is installed locally diff --git a/scm/etc/Cheyenne_setup_gnu.sh b/scm/etc/Cheyenne_setup_gnu.sh index 7ab38409..a0491922 100755 --- a/scm/etc/Cheyenne_setup_gnu.sh +++ b/scm/etc/Cheyenne_setup_gnu.sh @@ -17,6 +17,11 @@ export CC=gcc export CXX=g++ export FC=gfortran +echo "Setting NCEPLIBS_DIR environment variable" +NCEPLIBS_DIR=/glade/p/ral/jntp/GMTB/tools/NCEPlibs/20190307/gnu-8.1.0/mpt-2.19 +export NCEPLIBS_DIR=$NCEPLIBS_DIR + + #install f90nml for the local user #check to see if f90nml is installed locally diff --git a/scm/etc/Cheyenne_setup_intel.csh b/scm/etc/Cheyenne_setup_intel.csh index 3ff00f1b..7e5d678b 100755 --- a/scm/etc/Cheyenne_setup_intel.csh +++ b/scm/etc/Cheyenne_setup_intel.csh @@ -16,6 +16,10 @@ setenv CC icc setenv CXX icpc setenv FC ifort +echo "Setting NCEPLIBS_DIR environment variable" +set NCEPLIBS_DIR = "/glade/p/ral/jntp/GMTB/tools/NCEPlibs/20190307/intel-19.0.2/mpt-2.19" +setenv NCEPLIBS_DIR $NCEPLIBS_DIR + #install f90nml for the local user #check to see if f90nml is installed locally diff --git a/scm/etc/Cheyenne_setup_intel.sh b/scm/etc/Cheyenne_setup_intel.sh index e7c83453..4960e64c 100755 --- a/scm/etc/Cheyenne_setup_intel.sh +++ b/scm/etc/Cheyenne_setup_intel.sh @@ -16,6 +16,10 @@ export CC=icc export CXX=icpc export FC=ifort +echo "Setting NCEPLIBS_DIR environment variable" +NCEPLIBS_DIR=/glade/p/ral/jntp/GMTB/tools/NCEPlibs/20190307/intel-19.0.2/mpt-2.19 +export NCEPLIBS_DIR=$NCEPLIBS_DIR + #install f90nml for the local user #check to see if f90nml is installed locally diff --git a/scm/etc/Cheyenne_setup_pgi.csh b/scm/etc/Cheyenne_setup_pgi.csh index 085da017..767666b2 100755 --- a/scm/etc/Cheyenne_setup_pgi.csh +++ b/scm/etc/Cheyenne_setup_pgi.csh @@ -15,6 +15,10 @@ setenv CC pgcc setenv CXX pgc++ setenv FC pgf90 +echo "Setting NCEPLIBS_DIR environment variable" +set NCEPLIBS_DIR = "/glade/p/ral/jntp/GMTB/tools/NCEPlibs/20190307/pgi-17.9/mpt-2.19" +setenv NCEPLIBS_DIR $NCEPLIBS_DIR + #install f90nml for the local user #check to see if f90nml is installed locally diff --git a/scm/etc/Cheyenne_setup_pgi.sh b/scm/etc/Cheyenne_setup_pgi.sh index 66647f8c..bb87ee22 100755 --- a/scm/etc/Cheyenne_setup_pgi.sh +++ b/scm/etc/Cheyenne_setup_pgi.sh @@ -15,6 +15,10 @@ export CC=pgcc export CXX=pgc++ export FC=pgf90 +echo "Setting NCEPLIBS_DIR environment variable" +NCEPLIBS_DIR=/glade/p/ral/jntp/GMTB/tools/NCEPlibs/20190307/pgi-17.9/mpt-2.19 +export NCEPLIBS_DIR=$NCEPLIBS_DIR + #install f90nml for the local user #check to see if f90nml is installed locally diff --git a/scm/etc/Theia_setup_gnu.csh b/scm/etc/Theia_setup_gnu.csh index 2fbcde17..d0915dae 100755 --- a/scm/etc/Theia_setup_gnu.csh +++ b/scm/etc/Theia_setup_gnu.csh @@ -26,6 +26,10 @@ setenv CC gcc setenv CXX g++ setenv FC gfortran +echo "Setting NCEPLIBS_DIR environment variable" +set NCEPLIBS_DIR = "/scratch4/home/Dom.Heinzeller/NEMSfv3gfs_vlab_portability/NCEPlibs-gnu-20181105" +setenv NCEPLIBS_DIR $NCEPLIBS_DIR + #prepend the anaconda installation to the path so that the anaconda version of python (with its many installed modules) is used; check if the path already contains the right path first echo "Checking if the path to the anaconda python distribution is in PATH" echo $PATH | grep '/contrib/ananconda/2.3.0/bin$' >&/dev/null diff --git a/scm/etc/Theia_setup_gnu.sh b/scm/etc/Theia_setup_gnu.sh index b21aa0e2..cc898ca1 100755 --- a/scm/etc/Theia_setup_gnu.sh +++ b/scm/etc/Theia_setup_gnu.sh @@ -17,6 +17,10 @@ export CC=gcc export CXX=g++ export FC=gfortran +echo "Setting NCEPLIBS_DIR environment variable" +NCEPLIBS_DIR=/scratch4/home/Dom.Heinzeller/NEMSfv3gfs_vlab_portability/NCEPlibs-gnu-20181105 +export NCEPLIBS_DIR=$NCEPLIBS_DIR + #prepend the anaconda installation to the path so that the anaconda version of python (with its many installed modules) is used; check if the path already contains the right path first echo "Checking if the path to the anaconda python distribution is in PATH" echo $PATH | grep '/contrib/ananconda/2.3.0/bin$' >&/dev/null diff --git a/scm/etc/Theia_setup_intel.csh b/scm/etc/Theia_setup_intel.csh index e56150fd..5649c1bc 100755 --- a/scm/etc/Theia_setup_intel.csh +++ b/scm/etc/Theia_setup_intel.csh @@ -13,6 +13,10 @@ setenv CC icc setenv CXX icpc setenv FC ifort +echo "Setting NCEPLIBS_DIR environment variable" +set NCEPLIBS_DIR = "/scratch4/home/Dom.Heinzeller/NEMSfv3gfs_vlab_portability/NCEPlibs-intel-18.1.163-20181105" +setenv NCEPLIBS_DIR $NCEPLIBS_DIR + #prepend the anaconda installation to the path so that the anaconda version of python (with its many installed modules) is used; check if the path already contains the right path first echo "Checking if the path to the anaconda python distribution is in PATH" echo $PATH | grep '/contrib/ananconda/2.3.0/bin$' >&/dev/null diff --git a/scm/etc/Theia_setup_intel.sh b/scm/etc/Theia_setup_intel.sh index a014760d..d0d72dba 100755 --- a/scm/etc/Theia_setup_intel.sh +++ b/scm/etc/Theia_setup_intel.sh @@ -13,6 +13,10 @@ export CC=icc export CXX=icpc export FC=ifort +echo "Setting NCEPLIBS_DIR environment variable" +NCEPLIBS_DIR=/scratch4/home/Dom.Heinzeller/NEMSfv3gfs_vlab_portability/NCEPlibs-intel-18.1.163-20181105 +export NCEPLIBS_DIR=$NCEPLIBS_DIR + #prepend the anaconda installation to the path so that the anaconda version of python (with its many installed modules) is used; check if the path already contains the right path first echo "Checking if the path to the anaconda python distribution is in PATH" echo $PATH | grep '/contrib/ananconda/2.3.0/bin$' >&/dev/null diff --git a/scm/etc/Theia_setup_pgi.csh b/scm/etc/Theia_setup_pgi.csh index c05df182..505eb8cb 100755 --- a/scm/etc/Theia_setup_pgi.csh +++ b/scm/etc/Theia_setup_pgi.csh @@ -13,6 +13,10 @@ setenv CC pgcc setenv CXX pgc++ setenv FC pgf90 +echo "Setting NCEPLIBS_DIR environment variable" +set NCEPLIBS_DIR = "/scratch4/home/Dom.Heinzeller/NEMSfv3gfs_vlab_portability/NCEPlibs-pgi-20181105" +setenv NCEPLIBS_DIR $NCEPLIBS_DIR + #prepend the anaconda installation to the path so that the anaconda version of python (with its many installed modules) is used; check if the path already contains the right path first echo "Checking if the path to the anaconda python distribution is in PATH" echo $PATH | grep '/contrib/ananconda/2.3.0/bin$' >&/dev/null diff --git a/scm/etc/Theia_setup_pgi.sh b/scm/etc/Theia_setup_pgi.sh index 2c025a77..a9303d87 100755 --- a/scm/etc/Theia_setup_pgi.sh +++ b/scm/etc/Theia_setup_pgi.sh @@ -13,6 +13,10 @@ export CC=pgcc export CXX=pgc++ export FC=pgf90 +echo "Setting NCEPLIBS_DIR environment variable" +NCEPLIBS_DIR=/scratch4/home/Dom.Heinzeller/NEMSfv3gfs_vlab_portability/NCEPlibs-pgi-20181105 +export NCEPLIBS_DIR=$NCEPLIBS_DIR + #prepend the anaconda installation to the path so that the anaconda version of python (with its many installed modules) is used; check if the path already contains the right path first echo "Checking if the path to the anaconda python distribution is in PATH" echo $PATH | grep '/contrib/ananconda/2.3.0/bin$' >&/dev/null diff --git a/scm/src/CMakeLists.txt b/scm/src/CMakeLists.txt index f7e8cc97..e6933747 100644 --- a/scm/src/CMakeLists.txt +++ b/scm/src/CMakeLists.txt @@ -14,6 +14,19 @@ ELSE(DEFINED ENV{NETCDF}) MESSAGE(FATAL_ERROR "The NETCDF environement variable must be set to point to your NetCDF installation before building. Stopping...") ENDIF(DEFINED ENV{NETCDF}) +IF(DEFINED ENV{NCEPLIBS_DIR}) + MESSAGE("The NCEPLIBS_DIR env. variable is $ENV{NCEPLIBS_DIR}") + set(NCEPLIBS_DIR $ENV{NCEPLIBS_DIR}) +ELSE(DEFINED ENV{NCEPLIBS_DIR}) + MESSAGE(FATAL_ERROR "The NCEPLIBS_DIR environment variable must be set to point to your NCEPlibs installation before building. Stopping...") +ENDIF(DEFINED ENV{NCEPLIBS_DIR}) + +set(BACIO_LIB4 ${NCEPLIBS_DIR}/lib/libbacio_4.a) +set(SP_LIBd ${NCEPLIBS_DIR}/lib/libsp_v2.0.2_d.a) +set(W3NCO_LIBd ${NCEPLIBS_DIR}/lib/libw3nco_d.a) + +set(STATIC false) + SET(CCPP_SRC ${CMAKE_SOURCE_DIR}/../../ccpp/framework) SET(GFSPHYSICS_SRC ${CMAKE_SOURCE_DIR}/../../ccpp/physics)