diff --git a/ver-2.10.0/aea_8f.html b/ver-2.10.0/aea_8f.html new file mode 100644 index 00000000..8c1770c1 --- /dev/null +++ b/ver-2.10.0/aea_8f.html @@ -0,0 +1,207 @@ + + + + + + + +NCEPLIBS-w3emc: aea.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
aea.f File Reference
+
+
+ +

This subroutine converts ascii to ebcdic, or ebcdic to ascii. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine aea (IA, IE, NC)
 Program history log: More...
 
+

Detailed Description

+

This subroutine converts ascii to ebcdic, or ebcdic to ascii.

+
Author
desmarais
+
Date
11-29-1982
+ +

Definition in file aea.f.

+

Function/Subroutine Documentation

+ +

◆ aea()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
subroutine aea (character*1, dimension(*) IA,
character*1, dimension(*) IE,
 NC 
)
+
+ +

Program history log:

+
    +
  • 11-29-1982 Desmarais
    • +
  • 03-31-1988 R. E. Jones
      +
    • change logic so it works like a ibm370 translate instruction.
      • +
    +
    • +
  • 08-22-1988 R. E. Jones
      +
    • changes for microsoft fortran 4.10
      • +
    +
    • +
  • 09-04-1988 R. E. Jones
      +
    • change tables to 128 character set
      • +
    +
    • +
  • 01-31-1990 R. E. Jones
      +
    • convert to cray cft77 fortran cray does not allow char*1 to be set to hex
      • +
    +
    • +
  • 12-21-1998 Stephen Gilbert
      +
    • replaced function ichar with mova2i.
      • +
    +
    • +
+
Parameters
+ + + + +
[in,out]IAcharacter*1 array of ascii data if nc < 0
[in,out]IEcharacter*1 array of ebcdic data if nc > 0
[in]NCinteger, contains character count to convert.
    +
  • if nc .lt. 0, convert ascii to ebcdic
    • +
  • if nc .gt. 0, convert ebcdic to ascii
    • +
+
+
+
+
Note
This subroutine can be replaced by cray utility subroutines uscctc and uscctt. See manual sr-2079 page 3-15. Cray utility tr can also be used for ascii, ebcdic conversion. See manual sr-2079 page 9-35.
+
+Software version of ibm370 translate instruction, by changing the two tables we could do a 64, 96, 128 ascii character set, change lower case to upper, etc.
    +
  • aea() converts data at a rate of 1.5 million characters per sec.
    • +
  • cray utility usccti convert ibm ebcdic to ascii
    • +
  • cray utility uscctc convert ascii to ibm ebcdic
    • +
  • they convert data at a rate of 2.1 million characters per sec.
    • +
  • cray utility tr will also do a ascii, ebcdic conversion. tr convert data at a rate of 5.4 million characters per sec. tr is in library /usr/lib/libcos.a add to segldr card.
    • +
+
+
Author
desmarais
+
Date
11-29-1982
+ +

Definition at line 41 of file aea.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/aea_8f.js b/ver-2.10.0/aea_8f.js new file mode 100644 index 00000000..bcdecc09 --- /dev/null +++ b/ver-2.10.0/aea_8f.js @@ -0,0 +1,4 @@ +var aea_8f = +[ + [ "aea", "aea_8f.html#a9c58c678406a71b9db512ab40864666c", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/aea_8f_source.html b/ver-2.10.0/aea_8f_source.html new file mode 100644 index 00000000..475f67a5 --- /dev/null +++ b/ver-2.10.0/aea_8f_source.html @@ -0,0 +1,210 @@ + + + + + + + +NCEPLIBS-w3emc: aea.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
aea.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief This subroutine converts ascii to ebcdic, or ebcdic to ascii
+
3 C> @author desmarais @date 11-29-1982
+
4 
+
5 C> Program history log:
+
6 C> - 11-29-1982 Desmarais
+
7 C> - 03-31-1988 R. E. Jones
+
8 C> - change logic so it works like a ibm370 translate instruction.
+
9 C> - 08-22-1988 R. E. Jones
+
10 C> - changes for microsoft fortran 4.10
+
11 C> - 09-04-1988 R. E. Jones
+
12 C> - change tables to 128 character set
+
13 C> - 01-31-1990 R. E. Jones
+
14 C> - convert to cray cft77 fortran cray does not allow char*1 to be set to hex
+
15 C> - 12-21-1998 Stephen Gilbert
+
16 C> - replaced function ichar with mova2i.
+
17 C>
+
18 C> @param[in, out] IA character*1 array of ascii data if nc < 0
+
19 C> @param[in, out] IE character*1 array of ebcdic data if nc > 0
+
20 C> @param[in] NC integer, contains character count to convert.
+
21 C> - if nc .lt. 0, convert ascii to ebcdic
+
22 C> - if nc .gt. 0, convert ebcdic to ascii
+
23 C>
+
24 C> @note This subroutine can be replaced by cray utility subroutines
+
25 C> uscctc and uscctt. See manual sr-2079 page 3-15. Cray utility tr
+
26 C> can also be used for ascii, ebcdic conversion. See manual sr-2079
+
27 C> page 9-35.
+
28 C> @note Software version of ibm370 translate instruction, by
+
29 C> changing the two tables we could do a 64, 96, 128 ascii
+
30 C> character set, change lower case to upper, etc.
+
31 C> - aea() converts data at a rate of 1.5 million characters per sec.
+
32 C> - cray utility usccti convert ibm ebcdic to ascii
+
33 C> - cray utility uscctc convert ascii to ibm ebcdic
+
34 C> - they convert data at a rate of 2.1 million characters per sec.
+
35 C> - cray utility tr will also do a ascii, ebcdic conversion.
+
36 C> tr convert data at a rate of 5.4 million characters per sec.
+
37 C> tr is in library /usr/lib/libcos.a add to segldr card.
+
38 C>
+
39 C> @author desmarais @date 11-29-1982
+
40  SUBROUTINE aea (IA, IE, NC )
+
41 C*** ASCII CONTAINS ASCII CHARACTERS, AS PUNCHED ON IBM029
+
42 C
+
43  INTEGER(8) IASCII(32)
+
44  INTEGER(8) IEBCDC(32)
+
45 C
+
46  CHARACTER*1 IA(*)
+
47  CHARACTER*1 IE(*)
+
48  CHARACTER*1 ASCII(0:255)
+
49  CHARACTER*1 EBCDIC(0:255)
+
50 C
+
51  equivalence(iascii(1),ascii(0))
+
52  equivalence(iebcdc(1),ebcdic(0))
+
53 C
+
54  DATA iascii/
+
55  & z'000102030009007F',z'0000000B0C0D0E0F',
+
56  & z'1011120000000000',z'1819000000000000',
+
57  & z'00001C000A001700',z'0000000000050607',
+
58  & z'00001600001E0004',z'000000001415001A',
+
59  & z'2000600000000000',z'0000602E3C282B00',
+
60  & z'2600000000000000',z'000021242A293B5E',
+
61  & z'2D2F000000000000',z'00007C2C255F3E3F',
+
62  & z'0000000000000000',z'00603A2340273D22',
+
63  & z'2061626364656667',z'6869202020202020',
+
64  & z'206A6B6C6D6E6F70',z'7172202020202020',
+
65  & z'207E737475767778',z'797A2020205B2020',
+
66  & z'0000000000000000',z'00000000005D0000',
+
67  & z'7B41424344454647',z'4849202020202020',
+
68  & z'7D4A4B4C4D4E4F50',z'5152202020202020',
+
69  & z'5C20535455565758',z'595A202020202020',
+
70  & z'3031323334353637',z'3839202020202020'/
+
71 C
+
72 C*** EBCDIC CONTAINS HEX. REPRESENTATION OF EBCDIC CHARACTERS
+
73 C
+
74  DATA iebcdc/
+
75  & z'00010203372D2E2F',z'1605250B0C0D0E0F',
+
76  & z'101112003C3D3226',z'18193F2722003500',
+
77  & z'405A7F7B5B6C507D',z'4D5D5C4E6B604B61',
+
78  & z'F0F1F2F3F4F5F6F7',z'F8F97A5E4C7E6E6F',
+
79  & z'7CC1C2C3C4C5C6C7',z'C8C9D1D2D3D4D5D6',
+
80  & z'D7D8D9E2E3E4E5E6',z'E7E8E9ADE0BD5F6D',
+
81  & z'7981828384858687',z'8889919293949596',
+
82  & z'979899A2A3A4A5A6',z'A7A8A9C06AD0A107',
+
83  & 16*z'4040404040404040'/
+
84 C
+
85  num = iabs(nc)
+
86 C
+
87  IF (nc .EQ. 0) RETURN
+
88 C
+
89  IF (nc .GT. 0) THEN
+
90 C
+
91 C*** CONVERT STRING ... EBCDIC TO ASCII, NUM CHARACTERS
+
92 C
+
93  DO 10 j = 1, num
+
94  ia(j) = ascii(mova2i(ie(j)))
+
95  10 CONTINUE
+
96 C
+
97  ELSE
+
98 C
+
99 C*** CONVERT STRING ... ASCII TO EBCDIC, NUM CHARACTERS
+
100 C
+
101  DO 20 j = 1, num
+
102  ie(j) = ebcdic(mova2i(ia(j)))
+
103  20 CONTINUE
+
104  END IF
+
105 C
+
106  RETURN
+
107  END
+
+
+
aea
subroutine aea(IA, IE, NC)
Program history log:
Definition: aea.f:41
+
mova2i
integer function mova2i(a)
This Function copies a bit string from a Character*1 variable to an integer variable.
Definition: mova2i.f:25
+ + + + diff --git a/ver-2.10.0/annotated.html b/ver-2.10.0/annotated.html new file mode 100644 index 00000000..6e6cdd16 --- /dev/null +++ b/ver-2.10.0/annotated.html @@ -0,0 +1,107 @@ + + + + + + + +NCEPLIBS-w3emc: Data Types List + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
Data Types List
+
+
+
Here are the data types with brief descriptions:
+
[detail level 12]
+ + + +
 ▼Nargs_modThis Fortran Module acts as a wrapper to the system routines IARGC and GETARG
 Cgetarg
 Ciargc
+
+
+
+ + + + diff --git a/ver-2.10.0/annotated_dup.js b/ver-2.10.0/annotated_dup.js new file mode 100644 index 00000000..68014c6b --- /dev/null +++ b/ver-2.10.0/annotated_dup.js @@ -0,0 +1,4 @@ +var annotated_dup = +[ + [ "args_mod", "namespaceargs__mod.html", "namespaceargs__mod" ] +]; \ No newline at end of file diff --git a/ver-2.10.0/args__mod_8f.html b/ver-2.10.0/args__mod_8f.html new file mode 100644 index 00000000..63bcb76a --- /dev/null +++ b/ver-2.10.0/args__mod_8f.html @@ -0,0 +1,139 @@ + + + + + + + +NCEPLIBS-w3emc: args_mod.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Data Types | +Modules | +Functions/Subroutines
+
+
args_mod.f File Reference
+
+
+ +

Wrapper for routines iargc and getarg. +More...

+ +

Go to the source code of this file.

+ + + + + + +

+Data Types

interface  args_mod::getarg
 
interface  args_mod::iargc
 
+ + + + +

+Modules

module  args_mod
 This Fortran Module acts as a wrapper to the system routines IARGC and GETARG.
 
+ + + + + +

+Functions/Subroutines

+subroutine args_mod::getarg_8 (k, c)
 
+integer(8) function args_mod::iargc_8 ()
 
+

Detailed Description

+

Wrapper for routines iargc and getarg.

+
Author
Mark Iredell
+
Date
1998-11-DD
+ +

Definition in file args_mod.f.

+
+
+ + + + diff --git a/ver-2.10.0/args__mod_8f.js b/ver-2.10.0/args__mod_8f.js new file mode 100644 index 00000000..72c9234e --- /dev/null +++ b/ver-2.10.0/args__mod_8f.js @@ -0,0 +1,7 @@ +var args__mod_8f = +[ + [ "getarg", "interfaceargs__mod_1_1getarg.html", "interfaceargs__mod_1_1getarg" ], + [ "iargc", "interfaceargs__mod_1_1iargc.html", "interfaceargs__mod_1_1iargc" ], + [ "getarg_8", "args__mod_8f.html#a7ba1ffe2c151a1c87049a23730fa9ea6", null ], + [ "iargc_8", "args__mod_8f.html#a6abd46d69fad0b63bbdd0eddc14db1fe", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/args__mod_8f_source.html b/ver-2.10.0/args__mod_8f_source.html new file mode 100644 index 00000000..eab7b5d9 --- /dev/null +++ b/ver-2.10.0/args__mod_8f_source.html @@ -0,0 +1,138 @@ + + + + + + + +NCEPLIBS-w3emc: args_mod.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
args_mod.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Wrapper for routines iargc and getarg.
+
3 C> @author Mark Iredell @date 1998-11-DD
+
4 
+
5 C> This Fortran Module acts as a wrapper to the system
+
6 C> routines IARGC and GETARG. Use of this module allows IARGC and
+
7 C> GETARG to work properly with 4-byte or 8-byte integer arguments.
+
8 C>
+
9 C> @author Mark Iredell @date 1998-11-DD
+
10  module args_mod
+
11  interface iargc
+
12  module procedure iargc_8
+
13  end interface
+
14  interface getarg
+
15  subroutine getarg(k,c)
+
16  integer(4) k
+
17  character*(*) c
+
18  end subroutine getarg
+
19  module procedure getarg_8
+
20  end interface
+
21  contains
+
22  integer(8) function iargc_8()
+
23  integer(4) iargc
+
24  external iargc
+
25  iargc_8=iargc()
+
26  end function iargc_8
+
27  subroutine getarg_8(k,c)
+
28  integer(8) k
+
29  character*(*) c
+
30  integer(4) k4
+
31  k4=k
+
32  call getarg(k4,c)
+
33  end subroutine getarg_8
+
34  end module args_mod
+
+
+
args_mod
This Fortran Module acts as a wrapper to the system routines IARGC and GETARG.
Definition: args_mod.f:10
+
args_mod::iargc
Definition: args_mod.f:11
+
args_mod::getarg
Definition: args_mod.f:14
+ + + + diff --git a/ver-2.10.0/bc_s.png b/ver-2.10.0/bc_s.png new file mode 100644 index 00000000..224b29aa Binary files /dev/null and b/ver-2.10.0/bc_s.png differ diff --git a/ver-2.10.0/bdwn.png b/ver-2.10.0/bdwn.png new file mode 100644 index 00000000..940a0b95 Binary files /dev/null and b/ver-2.10.0/bdwn.png differ diff --git a/ver-2.10.0/classes.html b/ver-2.10.0/classes.html new file mode 100644 index 00000000..7a74e63b --- /dev/null +++ b/ver-2.10.0/classes.html @@ -0,0 +1,114 @@ + + + + + + + +NCEPLIBS-w3emc: Data Types + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
Data Types
+
+
+
g | i
+ + + + + + + + + +
  g  
+
  i  
+
getarg (args_mod)   iargc (args_mod)   
+
g | i
+
+
+ + + + diff --git a/ver-2.10.0/closed.png b/ver-2.10.0/closed.png new file mode 100644 index 00000000..98cc2c90 Binary files /dev/null and b/ver-2.10.0/closed.png differ diff --git a/ver-2.10.0/dir_49e56c817e5e54854c35e136979f97ca.html b/ver-2.10.0/dir_49e56c817e5e54854c35e136979f97ca.html new file mode 100644 index 00000000..78aa1dbe --- /dev/null +++ b/ver-2.10.0/dir_49e56c817e5e54854c35e136979f97ca.html @@ -0,0 +1,101 @@ + + + + + + + +NCEPLIBS-w3emc: docs Directory Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
docs Directory Reference
+
+
+
+
+ + + + diff --git a/ver-2.10.0/dir_68267d1309a1af8e8297ef4c3efbcdba.html b/ver-2.10.0/dir_68267d1309a1af8e8297ef4c3efbcdba.html new file mode 100644 index 00000000..262e53fb --- /dev/null +++ b/ver-2.10.0/dir_68267d1309a1af8e8297ef4c3efbcdba.html @@ -0,0 +1,738 @@ + + + + + + + +NCEPLIBS-w3emc: src Directory Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
src Directory Reference
+
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

+Files

file  aea.f [code]
 This subroutine converts ascii to ebcdic, or ebcdic to ascii.
 
file  args_mod.f [code]
 Wrapper for routines iargc and getarg.
 
file  errexit.f [code]
 Exit with a return code.
 
file  errmsg.f [code]
 Write a message to stderr.
 
file  fparsei.f [code]
 Extract integers from a free-format character string.
 
file  fparser.f [code]
 Extracts real numbers from a free-format character string.
 
file  gbyte.f [code]
 This is the fortran version of gbyte.
 
file  gbytec.f [code]
 Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
 
file  gbytes.f [code]
 This is the fortran version of gbytes.
 
file  gbytesc.f [code]
 Get bytes - unpack bits.
 
file  getbit.f [code]
 Compute number of bits and round field.
 
file  getgb.f [code]
 Find and unpack a grib message.
 
file  getgb1.f [code]
 Find and unpacks a grib message.
 
file  getgb1r.f [code]
 Reads and unpacks a grib message.
 
file  getgb1re.f [code]
 Reads and unpacks a grib message.
 
file  getgb1s.f [code]
 Find a grib message.
 
file  getgbe.f [code]
 Finds and unpacks a grib message.
 
file  getgbeh.f [code]
 Find a grib message.
 
file  getgbem.f [code]
 Find and unpack a grib message.
 
file  getgbemh.f [code]
 Find a grib message.
 
file  getgbemn.f [code]
 Finds and unpacks a grib message.
 
file  getgbemp.f [code]
 Find a grib message.
 
file  getgbens.f [code]
 Find and unpack a grib message.
 
file  getgbep.f [code]
 Find a grib message.
 
file  getgbex.f [code]
 Find and unpack a grib message.
 
file  getgbexm.f [code]
 Find and unpack a grib message.
 
file  getgbh.f [code]
 Find a grib message.
 
file  getgbm.f [code]
 Find and unpack a grib message.
 
file  getgbmh.f [code]
 Finds a grib message.
 
file  getgbmp.f [code]
 Finds a grib message.
 
file  getgbp.f [code]
 Finds a grib message.
 
file  getgi.f [code]
 Read a grib index file and return its contents.
 
file  getgir.f [code]
 Read a grib index file and return its index contents.
 
file  gtbits.f [code]
 The number of bits required to pack a given field.
 
file  idsdef.f [code]
 Sets decimal scalings defaults for various parameters.
 
file  instrument.f [code]
 Monitor wall-clock times, etc.
 
file  isrchne.f [code]
 Searches a vector for the first element not equal to a target.
 
file  iw3jdn.f [code]
 Computes julian day number from year (4 digits), month, and day.
 
file  iw3mat.f [code]
 Test n words starting at l1, l2 for equality, return .true. if all equal; otherwise .false.
 
file  iw3pds.f [code]
 Test two pds (grib product definition section) to see if all equal; otherwise .false.
 
file  iw3unp29.f [code]
 Reads and unpacks one report into the unpacked office note 29/124 format.
 
file  ixgb.f [code]
 This subprogram makes one index record.
 
file  lengds.f [code]
 GIven a grid description section (in w3fi63 format), return its size in terms of number of data points.
 
file  makwmo.f [code]
 FORMS THE WMO HEADER FOR A GIVEN BULLETIN.
 
file  mersenne_twister.f [code]
 Modern random number generator.
 
file  mkfldsep.f [code]
 Makes TOC Flag Field Separator Block.
 
file  mova2i.f [code]
 This Function copies a bit string from a Character*1 variable to an integer variable.
 
file  orders.f [code]
 A Fast and stable sort routine suitable for efficient, multiple-pass sorting on variable length characters, integers, or real numbers.
 
file  pdsens.f [code]
 Packs grib pds extension 41- for ensemble.
 
file  pdseup.f [code]
 Unpacks grib pds extension 41- for ensemble.
 
file  putgb.f [code]
 Packs and writes a grib message.
 
file  putgbe.f [code]
 Packs and writes a grib message.
 
file  putgben.f [code]
 Packs and writes a grib message.
 
file  putgbens.f [code]
 Packs and writes a grib message.
 
file  putgbex.f [code]
 Packs and writes a grib message.
 
file  putgbn.f [code]
 Packs and writes a grib message.
 
file  q9ie32.f [code]
 Convert IBM370 F.P. to IEEE F.P.
 
file  r63w72.f [code]
 Convert w3fi63() parms to w3fi72() parms.
 
file  sbyte.f [code]
 This is the fortran 32 bit version of sbyte().
 
file  sbytec.f [code]
 Wrapper for sbytesc()
 
file  sbytes.f [code]
 This is the fortran versions of sbytes().
 
file  sbytesc.f [code]
 Put arbitrary size values into a packed bit string.
 
file  skgb.f [code]
 Search for next grib message.
 
file  summary.c [code]
 Make a system call to return various useful parameters.
 
file  w3ai00.f [code]
 Real array to 16 bit packed format.
 
file  w3ai01.f [code]
 Unpack record into IEEE F.P.
 
file  w3ai08.f [code]
 Unpack grib field to grib grid.
 
file  w3ai15.f [code]
 Converts a set of binary numbers to an equivalent set of ascii number fields in core.
 
file  w3ai18.f [code]
 Line builder subroutine.
 
file  w3ai19.f [code]
 Blocker Subroutine.
 
file  w3ai24.f [code]
 Test for match of two strings.
 
file  w3ai38.f [code]
 EBCDIC to ASCII.
 
file  w3ai39.f [code]
 Translate 'ASCII' field to 'EBCDIC'.
 
file  w3ai40.f [code]
 Constant size binary string packer.
 
file  w3ai41.f [code]
 Constant size binary string unpacker.
 
file  w3aq15.f [code]
 GMT time packer.
 
file  w3as00.f [code]
 Get parm field from command-line.
 
file  w3ctzdat.f [code]
 Converts an ncep absolute date and time to another time zone.
 
file  w3difdat.f [code]
 Return a time interval between two dates.
 
file  w3doxdat.f [code]
 Returns the integer day of week, the day of year, and julian day given an NCEP absolute date and time.
 
file  w3fa01.f [code]
 Compute lifting condendsation level.
 
file  w3fa03.f [code]
 Compute standard height, temp, and pot temp.
 
file  w3fa03v.f [code]
 Compute standard height, temp, and pot temp.
 
file  w3fa04.f [code]
 Compute standard pressure, temp, pot temp.
 
file  w3fa06.f [code]
 Calculation of the lifted index.
 
file  w3fa09.f [code]
 Temperature to saturation vapor pressure.
 
file  w3fa11.f [code]
 Computes coefficients for use in w3fa12.
 
file  w3fa12.f [code]
 Computes legendre polynomials at a given latitude.
 
file  w3fa13.f [code]
 Computes Trig Functions.
 
file  w3fb00.f [code]
 Convert latitude, longitude to i,j.
 
file  w3fb01.f [code]
 I,J TO LATITUDE, LONGITUDE.
 
file  w3fb02.f [code]
 COnvert s. hemisphere lat/lon to i and j.
 
file  w3fb03.f [code]
 Convert i,j grid coordinates to lat/lon.
 
file  w3fb04.f [code]
 Latitude, longitude to grid coordinates.
 
file  w3fb05.f [code]
 Grid coordinates to latitude, longitude.
 
file  w3fb06.f [code]
 Lat/lon to pola (i,j) for grib.
 
file  w3fb07.f [code]
 Grid coords to lat/lon for grib.
 
file  w3fb08.f [code]
 Lat/lon to merc (i,j) for grib.
 
file  w3fb09.f [code]
 Merc (i,j) to lat/lon for grib.
 
file  w3fb10.f [code]
 Lat/long pair to compass bearing, gcd.
 
file  w3fb11.f [code]
 Lat/lon to lambert(i,j) for grib.
 
file  w3fb12.f [code]
 Lambert(i,j) to lat/lon for grib.
 
file  w3fc02.f [code]
 Grid U,V wind comps. to dir. and speed.
 
file  w3fc05.f [code]
 Earth U,V wind components to dir and spd.
 
file  w3fc06.f [code]
 Wind dir and spd to Earth U,V components.
 
file  w3fc07.f [code]
 Grid U-V to Earth U-V in north hem.
 
file  w3fc08.f [code]
 U-V Comps from Earth to north hem grid.
 
file  w3fi01.f [code]
 Determines machine word length in bytes.
 
file  w3fi02.f [code]
 Transfers array from 16 to 64 bit words.
 
file  w3fi03.f [code]
 Transfers default integers to 16 bit ints.
 
file  w3fi04.f [code]
 Find word size, endian, character set.
 
file  w3fi18.f [code]
 NMC octagon boundary finding subroutine.
 
file  w3fi19.f [code]
 NMC Rectangle boundary finding subroutine.
 
file  w3fi20.f [code]
 Cut a 65 x 65 grid to a nmc 1977 point grid.
 
file  w3fi32.f [code]
 Pack id's into office note 84 format.
 
file  w3fi47.f [code]
 Convert label to off. no. 85 format (cray)
 
file  w3fi48.f [code]
 Convert office note 85 label to IBM.
 
file  w3fi52.f [code]
 Computes scaling constants used by grdprt().
 
file  w3fi58.f [code]
 Pack positive differences in least bits.
 
file  w3fi59.f [code]
 Form and pack positive, scaled differences.
 
file  w3fi61.f [code]
 Build 40 char communications prefix.
 
file  w3fi62.f [code]
 Build 80-char on295 queue descriptor.
 
file  w3fi63.f [code]
 Unpack GRIB field to a GRIB grid.
 
file  w3fi64.f [code]
 NMC office note 29 report unpacker.
 
file  w3fi65.f [code]
 NMC office note 29 report packer.
 
file  w3fi66.f [code]
 Office note 29 report blocker.
 
file  w3fi67.f [code]
 BUFR message decoder.
 
file  w3fi68.f [code]
 Convert 25 word array to GRIB pds.
 
file  w3fi69.f [code]
 Convert pds to 25, or 27 word array.
 
file  w3fi70.f [code]
 Computes scaling constants used by grdprt().
 
file  w3fi71.f [code]
 Make array used by GRIB packer for GDS.
 
file  w3fi72.f [code]
 Make a complete GRIB message.
 
file  w3fi73.f [code]
 Construct grib bit map section (BMS).
 
file  w3fi74.f [code]
 Construct Grid Definition Section (GDS).
 
file  w3fi75.f [code]
 GRIB pack data and form bds octets(1-11)
 
file  w3fi76.f [code]
 Convert to ibm370 floating point.
 
file  w3fi78.f [code]
 BUFR Message decoder.
 
file  w3fi82.f [code]
 Convert to second diff array.
 
file  w3fi83.f [code]
 Restore delta packed data to original.
 
file  w3fi85.f [code]
 Generate bufr message.
 
file  w3fi88.f [code]
 BUFR message decoder.
 
file  w3fi92.f [code]
 Build 80-char on 295 grib queue descriptor.
 
file  w3fm07.f [code]
 Nine-point smoother for rectangular grids.
 
file  w3fm08.f [code]
 Nine point smoother/desmoother.
 
file  w3fp04.f [code]
 Print array of data points at lat/lon points.
 
file  w3fp05.f [code]
 Printer contour subroutine.
 
file  w3fp06.f [code]
 NMC title subroutine.
 
file  w3fp10.f [code]
 Printer contour subroutine.
 
file  w3fp11.f [code]
 One-line GRIB titler from pds section.
 
file  w3fp12.f [code]
 Creates the product definition section.
 
file  w3fp13.f [code]
 Convert GRIB PDS edition 1 to O.N. 84 ID.
 
file  w3fq07.f [code]
 Sends fax,varian,afos,awips, maps & bulls.
 
file  w3fs13.f [code]
 Year, month, and day to day of year.
 
file  w3fs15.f [code]
 Updating office note 85 date/time word.
 
file  w3fs21.f [code]
 Number of minutes since jan 1, 1978.
 
file  w3fs26.f [code]
 Year, month, day from julian day number.
 
file  w3ft00.f [code]
 Data field tranformation subroutine.
 
file  w3ft01.f [code]
 Interpolate values in a data field.
 
file  w3ft02.f [code]
 Interpolate precipitation to specific point.
 
file  w3ft03.f [code]
 A point interpolater.
 
file  w3ft05.f [code]
 Convert (145,37) to (65,65) n. hemi. grid.
 
file  w3ft05v.f [code]
 Convert (145,37) grid to (65,65) n. hemi. grid.
 
file  w3ft06.f [code]
 Convert (145,37) to (65,65) s. hemi. grid.
 
file  w3ft06v.f [code]
 Convert (145,37) grid to (65,65) s. hemi. grid.
 
file  w3ft07.f [code]
 Transform gridpoint fld by interpolation.
 
file  w3ft08.f [code]
 Computes 2.5 x 2.5 n. hemi. grid-scaler.
 
file  w3ft09.f [code]
 Computes 2.5x2.5 n. hemi. grid-vector.
 
file  w3ft10.f [code]
 Computes 2.5 x 2.5 s. hemi. grid-scaler.
 
file  w3ft11.f [code]
 Computes 2.5x2.5 s. hemi. grid vector.
 
file  w3ft12.f [code]
 Fast fourier for 2.5 degree grid.
 
file  w3ft16.f [code]
 Convert (95,91) grid to (3447) grid.
 
file  w3ft17.f [code]
 Convert (95,91) grid to (3447) grid.
 
file  w3ft201.f [code]
 Convert (361,181) grid to (65,65) n. hemi. grid.
 
file  w3ft202.f [code]
 Convert (361,91) grid to (65,43) n. hemi. grid.
 
file  w3ft203.f [code]
 Convert (361,91) grid to (45,39) n. hemi. grid.
 
file  w3ft204.f [code]
 Convert (361,181) grid to (93,68) mercator grid.
 
file  w3ft205.f [code]
 Convert (361,91) grid to (45,39) n. hemi. grid.
 
file  w3ft206.f [code]
 Convert (361,91) grid to (51,41) lambert grid.
 
file  w3ft207.f [code]
 Convert (361,91) grid to (49,35) n. hemi. grid.
 
file  w3ft208.f [code]
 Convert (361,91) grid to (29,27) mercator grid.
 
file  w3ft209.f [code]
 Convert (361,91) grid to (101,81) lambert grid.
 
file  w3ft21.f [code]
 Computes 2.5 x 2.5 n. hemi. grid-scaler.
 
file  w3ft210.f [code]
 Convert (361,91) grid to (25,25) mercator grid.
 
file  w3ft211.f [code]
 Convert (361,91) grid to (93,65) lambert grid.
 
file  w3ft212.f [code]
 Convert (361,91) grid to (185,129) lambert grid.
 
file  w3ft213.f [code]
 Convert (361,91) grid to (129,85) n. hemi. grid.
 
file  w3ft214.f [code]
 Convert (361,91) grid to (97,69) n. hemi. grid.
 
file  w3ft26.f [code]
 Creates wafs 1.25x1.25 thinned grids.
 
file  w3ft32.f [code]
 General interpolator between nmc flds.
 
file  w3ft33.f [code]
 Thicken thinned wafs grib grid 37-44.
 
file  w3ft38.f [code]
 Computes 2.5 x 2.5 n. hemi. grid-scaler.
 
file  w3ft39.f [code]
 Computes 2.5x2.5 n. hemi. grid-vector.
 
file  w3ft40.f [code]
 Computes 2.5 x 2.5 s. hemi. grid-scaler.
 
file  w3ft41.f [code]
 Computes 2.5x2.5 s. hemi. grid vector.
 
file  w3ft43v.f [code]
 Convert (361,181) grid to (65,65) n. hemi. grid.
 
file  w3kind.f [code]
 Return the real kind and integer kind used in w3 lib.
 
file  w3locdat.f [code]
 Return the local date and time.
 
file  w3miscan.f [code]
 Reads 1 ssm/i scan line from bufr d-set.
 
file  w3movdat.f [code]
 Return a date from a time interval and date.
 
file  w3nogds.f [code]
 Make a complete grib message.
 
file  w3pradat.f [code]
 Format a date and time into characters.
 
file  w3reddat.f [code]
 Reduce a time interval to a canonical form.
 
file  w3tagb.f [code]
 Operational job identifier.
 
file  w3trnarg.f [code]
 Translates arg line from standard input.
 
file  w3unpk77.f [code]
 Decodes single report from bufr messages.
 
file  w3utcdat.f [code]
 Return the utc date and time.
 
file  w3valdat.f [code]
 Determine the validity of a date and time.
 
file  w3ymdh4.f [code]
 4-byte date word unpacker and packer.
 
file  xdopen.f [code]
 Dummy subroutine.
 
file  xmovex.f [code]
 Assembler language to move data.
 
file  xstore.f [code]
 Stores a constant value into an array.
 
+
+
+ + + + diff --git a/ver-2.10.0/doc.png b/ver-2.10.0/doc.png new file mode 100644 index 00000000..17edabff Binary files /dev/null and b/ver-2.10.0/doc.png differ diff --git a/ver-2.10.0/doxygen.css b/ver-2.10.0/doxygen.css new file mode 100644 index 00000000..73ecbb2c --- /dev/null +++ b/ver-2.10.0/doxygen.css @@ -0,0 +1,1771 @@ +/* The standard CSS for doxygen 1.8.17 */ + +body, table, div, p, dl { + font: 400 14px/22px Roboto,sans-serif; +} + +p.reference, p.definition { + font: 400 14px/22px Roboto,sans-serif; +} + +/* @group Heading Levels */ + +h1.groupheader { + font-size: 150%; +} + +.title { + font: 400 14px/28px Roboto,sans-serif; + font-size: 150%; + font-weight: bold; + margin: 10px 2px; +} + +h2.groupheader { + border-bottom: 1px solid #879ECB; + color: #354C7B; + font-size: 150%; + font-weight: normal; + margin-top: 1.75em; + padding-top: 8px; + padding-bottom: 4px; + width: 100%; +} + +h3.groupheader { + font-size: 100%; +} + +h1, h2, h3, h4, h5, h6 { + -webkit-transition: text-shadow 0.5s linear; + -moz-transition: text-shadow 0.5s linear; + -ms-transition: text-shadow 0.5s linear; + -o-transition: text-shadow 0.5s linear; + transition: text-shadow 0.5s linear; + margin-right: 15px; +} + +h1.glow, h2.glow, h3.glow, h4.glow, h5.glow, h6.glow { + text-shadow: 0 0 15px cyan; +} + +dt { + font-weight: bold; +} + +ul.multicol { + -moz-column-gap: 1em; + -webkit-column-gap: 1em; + column-gap: 1em; + -moz-column-count: 3; + -webkit-column-count: 3; + column-count: 3; +} + +p.startli, p.startdd { + margin-top: 2px; +} + +th p.starttd, p.intertd, p.endtd { + font-size: 100%; + font-weight: 700; +} + +p.starttd { + margin-top: 0px; +} + +p.endli { + margin-bottom: 0px; +} + +p.enddd { + margin-bottom: 4px; +} + +p.endtd { + margin-bottom: 2px; +} + +p.interli { +} + +p.interdd { +} + +p.intertd { +} + +/* @end */ + +caption { + font-weight: bold; +} + +span.legend { + font-size: 70%; + text-align: center; +} + +h3.version { + font-size: 90%; + text-align: center; +} + +div.qindex, div.navtab{ + background-color: #EBEFF6; + border: 1px solid #A3B4D7; + text-align: center; +} + +div.qindex, div.navpath { + width: 100%; + line-height: 140%; +} + +div.navtab { + margin-right: 15px; +} + +/* @group Link Styling */ + +a { + color: #3D578C; + font-weight: normal; + text-decoration: none; +} + +.contents a:visited { + color: #4665A2; +} + +a:hover { + text-decoration: underline; +} + +a.qindex { + font-weight: bold; +} + +a.qindexHL { + font-weight: bold; + background-color: #9CAFD4; + color: #FFFFFF; + border: 1px double #869DCA; +} + +.contents a.qindexHL:visited { + color: #FFFFFF; +} + +a.el { + font-weight: bold; +} + +a.elRef { +} + +a.code, a.code:visited, a.line, a.line:visited { + color: #4665A2; +} + +a.codeRef, a.codeRef:visited, a.lineRef, a.lineRef:visited { + color: #4665A2; +} + +/* @end */ + +dl.el { + margin-left: -1cm; +} + +ul { + overflow: hidden; /*Fixed: list item bullets overlap floating elements*/ +} + +#side-nav ul { + overflow: visible; /* reset ul rule for scroll bar in GENERATE_TREEVIEW window */ +} + +#main-nav ul { + overflow: visible; /* reset ul rule for the navigation bar drop down lists */ +} + +.fragment { + text-align: left; + direction: ltr; + overflow-x: auto; /*Fixed: fragment lines overlap floating elements*/ + overflow-y: hidden; +} + +pre.fragment { + border: 1px solid #C4CFE5; + background-color: #FBFCFD; + padding: 4px 6px; + margin: 4px 8px 4px 2px; + overflow: auto; + word-wrap: break-word; + font-size: 9pt; + line-height: 125%; + font-family: monospace, fixed; + font-size: 105%; +} + +div.fragment { + padding: 0 0 1px 0; /*Fixed: last line underline overlap border*/ + margin: 4px 8px 4px 2px; + background-color: #FBFCFD; + border: 1px solid #C4CFE5; +} + +div.line { + font-family: monospace, fixed; + font-size: 13px; + min-height: 13px; + line-height: 1.0; + text-wrap: unrestricted; + white-space: -moz-pre-wrap; /* Moz */ + white-space: -pre-wrap; /* Opera 4-6 */ + white-space: -o-pre-wrap; /* Opera 7 */ + white-space: pre-wrap; /* CSS3 */ + word-wrap: break-word; /* IE 5.5+ */ + text-indent: -53px; + padding-left: 53px; + padding-bottom: 0px; + margin: 0px; + -webkit-transition-property: background-color, box-shadow; + -webkit-transition-duration: 0.5s; + -moz-transition-property: background-color, box-shadow; + -moz-transition-duration: 0.5s; + -ms-transition-property: background-color, box-shadow; + -ms-transition-duration: 0.5s; + -o-transition-property: background-color, box-shadow; + -o-transition-duration: 0.5s; + transition-property: background-color, box-shadow; + transition-duration: 0.5s; +} + +div.line:after { + content:"\000A"; + white-space: pre; +} + +div.line.glow { + background-color: cyan; + box-shadow: 0 0 10px cyan; +} + + +span.lineno { + padding-right: 4px; + text-align: right; + border-right: 2px solid #0F0; + background-color: #E8E8E8; + white-space: pre; +} +span.lineno a { + background-color: #D8D8D8; +} + +span.lineno a:hover { + background-color: #C8C8C8; +} + +.lineno { + -webkit-touch-callout: none; + -webkit-user-select: none; + -khtml-user-select: none; + -moz-user-select: none; + -ms-user-select: none; + user-select: none; +} + +div.ah, span.ah { + background-color: black; + font-weight: bold; + color: #FFFFFF; + margin-bottom: 3px; + margin-top: 3px; + padding: 0.2em; + border: solid thin #333; + border-radius: 0.5em; + -webkit-border-radius: .5em; + -moz-border-radius: .5em; + box-shadow: 2px 2px 3px #999; + -webkit-box-shadow: 2px 2px 3px #999; + -moz-box-shadow: rgba(0, 0, 0, 0.15) 2px 2px 2px; + background-image: -webkit-gradient(linear, left top, left bottom, from(#eee), to(#000),color-stop(0.3, #444)); + background-image: -moz-linear-gradient(center top, #eee 0%, #444 40%, #000 110%); +} + +div.classindex ul { + list-style: none; + padding-left: 0; +} + +div.classindex span.ai { + display: inline-block; +} + +div.groupHeader { + margin-left: 16px; + margin-top: 12px; + font-weight: bold; +} + +div.groupText { + margin-left: 16px; + font-style: italic; +} + +body { + background-color: white; + color: black; + margin: 0; +} + +div.contents { + margin-top: 10px; + margin-left: 12px; + margin-right: 8px; +} + +td.indexkey { + background-color: #EBEFF6; + font-weight: bold; + border: 1px solid #C4CFE5; + margin: 2px 0px 2px 0; + padding: 2px 10px; + white-space: nowrap; + vertical-align: top; +} + +td.indexvalue { + background-color: #EBEFF6; + border: 1px solid #C4CFE5; + padding: 2px 10px; + margin: 2px 0px; +} + +tr.memlist { + background-color: #EEF1F7; +} + +p.formulaDsp { + text-align: center; +} + +img.formulaDsp { + +} + +img.formulaInl, img.inline { + vertical-align: middle; +} + +div.center { + text-align: center; + margin-top: 0px; + margin-bottom: 0px; + padding: 0px; +} + +div.center img { + border: 0px; +} + +address.footer { + text-align: right; + padding-right: 12px; +} + +img.footer { + border: 0px; + vertical-align: middle; +} + +/* @group Code Colorization */ + +span.keyword { + color: #008000 +} + +span.keywordtype { + color: #604020 +} + +span.keywordflow { + color: #e08000 +} + +span.comment { + color: #800000 +} + +span.preprocessor { + color: #806020 +} + +span.stringliteral { + color: #002080 +} + +span.charliteral { + color: #008080 +} + +span.vhdldigit { + color: #ff00ff +} + +span.vhdlchar { + color: #000000 +} + +span.vhdlkeyword { + color: #700070 +} + +span.vhdllogic { + color: #ff0000 +} + +blockquote { + background-color: #F7F8FB; + border-left: 2px solid #9CAFD4; + margin: 0 24px 0 4px; + padding: 0 12px 0 16px; +} + +blockquote.DocNodeRTL { + border-left: 0; + border-right: 2px solid #9CAFD4; + margin: 0 4px 0 24px; + padding: 0 16px 0 12px; +} + +/* @end */ + +/* +.search { + color: #003399; + font-weight: bold; +} + +form.search { + margin-bottom: 0px; + margin-top: 0px; +} + +input.search { + font-size: 75%; + color: #000080; + font-weight: normal; + background-color: #e8eef2; +} +*/ + +td.tiny { + font-size: 75%; +} + +.dirtab { + padding: 4px; + border-collapse: collapse; + border: 1px solid #A3B4D7; +} + +th.dirtab { + background: #EBEFF6; + font-weight: bold; +} + +hr { + height: 0px; + border: none; + border-top: 1px solid #4A6AAA; +} + +hr.footer { + height: 1px; +} + +/* @group Member Descriptions */ + +table.memberdecls { + border-spacing: 0px; + padding: 0px; +} + +.memberdecls td, .fieldtable tr { + -webkit-transition-property: background-color, box-shadow; + -webkit-transition-duration: 0.5s; + -moz-transition-property: background-color, box-shadow; + -moz-transition-duration: 0.5s; + -ms-transition-property: background-color, box-shadow; + -ms-transition-duration: 0.5s; + -o-transition-property: background-color, box-shadow; + -o-transition-duration: 0.5s; + transition-property: background-color, box-shadow; + transition-duration: 0.5s; +} + +.memberdecls td.glow, .fieldtable tr.glow { + background-color: cyan; + box-shadow: 0 0 15px cyan; +} + +.mdescLeft, .mdescRight, +.memItemLeft, .memItemRight, +.memTemplItemLeft, .memTemplItemRight, .memTemplParams { + background-color: #F9FAFC; + border: none; + margin: 4px; + padding: 1px 0 0 8px; +} + +.mdescLeft, .mdescRight { + padding: 0px 8px 4px 8px; + color: #555; +} + +.memSeparator { + border-bottom: 1px solid #DEE4F0; + line-height: 1px; + margin: 0px; + padding: 0px; +} + +.memItemLeft, .memTemplItemLeft { + white-space: nowrap; +} + +.memItemRight, .memTemplItemRight { + width: 100%; +} + +.memTemplParams { + color: #4665A2; + white-space: nowrap; + font-size: 80%; +} + +/* @end */ + +/* @group Member Details */ + +/* Styles for detailed member documentation */ + +.memtitle { + padding: 8px; + border-top: 1px solid #A8B8D9; + border-left: 1px solid #A8B8D9; + border-right: 1px solid #A8B8D9; + border-top-right-radius: 4px; + border-top-left-radius: 4px; + margin-bottom: -1px; + background-image: url('nav_f.png'); + background-repeat: repeat-x; + background-color: #E2E8F2; + line-height: 1.25; + font-weight: 300; + float:left; +} + +.permalink +{ + font-size: 65%; + display: inline-block; + vertical-align: middle; +} + +.memtemplate { + font-size: 80%; + color: #4665A2; + font-weight: normal; + margin-left: 9px; +} + +.memnav { + background-color: #EBEFF6; + border: 1px solid #A3B4D7; + text-align: center; + margin: 2px; + margin-right: 15px; + padding: 2px; +} + +.mempage { + width: 100%; +} + +.memitem { + padding: 0; + margin-bottom: 10px; + margin-right: 5px; + -webkit-transition: box-shadow 0.5s linear; + -moz-transition: box-shadow 0.5s linear; + -ms-transition: box-shadow 0.5s linear; + -o-transition: box-shadow 0.5s linear; + transition: box-shadow 0.5s linear; + display: table !important; + width: 100%; +} + +.memitem.glow { + box-shadow: 0 0 15px cyan; +} + +.memname { + font-weight: 400; + margin-left: 6px; +} + +.memname td { + vertical-align: bottom; +} + +.memproto, dl.reflist dt { + border-top: 1px solid #A8B8D9; + border-left: 1px solid #A8B8D9; + border-right: 1px solid #A8B8D9; + padding: 6px 0px 6px 0px; + color: #253555; + font-weight: bold; + text-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9); + background-color: #DFE5F1; + /* opera specific markup */ + box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.15); + border-top-right-radius: 4px; + /* firefox specific markup */ + -moz-box-shadow: rgba(0, 0, 0, 0.15) 5px 5px 5px; + -moz-border-radius-topright: 4px; + /* webkit specific markup */ + -webkit-box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.15); + -webkit-border-top-right-radius: 4px; + +} + +.overload { + font-family: "courier new",courier,monospace; + font-size: 65%; +} + +.memdoc, dl.reflist dd { + border-bottom: 1px solid #A8B8D9; + border-left: 1px solid #A8B8D9; + border-right: 1px solid #A8B8D9; + padding: 6px 10px 2px 10px; + background-color: #FBFCFD; + border-top-width: 0; + background-image:url('nav_g.png'); + background-repeat:repeat-x; + background-color: #FFFFFF; + /* opera specific markup */ + border-bottom-left-radius: 4px; + border-bottom-right-radius: 4px; + box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.15); + /* firefox specific markup */ + -moz-border-radius-bottomleft: 4px; + -moz-border-radius-bottomright: 4px; + -moz-box-shadow: rgba(0, 0, 0, 0.15) 5px 5px 5px; + /* webkit specific markup */ + -webkit-border-bottom-left-radius: 4px; + -webkit-border-bottom-right-radius: 4px; + -webkit-box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.15); +} + +dl.reflist dt { + padding: 5px; +} + +dl.reflist dd { + margin: 0px 0px 10px 0px; + padding: 5px; +} + +.paramkey { + text-align: right; +} + +.paramtype { + white-space: nowrap; +} + +.paramname { + color: #602020; + white-space: nowrap; +} +.paramname em { + font-style: normal; +} +.paramname code { + line-height: 14px; +} + +.params, .retval, .exception, .tparams { + margin-left: 0px; + padding-left: 0px; +} + +.params .paramname, .retval .paramname, .tparams .paramname, .exception .paramname { + font-weight: bold; + vertical-align: top; +} + +.params .paramtype, .tparams .paramtype { + font-style: italic; + vertical-align: top; +} + +.params .paramdir, .tparams .paramdir { + font-family: "courier new",courier,monospace; + vertical-align: top; +} + +table.mlabels { + border-spacing: 0px; +} + +td.mlabels-left { + width: 100%; + padding: 0px; +} + +td.mlabels-right { + vertical-align: bottom; + padding: 0px; + white-space: nowrap; +} + +span.mlabels { + margin-left: 8px; +} + +span.mlabel { + background-color: #728DC1; + border-top:1px solid #5373B4; + border-left:1px solid #5373B4; + border-right:1px solid #C4CFE5; + border-bottom:1px solid #C4CFE5; + text-shadow: none; + color: white; + margin-right: 4px; + padding: 2px 3px; + border-radius: 3px; + font-size: 7pt; + white-space: nowrap; + vertical-align: middle; +} + + + +/* @end */ + +/* these are for tree view inside a (index) page */ + +div.directory { + margin: 10px 0px; + border-top: 1px solid #9CAFD4; + border-bottom: 1px solid #9CAFD4; + width: 100%; +} + +.directory table { + border-collapse:collapse; +} + +.directory td { + margin: 0px; + padding: 0px; + vertical-align: top; +} + +.directory td.entry { + white-space: nowrap; + padding-right: 6px; + padding-top: 3px; +} + +.directory td.entry a { + outline:none; +} + +.directory td.entry a img { + border: none; +} + +.directory td.desc { + width: 100%; + padding-left: 6px; + padding-right: 6px; + padding-top: 3px; + border-left: 1px solid rgba(0,0,0,0.05); +} + +.directory tr.even { + padding-left: 6px; + background-color: #F7F8FB; +} + +.directory img { + vertical-align: -30%; +} + +.directory .levels { + white-space: nowrap; + width: 100%; + text-align: right; + font-size: 9pt; +} + +.directory .levels span { + cursor: pointer; + padding-left: 2px; + padding-right: 2px; + color: #3D578C; +} + +.arrow { + color: #9CAFD4; + -webkit-user-select: none; + -khtml-user-select: none; + -moz-user-select: none; + -ms-user-select: none; + user-select: none; + cursor: pointer; + font-size: 80%; + display: inline-block; + width: 16px; + height: 22px; +} + +.icon { + font-family: Arial, Helvetica; + font-weight: bold; + font-size: 12px; + height: 14px; + width: 16px; + display: inline-block; + background-color: #728DC1; + color: white; + text-align: center; + border-radius: 4px; + margin-left: 2px; + margin-right: 2px; +} + +.icona { + width: 24px; + height: 22px; + display: inline-block; +} + +.iconfopen { + width: 24px; + height: 18px; + margin-bottom: 4px; + background-image:url('folderopen.png'); + background-position: 0px -4px; + background-repeat: repeat-y; + vertical-align:top; + display: inline-block; +} + +.iconfclosed { + width: 24px; + height: 18px; + margin-bottom: 4px; + background-image:url('folderclosed.png'); + background-position: 0px -4px; + background-repeat: repeat-y; + vertical-align:top; + display: inline-block; +} + +.icondoc { + width: 24px; + height: 18px; + margin-bottom: 4px; + background-image:url('doc.png'); + background-position: 0px -4px; + background-repeat: repeat-y; + vertical-align:top; + display: inline-block; +} + +table.directory { + font: 400 14px Roboto,sans-serif; +} + +/* @end */ + +div.dynheader { + margin-top: 8px; + -webkit-touch-callout: none; + -webkit-user-select: none; + -khtml-user-select: none; + -moz-user-select: none; + -ms-user-select: none; + user-select: none; +} + +address { + font-style: normal; + color: #2A3D61; +} + +table.doxtable caption { + caption-side: top; +} + +table.doxtable { + border-collapse:collapse; + margin-top: 4px; + margin-bottom: 4px; +} + +table.doxtable td, table.doxtable th { + border: 1px solid #2D4068; + padding: 3px 7px 2px; +} + +table.doxtable th { + background-color: #374F7F; + color: #FFFFFF; + font-size: 110%; + padding-bottom: 4px; + padding-top: 5px; +} + +table.fieldtable { + /*width: 100%;*/ + margin-bottom: 10px; + border: 1px solid #A8B8D9; + border-spacing: 0px; + -moz-border-radius: 4px; + -webkit-border-radius: 4px; + border-radius: 4px; + -moz-box-shadow: rgba(0, 0, 0, 0.15) 2px 2px 2px; + -webkit-box-shadow: 2px 2px 2px rgba(0, 0, 0, 0.15); + box-shadow: 2px 2px 2px rgba(0, 0, 0, 0.15); +} + +.fieldtable td, .fieldtable th { + padding: 3px 7px 2px; +} + +.fieldtable td.fieldtype, .fieldtable td.fieldname { + white-space: nowrap; + border-right: 1px solid #A8B8D9; + border-bottom: 1px solid #A8B8D9; + vertical-align: top; +} + +.fieldtable td.fieldname { + padding-top: 3px; +} + +.fieldtable td.fielddoc { + border-bottom: 1px solid #A8B8D9; + /*width: 100%;*/ +} + +.fieldtable td.fielddoc p:first-child { + margin-top: 0px; +} + +.fieldtable td.fielddoc p:last-child { + margin-bottom: 2px; +} + +.fieldtable tr:last-child td { + border-bottom: none; +} + +.fieldtable th { + background-image:url('nav_f.png'); + background-repeat:repeat-x; + background-color: #E2E8F2; + font-size: 90%; + color: #253555; + padding-bottom: 4px; + padding-top: 5px; + text-align:left; + font-weight: 400; + -moz-border-radius-topleft: 4px; + -moz-border-radius-topright: 4px; + -webkit-border-top-left-radius: 4px; + -webkit-border-top-right-radius: 4px; + border-top-left-radius: 4px; + border-top-right-radius: 4px; + border-bottom: 1px solid #A8B8D9; +} + + +.tabsearch { + top: 0px; + left: 10px; + height: 36px; + background-image: url('tab_b.png'); + z-index: 101; + overflow: hidden; + font-size: 13px; +} + +.navpath ul +{ + font-size: 11px; + background-image:url('tab_b.png'); + background-repeat:repeat-x; + background-position: 0 -5px; + height:30px; + line-height:30px; + color:#8AA0CC; + border:solid 1px #C2CDE4; + overflow:hidden; + margin:0px; + padding:0px; +} + +.navpath li +{ + list-style-type:none; + float:left; + padding-left:10px; + padding-right:15px; + background-image:url('bc_s.png'); + background-repeat:no-repeat; + background-position:right; + color:#364D7C; +} + +.navpath li.navelem a +{ + height:32px; + display:block; + text-decoration: none; + outline: none; + color: #283A5D; + font-family: 'Lucida Grande',Geneva,Helvetica,Arial,sans-serif; + text-shadow: 0px 1px 1px rgba(255, 255, 255, 0.9); + text-decoration: none; +} + +.navpath li.navelem a:hover +{ + color:#6884BD; +} + +.navpath li.footer +{ + list-style-type:none; + float:right; + padding-left:10px; + padding-right:15px; + background-image:none; + background-repeat:no-repeat; + background-position:right; + color:#364D7C; + font-size: 8pt; +} + + +div.summary +{ + float: right; + font-size: 8pt; + padding-right: 5px; + width: 50%; + text-align: right; +} + +div.summary a +{ + white-space: nowrap; +} + +table.classindex +{ + margin: 10px; + white-space: nowrap; + margin-left: 3%; + margin-right: 3%; + width: 94%; + border: 0; + border-spacing: 0; + padding: 0; +} + +div.ingroups +{ + font-size: 8pt; + width: 50%; + text-align: left; +} + +div.ingroups a +{ + white-space: nowrap; +} + +div.header +{ + background-image:url('nav_h.png'); + background-repeat:repeat-x; + background-color: #F9FAFC; + margin: 0px; + border-bottom: 1px solid #C4CFE5; +} + +div.headertitle +{ + padding: 5px 5px 5px 10px; +} + +.PageDocRTL-title div.headertitle { + text-align: right; + direction: rtl; +} + +dl { + padding: 0 0 0 0; +} + +/* dl.note, dl.warning, dl.attention, dl.pre, dl.post, dl.invariant, dl.deprecated, dl.todo, dl.test, dl.bug, dl.examples */ +dl.section { + margin-left: 0px; + padding-left: 0px; +} + +dl.section.DocNodeRTL { + margin-right: 0px; + padding-right: 0px; +} + +dl.note { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #D0C000; +} + +dl.note.DocNodeRTL { + margin-left: 0; + padding-left: 0; + border-left: 0; + margin-right: -7px; + padding-right: 3px; + border-right: 4px solid; + border-color: #D0C000; +} + +dl.warning, dl.attention { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #FF0000; +} + +dl.warning.DocNodeRTL, dl.attention.DocNodeRTL { + margin-left: 0; + padding-left: 0; + border-left: 0; + margin-right: -7px; + padding-right: 3px; + border-right: 4px solid; + border-color: #FF0000; +} + +dl.pre, dl.post, dl.invariant { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #00D000; +} + +dl.pre.DocNodeRTL, dl.post.DocNodeRTL, dl.invariant.DocNodeRTL { + margin-left: 0; + padding-left: 0; + border-left: 0; + margin-right: -7px; + padding-right: 3px; + border-right: 4px solid; + border-color: #00D000; +} + +dl.deprecated { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #505050; +} + +dl.deprecated.DocNodeRTL { + margin-left: 0; + padding-left: 0; + border-left: 0; + margin-right: -7px; + padding-right: 3px; + border-right: 4px solid; + border-color: #505050; +} + +dl.todo { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #00C0E0; +} + +dl.todo.DocNodeRTL { + margin-left: 0; + padding-left: 0; + border-left: 0; + margin-right: -7px; + padding-right: 3px; + border-right: 4px solid; + border-color: #00C0E0; +} + +dl.test { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #3030E0; +} + +dl.test.DocNodeRTL { + margin-left: 0; + padding-left: 0; + border-left: 0; + margin-right: -7px; + padding-right: 3px; + border-right: 4px solid; + border-color: #3030E0; +} + +dl.bug { + margin-left: -7px; + padding-left: 3px; + border-left: 4px solid; + border-color: #C08050; +} + +dl.bug.DocNodeRTL { + margin-left: 0; + padding-left: 0; + border-left: 0; + margin-right: -7px; + padding-right: 3px; + border-right: 4px solid; + border-color: #C08050; +} + +dl.section dd { + margin-bottom: 6px; +} + + +#projectlogo +{ + text-align: center; + vertical-align: bottom; + border-collapse: separate; +} + +#projectlogo img +{ + border: 0px none; +} + +#projectalign +{ + vertical-align: middle; +} + +#projectname +{ + font: 300% Tahoma, Arial,sans-serif; + margin: 0px; + padding: 2px 0px; +} + +#projectbrief +{ + font: 120% Tahoma, Arial,sans-serif; + margin: 0px; + padding: 0px; +} + +#projectnumber +{ + font: 50% Tahoma, Arial,sans-serif; + margin: 0px; + padding: 0px; +} + +#titlearea +{ + padding: 0px; + margin: 0px; + width: 100%; + border-bottom: 1px solid #5373B4; +} + +.image +{ + text-align: center; +} + +.dotgraph +{ + text-align: center; +} + +.mscgraph +{ + text-align: center; +} + +.plantumlgraph +{ + text-align: center; +} + +.diagraph +{ + text-align: center; +} + +.caption +{ + font-weight: bold; +} + +div.zoom +{ + border: 1px solid #90A5CE; +} + +dl.citelist { + margin-bottom:50px; +} + +dl.citelist dt { + color:#334975; + float:left; + font-weight:bold; + margin-right:10px; + padding:5px; +} + +dl.citelist dd { + margin:2px 0; + padding:5px 0; +} + +div.toc { + padding: 14px 25px; + background-color: #F4F6FA; + border: 1px solid #D8DFEE; + border-radius: 7px 7px 7px 7px; + float: right; + height: auto; + margin: 0 8px 10px 10px; + width: 200px; +} + +.PageDocRTL-title div.toc { + float: left !important; + text-align: right; +} + +div.toc li { + background: url("bdwn.png") no-repeat scroll 0 5px transparent; + font: 10px/1.2 Verdana,DejaVu Sans,Geneva,sans-serif; + margin-top: 5px; + padding-left: 10px; + padding-top: 2px; +} + +.PageDocRTL-title div.toc li { + background-position-x: right !important; + padding-left: 0 !important; + padding-right: 10px; +} + +div.toc h3 { + font: bold 12px/1.2 Arial,FreeSans,sans-serif; + color: #4665A2; + border-bottom: 0 none; + margin: 0; +} + +div.toc ul { + list-style: none outside none; + border: medium none; + padding: 0px; +} + +div.toc li.level1 { + margin-left: 0px; +} + +div.toc li.level2 { + margin-left: 15px; +} + +div.toc li.level3 { + margin-left: 30px; +} + +div.toc li.level4 { + margin-left: 45px; +} + +.PageDocRTL-title div.toc li.level1 { + margin-left: 0 !important; + margin-right: 0; +} + +.PageDocRTL-title div.toc li.level2 { + margin-left: 0 !important; + margin-right: 15px; +} + +.PageDocRTL-title div.toc li.level3 { + margin-left: 0 !important; + margin-right: 30px; +} + +.PageDocRTL-title div.toc li.level4 { + margin-left: 0 !important; + margin-right: 45px; +} + +.inherit_header { + font-weight: bold; + color: gray; + cursor: pointer; + -webkit-touch-callout: none; + -webkit-user-select: none; + -khtml-user-select: none; + -moz-user-select: none; + -ms-user-select: none; + user-select: none; +} + +.inherit_header td { + padding: 6px 0px 2px 5px; +} + +.inherit { + display: none; +} + +tr.heading h2 { + margin-top: 12px; + margin-bottom: 4px; +} + +/* tooltip related style info */ + +.ttc { + position: absolute; + display: none; +} + +#powerTip { + cursor: default; + white-space: nowrap; + background-color: white; + border: 1px solid gray; + border-radius: 4px 4px 4px 4px; + box-shadow: 1px 1px 7px gray; + display: none; + font-size: smaller; + max-width: 80%; + opacity: 0.9; + padding: 1ex 1em 1em; + position: absolute; + z-index: 2147483647; +} + +#powerTip div.ttdoc { + color: grey; + font-style: italic; +} + +#powerTip div.ttname a { + font-weight: bold; +} + +#powerTip div.ttname { + font-weight: bold; +} + +#powerTip div.ttdeci { + color: #006318; +} + +#powerTip div { + margin: 0px; + padding: 0px; + font: 12px/16px Roboto,sans-serif; +} + +#powerTip:before, #powerTip:after { + content: ""; + position: absolute; + margin: 0px; +} + +#powerTip.n:after, #powerTip.n:before, +#powerTip.s:after, #powerTip.s:before, +#powerTip.w:after, #powerTip.w:before, +#powerTip.e:after, #powerTip.e:before, +#powerTip.ne:after, #powerTip.ne:before, +#powerTip.se:after, #powerTip.se:before, +#powerTip.nw:after, #powerTip.nw:before, +#powerTip.sw:after, #powerTip.sw:before { + border: solid transparent; + content: " "; + height: 0; + width: 0; + position: absolute; +} + +#powerTip.n:after, #powerTip.s:after, +#powerTip.w:after, #powerTip.e:after, +#powerTip.nw:after, #powerTip.ne:after, +#powerTip.sw:after, #powerTip.se:after { + border-color: rgba(255, 255, 255, 0); +} + +#powerTip.n:before, #powerTip.s:before, +#powerTip.w:before, #powerTip.e:before, +#powerTip.nw:before, #powerTip.ne:before, +#powerTip.sw:before, #powerTip.se:before { + border-color: rgba(128, 128, 128, 0); +} + +#powerTip.n:after, #powerTip.n:before, +#powerTip.ne:after, #powerTip.ne:before, +#powerTip.nw:after, #powerTip.nw:before { + top: 100%; +} + +#powerTip.n:after, #powerTip.ne:after, #powerTip.nw:after { + border-top-color: #FFFFFF; + border-width: 10px; + margin: 0px -10px; +} +#powerTip.n:before { + border-top-color: #808080; + border-width: 11px; + margin: 0px -11px; +} +#powerTip.n:after, #powerTip.n:before { + left: 50%; +} + +#powerTip.nw:after, #powerTip.nw:before { + right: 14px; +} + +#powerTip.ne:after, #powerTip.ne:before { + left: 14px; +} + +#powerTip.s:after, #powerTip.s:before, +#powerTip.se:after, #powerTip.se:before, +#powerTip.sw:after, #powerTip.sw:before { + bottom: 100%; +} + +#powerTip.s:after, #powerTip.se:after, #powerTip.sw:after { + border-bottom-color: #FFFFFF; + border-width: 10px; + margin: 0px -10px; +} + +#powerTip.s:before, #powerTip.se:before, #powerTip.sw:before { + border-bottom-color: #808080; + border-width: 11px; + margin: 0px -11px; +} + +#powerTip.s:after, #powerTip.s:before { + left: 50%; +} + +#powerTip.sw:after, #powerTip.sw:before { + right: 14px; +} + +#powerTip.se:after, #powerTip.se:before { + left: 14px; +} + +#powerTip.e:after, #powerTip.e:before { + left: 100%; +} +#powerTip.e:after { + border-left-color: #FFFFFF; + border-width: 10px; + top: 50%; + margin-top: -10px; +} +#powerTip.e:before { + border-left-color: #808080; + border-width: 11px; + top: 50%; + margin-top: -11px; +} + +#powerTip.w:after, #powerTip.w:before { + right: 100%; +} +#powerTip.w:after { + border-right-color: #FFFFFF; + border-width: 10px; + top: 50%; + margin-top: -10px; +} +#powerTip.w:before { + border-right-color: #808080; + border-width: 11px; + top: 50%; + margin-top: -11px; +} + +@media print +{ + #top { display: none; } + #side-nav { display: none; } + #nav-path { display: none; } + body { overflow:visible; } + h1, h2, h3, h4, h5, h6 { page-break-after: avoid; } + .summary { display: none; } + .memitem { page-break-inside: avoid; } + #doc-content + { + margin-left:0 !important; + height:auto !important; + width:auto !important; + overflow:inherit; + display:inline; + } +} + +/* @group Markdown */ + +/* +table.markdownTable { + border-collapse:collapse; + margin-top: 4px; + margin-bottom: 4px; +} + +table.markdownTable td, table.markdownTable th { + border: 1px solid #2D4068; + padding: 3px 7px 2px; +} + +table.markdownTableHead tr { +} + +table.markdownTableBodyLeft td, table.markdownTable th { + border: 1px solid #2D4068; + padding: 3px 7px 2px; +} + +th.markdownTableHeadLeft th.markdownTableHeadRight th.markdownTableHeadCenter th.markdownTableHeadNone { + background-color: #374F7F; + color: #FFFFFF; + font-size: 110%; + padding-bottom: 4px; + padding-top: 5px; +} + +th.markdownTableHeadLeft { + text-align: left +} + +th.markdownTableHeadRight { + text-align: right +} + +th.markdownTableHeadCenter { + text-align: center +} +*/ + +table.markdownTable { + border-collapse:collapse; + margin-top: 4px; + margin-bottom: 4px; +} + +table.markdownTable td, table.markdownTable th { + border: 1px solid #2D4068; + padding: 3px 7px 2px; +} + +table.markdownTable tr { +} + +th.markdownTableHeadLeft, th.markdownTableHeadRight, th.markdownTableHeadCenter, th.markdownTableHeadNone { + background-color: #374F7F; + color: #FFFFFF; + font-size: 110%; + padding-bottom: 4px; + padding-top: 5px; +} + +th.markdownTableHeadLeft, td.markdownTableBodyLeft { + text-align: left +} + +th.markdownTableHeadRight, td.markdownTableBodyRight { + text-align: right +} + +th.markdownTableHeadCenter, td.markdownTableBodyCenter { + text-align: center +} + +.DocNodeRTL { + text-align: right; + direction: rtl; +} + +.DocNodeLTR { + text-align: left; + direction: ltr; +} + +table.DocNodeRTL { + width: auto; + margin-right: 0; + margin-left: auto; +} + +table.DocNodeLTR { + width: auto; + margin-right: auto; + margin-left: 0; +} + +tt, code, kbd, samp +{ + display: inline-block; + direction:ltr; +} +/* @end */ + +u { + text-decoration: underline; +} + diff --git a/ver-2.10.0/doxygen.png b/ver-2.10.0/doxygen.png new file mode 100644 index 00000000..3ff17d80 Binary files /dev/null and b/ver-2.10.0/doxygen.png differ diff --git a/ver-2.10.0/dynsections.js b/ver-2.10.0/dynsections.js new file mode 100644 index 00000000..c8e84aaa --- /dev/null +++ b/ver-2.10.0/dynsections.js @@ -0,0 +1,127 @@ +/* + @licstart The following is the entire license notice for the + JavaScript code in this file. + + Copyright (C) 1997-2017 by Dimitri van Heesch + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + + @licend The above is the entire license notice + for the JavaScript code in this file + */ +function toggleVisibility(linkObj) +{ + var base = $(linkObj).attr('id'); + var summary = $('#'+base+'-summary'); + var content = $('#'+base+'-content'); + var trigger = $('#'+base+'-trigger'); + var src=$(trigger).attr('src'); + if (content.is(':visible')===true) { + content.hide(); + summary.show(); + $(linkObj).addClass('closed').removeClass('opened'); + $(trigger).attr('src',src.substring(0,src.length-8)+'closed.png'); + } else { + content.show(); + summary.hide(); + $(linkObj).removeClass('closed').addClass('opened'); + $(trigger).attr('src',src.substring(0,src.length-10)+'open.png'); + } + return false; +} + +function updateStripes() +{ + $('table.directory tr'). + removeClass('even').filter(':visible:even').addClass('even'); +} + +function toggleLevel(level) +{ + $('table.directory tr').each(function() { + var l = this.id.split('_').length-1; + var i = $('#img'+this.id.substring(3)); + var a = $('#arr'+this.id.substring(3)); + if (l + + + + + + +NCEPLIBS-w3emc: errexit.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
errexit.f File Reference
+
+
+ +

Exit with a return code. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine errexit (IRET)
 Exit with a return code. More...
 
+

Detailed Description

+

Exit with a return code.

+
Author
Mark Iredell
+
Date
1998-06-04
+ +

Definition in file errexit.f.

+

Function/Subroutine Documentation

+ +

◆ errexit()

+ +
+
+ + + + + + + + +
subroutine errexit (integer IRET)
+
+ +

Exit with a return code.

+

Program history log:

    +
  • 1998-06-04 Mark Iredell
    • +
  • 1999-01-26 Stephen Gilbert
      +
    • Changed to use XLF utility routine exit_(n) instead of exit(n). exit_(n) will return the proper value (n must be 4 byte int) to the sh/ksh shell status variable $? ($status for csh) on the IBM SP.
      • +
    +
    • +
+
Parameters
+ + +
[in]IRETInteger return code.
+
+
+
Author
Mark Iredell
+
Date
1998-06-04
+ +

Definition at line 20 of file errexit.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/errexit_8f.js b/ver-2.10.0/errexit_8f.js new file mode 100644 index 00000000..3d580922 --- /dev/null +++ b/ver-2.10.0/errexit_8f.js @@ -0,0 +1,4 @@ +var errexit_8f = +[ + [ "errexit", "errexit_8f.html#abcd4c3fc1b8b684d5dc7b9412891de91", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/errexit_8f_source.html b/ver-2.10.0/errexit_8f_source.html new file mode 100644 index 00000000..e82d0184 --- /dev/null +++ b/ver-2.10.0/errexit_8f_source.html @@ -0,0 +1,126 @@ + + + + + + + +NCEPLIBS-w3emc: errexit.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
errexit.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Exit with a return code.
+
3 C> @author Mark Iredell @date 1998-06-04
+
4 
+
5 C> Exit with a return code.
+
6 C>
+
7 C> Program history log:
+
8 C> - 1998-06-04 Mark Iredell
+
9 C> - 1999-01-26 Stephen Gilbert
+
10 C> - Changed to use XLF utility routine exit_(n) instead of exit(n).
+
11 C> exit_(n) will return the proper value (n must be 4 byte int)
+
12 C> to the sh/ksh shell status variable $? ($status for csh)
+
13 C> on the IBM SP.
+
14 C>
+
15 C> @param[in] IRET Integer return code.
+
16 C>
+
17 C> @author Mark Iredell @date 1998-06-04
+
18 
+
19  SUBROUTINE errexit(IRET)
+
20  INTEGER IRET
+
21  INTEGER(4) JRET
+
22  jret=iret
+
23  CALL exit(jret)
+
24  END
+
+
+
errexit
subroutine errexit(IRET)
Exit with a return code.
Definition: errexit.f:20
+ + + + diff --git a/ver-2.10.0/errmsg_8f.html b/ver-2.10.0/errmsg_8f.html new file mode 100644 index 00000000..fb490481 --- /dev/null +++ b/ver-2.10.0/errmsg_8f.html @@ -0,0 +1,156 @@ + + + + + + + +NCEPLIBS-w3emc: errmsg.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
errmsg.f File Reference
+
+
+ +

Write a message to stderr. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine errmsg (CMSG)
 Write a message to stderr. More...
 
+

Detailed Description

+

Write a message to stderr.

+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition in file errmsg.f.

+

Function/Subroutine Documentation

+ +

◆ errmsg()

+ +
+
+ + + + + + + + +
subroutine errmsg (character*(*) CMSG)
+
+ +

Write a message to stderr.

+

Program history log:

    +
  • 1995-10-31 Mark Iredell
    • +
+
Parameters
+ + +
[in]CMSGcharacter*(*) message to write.
+
+
+
Note
This is a machine-dependent subprogram for Cray.
+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition at line 17 of file errmsg.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/errmsg_8f.js b/ver-2.10.0/errmsg_8f.js new file mode 100644 index 00000000..237b50ba --- /dev/null +++ b/ver-2.10.0/errmsg_8f.js @@ -0,0 +1,4 @@ +var errmsg_8f = +[ + [ "errmsg", "errmsg_8f.html#acb908fdaebb814b3210e63ecae74c996", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/errmsg_8f_source.html b/ver-2.10.0/errmsg_8f_source.html new file mode 100644 index 00000000..088cc8da --- /dev/null +++ b/ver-2.10.0/errmsg_8f_source.html @@ -0,0 +1,124 @@ + + + + + + + +NCEPLIBS-w3emc: errmsg.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
errmsg.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Write a message to stderr.
+
3 C> @author Mark Iredell @date 1995-10-31
+
4 
+
5 C> Write a message to stderr.
+
6 C>
+
7 C> Program history log:
+
8 C> - 1995-10-31 Mark Iredell
+
9 C>
+
10 C> @param[in] CMSG character*(*) message to write.
+
11 C>
+
12 C> @note This is a machine-dependent subprogram for Cray.
+
13 C>
+
14 C> @author Mark Iredell @date 1995-10-31
+
15 C-----------------------------------------------------------------------
+
16  SUBROUTINE errmsg(CMSG)
+
17  CHARACTER*(*) CMSG
+
18 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
19  WRITE(0,'(A)') cmsg
+
20 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
21  RETURN
+
22  END
+
+
+
errmsg
subroutine errmsg(CMSG)
Write a message to stderr.
Definition: errmsg.f:17
+ + + + diff --git a/ver-2.10.0/files.html b/ver-2.10.0/files.html new file mode 100644 index 00000000..1f762b9b --- /dev/null +++ b/ver-2.10.0/files.html @@ -0,0 +1,317 @@ + + + + + + + +NCEPLIBS-w3emc: File List + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
File List
+
+
+
Here is a list of all documented files with brief descriptions:
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
 aea.fThis subroutine converts ascii to ebcdic, or ebcdic to ascii
 args_mod.fWrapper for routines iargc and getarg
 errexit.fExit with a return code
 errmsg.fWrite a message to stderr
 fparsei.fExtract integers from a free-format character string
 fparser.fExtracts real numbers from a free-format character string
 gbyte.fThis is the fortran version of gbyte
 gbytec.fWrapper for gbytesc() limiting NSKIP and N to 0 and 1
 gbytes.fThis is the fortran version of gbytes
 gbytesc.fGet bytes - unpack bits
 getbit.fCompute number of bits and round field
 getgb.fFind and unpack a grib message
 getgb1.fFind and unpacks a grib message
 getgb1r.fReads and unpacks a grib message
 getgb1re.fReads and unpacks a grib message
 getgb1s.fFind a grib message
 getgbe.fFinds and unpacks a grib message
 getgbeh.fFind a grib message
 getgbem.fFind and unpack a grib message
 getgbemh.fFind a grib message
 getgbemn.fFinds and unpacks a grib message
 getgbemp.fFind a grib message
 getgbens.fFind and unpack a grib message
 getgbep.fFind a grib message
 getgbex.fFind and unpack a grib message
 getgbexm.fFind and unpack a grib message
 getgbh.fFind a grib message
 getgbm.fFind and unpack a grib message
 getgbmh.fFinds a grib message
 getgbmp.fFinds a grib message
 getgbp.fFinds a grib message
 getgi.fRead a grib index file and return its contents
 getgir.fRead a grib index file and return its index contents
 gtbits.fThe number of bits required to pack a given field
 idsdef.fSets decimal scalings defaults for various parameters
 instrument.fMonitor wall-clock times, etc
 isrchne.fSearches a vector for the first element not equal to a target
 iw3jdn.fComputes julian day number from year (4 digits), month, and day
 iw3mat.fTest n words starting at l1, l2 for equality, return .true. if all equal; otherwise .false
 iw3pds.fTest two pds (grib product definition section) to see if all equal; otherwise .false
 iw3unp29.fReads and unpacks one report into the unpacked office note 29/124 format
 ixgb.fThis subprogram makes one index record
 lengds.fGIven a grid description section (in w3fi63 format), return its size in terms of number of data points
 makgds.f90
 makwmo.fFORMS THE WMO HEADER FOR A GIVEN BULLETIN
 mersenne_twister.fModern random number generator
 mkfldsep.fMakes TOC Flag Field Separator Block
 mova2i.fThis Function copies a bit string from a Character*1 variable to an integer variable
 orders.fA Fast and stable sort routine suitable for efficient, multiple-pass sorting on variable length characters, integers, or real numbers
 pdsens.fPacks grib pds extension 41- for ensemble
 pdseup.fUnpacks grib pds extension 41- for ensemble
 putgb.fPacks and writes a grib message
 putgbe.fPacks and writes a grib message
 putgben.fPacks and writes a grib message
 putgbens.fPacks and writes a grib message
 putgbex.fPacks and writes a grib message
 putgbn.fPacks and writes a grib message
 q9ie32.fConvert IBM370 F.P. to IEEE F.P
 r63w72.fConvert w3fi63() parms to w3fi72() parms
 sbyte.fThis is the fortran 32 bit version of sbyte()
 sbytec.fWrapper for sbytesc()
 sbytes.fThis is the fortran versions of sbytes()
 sbytesc.fPut arbitrary size values into a packed bit string
 skgb.fSearch for next grib message
 summary.cMake a system call to return various useful parameters
 w3ai00.fReal array to 16 bit packed format
 w3ai01.fUnpack record into IEEE F.P
 w3ai08.fUnpack grib field to grib grid
 w3ai15.fConverts a set of binary numbers to an equivalent set of ascii number fields in core
 w3ai18.fLine builder subroutine
 w3ai19.fBlocker Subroutine
 w3ai24.fTest for match of two strings
 w3ai38.fEBCDIC to ASCII
 w3ai39.fTranslate 'ASCII' field to 'EBCDIC'
 w3ai40.fConstant size binary string packer
 w3ai41.fConstant size binary string unpacker
 w3aq15.fGMT time packer
 w3as00.fGet parm field from command-line
 w3ctzdat.fConverts an ncep absolute date and time to another time zone
 w3difdat.fReturn a time interval between two dates
 w3doxdat.fReturns the integer day of week, the day of year, and julian day given an NCEP absolute date and time
 w3fa01.fCompute lifting condendsation level
 w3fa03.fCompute standard height, temp, and pot temp
 w3fa03v.fCompute standard height, temp, and pot temp
 w3fa04.fCompute standard pressure, temp, pot temp
 w3fa06.fCalculation of the lifted index
 w3fa09.fTemperature to saturation vapor pressure
 w3fa11.fComputes coefficients for use in w3fa12
 w3fa12.fComputes legendre polynomials at a given latitude
 w3fa13.fComputes Trig Functions
 w3fb00.fConvert latitude, longitude to i,j
 w3fb01.fI,J TO LATITUDE, LONGITUDE
 w3fb02.fCOnvert s. hemisphere lat/lon to i and j
 w3fb03.fConvert i,j grid coordinates to lat/lon
 w3fb04.fLatitude, longitude to grid coordinates
 w3fb05.fGrid coordinates to latitude, longitude
 w3fb06.fLat/lon to pola (i,j) for grib
 w3fb07.fGrid coords to lat/lon for grib
 w3fb08.fLat/lon to merc (i,j) for grib
 w3fb09.fMerc (i,j) to lat/lon for grib
 w3fb10.fLat/long pair to compass bearing, gcd
 w3fb11.fLat/lon to lambert(i,j) for grib
 w3fb12.fLambert(i,j) to lat/lon for grib
 w3fc02.fGrid U,V wind comps. to dir. and speed
 w3fc05.fEarth U,V wind components to dir and spd
 w3fc06.fWind dir and spd to Earth U,V components
 w3fc07.fGrid U-V to Earth U-V in north hem
 w3fc08.fU-V Comps from Earth to north hem grid
 w3fi01.fDetermines machine word length in bytes
 w3fi02.fTransfers array from 16 to 64 bit words
 w3fi03.fTransfers default integers to 16 bit ints
 w3fi04.fFind word size, endian, character set
 w3fi18.fNMC octagon boundary finding subroutine
 w3fi19.fNMC Rectangle boundary finding subroutine
 w3fi20.fCut a 65 x 65 grid to a nmc 1977 point grid
 w3fi32.fPack id's into office note 84 format
 w3fi47.fConvert label to off. no. 85 format (cray)
 w3fi48.fConvert office note 85 label to IBM
 w3fi52.fComputes scaling constants used by grdprt()
 w3fi58.fPack positive differences in least bits
 w3fi59.fForm and pack positive, scaled differences
 w3fi61.fBuild 40 char communications prefix
 w3fi62.fBuild 80-char on295 queue descriptor
 w3fi63.fUnpack GRIB field to a GRIB grid
 w3fi64.fNMC office note 29 report unpacker
 w3fi65.fNMC office note 29 report packer
 w3fi66.fOffice note 29 report blocker
 w3fi67.fBUFR message decoder
 w3fi68.fConvert 25 word array to GRIB pds
 w3fi69.fConvert pds to 25, or 27 word array
 w3fi70.fComputes scaling constants used by grdprt()
 w3fi71.fMake array used by GRIB packer for GDS
 w3fi72.fMake a complete GRIB message
 w3fi73.fConstruct grib bit map section (BMS)
 w3fi74.fConstruct Grid Definition Section (GDS)
 w3fi75.fGRIB pack data and form bds octets(1-11)
 w3fi76.fConvert to ibm370 floating point
 w3fi78.fBUFR Message decoder
 w3fi82.fConvert to second diff array
 w3fi83.fRestore delta packed data to original
 w3fi85.fGenerate bufr message
 w3fi88.fBUFR message decoder
 w3fi92.fBuild 80-char on 295 grib queue descriptor
 w3fm07.fNine-point smoother for rectangular grids
 w3fm08.fNine point smoother/desmoother
 w3fp04.fPrint array of data points at lat/lon points
 w3fp05.fPrinter contour subroutine
 w3fp06.fNMC title subroutine
 w3fp10.fPrinter contour subroutine
 w3fp11.fOne-line GRIB titler from pds section
 w3fp12.fCreates the product definition section
 w3fp13.fConvert GRIB PDS edition 1 to O.N. 84 ID
 w3fq07.fSends fax,varian,afos,awips, maps & bulls
 w3fs13.fYear, month, and day to day of year
 w3fs15.fUpdating office note 85 date/time word
 w3fs21.fNumber of minutes since jan 1, 1978
 w3fs26.fYear, month, day from julian day number
 w3ft00.fData field tranformation subroutine
 w3ft01.fInterpolate values in a data field
 w3ft02.fInterpolate precipitation to specific point
 w3ft03.fA point interpolater
 w3ft05.fConvert (145,37) to (65,65) n. hemi. grid
 w3ft05v.fConvert (145,37) grid to (65,65) n. hemi. grid
 w3ft06.fConvert (145,37) to (65,65) s. hemi. grid
 w3ft06v.fConvert (145,37) grid to (65,65) s. hemi. grid
 w3ft07.fTransform gridpoint fld by interpolation
 w3ft08.fComputes 2.5 x 2.5 n. hemi. grid-scaler
 w3ft09.fComputes 2.5x2.5 n. hemi. grid-vector
 w3ft10.fComputes 2.5 x 2.5 s. hemi. grid-scaler
 w3ft11.fComputes 2.5x2.5 s. hemi. grid vector
 w3ft12.fFast fourier for 2.5 degree grid
 w3ft16.fConvert (95,91) grid to (3447) grid
 w3ft17.fConvert (95,91) grid to (3447) grid
 w3ft201.fConvert (361,181) grid to (65,65) n. hemi. grid
 w3ft202.fConvert (361,91) grid to (65,43) n. hemi. grid
 w3ft203.fConvert (361,91) grid to (45,39) n. hemi. grid
 w3ft204.fConvert (361,181) grid to (93,68) mercator grid
 w3ft205.fConvert (361,91) grid to (45,39) n. hemi. grid
 w3ft206.fConvert (361,91) grid to (51,41) lambert grid
 w3ft207.fConvert (361,91) grid to (49,35) n. hemi. grid
 w3ft208.fConvert (361,91) grid to (29,27) mercator grid
 w3ft209.fConvert (361,91) grid to (101,81) lambert grid
 w3ft21.fComputes 2.5 x 2.5 n. hemi. grid-scaler
 w3ft210.fConvert (361,91) grid to (25,25) mercator grid
 w3ft211.fConvert (361,91) grid to (93,65) lambert grid
 w3ft212.fConvert (361,91) grid to (185,129) lambert grid
 w3ft213.fConvert (361,91) grid to (129,85) n. hemi. grid
 w3ft214.fConvert (361,91) grid to (97,69) n. hemi. grid
 w3ft26.fCreates wafs 1.25x1.25 thinned grids
 w3ft32.fGeneral interpolator between nmc flds
 w3ft33.fThicken thinned wafs grib grid 37-44
 w3ft38.fComputes 2.5 x 2.5 n. hemi. grid-scaler
 w3ft39.fComputes 2.5x2.5 n. hemi. grid-vector
 w3ft40.fComputes 2.5 x 2.5 s. hemi. grid-scaler
 w3ft41.fComputes 2.5x2.5 s. hemi. grid vector
 w3ft43v.fConvert (361,181) grid to (65,65) n. hemi. grid
 w3kind.fReturn the real kind and integer kind used in w3 lib
 w3locdat.fReturn the local date and time
 w3log.f
 w3miscan.fReads 1 ssm/i scan line from bufr d-set
 w3movdat.fReturn a date from a time interval and date
 w3nogds.fMake a complete grib message
 w3pradat.fFormat a date and time into characters
 w3reddat.fReduce a time interval to a canonical form
 w3tagb.fOperational job identifier
 w3trnarg.fTranslates arg line from standard input
 w3unpk77.fDecodes single report from bufr messages
 w3utcdat.fReturn the utc date and time
 w3valdat.fDetermine the validity of a date and time
 w3ymdh4.f4-byte date word unpacker and packer
 xdopen.fDummy subroutine
 xmovex.fAssembler language to move data
 xstore.fStores a constant value into an array
+
+
+
+ + + + diff --git a/ver-2.10.0/files_dup.js b/ver-2.10.0/files_dup.js new file mode 100644 index 00000000..d3b2f947 --- /dev/null +++ b/ver-2.10.0/files_dup.js @@ -0,0 +1,216 @@ +var files_dup = +[ + [ "aea.f", "aea_8f.html", "aea_8f" ], + [ "args_mod.f", "args__mod_8f.html", "args__mod_8f" ], + [ "errexit.f", "errexit_8f.html", "errexit_8f" ], + [ "errmsg.f", "errmsg_8f.html", "errmsg_8f" ], + [ "fparsei.f", "fparsei_8f.html", "fparsei_8f" ], + [ "fparser.f", "fparser_8f.html", "fparser_8f" ], + [ "gbyte.f", "gbyte_8f.html", "gbyte_8f" ], + [ "gbytec.f", "gbytec_8f.html", "gbytec_8f" ], + [ "gbytes.f", "gbytes_8f.html", "gbytes_8f" ], + [ "gbytesc.f", "gbytesc_8f.html", "gbytesc_8f" ], + [ "getbit.f", "getbit_8f.html", "getbit_8f" ], + [ "getgb.f", "getgb_8f.html", "getgb_8f" ], + [ "getgb1.f", "getgb1_8f.html", "getgb1_8f" ], + [ "getgb1r.f", "getgb1r_8f.html", "getgb1r_8f" ], + [ "getgb1re.f", "getgb1re_8f.html", "getgb1re_8f" ], + [ "getgb1s.f", "getgb1s_8f.html", "getgb1s_8f" ], + [ "getgbe.f", "getgbe_8f.html", "getgbe_8f" ], + [ "getgbeh.f", "getgbeh_8f.html", "getgbeh_8f" ], + [ "getgbem.f", "getgbem_8f.html", "getgbem_8f" ], + [ "getgbemh.f", "getgbemh_8f.html", "getgbemh_8f" ], + [ "getgbemn.f", "getgbemn_8f.html", "getgbemn_8f" ], + [ "getgbemp.f", "getgbemp_8f.html", "getgbemp_8f" ], + [ "getgbens.f", "getgbens_8f.html", "getgbens_8f" ], + [ "getgbep.f", "getgbep_8f.html", "getgbep_8f" ], + [ "getgbex.f", "getgbex_8f.html", "getgbex_8f" ], + [ "getgbexm.f", "getgbexm_8f.html", "getgbexm_8f" ], + [ "getgbh.f", "getgbh_8f.html", "getgbh_8f" ], + [ "getgbm.f", "getgbm_8f.html", "getgbm_8f" ], + [ "getgbmh.f", "getgbmh_8f.html", "getgbmh_8f" ], + [ "getgbmp.f", "getgbmp_8f.html", "getgbmp_8f" ], + [ "getgbp.f", "getgbp_8f.html", "getgbp_8f" ], + [ "getgi.f", "getgi_8f.html", "getgi_8f" ], + [ "getgir.f", "getgir_8f.html", "getgir_8f" ], + [ "gtbits.f", "gtbits_8f.html", "gtbits_8f" ], + [ "idsdef.f", "idsdef_8f.html", "idsdef_8f" ], + [ "instrument.f", "instrument_8f.html", "instrument_8f" ], + [ "isrchne.f", "isrchne_8f.html", "isrchne_8f" ], + [ "iw3jdn.f", "iw3jdn_8f.html", "iw3jdn_8f" ], + [ "iw3mat.f", "iw3mat_8f.html", "iw3mat_8f" ], + [ "iw3pds.f", "iw3pds_8f.html", "iw3pds_8f" ], + [ "iw3unp29.f", "iw3unp29_8f.html", "iw3unp29_8f" ], + [ "ixgb.f", "ixgb_8f.html", "ixgb_8f" ], + [ "lengds.f", "lengds_8f.html", "lengds_8f" ], + [ "makgds.f90", "makgds_8f90_source.html", null ], + [ "makwmo.f", "makwmo_8f.html", "makwmo_8f" ], + [ "mersenne_twister.f", "mersenne__twister_8f.html", "mersenne__twister_8f" ], + [ "mkfldsep.f", "mkfldsep_8f.html", "mkfldsep_8f" ], + [ "mova2i.f", "mova2i_8f.html", "mova2i_8f" ], + [ "orders.f", "orders_8f.html", "orders_8f" ], + [ "pdsens.f", "pdsens_8f.html", "pdsens_8f" ], + [ "pdseup.f", "pdseup_8f.html", "pdseup_8f" ], + [ "putgb.f", "putgb_8f.html", "putgb_8f" ], + [ "putgbe.f", "putgbe_8f.html", "putgbe_8f" ], + [ "putgben.f", "putgben_8f.html", "putgben_8f" ], + [ "putgbens.f", "putgbens_8f.html", "putgbens_8f" ], + [ "putgbex.f", "putgbex_8f.html", "putgbex_8f" ], + [ "putgbn.f", "putgbn_8f.html", "putgbn_8f" ], + [ "q9ie32.f", "q9ie32_8f.html", "q9ie32_8f" ], + [ "r63w72.f", "r63w72_8f.html", "r63w72_8f" ], + [ "sbyte.f", "sbyte_8f.html", "sbyte_8f" ], + [ "sbytec.f", "sbytec_8f.html", "sbytec_8f" ], + [ "sbytes.f", "sbytes_8f.html", "sbytes_8f" ], + [ "sbytesc.f", "sbytesc_8f.html", "sbytesc_8f" ], + [ "skgb.f", "skgb_8f.html", "skgb_8f" ], + [ "summary.c", "summary_8c.html", "summary_8c" ], + [ "w3ai00.f", "w3ai00_8f.html", "w3ai00_8f" ], + [ "w3ai01.f", "w3ai01_8f.html", "w3ai01_8f" ], + [ "w3ai08.f", "w3ai08_8f.html", "w3ai08_8f" ], + [ "w3ai15.f", "w3ai15_8f.html", "w3ai15_8f" ], + [ "w3ai18.f", "w3ai18_8f.html", "w3ai18_8f" ], + [ "w3ai19.f", "w3ai19_8f.html", "w3ai19_8f" ], + [ "w3ai24.f", "w3ai24_8f.html", "w3ai24_8f" ], + [ "w3ai38.f", "w3ai38_8f.html", "w3ai38_8f" ], + [ "w3ai39.f", "w3ai39_8f.html", "w3ai39_8f" ], + [ "w3ai40.f", "w3ai40_8f.html", "w3ai40_8f" ], + [ "w3ai41.f", "w3ai41_8f.html", "w3ai41_8f" ], + [ "w3aq15.f", "w3aq15_8f.html", "w3aq15_8f" ], + [ "w3as00.f", "w3as00_8f.html", "w3as00_8f" ], + [ "w3ctzdat.f", "w3ctzdat_8f.html", "w3ctzdat_8f" ], + [ "w3difdat.f", "w3difdat_8f.html", "w3difdat_8f" ], + [ "w3doxdat.f", "w3doxdat_8f.html", "w3doxdat_8f" ], + [ "w3fa01.f", "w3fa01_8f.html", "w3fa01_8f" ], + [ "w3fa03.f", "w3fa03_8f.html", "w3fa03_8f" ], + [ "w3fa03v.f", "w3fa03v_8f.html", "w3fa03v_8f" ], + [ "w3fa04.f", "w3fa04_8f.html", "w3fa04_8f" ], + [ "w3fa06.f", "w3fa06_8f.html", "w3fa06_8f" ], + [ "w3fa09.f", "w3fa09_8f.html", "w3fa09_8f" ], + [ "w3fa11.f", "w3fa11_8f.html", "w3fa11_8f" ], + [ "w3fa12.f", "w3fa12_8f.html", "w3fa12_8f" ], + [ "w3fa13.f", "w3fa13_8f.html", "w3fa13_8f" ], + [ "w3fb00.f", "w3fb00_8f.html", "w3fb00_8f" ], + [ "w3fb01.f", "w3fb01_8f.html", "w3fb01_8f" ], + [ "w3fb02.f", "w3fb02_8f.html", "w3fb02_8f" ], + [ "w3fb03.f", "w3fb03_8f.html", "w3fb03_8f" ], + [ "w3fb04.f", "w3fb04_8f.html", "w3fb04_8f" ], + [ "w3fb05.f", "w3fb05_8f.html", "w3fb05_8f" ], + [ "w3fb06.f", "w3fb06_8f.html", "w3fb06_8f" ], + [ "w3fb07.f", "w3fb07_8f.html", "w3fb07_8f" ], + [ "w3fb08.f", "w3fb08_8f.html", "w3fb08_8f" ], + [ "w3fb09.f", "w3fb09_8f.html", "w3fb09_8f" ], + [ "w3fb10.f", "w3fb10_8f.html", "w3fb10_8f" ], + [ "w3fb11.f", "w3fb11_8f.html", "w3fb11_8f" ], + [ "w3fb12.f", "w3fb12_8f.html", "w3fb12_8f" ], + [ "w3fc02.f", "w3fc02_8f.html", "w3fc02_8f" ], + [ "w3fc05.f", "w3fc05_8f.html", "w3fc05_8f" ], + [ "w3fc06.f", "w3fc06_8f.html", "w3fc06_8f" ], + [ "w3fc07.f", "w3fc07_8f.html", "w3fc07_8f" ], + [ "w3fc08.f", "w3fc08_8f.html", "w3fc08_8f" ], + [ "w3fi01.f", "w3fi01_8f.html", "w3fi01_8f" ], + [ "w3fi02.f", "w3fi02_8f.html", "w3fi02_8f" ], + [ "w3fi03.f", "w3fi03_8f.html", "w3fi03_8f" ], + [ "w3fi04.f", "w3fi04_8f.html", "w3fi04_8f" ], + [ "w3fi18.f", "w3fi18_8f.html", "w3fi18_8f" ], + [ "w3fi19.f", "w3fi19_8f.html", "w3fi19_8f" ], + [ "w3fi20.f", "w3fi20_8f.html", "w3fi20_8f" ], + [ "w3fi32.f", "w3fi32_8f.html", "w3fi32_8f" ], + [ "w3fi47.f", "w3fi47_8f.html", "w3fi47_8f" ], + [ "w3fi48.f", "w3fi48_8f.html", "w3fi48_8f" ], + [ "w3fi52.f", "w3fi52_8f.html", "w3fi52_8f" ], + [ "w3fi58.f", "w3fi58_8f.html", "w3fi58_8f" ], + [ "w3fi59.f", "w3fi59_8f.html", "w3fi59_8f" ], + [ "w3fi61.f", "w3fi61_8f.html", "w3fi61_8f" ], + [ "w3fi62.f", "w3fi62_8f.html", "w3fi62_8f" ], + [ "w3fi63.f", "w3fi63_8f.html", "w3fi63_8f" ], + [ "w3fi64.f", "w3fi64_8f.html", "w3fi64_8f" ], + [ "w3fi65.f", "w3fi65_8f.html", "w3fi65_8f" ], + [ "w3fi66.f", "w3fi66_8f.html", "w3fi66_8f" ], + [ "w3fi67.f", "w3fi67_8f.html", "w3fi67_8f" ], + [ "w3fi68.f", "w3fi68_8f.html", "w3fi68_8f" ], + [ "w3fi69.f", "w3fi69_8f.html", "w3fi69_8f" ], + [ "w3fi70.f", "w3fi70_8f.html", "w3fi70_8f" ], + [ "w3fi71.f", "w3fi71_8f.html", "w3fi71_8f" ], + [ "w3fi72.f", "w3fi72_8f.html", "w3fi72_8f" ], + [ "w3fi73.f", "w3fi73_8f.html", "w3fi73_8f" ], + [ "w3fi74.f", "w3fi74_8f.html", "w3fi74_8f" ], + [ "w3fi75.f", "w3fi75_8f.html", "w3fi75_8f" ], + [ "w3fi76.f", "w3fi76_8f.html", "w3fi76_8f" ], + [ "w3fi78.f", "w3fi78_8f.html", "w3fi78_8f" ], + [ "w3fi82.f", "w3fi82_8f.html", "w3fi82_8f" ], + [ "w3fi83.f", "w3fi83_8f.html", "w3fi83_8f" ], + [ "w3fi85.f", "w3fi85_8f.html", "w3fi85_8f" ], + [ "w3fi88.f", "w3fi88_8f.html", "w3fi88_8f" ], + [ "w3fi92.f", "w3fi92_8f.html", "w3fi92_8f" ], + [ "w3fm07.f", "w3fm07_8f.html", "w3fm07_8f" ], + [ "w3fm08.f", "w3fm08_8f.html", "w3fm08_8f" ], + [ "w3fp04.f", "w3fp04_8f.html", "w3fp04_8f" ], + [ "w3fp05.f", "w3fp05_8f.html", "w3fp05_8f" ], + [ "w3fp06.f", "w3fp06_8f.html", "w3fp06_8f" ], + [ "w3fp10.f", "w3fp10_8f.html", "w3fp10_8f" ], + [ "w3fp11.f", "w3fp11_8f.html", "w3fp11_8f" ], + [ "w3fp12.f", "w3fp12_8f.html", "w3fp12_8f" ], + [ "w3fp13.f", "w3fp13_8f.html", "w3fp13_8f" ], + [ "w3fq07.f", "w3fq07_8f.html", "w3fq07_8f" ], + [ "w3fs13.f", "w3fs13_8f.html", "w3fs13_8f" ], + [ "w3fs15.f", "w3fs15_8f.html", "w3fs15_8f" ], + [ "w3fs21.f", "w3fs21_8f.html", "w3fs21_8f" ], + [ "w3fs26.f", "w3fs26_8f.html", "w3fs26_8f" ], + [ "w3ft00.f", "w3ft00_8f.html", "w3ft00_8f" ], + [ "w3ft01.f", "w3ft01_8f.html", "w3ft01_8f" ], + [ "w3ft02.f", "w3ft02_8f.html", "w3ft02_8f" ], + [ "w3ft03.f", "w3ft03_8f.html", "w3ft03_8f" ], + [ "w3ft05.f", "w3ft05_8f.html", "w3ft05_8f" ], + [ "w3ft05v.f", "w3ft05v_8f.html", "w3ft05v_8f" ], + [ "w3ft06.f", "w3ft06_8f.html", "w3ft06_8f" ], + [ "w3ft06v.f", "w3ft06v_8f.html", "w3ft06v_8f" ], + [ "w3ft07.f", "w3ft07_8f.html", "w3ft07_8f" ], + [ "w3ft08.f", "w3ft08_8f.html", "w3ft08_8f" ], + [ "w3ft09.f", "w3ft09_8f.html", "w3ft09_8f" ], + [ "w3ft10.f", "w3ft10_8f.html", "w3ft10_8f" ], + [ "w3ft11.f", "w3ft11_8f.html", "w3ft11_8f" ], + [ "w3ft12.f", "w3ft12_8f.html", "w3ft12_8f" ], + [ "w3ft16.f", "w3ft16_8f.html", "w3ft16_8f" ], + [ "w3ft17.f", "w3ft17_8f.html", "w3ft17_8f" ], + [ "w3ft201.f", "w3ft201_8f.html", "w3ft201_8f" ], + [ "w3ft202.f", "w3ft202_8f.html", "w3ft202_8f" ], + [ "w3ft203.f", "w3ft203_8f.html", "w3ft203_8f" ], + [ "w3ft204.f", "w3ft204_8f.html", "w3ft204_8f" ], + [ "w3ft205.f", "w3ft205_8f.html", "w3ft205_8f" ], + [ "w3ft206.f", "w3ft206_8f.html", "w3ft206_8f" ], + [ "w3ft207.f", "w3ft207_8f.html", "w3ft207_8f" ], + [ "w3ft208.f", "w3ft208_8f.html", "w3ft208_8f" ], + [ "w3ft209.f", "w3ft209_8f.html", "w3ft209_8f" ], + [ "w3ft21.f", "w3ft21_8f.html", "w3ft21_8f" ], + [ "w3ft210.f", "w3ft210_8f.html", "w3ft210_8f" ], + [ "w3ft211.f", "w3ft211_8f.html", "w3ft211_8f" ], + [ "w3ft212.f", "w3ft212_8f.html", "w3ft212_8f" ], + [ "w3ft213.f", "w3ft213_8f.html", "w3ft213_8f" ], + [ "w3ft214.f", "w3ft214_8f.html", "w3ft214_8f" ], + [ "w3ft26.f", "w3ft26_8f.html", "w3ft26_8f" ], + [ "w3ft32.f", "w3ft32_8f.html", "w3ft32_8f" ], + [ "w3ft33.f", "w3ft33_8f.html", "w3ft33_8f" ], + [ "w3ft38.f", "w3ft38_8f.html", "w3ft38_8f" ], + [ "w3ft39.f", "w3ft39_8f.html", "w3ft39_8f" ], + [ "w3ft40.f", "w3ft40_8f.html", "w3ft40_8f" ], + [ "w3ft41.f", "w3ft41_8f.html", "w3ft41_8f" ], + [ "w3ft43v.f", "w3ft43v_8f.html", "w3ft43v_8f" ], + [ "w3kind.f", "w3kind_8f.html", "w3kind_8f" ], + [ "w3locdat.f", "w3locdat_8f.html", "w3locdat_8f" ], + [ "w3log.f", "w3log_8f_source.html", null ], + [ "w3miscan.f", "w3miscan_8f.html", "w3miscan_8f" ], + [ "w3movdat.f", "w3movdat_8f.html", "w3movdat_8f" ], + [ "w3nogds.f", "w3nogds_8f.html", "w3nogds_8f" ], + [ "w3pradat.f", "w3pradat_8f.html", "w3pradat_8f" ], + [ "w3reddat.f", "w3reddat_8f.html", "w3reddat_8f" ], + [ "w3tagb.f", "w3tagb_8f.html", "w3tagb_8f" ], + [ "w3trnarg.f", "w3trnarg_8f.html", "w3trnarg_8f" ], + [ "w3unpk77.f", "w3unpk77_8f.html", "w3unpk77_8f" ], + [ "w3utcdat.f", "w3utcdat_8f.html", "w3utcdat_8f" ], + [ "w3valdat.f", "w3valdat_8f.html", "w3valdat_8f" ], + [ "w3ymdh4.f", "w3ymdh4_8f.html", "w3ymdh4_8f" ], + [ "xdopen.f", "xdopen_8f.html", "xdopen_8f" ], + [ "xmovex.f", "xmovex_8f.html", "xmovex_8f" ], + [ "xstore.f", "xstore_8f.html", "xstore_8f" ] +]; \ No newline at end of file diff --git a/ver-2.10.0/folderclosed.png b/ver-2.10.0/folderclosed.png new file mode 100644 index 00000000..bb8ab35e Binary files /dev/null and b/ver-2.10.0/folderclosed.png differ diff --git a/ver-2.10.0/folderopen.png b/ver-2.10.0/folderopen.png new file mode 100644 index 00000000..d6c7f676 Binary files /dev/null and b/ver-2.10.0/folderopen.png differ diff --git a/ver-2.10.0/fparsei_8f.html b/ver-2.10.0/fparsei_8f.html new file mode 100644 index 00000000..9129bb19 --- /dev/null +++ b/ver-2.10.0/fparsei_8f.html @@ -0,0 +1,175 @@ + + + + + + + +NCEPLIBS-w3emc: fparsei.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
fparsei.f File Reference
+
+
+ +

Extract integers from a free-format character string. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine fparsei (CARG, MARG, KARG)
 This subprogram extracts integers from a free-format character string. More...
 
+

Detailed Description

+

Extract integers from a free-format character string.

+
Author
Mark Iredell
+
Date
1998-09-03
+ +

Definition in file fparsei.f.

+

Function/Subroutine Documentation

+ +

◆ fparsei()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
subroutine fparsei (character*(*) CARG,
 MARG,
integer, dimension(marg) KARG 
)
+
+ +

This subprogram extracts integers from a free-format character string.

+

It is useful for parsing command arguments.

+

Program history log:

    +
  • 1998-09-03 Mark Iredell
    • +
+
Parameters
+ + + + +
[in]CARGcharacter*(*) string of ascii digits to parse. Integers may be separated by a comma or by blanks.
[in]MARGinteger maximum number of integers to parse.
[out]KARGinteger (MARG) numbers parsed. (from 0 to MARG values may be returned.)
+
+
+
Note
To determine the actual number of integers found in the string, KARG should be set to fill values before the call to FPARSEI() and the number of non-fill values should be counted after the call.
+
Author
Mark Iredell
+
Date
1998-09-03
+ +

Definition at line 25 of file fparsei.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/fparsei_8f.js b/ver-2.10.0/fparsei_8f.js new file mode 100644 index 00000000..ae0b6bc4 --- /dev/null +++ b/ver-2.10.0/fparsei_8f.js @@ -0,0 +1,4 @@ +var fparsei_8f = +[ + [ "fparsei", "fparsei_8f.html#a36e302a33bf921be9c7990e94ccc1a1f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/fparsei_8f_source.html b/ver-2.10.0/fparsei_8f_source.html new file mode 100644 index 00000000..88ded4fa --- /dev/null +++ b/ver-2.10.0/fparsei_8f_source.html @@ -0,0 +1,132 @@ + + + + + + + +NCEPLIBS-w3emc: fparsei.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
fparsei.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Extract integers from a free-format character string.
+
3 C> @author Mark Iredell @date 1998-09-03
+
4 
+
5 C> This subprogram extracts integers from a free-format
+
6 C> character string. It is useful for parsing command arguments.
+
7 C>
+
8 C> Program history log:
+
9 C> - 1998-09-03 Mark Iredell
+
10 C>
+
11 C> @param[in] CARG character*(*) string of ascii digits to parse.
+
12 C> Integers may be separated by a comma or by blanks.
+
13 C> @param[in] MARG integer maximum number of integers to parse.
+
14 C>
+
15 C> @param[out] KARG integer (MARG) numbers parsed.
+
16 C> (from 0 to MARG values may be returned.)
+
17 C>
+
18 C> @note To determine the actual number of integers found in the string,
+
19 C> KARG should be set to fill values before the call to FPARSEI() and
+
20 C> the number of non-fill values should be counted after the call.
+
21 C>
+
22 C> @author Mark Iredell @date 1998-09-03
+
23 C-----------------------------------------------------------------------
+
24  SUBROUTINE fparsei(CARG,MARG,KARG)
+
25  CHARACTER*(*) CARG
+
26  INTEGER KARG(MARG)
+
27 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
28  READ(carg,*,iostat=ios) karg
+
29 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
30  END
+
+
+
fparsei
subroutine fparsei(CARG, MARG, KARG)
This subprogram extracts integers from a free-format character string.
Definition: fparsei.f:25
+ + + + diff --git a/ver-2.10.0/fparser_8f.html b/ver-2.10.0/fparser_8f.html new file mode 100644 index 00000000..1c3694dc --- /dev/null +++ b/ver-2.10.0/fparser_8f.html @@ -0,0 +1,175 @@ + + + + + + + +NCEPLIBS-w3emc: fparser.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
fparser.f File Reference
+
+
+ +

Extracts real numbers from a free-format character string. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine fparser (CARG, MARG, RARG)
 This subprogram extracts real numbers from a free-format character string. More...
 
+

Detailed Description

+

Extracts real numbers from a free-format character string.

+
Author
Mark Iredell
+
Date
1998-09-03
+ +

Definition in file fparser.f.

+

Function/Subroutine Documentation

+ +

◆ fparser()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
subroutine fparser (character*(*) CARG,
 MARG,
real, dimension(marg) RARG 
)
+
+ +

This subprogram extracts real numbers from a free-format character string.

+

It is useful for parsing command arguments.

+

Program history log:

    +
  • 1998-09-03 Mark Iredell
    • +
+
Parameters
+ + + + +
[in]CARGcharacter*(*) string of ascii digits to parse. Real numbers may be separated by a comma or by blanks.
[in]MARGinteger maximum number of real numbers to parse.
[out]RARGreal (MARG) numbers parsed. (from 0 to MARG values may be returned.)
+
+
+
Note
To determine the actual number of real numbers found in the string, RARG should be set to fill values before the call to FPARSER() and the number of non-fill values should be counted after the call.
+
Author
Mark Iredell
+
Date
1998-09-03
+ +

Definition at line 25 of file fparser.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/fparser_8f.js b/ver-2.10.0/fparser_8f.js new file mode 100644 index 00000000..01254742 --- /dev/null +++ b/ver-2.10.0/fparser_8f.js @@ -0,0 +1,4 @@ +var fparser_8f = +[ + [ "fparser", "fparser_8f.html#afd0eece805c9f9aa1afa5b5496298aa5", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/fparser_8f_source.html b/ver-2.10.0/fparser_8f_source.html new file mode 100644 index 00000000..001bbf79 --- /dev/null +++ b/ver-2.10.0/fparser_8f_source.html @@ -0,0 +1,132 @@ + + + + + + + +NCEPLIBS-w3emc: fparser.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
fparser.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Extracts real numbers from a free-format character string.
+
3 C> @author Mark Iredell @date 1998-09-03
+
4 
+
5 C> This subprogram extracts real numbers from a free-format
+
6 C> character string. It is useful for parsing command arguments.
+
7 C>
+
8 C> Program history log:
+
9 C> - 1998-09-03 Mark Iredell
+
10 C>
+
11 C> @param[in] CARG character*(*) string of ascii digits to parse.
+
12 C> Real numbers may be separated by a comma or by blanks.
+
13 C> @param[in] MARG integer maximum number of real numbers to parse.
+
14 C>
+
15 C> @param[out] RARG real (MARG) numbers parsed.
+
16 C> (from 0 to MARG values may be returned.)
+
17 C>
+
18 C> @note To determine the actual number of real numbers found in the string,
+
19 C> RARG should be set to fill values before the call to FPARSER() and
+
20 C> the number of non-fill values should be counted after the call.
+
21 C>
+
22 C> @author Mark Iredell @date 1998-09-03
+
23 C-----------------------------------------------------------------------
+
24  SUBROUTINE fparser(CARG,MARG,RARG)
+
25  CHARACTER*(*) CARG
+
26  REAL RARG(MARG)
+
27 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
28  READ(carg,*,iostat=ios) rarg
+
29 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
30  END
+
+
+
fparser
subroutine fparser(CARG, MARG, RARG)
This subprogram extracts real numbers from a free-format character string.
Definition: fparser.f:25
+ + + + diff --git a/ver-2.10.0/gbyte_8f.html b/ver-2.10.0/gbyte_8f.html new file mode 100644 index 00000000..edee446e --- /dev/null +++ b/ver-2.10.0/gbyte_8f.html @@ -0,0 +1,181 @@ + + + + + + + +NCEPLIBS-w3emc: gbyte.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
gbyte.f File Reference
+
+
+ +

This is the fortran version of gbyte. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine gbyte (IPACKD, IUNPKD, NOFF, NBITS)
 This is the fortran version of gbyte. More...
 
+

Detailed Description

+

This is the fortran version of gbyte.

+
Author
Dr. Robert C. Gammill
+
Date
1972-05-DD
+ +

Definition in file gbyte.f.

+

Function/Subroutine Documentation

+ +

◆ gbyte()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine gbyte (integer, dimension(*) IPACKD,
integer IUNPKD,
 NOFF,
 NBITS 
)
+
+ +

This is the fortran version of gbyte.

+

Program history log:

    +
  • Russell E. Jones 1991-03-DD Changes for SiliconGraphics IRIS-4D/25 SiliconGraphics 3.3 FORTRAN 77.
    • +
+

To unpack a byte into a target word. The unpacked byte is right-justified in the target word, and the remainder of the word is zero-filled.

+
Parameters
+ + + + + +
[in]IPACKDThe word or array containing the byte to be unpacked.
[out]IUNPKDThe word which will contain the unpacked byte.
[in]NOFFThe number of bits to skip, left to right, in IPACKD in order to locate the byte to be unpacked.
[in]NBITSNumber of bits in the byte to be unpacked. Maximum of 64 bits on 64 bit machine, 32 bits on 32 bit machine.
+
+
+
Author
Dr. Robert C. Gammill
+
Date
1972-05-DD
+ +

Definition at line 27 of file gbyte.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/gbyte_8f.js b/ver-2.10.0/gbyte_8f.js new file mode 100644 index 00000000..f4d3943f --- /dev/null +++ b/ver-2.10.0/gbyte_8f.js @@ -0,0 +1,4 @@ +var gbyte_8f = +[ + [ "gbyte", "gbyte_8f.html#ad73b69048043b0e9876125b1d839e5c6", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/gbyte_8f_source.html b/ver-2.10.0/gbyte_8f_source.html new file mode 100644 index 00000000..628afa96 --- /dev/null +++ b/ver-2.10.0/gbyte_8f_source.html @@ -0,0 +1,188 @@ + + + + + + + +NCEPLIBS-w3emc: gbyte.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
gbyte.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief This is the fortran version of gbyte.
+
3 C> @author Dr. Robert C. Gammill @date 1972-05-DD
+
4 
+
5 C> This is the fortran version of gbyte
+
6 C>
+
7 C> Program history log:
+
8 C> - Russell E. Jones 1991-03-DD
+
9 C> Changes for SiliconGraphics IRIS-4D/25
+
10 C> SiliconGraphics 3.3 FORTRAN 77.
+
11 C>
+
12 C> To unpack a byte into a target word. The unpacked byte is right-justified
+
13 C> in the target word, and the remainder of the word is zero-filled.
+
14 C>
+
15 C> @param[in] IPACKD The word or array containing the byte to be unpacked.
+
16 C>
+
17 C> @param[out] IUNPKD The word which will contain the unpacked byte.
+
18 C>
+
19 C> @param[in] NOFF The number of bits to skip, left to right, in IPACKD
+
20 C> in order to locate the byte to be unpacked.
+
21 C>
+
22 C> @param[in] NBITS Number of bits in the byte to be unpacked. Maximum of
+
23 C> 64 bits on 64 bit machine, 32 bits on 32 bit machine.
+
24 C>
+
25 C> @author Dr. Robert C. Gammill @date 1972-05-DD
+
26  SUBROUTINE gbyte(IPACKD,IUNPKD,NOFF,NBITS)
+
27  INTEGER IPACKD(*)
+
28  INTEGER IUNPKD
+
29  INTEGER MASKS(64)
+
30 C
+
31  SAVE
+
32 C
+
33  DATA ifirst/1/
+
34  IF(ifirst.EQ.1) THEN
+
35  CALL w3fi01(lw)
+
36  nbitsw = 8 * lw
+
37  jshift = -1 * nint(alog(float(nbitsw)) / alog(2.0))
+
38  masks(1) = 1
+
39  DO i=2,nbitsw-1
+
40  masks(i) = 2 * masks(i-1) + 1
+
41  ENDDO
+
42  masks(nbitsw) = -1
+
43  ifirst = 0
+
44  ENDIF
+
45 C
+
46 C NBITS MUST BE LESS THAN OR EQUAL TO NBITSW
+
47 C
+
48  icon = nbitsw - nbits
+
49  IF (icon.LT.0) RETURN
+
50  mask = masks(nbits)
+
51 C
+
52 C INDEX TELLS HOW MANY WORDS INTO THE ARRAY 'IPACKD' THE NEXT BYTE
+
53 C APPEARS.
+
54 C
+
55  index = ishft(noff,jshift)
+
56 C
+
57 C II TELLS HOW MANY BITS THE BYTE IS FROM THE LEFT SIDE OF THE WORD.
+
58 C
+
59  ii = mod(noff,nbitsw)
+
60 C
+
61 C MOVER SPECIFIES HOW FAR TO THE RIGHT NBITS MUST BE MOVED IN ORDER
+
62 C
+
63 C TO BE RIGHT ADJUSTED.
+
64 C
+
65  mover = icon - ii
+
66 C
+
67  IF (mover.GT.0) THEN
+
68  iunpkd = iand(ishft(ipackd(index+1),-mover),mask)
+
69 C
+
70 C THE BYTE IS SPLIT ACROSS A WORD BREAK.
+
71 C
+
72  ELSE IF (mover.LT.0) THEN
+
73  movel = - mover
+
74  mover = nbitsw - movel
+
75  iunpkd = iand(ior(ishft(ipackd(index+1),movel),
+
76  & ishft(ipackd(index+2),-mover)),mask)
+
77 C
+
78 C THE BYTE IS ALREADY RIGHT ADJUSTED.
+
79 C
+
80  ELSE
+
81  iunpkd = iand(ipackd(index+1),mask)
+
82  ENDIF
+
83 C
+
84  RETURN
+
85  END
+
+
+
gbyte
subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
This is the fortran version of gbyte.
Definition: gbyte.f:27
+
w3fi01
subroutine w3fi01(LW)
Determines the number of bytes in a full word for the particular machine (IBM or cray).
Definition: w3fi01.f:19
+ + + + diff --git a/ver-2.10.0/gbytec_8f.html b/ver-2.10.0/gbytec_8f.html new file mode 100644 index 00000000..27b36406 --- /dev/null +++ b/ver-2.10.0/gbytec_8f.html @@ -0,0 +1,174 @@ + + + + + + + +NCEPLIBS-w3emc: gbytec.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
gbytec.f File Reference
+
+
+ +

Wrapper for gbytesc() limiting NSKIP and N to 0 and 1. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine gbytec (IN, IOUT, ISKIP, NBYTE)
 Wrapper for gbytesc() limiting NSKIP and N to 0 and 1. More...
 
+

Detailed Description

+

Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.

+
Author
NOAA Programmer
+ +

Definition in file gbytec.f.

+

Function/Subroutine Documentation

+ +

◆ gbytec()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine gbytec (character*1, dimension(*) IN,
integer, dimension(*) IOUT,
 ISKIP,
 NBYTE 
)
+
+ +

Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.

+
Parameters
+ + + + + +
[in]INCharacter*1 array input.
[out]IOUTUnpacked array output.
[in]ISKIPInitial number of bits to skip.
[in]NBYTENumber of bits to take.
+
+
+ +

Definition at line 14 of file gbytec.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/gbytec_8f.js b/ver-2.10.0/gbytec_8f.js new file mode 100644 index 00000000..1a118a20 --- /dev/null +++ b/ver-2.10.0/gbytec_8f.js @@ -0,0 +1,4 @@ +var gbytec_8f = +[ + [ "gbytec", "gbytec_8f.html#adcae5457ea7270b3b95a379fec9233d7", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/gbytec_8f_source.html b/ver-2.10.0/gbytec_8f_source.html new file mode 100644 index 00000000..d07eddad --- /dev/null +++ b/ver-2.10.0/gbytec_8f_source.html @@ -0,0 +1,121 @@ + + + + + + + +NCEPLIBS-w3emc: gbytec.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
gbytec.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
+
3 C> @author NOAA Programmer
+
4 
+
5 C> Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
+
6 C>
+
7 C> @param[in] IN Character*1 array input.
+
8 C> @param[out] IOUT Unpacked array output.
+
9 C> @param[in] ISKIP Initial number of bits to skip.
+
10 C> @param[in] NBYTE Number of bits to take.
+
11 C>
+
12 
+
13  SUBROUTINE gbytec(IN,IOUT,ISKIP,NBYTE)
+
14  character*1 in(*)
+
15  integer iout(*)
+
16  CALL gbytesc(in,iout,iskip,nbyte,0,1)
+
17  RETURN
+
18  END
+
+
+
gbytesc
subroutine gbytesc(IN, IOUT, ISKIP, NBYTE, NSKIP, N)
Extract arbitrary size values from a packed bit string, right justifying each value in the unpacked a...
Definition: gbytesc.f:16
+
gbytec
subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
Definition: gbytec.f:14
+ + + + diff --git a/ver-2.10.0/gbytes_8f.html b/ver-2.10.0/gbytes_8f.html new file mode 100644 index 00000000..97b47ec3 --- /dev/null +++ b/ver-2.10.0/gbytes_8f.html @@ -0,0 +1,193 @@ + + + + + + + +NCEPLIBS-w3emc: gbytes.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
gbytes.f File Reference
+
+
+ +

This is the fortran version of gbytes. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine gbytes (IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
 Program history log: More...
 
+

Detailed Description

+

This is the fortran version of gbytes.

+
Author
Dr. Robert C. Gammill
+
Date
1972-05
+ +

Definition in file gbytes.f.

+

Function/Subroutine Documentation

+ +

◆ gbytes()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine gbytes (integer, dimension(*) IPACKD,
integer, dimension(*) IUNPKD,
 NOFF,
 NBITS,
 ISKIP,
 ITER 
)
+
+ +

Program history log:

+
    +
  • Russell E. Jones 1991-03 Changes for SiliconGraphics IRIS-4D/25 SiliconGraphics 3.3 FORTRAN 77
    • +
+

To unpack a series of bytes into a target array. Each unpacked byte is right-justified in its target word, and the remainder of the word is zero-filled.

+
Parameters
+ + + + + + + +
[in]IPACKDThe word or array containing the packed bytes.
[out]IUNPKDThe array which will contain the unpacked bytes.
[in]NOFFThe initial number of bits to skip, left to right, in 'IPACKD' in order to locate the first byte to unpack.
[in]NBITSNumber of bits in the byte to be unpacked. Maximum of 64 bits on 64 bit machine, 32 bits on 32 bit machine.
[in]ISKIPThe number of bits to skip between each byte in 'IPACKD' in order to locate the next byte to be unpacked.
[in]ITERThe number of bytes to be unpacked.
+
+
+ +

Definition at line 26 of file gbytes.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/gbytes_8f.js b/ver-2.10.0/gbytes_8f.js new file mode 100644 index 00000000..06f92073 --- /dev/null +++ b/ver-2.10.0/gbytes_8f.js @@ -0,0 +1,4 @@ +var gbytes_8f = +[ + [ "gbytes", "gbytes_8f.html#ac957b0c87f1261d8460c52bfec7d0308", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/gbytes_8f_source.html b/ver-2.10.0/gbytes_8f_source.html new file mode 100644 index 00000000..54550ab6 --- /dev/null +++ b/ver-2.10.0/gbytes_8f_source.html @@ -0,0 +1,215 @@ + + + + + + + +NCEPLIBS-w3emc: gbytes.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
gbytes.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief This is the fortran version of gbytes.
+
3 C> @author Dr. Robert C. Gammill @date 1972-05
+
4 
+
5 C> Program history log:
+
6 C> - Russell E. Jones 1991-03
+
7 C> Changes for SiliconGraphics IRIS-4D/25
+
8 C> SiliconGraphics 3.3 FORTRAN 77
+
9 C>
+
10 C> To unpack a series of bytes into a target
+
11 C> array. Each unpacked byte is right-justified
+
12 C> in its target word, and the remainder of the
+
13 C> word is zero-filled.
+
14 C>
+
15 C> @param[in] IPACKD The word or array containing the packed bytes.
+
16 C> @param[out] IUNPKD The array which will contain the unpacked bytes.
+
17 C> @param[in] NOFF The initial number of bits to skip, left to right,
+
18 C> in 'IPACKD' in order to locate the first byte to unpack.
+
19 C> @param[in] NBITS Number of bits in the byte to be unpacked.
+
20 C> Maximum of 64 bits on 64 bit machine, 32 bits on 32 bit machine.
+
21 C> @param[in] ISKIP The number of bits to skip between each byte in
+
22 C> 'IPACKD' in order to locate the next byte to be unpacked.
+
23 C> @param[in] ITER The number of bytes to be unpacked.
+
24 C>
+
25  SUBROUTINE gbytes(IPACKD,IUNPKD,NOFF,NBITS,ISKIP,ITER)
+
26 
+
27  INTEGER IPACKD(*)
+
28 
+
29  INTEGER IUNPKD(*)
+
30  INTEGER MASKS(64)
+
31 C
+
32  SAVE
+
33 C
+
34  DATA ifirst/1/
+
35  IF(ifirst.EQ.1) THEN
+
36  CALL w3fi01(lw)
+
37  nbitsw = 8 * lw
+
38  jshift = -1 * nint(alog(float(nbitsw)) / alog(2.0))
+
39  masks(1) = 1
+
40  DO i=2,nbitsw-1
+
41  masks(i) = 2 * masks(i-1) + 1
+
42  ENDDO
+
43  masks(nbitsw) = -1
+
44  ifirst = 0
+
45  ENDIF
+
46 C
+
47 C NBITS MUST BE LESS THAN OR EQUAL TO NBITSW
+
48 C
+
49  icon = nbitsw - nbits
+
50  IF (icon.LT.0) RETURN
+
51  mask = masks(nbits)
+
52 C
+
53 C INDEX TELLS HOW MANY WORDS INTO THE ARRAY 'IPACKD' THE NEXT BYTE
+
54 C APPEARS.
+
55 C
+
56  index = ishft(noff,jshift)
+
57 C
+
58 C II TELLS HOW MANY BITS THE BYTE IS FROM THE LEFT SIDE OF THE WORD.
+
59 C
+
60  ii = mod(noff,nbitsw)
+
61 C
+
62 C ISTEP IS THE DISTANCE IN BITS FROM THE START OF ONE BYTE TO THE NEXT.
+
63 C
+
64  istep = nbits + iskip
+
65 C
+
66 C IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT.
+
67 C
+
68  iwords = istep / nbitsw
+
69 C
+
70 C IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS.
+
71 C
+
72  ibits = mod(istep,nbitsw)
+
73 C
+
74  DO 10 i = 1,iter
+
75 C
+
76 C MOVER SPECIFIES HOW FAR TO THE RIGHT A BYTE MUST BE MOVED IN ORDER
+
77 C
+
78 C TO BE RIGHT ADJUSTED.
+
79 C
+
80  mover = icon - ii
+
81 C
+
82 C THE BYTE IS SPLIT ACROSS A WORD BREAK.
+
83 C
+
84  IF (mover.LT.0) THEN
+
85  movel = - mover
+
86  mover = nbitsw - movel
+
87  iunpkd(i) = iand(ior(ishft(ipackd(index+1),movel),
+
88  & ishft(ipackd(index+2),-mover)),mask)
+
89 C
+
90 C RIGHT ADJUST THE BYTE.
+
91 C
+
92  ELSE IF (mover.GT.0) THEN
+
93  iunpkd(i) = iand(ishft(ipackd(index+1),-mover),mask)
+
94 C
+
95 C THE BYTE IS ALREADY RIGHT ADJUSTED.
+
96 C
+
97  ELSE
+
98  iunpkd(i) = iand(ipackd(index+1),mask)
+
99  ENDIF
+
100 C
+
101 C INCREMENT II AND INDEX.
+
102 C
+
103  ii = ii + ibits
+
104  index = index + iwords
+
105  IF (ii.GE.nbitsw) THEN
+
106  ii = ii - nbitsw
+
107  index = index + 1
+
108  ENDIF
+
109 C
+
110  10 CONTINUE
+
111  RETURN
+
112  END
+
+
+
gbytes
subroutine gbytes(IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
Program history log:
Definition: gbytes.f:26
+
w3fi01
subroutine w3fi01(LW)
Determines the number of bytes in a full word for the particular machine (IBM or cray).
Definition: w3fi01.f:19
+ + + + diff --git a/ver-2.10.0/gbytesc_8f.html b/ver-2.10.0/gbytesc_8f.html new file mode 100644 index 00000000..54343f88 --- /dev/null +++ b/ver-2.10.0/gbytesc_8f.html @@ -0,0 +1,188 @@ + + + + + + + +NCEPLIBS-w3emc: gbytesc.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
gbytesc.f File Reference
+
+
+ +

Get bytes - unpack bits. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine gbytesc (IN, IOUT, ISKIP, NBYTE, NSKIP, N)
 Extract arbitrary size values from a packed bit string, right justifying each value in the unpacked array. More...
 
+

Detailed Description

+

Get bytes - unpack bits.

+
Author
Unknown
+ +

Definition in file gbytesc.f.

+

Function/Subroutine Documentation

+ +

◆ gbytesc()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine gbytesc (character*1, dimension(*) IN,
integer, dimension(*) IOUT,
 ISKIP,
 NBYTE,
 NSKIP,
 N 
)
+
+ +

Extract arbitrary size values from a packed bit string, right justifying each value in the unpacked array.

+
Parameters
+ + + + + + + +
[in]INCharacter*1 array input.
[out]IOUTUnpacked array output.
[in]ISKIPInitial number of bits to skip.
[in]NBYTENumber of bits to take.
[in]NSKIPAdditional number of bits to skip on each iteration.
[in]NNumber of iterations.
+
+
+ +

Definition at line 16 of file gbytesc.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/gbytesc_8f.js b/ver-2.10.0/gbytesc_8f.js new file mode 100644 index 00000000..b390b28b --- /dev/null +++ b/ver-2.10.0/gbytesc_8f.js @@ -0,0 +1,4 @@ +var gbytesc_8f = +[ + [ "gbytesc", "gbytesc_8f.html#a8fd2d6beeef9feaf3ef1e927f66678db", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/gbytesc_8f_source.html b/ver-2.10.0/gbytesc_8f_source.html new file mode 100644 index 00000000..07624313 --- /dev/null +++ b/ver-2.10.0/gbytesc_8f_source.html @@ -0,0 +1,157 @@ + + + + + + + +NCEPLIBS-w3emc: gbytesc.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
gbytesc.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Get bytes - unpack bits.
+
3 C> @author Unknown
+
4 
+
5 C> Extract arbitrary size values from a packed bit string,
+
6 C> right justifying each value in the unpacked array.
+
7 C>
+
8 C> @param[in] IN Character*1 array input.
+
9 C> @param[out] IOUT Unpacked array output.
+
10 C> @param[in] ISKIP Initial number of bits to skip.
+
11 C> @param[in] NBYTE Number of bits to take.
+
12 C> @param[in] NSKIP Additional number of bits to skip on each iteration.
+
13 C> @param[in] N Number of iterations.
+
14 C>
+
15  SUBROUTINE gbytesc(IN,IOUT,ISKIP,NBYTE,NSKIP,N)
+
16  character*1 in(*)
+
17  integer iout(*)
+
18  integer ones(8), tbit, bitcnt
+
19  save ones
+
20  data ones/1,3,7,15,31,63,127,255/
+
21 
+
22 c nbit is the start position of the field in bits
+
23  nbit = iskip
+
24  do i = 1, n
+
25  bitcnt = nbyte
+
26  index=nbit/8+1
+
27  ibit=mod(nbit,8)
+
28  nbit = nbit + nbyte + nskip
+
29 
+
30 c first byte
+
31  tbit = min(bitcnt,8-ibit)
+
32  itmp = iand(mova2i(in(index)),ones(8-ibit))
+
33  if (tbit.ne.8-ibit) itmp = ishft(itmp,tbit-8+ibit)
+
34  index = index + 1
+
35  bitcnt = bitcnt - tbit
+
36 
+
37 c now transfer whole bytes
+
38  do while (bitcnt.ge.8)
+
39  itmp = ior(ishft(itmp,8),mova2i(in(index)))
+
40  bitcnt = bitcnt - 8
+
41  index = index + 1
+
42  enddo
+
43 
+
44 c get data from last byte
+
45  if (bitcnt.gt.0) then
+
46  itmp = ior(ishft(itmp,bitcnt),iand(ishft(mova2i(in(index)),
+
47  1 -(8-bitcnt)),ones(bitcnt)))
+
48  endif
+
49 
+
50  iout(i) = itmp
+
51  enddo
+
52 
+
53  RETURN
+
54  END
+
+
+
gbytesc
subroutine gbytesc(IN, IOUT, ISKIP, NBYTE, NSKIP, N)
Extract arbitrary size values from a packed bit string, right justifying each value in the unpacked a...
Definition: gbytesc.f:16
+
mova2i
integer function mova2i(a)
This Function copies a bit string from a Character*1 variable to an integer variable.
Definition: mova2i.f:25
+ + + + diff --git a/ver-2.10.0/getbit_8f.html b/ver-2.10.0/getbit_8f.html new file mode 100644 index 00000000..052cbcc1 --- /dev/null +++ b/ver-2.10.0/getbit_8f.html @@ -0,0 +1,143 @@ + + + + + + + +NCEPLIBS-w3emc: getbit.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getbit.f File Reference
+
+
+ +

Compute number of bits and round field. +More...

+ +

Go to the source code of this file.

+ + + + +

+Functions/Subroutines

+subroutine getbit (IBM, IBS, IDS, LEN, MG, G, GROUND, GMIN, GMAX, NBIT)
 
+

Detailed Description

+

Compute number of bits and round field.

+
Author
Mark Iredell
+
Date
1992-10-31
+

The number of bits required to pack a given field. The field is rounded off to the decimal scaling for packing. The minimum and maximum rounded field values are also returned. For particular binary and decimal scalings is computed. Grib bitmap masking for valid data is optionally used.

+

Program history log:

    +
  • Mark Iredell 1996-09-16
    • +
+
Parameters
+ + + + + + + + + + + +
[in]IBMInteger bitmap flag (=0 for no bitmap).
[in]IBSInteger binary scaling (e.g. ibs=3 to round field to nearest eighth value).
[in]IDSInteger decimal scaling (e.g. ids=3 to round field to nearest milli-value) (note that ids and ibs can both be nonzero, e.g. ids=1 and ibs=1 rounds to the nearest twentieth).
[in]LENInteger length of the field and bitmap.
[in]MGInteger (LEN) bitmap if ibm=1 (0 to skip, 1 to keep).
[in]GReal (LEN) field.
[out]GROUNDReal (LEN) field rounded to decimal and binary scaling (set to zero where bitmap is 0 if ibm=1).
[out]GMINReal minimum valid rounded field value.
[out]GMAXReal maximum valid rounded field value.
[out]NBITInteger number of bits to pack.
+
+
+
Note
CRAY FORTRAN
+
Author
Mark Iredell
+
Date
1992-10-31
+ +

Definition in file getbit.f.

+
+
+ + + + diff --git a/ver-2.10.0/getbit_8f.js b/ver-2.10.0/getbit_8f.js new file mode 100644 index 00000000..40001f69 --- /dev/null +++ b/ver-2.10.0/getbit_8f.js @@ -0,0 +1,4 @@ +var getbit_8f = +[ + [ "getbit", "getbit_8f.html#a4f6601b376b03ad983fefd25058f1de9", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getbit_8f_source.html b/ver-2.10.0/getbit_8f_source.html new file mode 100644 index 00000000..f554bfd1 --- /dev/null +++ b/ver-2.10.0/getbit_8f_source.html @@ -0,0 +1,181 @@ + + + + + + + +NCEPLIBS-w3emc: getbit.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getbit.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Compute number of bits and round field.
+
3 C> @author Mark Iredell @date 1992-10-31
+
4 C>
+
5 C> The number of bits required to pack a given field.
+
6 C> The field is rounded off to the decimal scaling for packing.
+
7 C> The minimum and maximum rounded field values are also returned.
+
8 C> For particular binary and decimal scalings is computed.
+
9 C> Grib bitmap masking for valid data is optionally used.
+
10 C>
+
11 C> Program history log:
+
12 C> - Mark Iredell 1996-09-16
+
13 C>
+
14 C> @param[in] IBM Integer bitmap flag (=0 for no bitmap).
+
15 C> @param[in] IBS Integer binary scaling (e.g. ibs=3 to round field
+
16 C> to nearest eighth value).
+
17 C> @param[in] IDS Integer decimal scaling (e.g. ids=3 to round field
+
18 C> to nearest milli-value) (note that ids and ibs can both be nonzero,
+
19 C> e.g. ids=1 and ibs=1 rounds to the nearest twentieth).
+
20 C> @param[in] LEN Integer length of the field and bitmap.
+
21 C> @param[in] MG Integer (LEN) bitmap if ibm=1 (0 to skip, 1 to keep).
+
22 C> @param[in] G Real (LEN) field.
+
23 C> @param[out] GROUND Real (LEN) field rounded to decimal and binary scaling
+
24 C> (set to zero where bitmap is 0 if ibm=1).
+
25 C> @param[out] GMIN Real minimum valid rounded field value.
+
26 C> @param[out] GMAX Real maximum valid rounded field value.
+
27 C> @param[out] NBIT Integer number of bits to pack.
+
28 C>
+
29 C> @note CRAY FORTRAN
+
30 C>
+
31 C> @author Mark Iredell @date 1992-10-31
+
32  SUBROUTINE getbit(IBM,IBS,IDS,LEN,MG,G,GROUND,GMIN,GMAX,NBIT)
+
33  dimension mg(len),g(len),ground(len)
+
34 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
35 C ROUND FIELD AND DETERMINE EXTREMES WHERE BITMAP IS ON
+
36  s=2.**ibs*10.**ids
+
37  IF(ibm.EQ.0) THEN
+
38  ground(1)=nint(g(1)*s)/s
+
39  gmax=ground(1)
+
40  gmin=ground(1)
+
41  DO i=2,len
+
42  ground(i)=nint(g(i)*s)/s
+
43  gmax=max(gmax,ground(i))
+
44  gmin=min(gmin,ground(i))
+
45  ENDDO
+
46  ELSE
+
47  i1=1
+
48  dowhile(i1.LE.len.AND.mg(i1).EQ.0)
+
49  i1=i1+1
+
50  ENDDO
+
51  IF(i1.LE.len) THEN
+
52  DO i=1,i1-1
+
53  ground(i)=0.
+
54  ENDDO
+
55  ground(i1)=nint(g(i1)*s)/s
+
56  gmax=ground(i1)
+
57  gmin=ground(i1)
+
58  DO i=i1+1,len
+
59  IF(mg(i).NE.0) THEN
+
60  ground(i)=nint(g(i)*s)/s
+
61  gmax=max(gmax,ground(i))
+
62  gmin=min(gmin,ground(i))
+
63  ELSE
+
64  ground(i)=0.
+
65  ENDIF
+
66  ENDDO
+
67  ELSE
+
68  DO i=1,len
+
69  ground(i)=0.
+
70  ENDDO
+
71  gmax=0.
+
72  gmin=0.
+
73  ENDIF
+
74  ENDIF
+
75 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
76 C COMPUTE NUMBER OF BITS
+
77  nbit=log((gmax-gmin)*s+0.9)/log(2.)+1.
+
78 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
79  RETURN
+
80  END
+
+
+ + + + diff --git a/ver-2.10.0/getgb1_8f.html b/ver-2.10.0/getgb1_8f.html new file mode 100644 index 00000000..80be35f7 --- /dev/null +++ b/ver-2.10.0/getgb1_8f.html @@ -0,0 +1,260 @@ + + + + + + + +NCEPLIBS-w3emc: getgb1.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgb1.f File Reference
+
+
+ +

Find and unpacks a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgb1 (LUGB, LUGI, JF, J, JPDS, JGDS, GRIB, KF, K, KPDS, KGDS, LB, F, IRET)
 Find and unpack a grib message. More...
 
+

Detailed Description

+

Find and unpacks a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgb1.f.

+

Function/Subroutine Documentation

+ +

◆ getgb1()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgb1 ( LUGB,
 LUGI,
 JF,
 J,
integer, dimension(25) JPDS,
integer, dimension(*) JGDS,
character*1, dimension(*) GRIB,
 KF,
 K,
integer, dimension(25) KPDS,
integer, dimension(*) KGDS,
logical, dimension(*) LB,
real, dimension(*) F,
 IRET 
)
+
+ +

Find and unpack a grib message.

+

Read an associated grib index file (unless it already was read). Find in the index file a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file and unpacked. Its message number is returned along with the unpacked pds and gds parameters, the unpacked bitmap (if any), and the unpacked data. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Ralph Jones 1995-05-10 Add one more parameter to getgb and change name to getgb1.
    • +
+
Parameters
+ + + + + + + + + + + + + + + +
[in]lugblogical unit of the unblocked grib data file.
[in]lugilogical unit of the unblocked grib index file.
[in]jfinteger maximum number of data points to unpack.
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to reopen index file and search from beginning).
[in]jpdsinteger (25) pds parameters for which to search (=-1 for wildcard) look in doc block of w3fi63 for array kpds for list of order of unpacked pds values. In most cases you only need to set 4 or 5 values to pick up record.
[in]jgdsinteger (22) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
[out]gribGrib data array before it is unpacked.
[out]kfInteger number of data points unpacked.
[out]kInteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsInteger (25) unpacked pds parameters.
[out]kgdsInteger (22) unpacked gds parameters.
[out]lbLogical (kf) unpacked bitmap if present.
[out]fReal (kf) unpacked data.
[out]iretInteger return code.
    +
  • 0 All ok.
    • +
  • 96 Error reading index file.
    • +
  • 97 Error reading grib file.
    • +
  • 98 Number of data points greater than jf.
    • +
  • 99 Request not found.
    • +
  • other w3fi63 grib unpacker return code.
    • +
+
+
+
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 53 of file getgb1.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgb1_8f.js b/ver-2.10.0/getgb1_8f.js new file mode 100644 index 00000000..c5b2de0c --- /dev/null +++ b/ver-2.10.0/getgb1_8f.js @@ -0,0 +1,4 @@ +var getgb1_8f = +[ + [ "getgb1", "getgb1_8f.html#a124fccd25cd6967ce2b5ba8629e3707c", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgb1_8f_source.html b/ver-2.10.0/getgb1_8f_source.html new file mode 100644 index 00000000..41a9411b --- /dev/null +++ b/ver-2.10.0/getgb1_8f_source.html @@ -0,0 +1,285 @@ + + + + + + + +NCEPLIBS-w3emc: getgb1.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgb1.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find and unpacks a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Find and unpack a grib message.
+
6 C> Read an associated grib index file (unless it already was read).
+
7 C> Find in the index file a reference to the grib message requested.
+
8 C> The grib message request specifies the number of messages to skip
+
9 C> and the unpacked pds and gds parameters. (A requested parameter
+
10 C> of -1 means to allow any value of this parameter to be found.)
+
11 C> If the requested grib message is found, then it is read from the
+
12 C> grib file and unpacked. Its message number is returned along with
+
13 C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
14 C> and the unpacked data. If the grib message is not found, then the
+
15 C> return code will be nonzero.
+
16 C>
+
17 C> Program history log:
+
18 C> - Mark Iredell 1994-04-01
+
19 C> - Ralph Jones 1995-05-10 Add one more parameter to getgb and
+
20 C> change name to getgb1.
+
21 C>
+
22 C> @param[in] lugb logical unit of the unblocked grib data file.
+
23 C> @param[in] lugi logical unit of the unblocked grib index file.
+
24 C> @param[in] jf integer maximum number of data points to unpack.
+
25 C> @param[in] j integer number of messages to skip (=0 to search from beginning)
+
26 C> (<0 to reopen index file and search from beginning).
+
27 C> @param[in] jpds integer (25) pds parameters for which to search
+
28 C> (=-1 for wildcard) look in doc block of w3fi63 for array kpds
+
29 C> for list of order of unpacked pds values.
+
30 C> In most cases you only need to set 4 or 5 values to pick up record.
+
31 C> @param[in] jgds integer (22) gds parameters for which to search
+
32 C> (only searched if jpds(3)=255) (=-1 for wildcard).
+
33 C> @param[out] grib Grib data array before it is unpacked.
+
34 C> @param[out] kf Integer number of data points unpacked.
+
35 C> @param[out] k Integer message number unpacked
+
36 C> (can be same as j in calling program
+
37 C> in order to facilitate multiple searches).
+
38 C> @param[out] kpds Integer (25) unpacked pds parameters.
+
39 C> @param[out] kgds Integer (22) unpacked gds parameters.
+
40 C> @param[out] lb Logical (kf) unpacked bitmap if present.
+
41 C> @param[out] f Real (kf) unpacked data.
+
42 C> @param[out] iret Integer return code.
+
43 C> - 0 All ok.
+
44 C> - 96 Error reading index file.
+
45 C> - 97 Error reading grib file.
+
46 C> - 98 Number of data points greater than jf.
+
47 C> - 99 Request not found.
+
48 C> - other w3fi63 grib unpacker return code.
+
49 C>
+
50 C> @author Mark Iredell @date 1994-04-01
+
51  SUBROUTINE getgb1(LUGB,LUGI,JF,J,JPDS,JGDS,
+
52  & GRIB,KF,K,KPDS,KGDS,LB,F,IRET)
+
53 C
+
54  parameter(mbuf=8192*128)
+
55  parameter(lpds=23,lgds=22)
+
56 C
+
57  INTEGER JPDS(25),JGDS(*),KPDS(25),KGDS(*)
+
58  INTEGER IPDSP(LPDS),JPDSP(LPDS),IGDSP(LGDS)
+
59  INTEGER JGDSP(LGDS)
+
60  INTEGER KPTR(20)
+
61 C
+
62  LOGICAL LB(*)
+
63 C
+
64  REAL F(*)
+
65 C
+
66  CHARACTER CBUF(MBUF)
+
67  CHARACTER*81 CHEAD(2)
+
68  CHARACTER*1 CPDS(28)
+
69  CHARACTER*1 CGDS(42)
+
70  CHARACTER*1 GRIB(*)
+
71 C
+
72 C SAVE LUX,NSKP,NLEN,NNUM,CBUF
+
73  SAVE
+
74 C
+
75  DATA lux/0/
+
76 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
77 C READ INDEX FILE
+
78  IF(j.LT.0.OR.lugi.NE.lux) THEN
+
79 C REWIND LUGI
+
80 C READ(LUGI,fmt='(2A81)',IOSTAT=IOS) CHEAD
+
81  CALL baread(lugi,0,162,ios,chead)
+
82  IF(ios.EQ.162.AND.chead(1)(42:47).EQ.'GB1IX1') THEN
+
83  lux=0
+
84  READ(chead(2),'(8X,3I10,2X,A40)',iostat=ios) nskp,nlen,nnum
+
85  IF(ios.EQ.0) THEN
+
86  nbuf=nnum*nlen
+
87  IF(nbuf.GT.mbuf) THEN
+
88  print *,'GETGB1: INCREASE BUFFER FROM ',mbuf,' TO ',nbuf
+
89  nnum=mbuf/nlen
+
90  nbuf=nnum*nlen
+
91  ENDIF
+
92  CALL baread(lugi,nskp,nbuf,lbuf,cbuf)
+
93  IF(lbuf.EQ.nbuf) THEN
+
94  lux=lugi
+
95  j=max(j,0)
+
96  ENDIF
+
97  ENDIF
+
98  ENDIF
+
99  ENDIF
+
100 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
101 C SEARCH FOR REQUEST
+
102  lgrib=0
+
103  kj=j
+
104  k=j
+
105  kf=0
+
106  IF(j.GE.0.AND.lugi.EQ.lux) THEN
+
107  lpdsp=0
+
108  DO i=1,lpds
+
109  IF(jpds(i).NE.-1) THEN
+
110  lpdsp=lpdsp+1
+
111  ipdsp(lpdsp)=i
+
112  jpdsp(lpdsp)=jpds(i)
+
113  ENDIF
+
114  ENDDO
+
115  lgdsp=0
+
116  IF(jpds(3).EQ.255) THEN
+
117  DO i=1,lgds
+
118  IF(jgds(i).NE.-1) THEN
+
119  lgdsp=lgdsp+1
+
120  igdsp(lgdsp)=i
+
121  jgdsp(lgdsp)=jgds(i)
+
122  ENDIF
+
123  ENDDO
+
124  ENDIF
+
125  iret=99
+
126  dowhile(lgrib.EQ.0.AND.kj.LT.nnum)
+
127  kj=kj+1
+
128  lt=0
+
129  IF(lpdsp.GT.0) THEN
+
130  cpds=cbuf((kj-1)*nlen+26:(kj-1)*nlen+53)
+
131  kptr=0
+
132  CALL gbyte(cbuf,kptr(3),(kj-1)*nlen*8+25*8,3*8)
+
133  CALL fi632(cpds,kptr,kpds,iret)
+
134  DO i=1,lpdsp
+
135  ip=ipdsp(i)
+
136  lt=lt+abs(jpds(ip)-kpds(ip))
+
137  ENDDO
+
138  ENDIF
+
139  IF(lt.EQ.0.AND.lgdsp.GT.0) THEN
+
140  cgds=cbuf((kj-1)*nlen+54:(kj-1)*nlen+95)
+
141  kptr=0
+
142  CALL fi633(cgds,kptr,kgds,iret)
+
143  DO i=1,lgdsp
+
144  ip=igdsp(i)
+
145  lt=lt+abs(jgds(ip)-kgds(ip))
+
146  ENDDO
+
147  ENDIF
+
148 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
149 C READ AND UNPACK GRIB DATA
+
150  IF(lt.EQ.0) THEN
+
151  CALL gbyte(cbuf,lskip,(kj-1)*nlen*8,4*8)
+
152  CALL gbyte(cbuf,lgrib,(kj-1)*nlen*8+20*8,4*8)
+
153  cgds=cbuf((kj-1)*nlen+54:(kj-1)*nlen+95)
+
154  kptr=0
+
155  CALL fi633(cgds,kptr,kgds,iret)
+
156 C BSM IF(LGRIB.LE.200+17*JF/8.AND.KGDS(2)*KGDS(3).LE.JF) THEN
+
157 C Change number of bits that can be handled to 25
+
158  IF(lgrib.LE.200+25*jf/8.AND.kgds(2)*kgds(3).LE.jf) THEN
+
159  CALL baread(lugb,lskip,lgrib,lread,grib)
+
160  IF(lread.EQ.lgrib) THEN
+
161  CALL w3fi63(grib,kpds,kgds,lb,f,kptr,iret)
+
162  IF(iret.EQ.0) THEN
+
163  k=kj
+
164  kf=kptr(10)
+
165  ENDIF
+
166  ELSE
+
167  iret=97
+
168  ENDIF
+
169  ELSE
+
170  iret=98
+
171  ENDIF
+
172  ENDIF
+
173  ENDDO
+
174  ELSE
+
175  iret=96
+
176  ENDIF
+
177 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
178  RETURN
+
179  END
+
+
+
fi632
subroutine fi632(MSGA, KPTR, KPDS, KRET)
Gather info from product definition sec.
Definition: w3fi63.f:635
+
w3fi63
subroutine w3fi63(MSGA, KPDS, KGDS, KBMS, DATA, KPTR, KRET)
Unpack a GRIB (edition 1) field to the exact grid specified in the GRIB message, isolate the bit map,...
Definition: w3fi63.f:243
+
fi633
subroutine fi633(MSGA, KPTR, KGDS, KRET)
Extract info from grib-gds.
Definition: w3fi63.f:981
+
getgb1
subroutine getgb1(LUGB, LUGI, JF, J, JPDS, JGDS, GRIB, KF, K, KPDS, KGDS, LB, F, IRET)
Find and unpack a grib message.
Definition: getgb1.f:53
+
gbyte
subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
This is the fortran version of gbyte.
Definition: gbyte.f:27
+ + + + diff --git a/ver-2.10.0/getgb1r_8f.html b/ver-2.10.0/getgb1r_8f.html new file mode 100644 index 00000000..7a6fd40f --- /dev/null +++ b/ver-2.10.0/getgb1r_8f.html @@ -0,0 +1,234 @@ + + + + + + + +NCEPLIBS-w3emc: getgb1r.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgb1r.f File Reference
+
+
+ +

Reads and unpacks a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgb1r (LUGB, LSKIP, LGRIB, KF, KPDS, KGDS, KENS, LB, F, NBITSS, IRET)
 Program history log: More...
 
+

Detailed Description

+

Reads and unpacks a grib message.

+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition in file getgb1r.f.

+

Function/Subroutine Documentation

+ +

◆ getgb1r()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgb1r ( LUGB,
 LSKIP,
 LGRIB,
 KF,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
logical*1, dimension(*) LB,
real, dimension(*) F,
 NBITSS,
 IRET 
)
+
+ +

Program history log:

+
    +
  • Mark Iredell 1995-10-31
    • +
  • Chuang 2004-07-22 Add packing bit number nbitss in the argument list because eta grib files need it to repack grib file.
    Parameters
    + + + + + + + + + + + + +
    [in]LUGBInteger unit of the unblocked grib data file.
    [in]LSKIPInteger number of bytes to skip.
    [in]LGRIBInteger number of bytes to read.
    [out]KFInteger number of data points unpacked.
    [out]KPDSInteger (200) unpacked pds parameters.
    [out]KGDSInteger (200) unpacked gds parameters.
    [out]KENSInteger (200) unpacked ensemble pds parms.
    [out]LBLogical*1 (kf) unpacked bitmap if present.
    [out]FReal (kf) unpacked data.
    [out]NBITSSPackaging bit number. Used by GRIB file to repack.
    [out]IRETInteger return code.
    +
    +
    +
    • +
  • 0 All ok.
    • +
  • 97 Error reading grib file.
    • +
  • other w3fi63 grib unpacker return code.
    • +
+
Note
There is no protection against unpacking too much data. Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor. This subprogram is intended for private use by getgb routines only.
+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition at line 34 of file getgb1r.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgb1r_8f.js b/ver-2.10.0/getgb1r_8f.js new file mode 100644 index 00000000..c9c560e1 --- /dev/null +++ b/ver-2.10.0/getgb1r_8f.js @@ -0,0 +1,4 @@ +var getgb1r_8f = +[ + [ "getgb1r", "getgb1r_8f.html#a38f437c2ae06e0aecb78f8841749a09d", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgb1r_8f_source.html b/ver-2.10.0/getgb1r_8f_source.html new file mode 100644 index 00000000..cfeacce7 --- /dev/null +++ b/ver-2.10.0/getgb1r_8f_source.html @@ -0,0 +1,166 @@ + + + + + + + +NCEPLIBS-w3emc: getgb1r.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgb1r.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Reads and unpacks a grib message.
+
3 C> @author Mark Iredell @date 1995-10-31
+
4 
+
5 C> Program history log:
+
6 C> - Mark Iredell 1995-10-31
+
7 C> - Chuang 2004-07-22 Add packing bit number nbitss in the argument
+
8 C> list because eta grib files need it to repack grib file.
+
9 C> @param[in] LUGB Integer unit of the unblocked grib data file.
+
10 C> @param[in] LSKIP Integer number of bytes to skip.
+
11 C> @param[in] LGRIB Integer number of bytes to read.
+
12 C> @param[out] KF Integer number of data points unpacked.
+
13 C> @param[out] KPDS Integer (200) unpacked pds parameters.
+
14 C> @param[out] KGDS Integer (200) unpacked gds parameters.
+
15 C> @param[out] KENS Integer (200) unpacked ensemble pds parms.
+
16 C> @param[out] LB Logical*1 (kf) unpacked bitmap if present.
+
17 C> @param[out] F Real (kf) unpacked data.
+
18 C> @param[out] NBITSS Packaging bit number. Used by GRIB file to repack.
+
19 C> @param[out] IRET Integer return code.
+
20 C> - 0 All ok.
+
21 C> - 97 Error reading grib file.
+
22 C> - other w3fi63 grib unpacker return code.
+
23 C>
+
24 C> @note There is no protection against unpacking too much data.
+
25 C> Subprogram can be called from a multiprocessing environment.
+
26 C> Do not engage the same logical unit from more than one processor.
+
27 C> This subprogram is intended for private use by getgb routines only.
+
28 C>
+
29 C> @author Mark Iredell @date 1995-10-31
+
30 
+
31 C-----------------------------------------------------------------------
+
32  SUBROUTINE getgb1r(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,NBITSS
+
33  + ,IRET)
+
34  INTEGER KPDS(200),KGDS(200),KENS(200)
+
35  LOGICAL*1 LB(*)
+
36  REAL F(*)
+
37  INTEGER KPTR(200)
+
38  CHARACTER GRIB(LGRIB)*1
+
39 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
40 C READ GRIB RECORD
+
41  CALL baread(lugb,lskip,lgrib,lread,grib)
+
42 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
43 C UNPACK GRIB RECORD
+
44  IF(lread.EQ.lgrib) THEN
+
45  CALL w3fi63(grib,kpds,kgds,lb,f,kptr,iret)
+
46  IF(iret.EQ.0.AND.kpds(23).EQ.2) THEN
+
47  CALL pdseup(kens,kprob,xprob,kclust,kmembr,45,grib(9))
+
48  ENDIF
+
49  ELSE
+
50  iret=97
+
51  ENDIF
+
52  nbitss=kptr(20)
+
53 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
54 C RETURN NUMBER OF POINTS
+
55  IF(iret.EQ.0) THEN
+
56  kf=kptr(10)
+
57  ELSE
+
58  kf=0
+
59  ENDIF
+
60 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
61  RETURN
+
62  END
+
+
+
getgb1r
subroutine getgb1r(LUGB, LSKIP, LGRIB, KF, KPDS, KGDS, KENS, LB, F, NBITSS, IRET)
Program history log:
Definition: getgb1r.f:34
+
w3fi63
subroutine w3fi63(MSGA, KPDS, KGDS, KBMS, DATA, KPTR, KRET)
Unpack a GRIB (edition 1) field to the exact grid specified in the GRIB message, isolate the bit map,...
Definition: w3fi63.f:243
+
pdseup
subroutine pdseup(KENS, KPROB, XPROB, KCLUST, KMEMBR, ILAST, MSGA)
Unpacks grib pds extension starting on byte 41 for ensemble forecast products.
Definition: pdseup.f:28
+ + + + diff --git a/ver-2.10.0/getgb1re_8f.html b/ver-2.10.0/getgb1re_8f.html new file mode 100644 index 00000000..ece153dd --- /dev/null +++ b/ver-2.10.0/getgb1re_8f.html @@ -0,0 +1,254 @@ + + + + + + + +NCEPLIBS-w3emc: getgb1re.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgb1re.f File Reference
+
+
+ +

Reads and unpacks a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgb1re (LUGB, LSKIP, LGRIB, KF, KPDS, KGDS, KENS, KPROB, XPROB, KCLUST, KMEMBR, LB, F, IRET)
 Reads and unpacks a grib message. More...
 
+

Detailed Description

+

Reads and unpacks a grib message.

+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition in file getgb1re.f.

+

Function/Subroutine Documentation

+ +

◆ getgb1re()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgb1re ( LUGB,
 LSKIP,
 LGRIB,
 KF,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
integer, dimension(2) KPROB,
real, dimension(2) XPROB,
integer, dimension(16) KCLUST,
integer, dimension(80) KMEMBR,
logical*1, dimension(*) LB,
real, dimension(*) F,
 IRET 
)
+
+ +

Reads and unpacks a grib message.

+

PROGRAM HISTORY LOG: Mark Iredell 1995-10-31 Y. Zhu 1997-02-11 Included probability and cluster arguments.

+
Parameters
+ + + + + + + + + + + + + + + +
[in]LUGBInteger unit of the unblocked grib data file.
[in]LSKIPInteger number of bytes to skip.
[in]LGRIBInteger number of bytes to read.
[out]KFInteger number of data points unpacked.
[out]KPDSInteger (200) unpacked pds parameters.
[out]KGDSInteger (200) unpacked gds parameters.
[out]KENSInteger (200) unpacked ensemble pds parms.
[out]KPROBInteger (2) probability ensemble parms.
[out]XPROBReal (2) probability ensemble parms.
[out]KCLUSTInteger (16) cluster ensemble parms.
[out]KMEMBRInteger (8) cluster ensemble parms.
[out]LBLogical*1 (kf) unpacked bitmap if present.
[out]FReal (kf) unpacked data.
[out]IRETInteger return code.
    +
  • 0 All ok.
    • +
  • 97 Error reading grib file.
    • +
  • other w3fi63 grib unpacker return code.
    • +
+
+
+
+
Note
There is no protection against unpacking too much data. Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor. This subprogram is intended for private use by getgb routines only.
+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition at line 38 of file getgb1re.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgb1re_8f.js b/ver-2.10.0/getgb1re_8f.js new file mode 100644 index 00000000..cbebc91a --- /dev/null +++ b/ver-2.10.0/getgb1re_8f.js @@ -0,0 +1,4 @@ +var getgb1re_8f = +[ + [ "getgb1re", "getgb1re_8f.html#a964db1a320f7b795dd353fbd292c06d7", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgb1re_8f_source.html b/ver-2.10.0/getgb1re_8f_source.html new file mode 100644 index 00000000..5bd68da3 --- /dev/null +++ b/ver-2.10.0/getgb1re_8f_source.html @@ -0,0 +1,171 @@ + + + + + + + +NCEPLIBS-w3emc: getgb1re.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgb1re.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Reads and unpacks a grib message.
+
3 C> @author Mark Iredell @date 1995-10-31
+
4 
+
5 C> Reads and unpacks a grib message.
+
6 C>
+
7 C> PROGRAM HISTORY LOG:
+
8 C> Mark Iredell 1995-10-31
+
9 C> Y. Zhu 1997-02-11 Included probability and cluster arguments.
+
10 C>
+
11 C> @param[in] LUGB Integer unit of the unblocked grib data file.
+
12 C> @param[in] LSKIP Integer number of bytes to skip.
+
13 C> @param[in] LGRIB Integer number of bytes to read.
+
14 C> @param[out] KF Integer number of data points unpacked.
+
15 C> @param[out] KPDS Integer (200) unpacked pds parameters.
+
16 C> @param[out] KGDS Integer (200) unpacked gds parameters.
+
17 C> @param[out] KENS Integer (200) unpacked ensemble pds parms.
+
18 C> @param[out] KPROB Integer (2) probability ensemble parms.
+
19 C> @param[out] XPROB Real (2) probability ensemble parms.
+
20 C> @param[out] KCLUST Integer (16) cluster ensemble parms.
+
21 C> @param[out] KMEMBR Integer (8) cluster ensemble parms.
+
22 C> @param[out] LB Logical*1 (kf) unpacked bitmap if present.
+
23 C> @param[out] F Real (kf) unpacked data.
+
24 C> @param[out] IRET Integer return code.
+
25 C> - 0 All ok.
+
26 C> - 97 Error reading grib file.
+
27 C> - other w3fi63 grib unpacker return code.
+
28 C>
+
29 C> @note There is no protection against unpacking too much data.
+
30 C> Subprogram can be called from a multiprocessing environment.
+
31 C> Do not engage the same logical unit from more than one processor.
+
32 C> This subprogram is intended for private use by getgb routines only.
+
33 C>
+
34 C> @author Mark Iredell @date 1995-10-31
+
35 C-----------------------------------------------------------------------
+
36  SUBROUTINE getgb1re(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,
+
37  & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET)
+
38  INTEGER KPDS(200),KGDS(200),KENS(200)
+
39  INTEGER KPROB(2),KCLUST(16),KMEMBR(80)
+
40  REAL XPROB(2)
+
41  LOGICAL*1 LB(*)
+
42  REAL F(*)
+
43  INTEGER KPTR(200)
+
44  CHARACTER GRIB(LGRIB)*1
+
45 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
46 C READ GRIB RECORD
+
47  CALL baread(lugb,lskip,lgrib,lread,grib)
+
48 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
49 C UNPACK GRIB RECORD
+
50  IF(lread.EQ.lgrib) THEN
+
51  CALL w3fi63(grib,kpds,kgds,lb,f,kptr,iret)
+
52  IF(iret.EQ.0.AND.kpds(23).EQ.2) THEN
+
53  CALL pdseup(kens,kprob,xprob,kclust,kmembr,86,grib(9))
+
54  ENDIF
+
55  ELSE
+
56  iret=97
+
57  ENDIF
+
58 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
59 C RETURN NUMBER OF POINTS
+
60  IF(iret.EQ.0) THEN
+
61  kf=kptr(10)
+
62  ELSE
+
63  kf=0
+
64  ENDIF
+
65 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
66  RETURN
+
67  END
+
+
+
getgb1re
subroutine getgb1re(LUGB, LSKIP, LGRIB, KF, KPDS, KGDS, KENS, KPROB, XPROB, KCLUST, KMEMBR, LB, F, IRET)
Reads and unpacks a grib message.
Definition: getgb1re.f:38
+
w3fi63
subroutine w3fi63(MSGA, KPDS, KGDS, KBMS, DATA, KPTR, KRET)
Unpack a GRIB (edition 1) field to the exact grid specified in the GRIB message, isolate the bit map,...
Definition: w3fi63.f:243
+
pdseup
subroutine pdseup(KENS, KPROB, XPROB, KCLUST, KMEMBR, ILAST, MSGA)
Unpacks grib pds extension starting on byte 41 for ensemble forecast products.
Definition: pdseup.f:28
+ + + + diff --git a/ver-2.10.0/getgb1s_8f.html b/ver-2.10.0/getgb1s_8f.html new file mode 100644 index 00000000..9f2af5ff --- /dev/null +++ b/ver-2.10.0/getgb1s_8f.html @@ -0,0 +1,257 @@ + + + + + + + +NCEPLIBS-w3emc: getgb1s.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgb1s.f File Reference
+
+
+ +

Find a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgb1s (CBUF, NLEN, NNUM, J, JPDS, JGDS, JENS, K, KPDS, KGDS, KENS, LSKIP, LGRIB, IRET)
 Find a grib message. More...
 
+

Detailed Description

+

Find a grib message.

+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition in file getgb1s.f.

+

Function/Subroutine Documentation

+ +

◆ getgb1s()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgb1s (character, dimension(nlen*nnum) CBUF,
 NLEN,
 NNUM,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
integer, dimension(200) JENS,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
 LSKIP,
 LGRIB,
 IRET 
)
+
+ +

Find a grib message.

+

Find in the index file a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.)

+

Program history log:

    +
  • Mark Iredell 1995-10-31
    • +
  • Mark Iredell 2001-06-05 Apply linux port by ebisuzaki.
    • +
+
Parameters
+ + + + + + + + + + + + + + + +
[in]CBUFCharacter*1 (nlen*nnum) buffer containing index data.
[in]NLENInteger length of each index record in bytes.
[in]NNUMInteger number of index records.
[in]JInteger number of messages to skip (=0 to search from beginning).
[in]JPDSInteger (200) pds parameters for which to search (=-1 for wildcard).
[in]JGDSInteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
[in]JENSInteger (200) ensemble pds parms for which to search (only searched if jpds(23)=2) (=-1 for wildcard).
[out]KInteger message number found (can be same as j in calling program in order to facilitate multiple searches).
[out]KPDSInteger (200) unpacked pds parameters.
[out]KGDSInteger (200) unpacked gds parameters.
[out]KENSInteger (200) unpacked ensemble pds parms.
[out]LSKIPInteger number of bytes to skip.
[out]LGRIBInteger number of bytes to read.
[out]IRETInteger return code.
    +
  • 0 All ok.
    • +
  • 1 Request not found.
    • +
+
+
+
+
Note
Subprogram can be called from a multiprocessing environment. This subprogram is intended for private use by getgb routines only.
+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition at line 44 of file getgb1s.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgb1s_8f.js b/ver-2.10.0/getgb1s_8f.js new file mode 100644 index 00000000..85ccd6c5 --- /dev/null +++ b/ver-2.10.0/getgb1s_8f.js @@ -0,0 +1,4 @@ +var getgb1s_8f = +[ + [ "getgb1s", "getgb1s_8f.html#a112566bbdfcf96f3ce3f7c5e2ba8618f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgb1s_8f_source.html b/ver-2.10.0/getgb1s_8f_source.html new file mode 100644 index 00000000..ed1b9a14 --- /dev/null +++ b/ver-2.10.0/getgb1s_8f_source.html @@ -0,0 +1,273 @@ + + + + + + + +NCEPLIBS-w3emc: getgb1s.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgb1s.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find a grib message.
+
3 C> @author Mark Iredell @date 1995-10-31
+
4 
+
5 C> Find a grib message.
+
6 C> Find in the index file a reference to the grib message requested.
+
7 C> The grib message request specifies the number of messages to skip
+
8 c> and the unpacked pds and gds parameters. (A requested parameter
+
9 c> of -1 means to allow any value of this parameter to be found.)
+
10 C>
+
11 C> Program history log:
+
12 C> - Mark Iredell 1995-10-31
+
13 C> - Mark Iredell 2001-06-05 Apply linux port by ebisuzaki.
+
14 C>
+
15 C> @param[in] CBUF Character*1 (nlen*nnum) buffer containing index data.
+
16 C> @param[in] NLEN Integer length of each index record in bytes.
+
17 C> @param[in] NNUM Integer number of index records.
+
18 C> @param[in] J Integer number of messages to skip
+
19 c> (=0 to search from beginning).
+
20 C> @param[in] JPDS Integer (200) pds parameters for which to search
+
21 c> (=-1 for wildcard).
+
22 C> @param[in] JGDS Integer (200) gds parameters for which to search
+
23 c> (only searched if jpds(3)=255) (=-1 for wildcard).
+
24 C> @param[in] JENS Integer (200) ensemble pds parms for which to search
+
25 c> (only searched if jpds(23)=2) (=-1 for wildcard).
+
26 C> @param[out] K Integer message number found
+
27 c> (can be same as j in calling program in order to facilitate multiple searches).
+
28 C> @param[out] KPDS Integer (200) unpacked pds parameters.
+
29 C> @param[out] KGDS Integer (200) unpacked gds parameters.
+
30 C> @param[out] KENS Integer (200) unpacked ensemble pds parms.
+
31 C> @param[out] LSKIP Integer number of bytes to skip.
+
32 C> @param[out] LGRIB Integer number of bytes to read.
+
33 C> @param[out] IRET Integer return code.
+
34 C> - 0 All ok.
+
35 C> - 1 Request not found.
+
36 C>
+
37 C> @note Subprogram can be called from a multiprocessing environment.
+
38 C> This subprogram is intended for private use by getgb routines only.
+
39 C>
+
40 C> @author Mark Iredell @date 1995-10-31
+
41 C-----------------------------------------------------------------------
+
42  SUBROUTINE getgb1s(CBUF,NLEN,NNUM,J,JPDS,JGDS,JENS,
+
43  & K,KPDS,KGDS,KENS,LSKIP,LGRIB,IRET)
+
44  CHARACTER CBUF(NLEN*NNUM)
+
45  INTEGER JPDS(200),JGDS(200),JENS(200)
+
46  INTEGER KPDS(200),KGDS(200),KENS(200)
+
47  parameter(lpds=23,lgds=22,lens=5) ! ACTUAL SEARCH RANGES
+
48  CHARACTER CPDS(400)*1,CGDS(400)*1
+
49  INTEGER KPTR(200)
+
50  INTEGER IPDSP(LPDS),JPDSP(LPDS)
+
51  INTEGER IGDSP(LGDS),JGDSP(LGDS)
+
52  INTEGER IENSP(LENS),JENSP(LENS)
+
53 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
54 C COMPRESS REQUEST LISTS
+
55  k=j
+
56  lskip=0
+
57  lgrib=0
+
58  iret=1
+
59 C COMPRESS PDS REQUEST
+
60  lpdsp=0
+
61  DO i=1,lpds
+
62  IF(jpds(i).NE.-1) THEN
+
63  lpdsp=lpdsp+1
+
64  ipdsp(lpdsp)=i
+
65  jpdsp(lpdsp)=jpds(i)
+
66  ENDIF
+
67  ENDDO
+
68 C COMPRESS GDS REQUEST
+
69  lgdsp=0
+
70  IF(jpds(3).EQ.255) THEN
+
71  DO i=1,lgds
+
72  IF(jgds(i).NE.-1) THEN
+
73  lgdsp=lgdsp+1
+
74  igdsp(lgdsp)=i
+
75  jgdsp(lgdsp)=jgds(i)
+
76  ENDIF
+
77  ENDDO
+
78  ENDIF
+
79 C COMPRESS ENS REQUEST
+
80  lensp=0
+
81  IF(jpds(23).EQ.2) THEN
+
82  DO i=1,lens
+
83  IF(jens(i).NE.-1) THEN
+
84  lensp=lensp+1
+
85  iensp(lensp)=i
+
86  jensp(lensp)=jens(i)
+
87  ENDIF
+
88  ENDDO
+
89  ENDIF
+
90 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
91 C SEARCH FOR REQUEST
+
92  dowhile(iret.NE.0.AND.k.LT.nnum)
+
93  k=k+1
+
94  lt=0
+
95 C SEARCH FOR PDS REQUEST
+
96  IF(lpdsp.GT.0) THEN
+
97  cpds=char(0)
+
98  cpds(1:28)=cbuf((k-1)*nlen+26:(k-1)*nlen+53)
+
99  nless=max(184-nlen,0)
+
100  cpds(29:40-nless)=cbuf((k-1)*nlen+173:(k-1)*nlen+184-nless)
+
101  kptr=0
+
102  CALL gbytec(cbuf,kptr(3),(k-1)*nlen*8+25*8,3*8)
+
103  kpds(18)=1
+
104  CALL gbytec(cpds,kpds(4),7*8,8)
+
105  CALL fi632(cpds,kptr,kpds,kret)
+
106  DO i=1,lpdsp
+
107  ip=ipdsp(i)
+
108  lt=lt+abs(jpds(ip)-kpds(ip))
+
109  ENDDO
+
110  ENDIF
+
111 C SEARCH FOR GDS REQUEST
+
112  IF(lt.EQ.0.AND.lgdsp.GT.0) THEN
+
113  cgds=char(0)
+
114  cgds(1:42)=cbuf((k-1)*nlen+54:(k-1)*nlen+95)
+
115  nless=max(320-nlen,0)
+
116  cgds(43:178-nless)=cbuf((k-1)*nlen+185:(k-1)*nlen+320-nless)
+
117  kptr=0
+
118  CALL fi633(cgds,kptr,kgds,kret)
+
119  DO i=1,lgdsp
+
120  ip=igdsp(i)
+
121  lt=lt+abs(jgds(ip)-kgds(ip))
+
122  ENDDO
+
123  ENDIF
+
124 C SEARCH FOR ENS REQUEST
+
125  IF(lt.EQ.0.AND.lensp.GT.0) THEN
+
126  nless=max(172-nlen,0)
+
127  cpds(41:100-nless)=cbuf((k-1)*nlen+113:(k-1)*nlen+172-nless)
+
128  CALL pdseup(kens,kprob,xprob,kclust,kmembr,45,cpds)
+
129  DO i=1,lensp
+
130  ip=iensp(i)
+
131  lt=lt+abs(jens(ip)-kens(ip))
+
132  ENDDO
+
133  ENDIF
+
134 C RETURN IF REQUEST IS FOUND
+
135  IF(lt.EQ.0) THEN
+
136  CALL gbytec(cbuf,lskip,(k-1)*nlen*8,4*8)
+
137  CALL gbytec(cbuf,lgrib,(k-1)*nlen*8+20*8,4*8)
+
138  IF(lpdsp.EQ.0) THEN
+
139  cpds=char(0)
+
140  cpds(1:28)=cbuf((k-1)*nlen+26:(k-1)*nlen+53)
+
141  nless=max(184-nlen,0)
+
142  cpds(29:40-nless)=cbuf((k-1)*nlen+173:(k-1)*nlen+184-nless)
+
143  kptr=0
+
144  CALL gbytec(cbuf,kptr(3),(k-1)*nlen*8+25*8,3*8)
+
145  kpds(18)=1
+
146  CALL gbytec(cpds,kpds(4),7*8,8)
+
147  CALL fi632(cpds,kptr,kpds,kret)
+
148  ENDIF
+
149  IF(lgdsp.EQ.0) THEN
+
150  cgds=char(0)
+
151  cgds(1:42)=cbuf((k-1)*nlen+54:(k-1)*nlen+95)
+
152  nless=max(320-nlen,0)
+
153  cgds(43:178-nless)=cbuf((k-1)*nlen+185:(k-1)*nlen+320-nless)
+
154  kptr=0
+
155  CALL fi633(cgds,kptr,kgds,kret)
+
156  ENDIF
+
157  IF(kpds(23).EQ.2.AND.lensp.EQ.0) THEN
+
158  nless=max(172-nlen,0)
+
159  cpds(41:100-nless)=cbuf((k-1)*nlen+113:(k-1)*nlen+172-nless)
+
160  CALL pdseup(kens,kprob,xprob,kclust,kmembr,45,cpds)
+
161  ENDIF
+
162  iret=0
+
163  ENDIF
+
164  ENDDO
+
165 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
166  RETURN
+
167  END
+
+
+
fi632
subroutine fi632(MSGA, KPTR, KPDS, KRET)
Gather info from product definition sec.
Definition: w3fi63.f:635
+
getgb1s
subroutine getgb1s(CBUF, NLEN, NNUM, J, JPDS, JGDS, JENS, K, KPDS, KGDS, KENS, LSKIP, LGRIB, IRET)
Find a grib message.
Definition: getgb1s.f:44
+
gbytec
subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
Definition: gbytec.f:14
+
fi633
subroutine fi633(MSGA, KPTR, KGDS, KRET)
Extract info from grib-gds.
Definition: w3fi63.f:981
+
pdseup
subroutine pdseup(KENS, KPROB, XPROB, KCLUST, KMEMBR, ILAST, MSGA)
Unpacks grib pds extension starting on byte 41 for ensemble forecast products.
Definition: pdseup.f:28
+ + + + diff --git a/ver-2.10.0/getgb_8f.html b/ver-2.10.0/getgb_8f.html new file mode 100644 index 00000000..db7fc74b --- /dev/null +++ b/ver-2.10.0/getgb_8f.html @@ -0,0 +1,376 @@ + + + + + + + +NCEPLIBS-w3emc: getgb.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgb.f File Reference
+
+
+ +

Find and unpack a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgb (LUGB, LUGI, JF, J, JPDS, JGDS, KF, K, KPDS, KGDS, LB, F, IRET)
 Find and unpack a grib message. More...
 
+

Detailed Description

+

Find and unpack a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgb.f.

+

Function/Subroutine Documentation

+ +

◆ getgb()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgb ( LUGB,
 LUGI,
 JF,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
 KF,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
logical*1, dimension(jf) LB,
real, dimension(jf) F,
 IRET 
)
+
+ +

Find and unpack a grib message.

+

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. table of contents) for the grib file. (The index buffer is saved for use by future prospective calls.) Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file and unpacked. It's message number is returned along with the unpacked pds and gds parameters, the unpacked bitmap (if any), and the unpacked data. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 modularized portions of code into subprograms and allowed for unspecified index file
    • +
+
Parameters
+ + + + + + + + + + + + + + +
[in]LUGBInteger unit of the unblocked grib data file
[in]LUGIInteger unit of the unblocked grib index file (=0 to get index buffer from the grib file)
[in]JFInteger maximum number of data points to unpack
[in]JInteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages)
[in]JPDSInteger (200) pds parameters for which to search (=-1 for wildcard)
    +
  • 1 Id of center
    • +
  • 2 Generating process id number
    • +
  • 3 Grid definition
    • +
  • 4 Gds/bms flag (right adj copy of octet 8)
    • +
  • 5 Indicator of parameter
    • +
  • 6 Type of level
    • +
  • 7 Height/pressure , etc of level
    • +
  • 8 Year including (century-1)
    • +
  • 9 Month of year
    • +
  • 10 Day of month
    • +
  • 11 Hour of day
    • +
  • 12 Minute of hour
    • +
  • 13 Indicator of forecast time unit
    • +
  • 14 Time range 1
    • +
  • 15 Time range 2
    • +
  • 16 Time range flag
    • +
  • 17 Number included in average
    • +
  • 18 Version nr of grib specification
    • +
  • 19 Version nr of parameter table
    • +
  • 20 Nr missing from average/accumulation
    • +
  • 21 Century of reference time of data
    • +
  • 22 Units decimal scale factor
    • +
  • 23 Subcenter number
    • +
  • 24 Pds byte 29, for nmc ensemble products
      +
    • 128 if forecast field error
      • +
    • 64 if bias corrected fcst field
      • +
    • 32 if smoothed field
      • +
    • warning: can be combination of more than 1
      • +
    • 25 pds byte 30, not used
      • +
    +
    • +
+
[in]JGDSInteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard)
    +
  • 1 Data representation type
    • +
  • 19 Number of vertical coordinate parameters
    • +
  • 20 Octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present
    • +
  • 21 For grids with pl, number of points in grid
    • +
  • 22 Number of words in each row
    • +
  • Latitude/longitude grids
      +
    • 2 n(i) nr points on latitude circle
      • +
    • 3 n(j) nr points on longitude meridian
      • +
    • 4 la(1) latitude of origin
      • +
    • 5 lo(1) longitude of origin
      • +
    • 6 resolution flag (right adj copy of octet 17)
      • +
    • 7 la(2) latitude of extreme point
      • +
    • 8 lo(2) longitude of extreme point
      • +
    • 9 di longitudinal direction of increment
      • +
    • 10 dj latitudinal direction increment
      • +
    • 11 scanning mode flag (right adj copy of octet 28)
      • +
    +
    • +
  • Gaussian grids
      +
    • 2 n(i) nr points on latitude circle
      • +
    • 3 n(j) nr points on longitude meridian
      • +
    • 4 la(1) latitude of origin
      • +
    • 5 lo(1) longitude of origin
      • +
    • 6 resolution flag (right adj copy of octet 17)
      • +
    • 7 la(2) latitude of extreme point
      • +
    • 8 lo(2) longitude of extreme point
      • +
    • 9 di longitudinal direction of increment
      • +
    • 10 n nr of circles pole to equator
      • +
    • 11 scanning mode flag (right adj copy of octet 28)
      • +
    • 12 nv nr of vert coord parameters
      • +
    • 13 pv octet nr of list of vert coord parameters or
        +
      • pl location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present
        • +
      +
      • +
    +
    • +
  • Polar stereographic grids
      +
    • 2 n(i) nr points along lat circle
      • +
    • 3 n(j) nr points along lon circle
      • +
    • 4 la(1) latitude of origin
      • +
    • 5 lo(1) longitude of origin
      • +
    • 6 Resolution flag (right adj copy of octet 17)
      • +
    • 7 lov grid orientation
      • +
    • 8 dx - x direction increment
      • +
    • 9 dy - y direction increment
      • +
    • 10 Projection center flag
      • +
    • 11 Scanning mode (right adj copy of octet 28)
      • +
    +
    • +
  • Spherical harmonic coefficients
      +
    • 2 j pentagonal resolution parameter
      • +
    • 3 k pentagonal resolution parameter
      • +
    • 4 m pentagonal resolution parameter
      • +
    • 5 Representation type
      • +
    • 6 Coefficient storage mode
      • +
    +
    • +
  • Mercator grids
      +
    • 2 n(i) nr points on latitude circle
      • +
    • 3 n(j) nr points on longitude meridian
      • +
    • 4 la(1) latitude of origin
      • +
    • 5 lo(1) longitude of origin
      • +
    • 6 Resolution flag (right adj copy of octet 17)
      • +
    • 7 la(2) latitude of last grid point
      • +
    • 8 lo(2) longitude of last grid point
      • +
    • 9 latit - latitude of projection intersection
      • +
    • 10 Reserved
      • +
    • 11 Scanning mode flag (right adj copy of octet 28)
      • +
    • 12 Longitudinal dir grid length
      • +
    • 13 Latitudinal dir grid length
      • +
    +
    • +
  • lambert conformal grids
      +
    • 2 nx nr points along x-axis
      • +
    • 3 ny nr points along y-axis
      • +
    • 4 la1 lat of origin (lower left)
      • +
    • 5 lo1 lon of origin (lower left)
      • +
    • 6 Resolution (right adj copy of octet 17)
      • +
    • 7 lov - orientation of grid
      • +
    • 8 dx - x-dir increment
      • +
    • 9 dy - y-dir increment
      • +
    • 10 Projection center flag
      • +
    • 11 Scanning mode flag (right adj copy of octet 28)
      • +
    • 12 latin 1 - first lat from pole of secant cone inter
      • +
    • 13 latin 2 - second lat from pole of secant cone inter
      • +
    +
    • +
+
[out]KFInteger number of data points unpacked
[out]KInteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches)
[out]KPDSInteger (200) unpacked pds parameters
[out]KGDSInteger (200) unpacked gds parameters
[out]LBLogical*1 (kf) unpacked bitmap if present
[out]FReal (kf) unpacked data
[out]IRETInteger return code
    +
  • 0 All ok
    • +
  • 96 Error reading index file
    • +
  • 97 Error reading grib file
    • +
  • 98 Number of data points greater than jf
    • +
  • 99 Request not found
    • +
  • other w3fi63 grib unpacker return code
    • +
+
+
+
+
Note
In order to unpack grib from a multiprocessing environment where each processor is attempting to read from its own pair of logical units, one must directly call subprogram getgbm as below, allocating a private copy of cbuf, nlen and nnum to each processor. do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 166 of file getgb.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgb_8f.js b/ver-2.10.0/getgb_8f.js new file mode 100644 index 00000000..6ce7182c --- /dev/null +++ b/ver-2.10.0/getgb_8f.js @@ -0,0 +1,4 @@ +var getgb_8f = +[ + [ "getgb", "getgb_8f.html#ab1cec03904b6e6c41840726cd53a69ce", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgb_8f_source.html b/ver-2.10.0/getgb_8f_source.html new file mode 100644 index 00000000..10b706ba --- /dev/null +++ b/ver-2.10.0/getgb_8f_source.html @@ -0,0 +1,295 @@ + + + + + + + +NCEPLIBS-w3emc: getgb.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgb.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find and unpack a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Find and unpack a grib message.
+
6 C> Read a grib index file (or optionally the grib file itself)
+
7 C> to get the index buffer (i.e. table of contents) for the grib file.
+
8 C> (The index buffer is saved for use by future prospective calls.)
+
9 C> Find in the index buffer a reference to the grib message requested.
+
10 C> The grib message request specifies the number of messages to skip
+
11 C> and the unpacked pds and gds parameters. (A requested parameter
+
12 C> of -1 means to allow any value of this parameter to be found.)
+
13 C> If the requested grib message is found, then it is read from the
+
14 C> grib file and unpacked. It's message number is returned along with
+
15 C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
16 C> and the unpacked data. If the grib message is not found, then the
+
17 C> return code will be nonzero.
+
18 C>
+
19 C> Program history log:
+
20 C> - Mark Iredell 1994-04-01
+
21 C> - Mark Iredell 1995-10-31 modularized portions of code into
+
22 C> subprograms and allowed for unspecified index file
+
23 C>
+
24 C> @param[in] LUGB Integer unit of the unblocked grib data file
+
25 C> @param[in] LUGI Integer unit of the unblocked grib index file
+
26 C> (=0 to get index buffer from the grib file)
+
27 C> @param[in] JF Integer maximum number of data points to unpack
+
28 C> @param[in] J Integer number of messages to skip
+
29 C> (=0 to search from beginning)
+
30 C> (<0 to read index buffer and skip -1-j messages)
+
31 C> @param[in] JPDS Integer (200) pds parameters for which to search
+
32 C> (=-1 for wildcard)
+
33 C> - 1 Id of center
+
34 C> - 2 Generating process id number
+
35 C> - 3 Grid definition
+
36 C> - 4 Gds/bms flag (right adj copy of octet 8)
+
37 C> - 5 Indicator of parameter
+
38 C> - 6 Type of level
+
39 C> - 7 Height/pressure , etc of level
+
40 C> - 8 Year including (century-1)
+
41 C> - 9 Month of year
+
42 C> - 10 Day of month
+
43 C> - 11 Hour of day
+
44 C> - 12 Minute of hour
+
45 C> - 13 Indicator of forecast time unit
+
46 C> - 14 Time range 1
+
47 C> - 15 Time range 2
+
48 C> - 16 Time range flag
+
49 C> - 17 Number included in average
+
50 C> - 18 Version nr of grib specification
+
51 C> - 19 Version nr of parameter table
+
52 C> - 20 Nr missing from average/accumulation
+
53 C> - 21 Century of reference time of data
+
54 C> - 22 Units decimal scale factor
+
55 C> - 23 Subcenter number
+
56 C> - 24 Pds byte 29, for nmc ensemble products
+
57 C> - 128 if forecast field error
+
58 C> - 64 if bias corrected fcst field
+
59 C> - 32 if smoothed field
+
60 C> - warning: can be combination of more than 1
+
61 C> - 25 pds byte 30, not used
+
62 C> @param[in] JGDS Integer (200) gds parameters for which to search
+
63 C> (only searched if jpds(3)=255) (=-1 for wildcard)
+
64 C> - 1 Data representation type
+
65 C> - 19 Number of vertical coordinate parameters
+
66 C> - 20 Octet number of the list of vertical coordinate
+
67 C> parameters or octet number of the list of numbers of points
+
68 C> in each row or 255 if neither are present
+
69 C> - 21 For grids with pl, number of points in grid
+
70 C> - 22 Number of words in each row
+
71 C> - Latitude/longitude grids
+
72 C> - 2 n(i) nr points on latitude circle
+
73 C> - 3 n(j) nr points on longitude meridian
+
74 C> - 4 la(1) latitude of origin
+
75 C> - 5 lo(1) longitude of origin
+
76 C> - 6 resolution flag (right adj copy of octet 17)
+
77 C> - 7 la(2) latitude of extreme point
+
78 C> - 8 lo(2) longitude of extreme point
+
79 C> - 9 di longitudinal direction of increment
+
80 C> - 10 dj latitudinal direction increment
+
81 C> - 11 scanning mode flag (right adj copy of octet 28)
+
82 C> - Gaussian grids
+
83 C> - 2 n(i) nr points on latitude circle
+
84 C> - 3 n(j) nr points on longitude meridian
+
85 C> - 4 la(1) latitude of origin
+
86 C> - 5 lo(1) longitude of origin
+
87 C> - 6 resolution flag (right adj copy of octet 17)
+
88 C> - 7 la(2) latitude of extreme point
+
89 C> - 8 lo(2) longitude of extreme point
+
90 C> - 9 di longitudinal direction of increment
+
91 C> - 10 n nr of circles pole to equator
+
92 C> - 11 scanning mode flag (right adj copy of octet 28)
+
93 C> - 12 nv nr of vert coord parameters
+
94 C> - 13 pv octet nr of list of vert coord parameters or
+
95 C> - pl location of the list of numbers of points in
+
96 C> each row (if no vert coord parameters are present) or
+
97 C> 255 if neither are present
+
98 C> - Polar stereographic grids
+
99 C> - 2 n(i) nr points along lat circle
+
100 C> - 3 n(j) nr points along lon circle
+
101 C> - 4 la(1) latitude of origin
+
102 C> - 5 lo(1) longitude of origin
+
103 C> - 6 Resolution flag (right adj copy of octet 17)
+
104 C> - 7 lov grid orientation
+
105 C> - 8 dx - x direction increment
+
106 C> - 9 dy - y direction increment
+
107 C> - 10 Projection center flag
+
108 C> - 11 Scanning mode (right adj copy of octet 28)
+
109 C> - Spherical harmonic coefficients
+
110 C> - 2 j pentagonal resolution parameter
+
111 C> - 3 k pentagonal resolution parameter
+
112 C> - 4 m pentagonal resolution parameter
+
113 C> - 5 Representation type
+
114 C> - 6 Coefficient storage mode
+
115 C> - Mercator grids
+
116 C> - 2 n(i) nr points on latitude circle
+
117 C> - 3 n(j) nr points on longitude meridian
+
118 C> - 4 la(1) latitude of origin
+
119 C> - 5 lo(1) longitude of origin
+
120 C> - 6 Resolution flag (right adj copy of octet 17)
+
121 C> - 7 la(2) latitude of last grid point
+
122 C> - 8 lo(2) longitude of last grid point
+
123 C> - 9 latit - latitude of projection intersection
+
124 C> - 10 Reserved
+
125 C> - 11 Scanning mode flag (right adj copy of octet 28)
+
126 C> - 12 Longitudinal dir grid length
+
127 C> - 13 Latitudinal dir grid length
+
128 C> - lambert conformal grids
+
129 C> - 2 nx nr points along x-axis
+
130 C> - 3 ny nr points along y-axis
+
131 C> - 4 la1 lat of origin (lower left)
+
132 C> - 5 lo1 lon of origin (lower left)
+
133 C> - 6 Resolution (right adj copy of octet 17)
+
134 C> - 7 lov - orientation of grid
+
135 C> - 8 dx - x-dir increment
+
136 C> - 9 dy - y-dir increment
+
137 C> - 10 Projection center flag
+
138 C> - 11 Scanning mode flag (right adj copy of octet 28)
+
139 C> - 12 latin 1 - first lat from pole of secant cone inter
+
140 C> - 13 latin 2 - second lat from pole of secant cone inter
+
141 C> @param[out] KF Integer number of data points unpacked
+
142 C> @param[out] K Integer message number unpacked
+
143 C> (can be same as j in calling program
+
144 C> in order to facilitate multiple searches)
+
145 C> @param[out] KPDS Integer (200) unpacked pds parameters
+
146 C> @param[out] KGDS Integer (200) unpacked gds parameters
+
147 C> @param[out] LB Logical*1 (kf) unpacked bitmap if present
+
148 C> @param[out] F Real (kf) unpacked data
+
149 C> @param[out] IRET Integer return code
+
150 C> - 0 All ok
+
151 C> - 96 Error reading index file
+
152 C> - 97 Error reading grib file
+
153 C> - 98 Number of data points greater than jf
+
154 C> - 99 Request not found
+
155 C> - other w3fi63 grib unpacker return code
+
156 C>
+
157 C> @note In order to unpack grib from a multiprocessing environment
+
158 C> where each processor is attempting to read from its own pair of
+
159 C> logical units, one must directly call subprogram getgbm as below,
+
160 C> allocating a private copy of cbuf, nlen and nnum to each processor.
+
161 C> do not engage the same logical unit from more than one processor.
+
162 C> @author Mark Iredell @date 1994-04-01
+
163 C-----------------------------------------------------------------------
+
164  SUBROUTINE getgb(LUGB,LUGI,JF,J,JPDS,JGDS,
+
165  & KF,K,KPDS,KGDS,LB,F,IRET)
+
166  INTEGER JPDS(200),JGDS(200),KPDS(200),KGDS(200)
+
167  LOGICAL*1 LB(JF)
+
168  REAL F(JF)
+
169  parameter(mbuf=256*1024)
+
170  CHARACTER CBUF(MBUF)
+
171  SAVE cbuf,nlen,nnum,mnum
+
172  DATA lux/0/
+
173 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
174 C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
+
175  IF(lugi.GT.0.AND.(j.LT.0.OR.lugi.NE.lux)) THEN
+
176  lux=lugi
+
177  jj=min(j,-1-j)
+
178  ELSEIF(lugi.LE.0.AND.(j.LT.0.OR.lugb.NE.lux)) THEN
+
179  lux=lugb
+
180  jj=min(j,-1-j)
+
181  ELSE
+
182  jj=j
+
183  ENDIF
+
184 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
185 C FIND AND UNPACK GRIB MESSAGE
+
186  CALL getgbm(lugb,lugi,jf,jj,jpds,jgds,
+
187  & mbuf,cbuf,nlen,nnum,mnum,
+
188  & kf,k,kpds,kgds,lb,f,iret)
+
189  IF(iret.EQ.96) lux=0
+
190 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
191  RETURN
+
192  END
+
+
+
getgbm
subroutine getgbm(LUGB, LUGI, JF, J, JPDS, JGDS, MBUF, CBUF, NLEN, NNUM, MNUM, KF, K, KPDS, KGDS, LB, F, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbm.f:176
+
getgb
subroutine getgb(LUGB, LUGI, JF, J, JPDS, JGDS, KF, K, KPDS, KGDS, LB, F, IRET)
Find and unpack a grib message.
Definition: getgb.f:166
+ + + + diff --git a/ver-2.10.0/getgbe_8f.html b/ver-2.10.0/getgbe_8f.html new file mode 100644 index 00000000..790afcf7 --- /dev/null +++ b/ver-2.10.0/getgbe_8f.html @@ -0,0 +1,397 @@ + + + + + + + +NCEPLIBS-w3emc: getgbe.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbe.f File Reference
+
+
+ +

Finds and unpacks a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbe (LUGB, LUGI, JF, J, JPDS, JGDS, JENS, KF, K, KPDS, KGDS, KENS, LB, F, IRET)
 Find and unpack a grib message. More...
 
+

Detailed Description

+

Finds and unpacks a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbe.f.

+

Function/Subroutine Documentation

+ +

◆ getgbe()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbe ( LUGB,
 LUGI,
 JF,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
integer, dimension(200) JENS,
 KF,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
logical*1, dimension(jf) LB,
real, dimension(jf) F,
 IRET 
)
+
+ +

Find and unpack a grib message.

+

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. table of contents) for the grib file. (The index buffer is saved for use by future prospective calls.) Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file and unpacked. Its message number is returned along with the unpacked pds and gds parameters, the unpacked bitmap (if any), and the unpacked data. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
+
Parameters
+ + + + + + + + + + + + + + + + +
[in]lugbInteger unit of the unblocked grib data file.
[in]lugiInteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jfInteger maximum number of data points to unpack.
[in]jInteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages).
[in]jpdsInteger (200) pds parameters for which to search (=-1 for wildcard).
    +
  • 1 Id of center.
    • +
  • 2 Generating process id number.
    • +
  • 3 Grid definition.
    • +
  • 4 Gds/bms flag (right adj copy of octet 8).
    • +
  • 5 Indicator of parameter.
    • +
  • 6 Type of level.
    • +
  • 7 Height/pressure , etc of level.
    • +
  • 8 Year including (century-1).
    • +
  • 9 Month of year.
    • +
  • 10 Day of month.
    • +
  • 11 Hour of day.
    • +
  • 12 Minute of hour.
    • +
  • 13 Indicator of forecast time unit.
    • +
  • 14 Time range 1.
    • +
  • 15 Time range 2.
    • +
  • 16 Time range flag.
    • +
  • 17 Number included in average.
    • +
  • 18 Version nr of grib specification.
    • +
  • 19 Version nr of parameter table.
    • +
  • 20 Nr missing from average/accumulation.
    • +
  • 21 Century of reference time of data.
    • +
  • 22 Units decimal scale factor.
    • +
  • 23 Subcenter number.
    • +
  • 24 Pds byte 29, for nmc ensemble products.
      +
    • 128 If forecast field error.
      • +
    • 64 If bias corrected fcst field.
      • +
    • 32 If smoothed field (warning: can be combination of more than 1).
      • +
    +
    • +
  • 25 Pds byte 30, not used
    • +
+
[in]jgdsInteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1 Data representation type.
    • +
  • 19 Number of vertical coordinate parameters.
    • +
  • 20 Octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 If neither are present.
    • +
  • 21 For grids with pl, number of points in grid.
    • +
  • 22 Number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2 n(i) Nr points on latitude circle.
      • +
    • 3 n(j) Nr points on longitude meridian.
      • +
    • 4 la(1) Latitude of origin.
      • +
    • 5 lo(1) Longitude of origin.
      • +
    • 6 Resolution flag (right adj copy of octet 17).
      • +
    • 7 la(2) Latitude of extreme point.
      • +
    • 8 lo(2) Longitude of extreme point.
      • +
    • 9 di Longitudinal direction of increment.
      • +
    • 10 dj Latitudinal direction increment.
      • +
    • 11 Scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids.
      +
    • 2 n(i) Nr points on latitude circle.
      • +
    • 3 n(j) Nr points on longitude meridian.
      • +
    • 4 la(1) Latitude of origin.
      • +
    • 5 lo(1) Longitude of origin.
      • +
    • 6 Resolution flag (right adj copy of octet 17).
      • +
    • 7 la(2) Latitude of extreme point.
      • +
    • 8 lo(2) Longitude of extreme point.
      • +
    • 9 di Longitudinal direction of increment.
      • +
    • 10 n Nr of circles pole to equator.
      • +
    • 11 Scanning mode flag (right adj copy of octet 28).
      • +
    • 12 nv Nr of vert coord parameters.
      • +
    • 13 pv Octet nr of list of vert coord parameters or
        +
      • pl Location of the list of numbers of points in each row (if no vert coord parameters are present) or
        • +
      • 255 If neither are present.
        • +
      +
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2 n(i) Nr points along lat circle.
      • +
    • 3 n(j) Nr points along lon circle.
      • +
    • 4 la(1) Latitude of origin.
      • +
    • 5 lo(1) Longitude of origin.
      • +
    • 6 Resolution flag (right adj copy of octet 17).
      • +
    • 7 lov Grid orientation.
      • +
    • 8 dx - X direction increment.
      • +
    • 9 dy - Y direction increment.
      • +
    • 10 Projection center flag.
      • +
    • 11 Scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2 j Pentagonal resolution parameter.
      • +
    • 3 k Pentagonal resolution parameter.
      • +
    • 4 m Pentagonal resolution parameter.
      • +
    • 5 Representation type.
      • +
    • 6 Coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2 n(i) Nr points on latitude circle.
      • +
    • 3 n(j) Nr points on longitude meridian.
      • +
    • 4 la(1) Latitude of origin.
      • +
    • 5 lo(1) Longitude of origin.
      • +
    • 6 Resolution flag (right adj copy of octet 17).
      • +
    • 7 la(2) Latitude of last grid point.
      • +
    • 8 lo(2) Longitude of last grid point.
      • +
    • 9 latit - Latitude of projection intersection.
      • +
    • 10 Reserved.
      • +
    • 11 Scanning mode flag (right adj copy of octet 28).
      • +
    • 12 Longitudinal dir grid length.
      • +
    • 13 Latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2 nx Nr points along x-axis.
      • +
    • 3 ny Nr points along y-axis.
      • +
    • 4 la1 Lat of origin (lower left).
      • +
    • 5 lo1 Lon of origin (lower left).
      • +
    • 6 Resolution (right adj copy of octet 17).
      • +
    • 7 lov - Orientation of grid.
      • +
    • 8 dx - X-dir increment.
      • +
    • 9 dy - Y-dir increment.
      • +
    • 10 Projection center flag.
      • +
    • 11 Scanning mode flag (right adj copy of octet 28).
      • +
    • 12 latin 1 First lat from pole of secant cone inter.
      • +
    • 13 latin 2 Second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]jensInteger (200) ensemble pds parms for which to search (only searched if jpds(23)=2) (=-1 for wildcard).
    +
  • 1 Application identifier.
    • +
  • 2 Ensemble type.
    • +
  • 3 Ensemble identifier.
    • +
  • 4 Product identifier.
    • +
  • 5 Smoothing flag.
    • +
+
[out]kfInteger number of data points unpacked.
[out]kInteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsInteger (200) unpacked pds parameters.
[out]kgdsInteger (200) unpacked gds parameters.
[out]kensInteger (200) unpacked ensemble pds parms.
[out]lbLogical*1 (kf) unpacked bitmap if present.
[out]fReal (kf) unpacked data.
[out]iretInteger return code.
    +
  • 0 All ok
    • +
  • 96 Error reading index file
    • +
  • 97 Error reading grib file
    • +
  • 98 Number of data points greater than jf
    • +
  • 99 Request not found
    • +
  • other w3fi63 grib unpacker return code
    • +
+
+
+
+
Note
In order to unpack grib from a multiprocessing environment where each processor is attempting to read from its own pair of logical units, one must directly call subprogram getgbem as below, allocating a private copy of cbuf, nlen and nnum to each processor. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 176 of file getgbe.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbe_8f.js b/ver-2.10.0/getgbe_8f.js new file mode 100644 index 00000000..85447c8d --- /dev/null +++ b/ver-2.10.0/getgbe_8f.js @@ -0,0 +1,4 @@ +var getgbe_8f = +[ + [ "getgbe", "getgbe_8f.html#a947b6d97db47adbcce8dde953f7e5de2", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbe_8f_source.html b/ver-2.10.0/getgbe_8f_source.html new file mode 100644 index 00000000..6ae19e35 --- /dev/null +++ b/ver-2.10.0/getgbe_8f_source.html @@ -0,0 +1,306 @@ + + + + + + + +NCEPLIBS-w3emc: getgbe.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbe.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Finds and unpacks a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Find and unpack a grib message.
+
6 C> Read a grib index file (or optionally the grib file itself)
+
7 C> to get the index buffer (i.e. table of contents) for the grib file.
+
8 C> (The index buffer is saved for use by future prospective calls.)
+
9 C> Find in the index buffer a reference to the grib message requested.
+
10 C> The grib message request specifies the number of messages to skip
+
11 C> and the unpacked pds and gds parameters. (A requested parameter
+
12 C> of -1 means to allow any value of this parameter to be found.)
+
13 C> If the requested grib message is found, then it is read from the
+
14 C> grib file and unpacked. Its message number is returned along with
+
15 C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
16 C> and the unpacked data. If the grib message is not found, then the
+
17 C> return code will be nonzero.
+
18 C>
+
19 C> Program history log:
+
20 C> - Mark Iredell 1994-04-01
+
21 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
22 C> and allowed for unspecified index file.
+
23 C>
+
24 C> @param[in] lugb Integer unit of the unblocked grib data file.
+
25 C> @param[in] lugi Integer unit of the unblocked grib index file
+
26 C> (=0 to get index buffer from the grib file).
+
27 C> @param[in] jf Integer maximum number of data points to unpack.
+
28 C> @param[in] j Integer number of messages to skip
+
29 C> (=0 to search from beginning)
+
30 C> (<0 to read index buffer and skip -1-j messages).
+
31 C> @param[in] jpds Integer (200) pds parameters for which to search
+
32 C> (=-1 for wildcard).
+
33 C> - 1 Id of center.
+
34 C> - 2 Generating process id number.
+
35 C> - 3 Grid definition.
+
36 C> - 4 Gds/bms flag (right adj copy of octet 8).
+
37 C> - 5 Indicator of parameter.
+
38 C> - 6 Type of level.
+
39 C> - 7 Height/pressure , etc of level.
+
40 C> - 8 Year including (century-1).
+
41 C> - 9 Month of year.
+
42 C> - 10 Day of month.
+
43 C> - 11 Hour of day.
+
44 C> - 12 Minute of hour.
+
45 C> - 13 Indicator of forecast time unit.
+
46 C> - 14 Time range 1.
+
47 C> - 15 Time range 2.
+
48 C> - 16 Time range flag.
+
49 C> - 17 Number included in average.
+
50 C> - 18 Version nr of grib specification.
+
51 C> - 19 Version nr of parameter table.
+
52 C> - 20 Nr missing from average/accumulation.
+
53 C> - 21 Century of reference time of data.
+
54 C> - 22 Units decimal scale factor.
+
55 C> - 23 Subcenter number.
+
56 C> - 24 Pds byte 29, for nmc ensemble products.
+
57 C> - 128 If forecast field error.
+
58 C> - 64 If bias corrected fcst field.
+
59 C> - 32 If smoothed field (warning: can be combination of more than 1).
+
60 C> - 25 Pds byte 30, not used
+
61 C> @param[in] jgds Integer (200) gds parameters for which to search
+
62 C> (only searched if jpds(3)=255)
+
63 C> (=-1 for wildcard).
+
64 C> - 1 Data representation type.
+
65 C> - 19 Number of vertical coordinate parameters.
+
66 C> - 20 Octet number of the list of vertical coordinate parameters
+
67 C> or octet number of the list of numbers of points in each row or
+
68 C> 255 If neither are present.
+
69 C> - 21 For grids with pl, number of points in grid.
+
70 C> - 22 Number of words in each row.
+
71 C> - Latitude/longitude grids.
+
72 C> - 2 n(i) Nr points on latitude circle.
+
73 C> - 3 n(j) Nr points on longitude meridian.
+
74 C> - 4 la(1) Latitude of origin.
+
75 C> - 5 lo(1) Longitude of origin.
+
76 C> - 6 Resolution flag (right adj copy of octet 17).
+
77 C> - 7 la(2) Latitude of extreme point.
+
78 C> - 8 lo(2) Longitude of extreme point.
+
79 C> - 9 di Longitudinal direction of increment.
+
80 C> - 10 dj Latitudinal direction increment.
+
81 C> - 11 Scanning mode flag (right adj copy of octet 28).
+
82 C> - Gaussian grids.
+
83 C> - 2 n(i) Nr points on latitude circle.
+
84 C> - 3 n(j) Nr points on longitude meridian.
+
85 C> - 4 la(1) Latitude of origin.
+
86 C> - 5 lo(1) Longitude of origin.
+
87 C> - 6 Resolution flag (right adj copy of octet 17).
+
88 C> - 7 la(2) Latitude of extreme point.
+
89 C> - 8 lo(2) Longitude of extreme point.
+
90 C> - 9 di Longitudinal direction of increment.
+
91 C> - 10 n Nr of circles pole to equator.
+
92 C> - 11 Scanning mode flag (right adj copy of octet 28).
+
93 C> - 12 nv Nr of vert coord parameters.
+
94 C> - 13 pv Octet nr of list of vert coord parameters or
+
95 C> - pl Location of the list of numbers of points in
+
96 C> each row (if no vert coord parameters are present) or
+
97 C> - 255 If neither are present.
+
98 C> - Polar stereographic grids.
+
99 C> - 2 n(i) Nr points along lat circle.
+
100 C> - 3 n(j) Nr points along lon circle.
+
101 C> - 4 la(1) Latitude of origin.
+
102 C> - 5 lo(1) Longitude of origin.
+
103 C> - 6 Resolution flag (right adj copy of octet 17).
+
104 C> - 7 lov Grid orientation.
+
105 C> - 8 dx - X direction increment.
+
106 C> - 9 dy - Y direction increment.
+
107 C> - 10 Projection center flag.
+
108 C> - 11 Scanning mode (right adj copy of octet 28).
+
109 C> - Spherical harmonic coefficients.
+
110 C> - 2 j Pentagonal resolution parameter.
+
111 C> - 3 k Pentagonal resolution parameter.
+
112 C> - 4 m Pentagonal resolution parameter.
+
113 C> - 5 Representation type.
+
114 C> - 6 Coefficient storage mode.
+
115 C> - Mercator grids.
+
116 C> - 2 n(i) Nr points on latitude circle.
+
117 C> - 3 n(j) Nr points on longitude meridian.
+
118 C> - 4 la(1) Latitude of origin.
+
119 C> - 5 lo(1) Longitude of origin.
+
120 C> - 6 Resolution flag (right adj copy of octet 17).
+
121 C> - 7 la(2) Latitude of last grid point.
+
122 C> - 8 lo(2) Longitude of last grid point.
+
123 C> - 9 latit - Latitude of projection intersection.
+
124 C> - 10 Reserved.
+
125 C> - 11 Scanning mode flag (right adj copy of octet 28).
+
126 C> - 12 Longitudinal dir grid length.
+
127 C> - 13 Latitudinal dir grid length.
+
128 C> - Lambert conformal grids.
+
129 C> - 2 nx Nr points along x-axis.
+
130 C> - 3 ny Nr points along y-axis.
+
131 C> - 4 la1 Lat of origin (lower left).
+
132 C> - 5 lo1 Lon of origin (lower left).
+
133 C> - 6 Resolution (right adj copy of octet 17).
+
134 C> - 7 lov - Orientation of grid.
+
135 C> - 8 dx - X-dir increment.
+
136 C> - 9 dy - Y-dir increment.
+
137 C> - 10 Projection center flag.
+
138 C> - 11 Scanning mode flag (right adj copy of octet 28).
+
139 C> - 12 latin 1 First lat from pole of secant cone inter.
+
140 C> - 13 latin 2 Second lat from pole of secant cone inter.
+
141 C> @param[in] jens Integer (200) ensemble pds parms for which to search
+
142 C> (only searched if jpds(23)=2) (=-1 for wildcard).
+
143 C> - 1 Application identifier.
+
144 C> - 2 Ensemble type.
+
145 C> - 3 Ensemble identifier.
+
146 C> - 4 Product identifier.
+
147 C> - 5 Smoothing flag.
+
148 C>
+
149 C> @param[out] kf Integer number of data points unpacked.
+
150 C> @param[out] k Integer message number unpacked
+
151 C> (can be same as j in calling program
+
152 C> in order to facilitate multiple searches).
+
153 C> @param[out] kpds Integer (200) unpacked pds parameters.
+
154 C> @param[out] kgds Integer (200) unpacked gds parameters.
+
155 C> @param[out] kens Integer (200) unpacked ensemble pds parms.
+
156 C> @param[out] lb Logical*1 (kf) unpacked bitmap if present.
+
157 C> @param[out] f Real (kf) unpacked data.
+
158 C> @param[out] iret Integer return code.
+
159 C> - 0 All ok
+
160 C> - 96 Error reading index file
+
161 C> - 97 Error reading grib file
+
162 C> - 98 Number of data points greater than jf
+
163 C> - 99 Request not found
+
164 C> - other w3fi63 grib unpacker return code
+
165 C>
+
166 C> @note In order to unpack grib from a multiprocessing environment
+
167 C> where each processor is attempting to read from its own pair of
+
168 C> logical units, one must directly call subprogram getgbem as below,
+
169 C> allocating a private copy of cbuf, nlen and nnum to each processor.
+
170 C> Do not engage the same logical unit from more than one processor.
+
171 C>
+
172 C> @author Mark Iredell @date 1994-04-01
+
173 C-----------------------------------------------------------------------
+
174  SUBROUTINE getgbe(LUGB,LUGI,JF,J,JPDS,JGDS,JENS,
+
175  & KF,K,KPDS,KGDS,KENS,LB,F,IRET)
+
176  INTEGER JPDS(200),JGDS(200),JENS(200)
+
177  INTEGER KPDS(200),KGDS(200),KENS(200)
+
178  LOGICAL*1 LB(JF)
+
179  REAL F(JF)
+
180  parameter(mbuf=256*1024)
+
181  CHARACTER CBUF(MBUF)
+
182  SAVE cbuf,nlen,nnum,mnum
+
183  DATA lux/0/
+
184 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
185 C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
+
186  IF(lugi.GT.0.AND.(j.LT.0.OR.lugi.NE.lux)) THEN
+
187  lux=lugi
+
188  jj=min(j,-1-j)
+
189  ELSEIF(lugi.LE.0.AND.(j.LT.0.OR.lugb.NE.lux)) THEN
+
190  lux=lugb
+
191  jj=min(j,-1-j)
+
192  ELSE
+
193  jj=j
+
194  ENDIF
+
195 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
196 C FIND AND UNPACK GRIB MESSAGE
+
197  CALL getgbem(lugb,lugi,jf,jj,jpds,jgds,jens,
+
198  & mbuf,cbuf,nlen,nnum,mnum,
+
199  & kf,k,kpds,kgds,kens,lb,f,iret)
+
200  IF(iret.EQ.96) lux=0
+
201 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
202  RETURN
+
203  END
+
+
+
getgbe
subroutine getgbe(LUGB, LUGI, JF, J, JPDS, JGDS, JENS, KF, K, KPDS, KGDS, KENS, LB, F, IRET)
Find and unpack a grib message.
Definition: getgbe.f:176
+
getgbem
subroutine getgbem(LUGB, LUGI, JF, J, JPDS, JGDS, JENS, MBUF, CBUF, NLEN, NNUM, MNUM, KF, K, KPDS, KGDS, KENS, LB, F, IRET)
Find and unpack a grib message.
Definition: getgbem.f:183
+ + + + diff --git a/ver-2.10.0/getgbeh_8f.html b/ver-2.10.0/getgbeh_8f.html new file mode 100644 index 00000000..7a6dde26 --- /dev/null +++ b/ver-2.10.0/getgbeh_8f.html @@ -0,0 +1,380 @@ + + + + + + + +NCEPLIBS-w3emc: getgbeh.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbeh.f File Reference
+
+
+ +

Find a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbeh (LUGB, LUGI, J, JPDS, JGDS, JENS, KG, KF, K, KPDS, KGDS, KENS, IRET)
 Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. More...
 
+

Detailed Description

+

Find a grib message.

+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition in file getgbeh.f.

+

Function/Subroutine Documentation

+ +

◆ getgbeh()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbeh ( LUGB,
 LUGI,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
integer, dimension(200) JENS,
 KG,
 KF,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
 IRET 
)
+
+ +

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e.

+

table of contents) for the grib file. (The index buffer is saved for use by future prospective calls.) Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then its message number is returned along with the unpacked pds and gds parameters. If the grib message is not found, then the return code will be nonzero.

+

Program History:

    +
  • 1995-10-31 Mark Iredell Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
+
Parameters
+ + + + + + + + + + + + + + +
[in]LUGBInteger unit of the unblocked grib data file. (only used if lugi=0)
[in]LUGIInteger unit of the unblocked grib index file. (=0 to get index buffer from the grib file)
[in]JInteger number of messages to skip.
    +
  • (=0 to search from beginning)
    • +
  • (<0 to read index buffer and skip -1-j messages)
    • +
+
[in]JPDSInteger (200) pds parameters for which to search (can be combination of more than 1).
    +
  • -1 for wildcard.
    • +
  • 1 id of center.
    • +
  • 2 generating process id number.
    • +
  • 3 grid definition.
    • +
  • 4 gds/bms flag (right adj copy of octet 8).
    • +
  • 5 indicator of parameter.
    • +
  • 6 type of level.
    • +
  • 7 height/pressure , etc of level.
    • +
  • 8 year including (century-1).
    • +
  • 9 month of year.
    • +
  • 10 day of month.
    • +
  • 11 hour of day.
    • +
  • 12 minute of hour.
    • +
  • 13 indicator of forecast time unit.
    • +
  • 14 time range 1.
    • +
  • 15 time range 2.
    • +
  • 16 time range flag.
    • +
  • 17 number included in average.
    • +
  • 18 version nr of grib specification.
    • +
  • 19 version nr of parameter table.
    • +
  • 20 nr missing from average/accumulation.
    • +
  • 21 century of reference time of data.
    • +
  • 22 units decimal scale factor.
    • +
  • 23 subcenter number.
    • +
  • 24 pds byte 29, for nmc ensemble products.
    • +
  • 128 if forecast field error.
    • +
  • 64 if bias corrected fcst field.
    • +
  • 32 if smoothed field.
    • +
  • 25 pds byte 30, not used.
    • +
+
[in]JGDSInteger (200) gds parameters for which to search. (only searched if jpds(3)=255)
    +
  • -1 for wildcard.
    • +
  • 1 data representation type.
    • +
  • 19 number of vertical coordinate parameters.
    • +
  • 20 octet number of the list of vertical coordinate parameters. or octet number of the list of numbers of points in each row or 255 if neither are present.
    • +
  • 21 for grids with pl, number of points in grid.
    • +
  • 22 number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2 n(i) nr points on latitude circle.
      • +
    • 3 n(j) nr points on longitude meridian.
      • +
    • 4 la(1) latitude of origin.
      • +
    • 5 lo(1) longitude of origin.
      • +
    • 6 resolution flag (right adj copy of octet 17).
      • +
    • 7 la(2) latitude of extreme point.
      • +
    • 8 lo(2) longitude of extreme point.
      • +
    • 9 di longitudinal direction of increment.
      • +
    • 10 dj latitudinal direction increment.
      • +
    • 11 scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids
      +
    • 2 n(i) nr points on latitude circle.
      • +
    • 3 n(j) nr points on longitude meridian.
      • +
    • 4 la(1) latitude of origin.
      • +
    • 5 lo(1) longitude of origin.
      • +
    • 6 resolution flag (right adj copy of octet 17).
      • +
    • 7 la(2) latitude of extreme point.
      • +
    • 8 lo(2) longitude of extreme point.
      • +
    • 9 di longitudinal direction of increment.
      • +
    • 10 n - nr of circles pole to equator.
      • +
    • 11 scanning mode flag (right adj copy of octet 28).
      • +
    • 12 nv - nr of vert coord parameters.
      • +
    • 13 pv - octet nr of list of vert coord parameters or pl location of the list of numbers of points in each row (if no vert coord parameters are present or 255 if neither are present.
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2 n(i) nr points along lat circle.
      • +
    • 3 n(j) nr points along lon circle.
      • +
    • 4 la(1) latitude of origin.
      • +
    • 5 lo(1) longitude of origin.
      • +
    • 6 resolution flag (right adj copy of octet 17).
      • +
    • 7 lov grid orientation.
      • +
    • 8 dx - x direction increment.
      • +
    • 9 dy - y direction increment.
      • +
    • 10 projection center flag.
      • +
    • 11 scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients
      +
    • 2 j pentagonal resolution parameter.
      • +
    • 3 k pentagonal resolution parameter.
      • +
    • 4 m pentagonal resolution parameter.
      • +
    • 5 representation type.
      • +
    • 6 coefficient storage mode.
      • +
    +
    • +
  • Mercator grids
      +
    • 2 n(i) nr points on latitude circle.
      • +
    • 3 n(j) nr points on longitude meridian.
      • +
    • 4 la(1) latitude of origin.
      • +
    • 5 lo(1) longitude of origin.
      • +
    • 6 resolution flag (right adj copy of octet 17).
      • +
    • 7 la(2) latitude of last grid point.
      • +
    • 8 lo(2) longitude of last grid point.
      • +
    • 9 latit - latitude of projection intersection.
      • +
    • 10 reserved.
      • +
    • 11 scanning mode flag (right adj copy of octet 28).
      • +
    • 12 longitudinal dir grid length.
      • +
    • 13 latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids
      +
    • 2 nx nr points along x-axis.
      • +
    • 3 ny nr points along y-axis.
      • +
    • 4 la1 lat of origin (lower left).
      • +
    • 5 lo1 lon of origin (lower left).
      • +
    • 6 resolution (right adj copy of octet 17).
      • +
    • 7 lov - orientation of grid.
      • +
    • 8 dx - x-dir increment.
      • +
    • 9 dy - y-dir increment.
      • +
    • 10 projection center flag.
      • +
    • 11 scanning mode flag (right adj copy of octet 28).
      • +
    • 12 latin 1 - first lat from pole of secant cone inter.
      • +
    • 13 latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]JENSInteger (200) ensemble pds parms for which to search (only searched if jpds(23)=2).
    +
  • -1 for wildcard.
    • +
  • 1 application identifier.
    • +
  • 2 ensemble type.
    • +
  • 3 ensemble identifier.
    • +
  • 4 product identifier.
    • +
  • 5 smoothing flag.
    • +
+
[out]KGInteger number of bytes in the grib message.
[out]KFInteger number of data points in the message.
[out]KInteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]KPDSInteger (200) unpacked pds parameters.
[out]KGDSInteger (200) unpacked gds parameters.
[out]KENSInteger (200) unpacked ensemble pds parms.
[out]IRETInteger return code.
    +
  • 0 all ok.
    • +
  • 96 error reading index file.
    • +
  • 99 request not found.
    • +
+
+
+
+
Note
In order to unpack grib from a multiprocessing environment where each processor is attempting to read from its own pair of logical units, one must directly call subprogram getgbemh as below, allocating a private copy of cbuf, nlen and nnum to each processor. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
94-04-01
+ +

Definition at line 167 of file getgbeh.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbeh_8f.js b/ver-2.10.0/getgbeh_8f.js new file mode 100644 index 00000000..cce029aa --- /dev/null +++ b/ver-2.10.0/getgbeh_8f.js @@ -0,0 +1,4 @@ +var getgbeh_8f = +[ + [ "getgbeh", "getgbeh_8f.html#ae52a0759ee42423a1ad4d714665cdb64", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbeh_8f_source.html b/ver-2.10.0/getgbeh_8f_source.html new file mode 100644 index 00000000..63a2fed9 --- /dev/null +++ b/ver-2.10.0/getgbeh_8f_source.html @@ -0,0 +1,295 @@ + + + + + + + +NCEPLIBS-w3emc: getgbeh.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbeh.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find a grib message.
+
3 C> @author Mark Iredell @date 1995-10-31
+
4 
+
5 C> Read a grib index file (or optionally the grib file itself) to get
+
6 C> the index buffer (i.e. table of contents) for the grib file. (The
+
7 C> index buffer is saved for use by future prospective calls.) Find
+
8 C> in the index buffer a reference to the grib message requested.
+
9 C> The grib message request specifies the number of messages to skip
+
10 C> and the unpacked pds and gds parameters. (A requested parameter of
+
11 C> -1 means to allow any value of this parameter to be found.) If the
+
12 C> requested grib message is found, then its message number is
+
13 C> returned along with the unpacked pds and gds parameters. If the
+
14 C> grib message is not found, then the return code will be nonzero.
+
15 C>
+
16 C> Program History:
+
17 C> - 1995-10-31 Mark Iredell Modularized portions of code into subprograms
+
18 C> and allowed for unspecified index file.
+
19 C>
+
20 C> @param[in] LUGB Integer unit of the unblocked grib data file.
+
21 C> (only used if lugi=0)
+
22 C> @param[in] LUGI Integer unit of the unblocked grib index file.
+
23 C> (=0 to get index buffer from the grib file)
+
24 C> @param[in] J Integer number of messages to skip.
+
25 C> - (=0 to search from beginning)
+
26 C> - (<0 to read index buffer and skip -1-j messages)
+
27 C> @param[in] JPDS Integer (200) pds parameters for which to search (can
+
28 C> be combination of more than 1).
+
29 C> - -1 for wildcard.
+
30 C> - 1 id of center.
+
31 C> - 2 generating process id number.
+
32 C> - 3 grid definition.
+
33 C> - 4 gds/bms flag (right adj copy of octet 8).
+
34 C> - 5 indicator of parameter.
+
35 C> - 6 type of level.
+
36 C> - 7 height/pressure , etc of level.
+
37 C> - 8 year including (century-1).
+
38 C> - 9 month of year.
+
39 C> - 10 day of month.
+
40 C> - 11 hour of day.
+
41 C> - 12 minute of hour.
+
42 C> - 13 indicator of forecast time unit.
+
43 C> - 14 time range 1.
+
44 C> - 15 time range 2.
+
45 C> - 16 time range flag.
+
46 C> - 17 number included in average.
+
47 C> - 18 version nr of grib specification.
+
48 C> - 19 version nr of parameter table.
+
49 C> - 20 nr missing from average/accumulation.
+
50 C> - 21 century of reference time of data.
+
51 C> - 22 units decimal scale factor.
+
52 C> - 23 subcenter number.
+
53 C> - 24 pds byte 29, for nmc ensemble products.
+
54 C> - 128 if forecast field error.
+
55 C> - 64 if bias corrected fcst field.
+
56 C> - 32 if smoothed field.
+
57 C> - 25 pds byte 30, not used.
+
58 C> @param[in] JGDS Integer (200) gds parameters for which to search.
+
59 C> (only searched if jpds(3)=255)
+
60 C> - -1 for wildcard.
+
61 C> - 1 data representation type.
+
62 C> - 19 number of vertical coordinate parameters.
+
63 C> - 20 octet number of the list of vertical coordinate parameters.
+
64 C> or octet number of the list of numbers of points in each row
+
65 C> or 255 if neither are present.
+
66 C> - 21 for grids with pl, number of points in grid.
+
67 C> - 22 number of words in each row.
+
68 C> - Latitude/longitude grids.
+
69 C> - 2 n(i) nr points on latitude circle.
+
70 C> - 3 n(j) nr points on longitude meridian.
+
71 C> - 4 la(1) latitude of origin.
+
72 C> - 5 lo(1) longitude of origin.
+
73 C> - 6 resolution flag (right adj copy of octet 17).
+
74 C> - 7 la(2) latitude of extreme point.
+
75 C> - 8 lo(2) longitude of extreme point.
+
76 C> - 9 di longitudinal direction of increment.
+
77 C> - 10 dj latitudinal direction increment.
+
78 C> - 11 scanning mode flag (right adj copy of octet 28).
+
79 C> - Gaussian grids
+
80 C> - 2 n(i) nr points on latitude circle.
+
81 C> - 3 n(j) nr points on longitude meridian.
+
82 C> - 4 la(1) latitude of origin.
+
83 C> - 5 lo(1) longitude of origin.
+
84 C> - 6 resolution flag (right adj copy of octet 17).
+
85 C> - 7 la(2) latitude of extreme point.
+
86 C> - 8 lo(2) longitude of extreme point.
+
87 C> - 9 di longitudinal direction of increment.
+
88 C> - 10 n - nr of circles pole to equator.
+
89 C> - 11 scanning mode flag (right adj copy of octet 28).
+
90 C> - 12 nv - nr of vert coord parameters.
+
91 C> - 13 pv - octet nr of list of vert coord parameters or pl location
+
92 C> of the list of numbers of points in each row (if no vert coord
+
93 C> parameters are present or 255 if neither are present.
+
94 C> - Polar stereographic grids.
+
95 C> - 2 n(i) nr points along lat circle.
+
96 C> - 3 n(j) nr points along lon circle.
+
97 C> - 4 la(1) latitude of origin.
+
98 C> - 5 lo(1) longitude of origin.
+
99 C> - 6 resolution flag (right adj copy of octet 17).
+
100 C> - 7 lov grid orientation.
+
101 C> - 8 dx - x direction increment.
+
102 C> - 9 dy - y direction increment.
+
103 C> - 10 projection center flag.
+
104 C> - 11 scanning mode (right adj copy of octet 28).
+
105 C> - Spherical harmonic coefficients
+
106 C> - 2 j pentagonal resolution parameter.
+
107 C> - 3 k pentagonal resolution parameter.
+
108 C> - 4 m pentagonal resolution parameter.
+
109 C> - 5 representation type.
+
110 C> - 6 coefficient storage mode.
+
111 C> - Mercator grids
+
112 C> - 2 n(i) nr points on latitude circle.
+
113 C> - 3 n(j) nr points on longitude meridian.
+
114 C> - 4 la(1) latitude of origin.
+
115 C> - 5 lo(1) longitude of origin.
+
116 C> - 6 resolution flag (right adj copy of octet 17).
+
117 C> - 7 la(2) latitude of last grid point.
+
118 C> - 8 lo(2) longitude of last grid point.
+
119 C> - 9 latit - latitude of projection intersection.
+
120 C> - 10 reserved.
+
121 C> - 11 scanning mode flag (right adj copy of octet 28).
+
122 C> - 12 longitudinal dir grid length.
+
123 C> - 13 latitudinal dir grid length.
+
124 C> - Lambert conformal grids
+
125 C> - 2 nx nr points along x-axis.
+
126 C> - 3 ny nr points along y-axis.
+
127 C> - 4 la1 lat of origin (lower left).
+
128 C> - 5 lo1 lon of origin (lower left).
+
129 C> - 6 resolution (right adj copy of octet 17).
+
130 C> - 7 lov - orientation of grid.
+
131 C> - 8 dx - x-dir increment.
+
132 C> - 9 dy - y-dir increment.
+
133 C> - 10 projection center flag.
+
134 C> - 11 scanning mode flag (right adj copy of octet 28).
+
135 C> - 12 latin 1 - first lat from pole of secant cone inter.
+
136 C> - 13 latin 2 - second lat from pole of secant cone inter.
+
137 C> @param[in] JENS Integer (200) ensemble pds parms for which to
+
138 C> search (only searched if jpds(23)=2).
+
139 C> - -1 for wildcard.
+
140 C> - 1 application identifier.
+
141 C> - 2 ensemble type.
+
142 C> - 3 ensemble identifier.
+
143 C> - 4 product identifier.
+
144 C> - 5 smoothing flag.
+
145 C> @param[out] KG Integer number of bytes in the grib message.
+
146 C> @param[out] KF Integer number of data points in the message.
+
147 C> @param[out] K Integer message number unpacked (can be same as j in
+
148 C> calling program in order to facilitate multiple searches).
+
149 C> @param[out] KPDS Integer (200) unpacked pds parameters.
+
150 C> @param[out] KGDS Integer (200) unpacked gds parameters.
+
151 C> @param[out] KENS Integer (200) unpacked ensemble pds parms.
+
152 C> @param[out] IRET Integer return code.
+
153 C> - 0 all ok.
+
154 C> - 96 error reading index file.
+
155 C> - 99 request not found.
+
156 C>
+
157 C> @note In order to unpack grib from a multiprocessing environment
+
158 C> where each processor is attempting to read from its own pair of
+
159 C> logical units, one must directly call subprogram getgbemh as
+
160 C> below, allocating a private copy of cbuf, nlen and nnum to each
+
161 C> processor. Do not engage the same logical unit from more than one
+
162 C> processor.
+
163 C>
+
164 C> @author Mark Iredell @date 94-04-01
+
165  SUBROUTINE getgbeh(LUGB,LUGI,J,JPDS,JGDS,JENS,
+
166  & KG,KF,K,KPDS,KGDS,KENS,IRET)
+
167  INTEGER JPDS(200),JGDS(200),JENS(200)
+
168  INTEGER KPDS(200),KGDS(200),KENS(200)
+
169  parameter(mbuf=256*1024)
+
170  CHARACTER CBUF(MBUF)
+
171  SAVE cbuf,nlen,nnum,mnum
+
172  DATA lux/0/
+
173 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
174 C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
+
175  IF(lugi.GT.0.AND.(j.LT.0.OR.lugi.NE.lux)) THEN
+
176  lux=lugi
+
177  jj=min(j,-1-j)
+
178  ELSEIF(lugi.LE.0.AND.(j.LT.0.OR.lugb.NE.lux)) THEN
+
179  lux=lugb
+
180  jj=min(j,-1-j)
+
181  ELSE
+
182  jj=j
+
183  ENDIF
+
184 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
185 C FIND AND UNPACK GRIB MESSAGE
+
186  CALL getgbemh(lugb,lugi,jj,jpds,jgds,jens,
+
187  & mbuf,cbuf,nlen,nnum,mnum,
+
188  & kg,kf,k,kpds,kgds,kens,iret)
+
189  IF(iret.EQ.96) lux=0
+
190 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
191  RETURN
+
192  END
+
+
+
getgbemh
subroutine getgbemh(LUGB, LUGI, J, JPDS, JGDS, JENS, MBUF, CBUF, NLEN, NNUM, MNUM, KG, KF, K, KPDS, KGDS, KENS, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbemh.f:177
+
getgbeh
subroutine getgbeh(LUGB, LUGI, J, JPDS, JGDS, JENS, KG, KF, K, KPDS, KGDS, KENS, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbeh.f:167
+ + + + diff --git a/ver-2.10.0/getgbem_8f.html b/ver-2.10.0/getgbem_8f.html new file mode 100644 index 00000000..3a07426a --- /dev/null +++ b/ver-2.10.0/getgbem_8f.html @@ -0,0 +1,431 @@ + + + + + + + +NCEPLIBS-w3emc: getgbem.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbem.f File Reference
+
+
+ +

Find and unpack a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbem (LUGB, LUGI, JF, J, JPDS, JGDS, JENS, MBUF, CBUF, NLEN, NNUM, MNUM, KF, K, KPDS, KGDS, KENS, LB, F, IRET)
 Find and unpack a grib message. More...
 
+

Detailed Description

+

Find and unpack a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbem.f.

+

Function/Subroutine Documentation

+ +

◆ getgbem()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbem ( LUGB,
 LUGI,
 JF,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
integer, dimension(200) JENS,
 MBUF,
character, dimension(mbuf) CBUF,
 NLEN,
 NNUM,
 MNUM,
 KF,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
logical*1, dimension(jf) LB,
real, dimension(jf) F,
 IRET 
)
+
+ +

Find and unpack a grib message.

+

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. table of contents) for the grib file. Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file and unpacked. Its message number is returned along with the unpacked pds and gds parameters, the unpacked bitmap (if any), and the unpacked data. if the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
+
Parameters
+ + + + + + + + + + + + + + + + + + + + + +
[in]LUGBInteger unit of the unblocked grib data file.
[in]LUGIInteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]JFInteger maximum number of data points to unpack.
[in]Jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages)
[in]jpdsinteger (200) pds parameters for which to search (=-1 for wildcard)
    +
  • 1 id of center.
    • +
  • 2 generating process id number.
    • +
  • 3 grid definition.
    • +
  • 4 gds/bms flag (right adj copy of octet 8).
    • +
  • 5 indicator of parameter.
    • +
  • 6 type of level.
    • +
  • 7 height/pressure , etc of level.
    • +
  • 8 year including (century-1).
    • +
  • 9 month of year.
    • +
  • 10 day of month.
    • +
  • 11 hour of day.
    • +
  • 12 minute of hour.
    • +
  • 13 indicator of forecast time unit.
    • +
  • 14 time range 1.
    • +
  • 15 time range 2.
    • +
  • 16 time range flag.
    • +
  • 17 number included in average.
    • +
  • 18 version nr of grib specification.
    • +
  • 19 version nr of parameter table.
    • +
  • 20 nr missing from average/accumulation.
    • +
  • 21 century of reference time of data.
    • +
  • 22 units decimal scale factor.
    • +
  • 23 subcenter number.
    • +
  • 24 pds byte 29, for nmc ensemble products.
      +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    +
    • +
  • (25) - pds byte 30, not used.
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1 data representation type.
    • +
  • 19 number of vertical coordinate parameters.
    • +
  • 20 octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
    • +
  • 21 for grids with pl, number of points in grid.
    • +
  • 22 number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2 n(i) nr points on latitude circle.
      • +
    • 3 n(j) nr points on longitude meridian.
      • +
    • 4 la(1) latitude of origin.
      • +
    • 5 lo(1) longitude of origin.
      • +
    • 6 resolution flag (right adj copy of octet 17).
      • +
    • 7 la(2) latitude of extreme point.
      • +
    • 8 lo(2) longitude of extreme point.
      • +
    • 9 di longitudinal direction of increment.
      • +
    • 10 dj latitudinal direction increment.
      • +
    • 11 scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids.
      +
    • 2 n(i) nr points on latitude circle.
      • +
    • 3 n(j) nr points on longitude meridian.
      • +
    • 4 la(1) latitude of origin.
      • +
    • 5 lo(1) longitude of origin.
      • +
    • 6 resolution flag (right adj copy of octet 17).
      • +
    • 7 la(2) latitude of extreme point.
      • +
    • 8 lo(2) longitude of extreme point.
      • +
    • 9 di longitudinal direction of increment.
      • +
    • 10 n: nr of circles pole to equator.
      • +
    • 11 scanning mode flag (right adj copy of octet 28).
      • +
    • 12 nv: nr of vert coord parameters.
      • +
    • 13 pv: octet nr of list of vert coord parameters or
        +
      • pl: location of the list of numbers of points in each row (if no vert coord parameters are present or
        • +
      • 255 if neither are present.
        • +
      +
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2 n(i) nr points along lat circle.
      • +
    • 3 n(j) nr points along lon circle.
      • +
    • 4 la(1) latitude of origin.
      • +
    • 5 lo(1) longitude of origin.
      • +
    • 6 resolution flag (right adj copy of octet 17).
      • +
    • 7 lov grid orientation.
      • +
    • 8 dx - x direction increment.
      • +
    • 9 dy - y direction increment.
      • +
    • 10 projection center flag.
      • +
    • 11 scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2 j pentagonal resolution parameter.
      • +
    • 3 k pentagonal resolution parameter.
      • +
    • 4 m pentagonal resolution parameter.
      • +
    • 5 representation type.
      • +
    • 6 coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2 n(i) nr points on latitude circle.
      • +
    • 3 n(j) nr points on longitude meridian.
      • +
    • 4 la(1) latitude of origin.
      • +
    • 5 lo(1) longitude of origin.
      • +
    • 6 resolution flag (right adj copy of octet 17).
      • +
    • 7 la(2) latitude of last grid point.
      • +
    • 8 lo(2) longitude of last grid point.
      • +
    • 9 latit - latitude of projection intersection.
      • +
    • 10 reserved.
      • +
    • 11 scanning mode flag (right adj copy of octet 28).
      • +
    • 12 longitudinal dir grid length.
      • +
    • 13 latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2 nx nr points along x-axis.
      • +
    • 3 ny nr points along y-axis.
      • +
    • 4 la1 lat of origin (lower left).
      • +
    • 5 lo1 lon of origin (lower left).
      • +
    • 6 resolution (right adj copy of octet 17).
      • +
    • 7 lov - orientation of grid.
      • +
    • 8 dx - x-dir increment.
      • +
    • 9 dy - y-dir increment.
      • +
    • 10 projection center flag.
      • +
    • 11 scanning mode flag (right adj copy of octet 28).
      • +
    • 12 latin 1 - first lat from pole of secant cone inter.
      • +
    • 13 latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]jensinteger (200) ensemble pds parms for which to search (only searched if jpds(23)=2) (=-1 for wildcard).
    +
  • 1 application identifier.
    • +
  • 2 ensemble type.
    • +
  • 3 ensemble identifier.
    • +
  • 4 product identifier.
    • +
  • 5 smoothing flag.
    • +
+
[in]mbufinteger length of index buffer in bytes.
[in,out]nnuminteger number of index records (initialize by setting j=-1).
[in,out]mnuminteger number of index records skipped (initialize by setting j=-1).
[in,out]cbufcharacter*1 (mbuf) index buffer (initialize by setting j=-1).
[in,out]nleninteger length of each index record in bytes. (initialize by setting j=-1).
[out]kfinteger number of data points unpacked.
[out]kinteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]kensinteger (200) unpacked ensemble pds parms.
[out]lblogical*1 (kf) unpacked bitmap if present.
[out]freal (kf) unpacked data.
[out]iretinteger return code.
    +
  • 0 all ok.
    • +
  • 96 error reading index file.
    • +
  • 97 error reading grib file.
    • +
  • 98 number of data points greater than jf.
    • +
  • 99 request not found.
    • +
  • other w3fi63 grib unpacker return code.
    • +
+
+
+
+
Note
Specify an index file if feasible to increase speed. Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
+ +

Definition at line 183 of file getgbem.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbem_8f.js b/ver-2.10.0/getgbem_8f.js new file mode 100644 index 00000000..3f7371fe --- /dev/null +++ b/ver-2.10.0/getgbem_8f.js @@ -0,0 +1,4 @@ +var getgbem_8f = +[ + [ "getgbem", "getgbem_8f.html#a1b647652df8027c1858a12f78234d246", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbem_8f_source.html b/ver-2.10.0/getgbem_8f_source.html new file mode 100644 index 00000000..7022bf5f --- /dev/null +++ b/ver-2.10.0/getgbem_8f_source.html @@ -0,0 +1,353 @@ + + + + + + + +NCEPLIBS-w3emc: getgbem.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbem.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find and unpack a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Find and unpack a grib message.
+
6 C> Read a grib index file (or optionally the grib file itself)
+
7 C> to get the index buffer (i.e. table of contents) for the grib file.
+
8 C> Find in the index buffer a reference to the grib message requested.
+
9 C> The grib message request specifies the number of messages to skip
+
10 C> and the unpacked pds and gds parameters. (A requested parameter
+
11 C> of -1 means to allow any value of this parameter to be found.)
+
12 C> If the requested grib message is found, then it is read from the
+
13 C> grib file and unpacked. Its message number is returned along with
+
14 C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
15 C> and the unpacked data. if the grib message is not found, then the
+
16 C> return code will be nonzero.
+
17 C>
+
18 C> Program history log:
+
19 C> - Mark Iredell 1994-04-01
+
20 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
21 C> and allowed for unspecified index file.
+
22 C>
+
23 C> @param[in] LUGB Integer unit of the unblocked grib data file.
+
24 C> @param[in] LUGI Integer unit of the unblocked grib index file
+
25 C> (=0 to get index buffer from the grib file).
+
26 C> @param[in] JF Integer maximum number of data points to unpack.
+
27 C> @param[in] J integer number of messages to skip
+
28 C> (=0 to search from beginning)
+
29 C> (<0 to read index buffer and skip -1-j messages)
+
30 C> @param[in] jpds integer (200) pds parameters for which to search
+
31 C> (=-1 for wildcard)
+
32 C> - 1 id of center.
+
33 C> - 2 generating process id number.
+
34 C> - 3 grid definition.
+
35 C> - 4 gds/bms flag (right adj copy of octet 8).
+
36 C> - 5 indicator of parameter.
+
37 C> - 6 type of level.
+
38 C> - 7 height/pressure , etc of level.
+
39 C> - 8 year including (century-1).
+
40 C> - 9 month of year.
+
41 C> - 10 day of month.
+
42 C> - 11 hour of day.
+
43 C> - 12 minute of hour.
+
44 C> - 13 indicator of forecast time unit.
+
45 C> - 14 time range 1.
+
46 C> - 15 time range 2.
+
47 C> - 16 time range flag.
+
48 C> - 17 number included in average.
+
49 C> - 18 version nr of grib specification.
+
50 C> - 19 version nr of parameter table.
+
51 C> - 20 nr missing from average/accumulation.
+
52 C> - 21 century of reference time of data.
+
53 C> - 22 units decimal scale factor.
+
54 C> - 23 subcenter number.
+
55 C> - 24 pds byte 29, for nmc ensemble products.
+
56 C> - 128 if forecast field error.
+
57 C> - 64 if bias corrected fcst field.
+
58 C> - 32 if smoothed field.
+
59 C> - warning: can be combination of more than 1.
+
60 C> - (25) - pds byte 30, not used.
+
61 C> @param[in] jgds integer (200) gds parameters for which to search
+
62 C> (only searched if jpds(3)=255)
+
63 C> (=-1 for wildcard).
+
64 C> - 1 data representation type.
+
65 C> - 19 number of vertical coordinate parameters.
+
66 C> - 20 octet number of the list of vertical coordinate parameters
+
67 C> or octet number of the list of numbers of points in each row or
+
68 C> 255 if neither are present.
+
69 C> - 21 for grids with pl, number of points in grid.
+
70 C> - 22 number of words in each row.
+
71 C> - Latitude/longitude grids.
+
72 C> - 2 n(i) nr points on latitude circle.
+
73 C> - 3 n(j) nr points on longitude meridian.
+
74 C> - 4 la(1) latitude of origin.
+
75 C> - 5 lo(1) longitude of origin.
+
76 C> - 6 resolution flag (right adj copy of octet 17).
+
77 C> - 7 la(2) latitude of extreme point.
+
78 C> - 8 lo(2) longitude of extreme point.
+
79 C> - 9 di longitudinal direction of increment.
+
80 C> - 10 dj latitudinal direction increment.
+
81 C> - 11 scanning mode flag (right adj copy of octet 28).
+
82 C> - Gaussian grids.
+
83 C> - 2 n(i) nr points on latitude circle.
+
84 C> - 3 n(j) nr points on longitude meridian.
+
85 C> - 4 la(1) latitude of origin.
+
86 C> - 5 lo(1) longitude of origin.
+
87 C> - 6 resolution flag (right adj copy of octet 17).
+
88 C> - 7 la(2) latitude of extreme point.
+
89 C> - 8 lo(2) longitude of extreme point.
+
90 C> - 9 di longitudinal direction of increment.
+
91 C> - 10 n: nr of circles pole to equator.
+
92 C> - 11 scanning mode flag (right adj copy of octet 28).
+
93 C> - 12 nv: nr of vert coord parameters.
+
94 C> - 13 pv: octet nr of list of vert coord parameters or
+
95 C> - pl: location of the list of numbers of points in
+
96 C> each row (if no vert coord parameters are present or
+
97 C> - 255 if neither are present.
+
98 C> - Polar stereographic grids.
+
99 C> - 2 n(i) nr points along lat circle.
+
100 C> - 3 n(j) nr points along lon circle.
+
101 C> - 4 la(1) latitude of origin.
+
102 C> - 5 lo(1) longitude of origin.
+
103 C> - 6 resolution flag (right adj copy of octet 17).
+
104 C> - 7 lov grid orientation.
+
105 C> - 8 dx - x direction increment.
+
106 C> - 9 dy - y direction increment.
+
107 C> - 10 projection center flag.
+
108 C> - 11 scanning mode (right adj copy of octet 28).
+
109 C> - Spherical harmonic coefficients.
+
110 C> - 2 j pentagonal resolution parameter.
+
111 C> - 3 k pentagonal resolution parameter.
+
112 C> - 4 m pentagonal resolution parameter.
+
113 C> - 5 representation type.
+
114 C> - 6 coefficient storage mode.
+
115 C> - Mercator grids.
+
116 C> - 2 n(i) nr points on latitude circle.
+
117 C> - 3 n(j) nr points on longitude meridian.
+
118 C> - 4 la(1) latitude of origin.
+
119 C> - 5 lo(1) longitude of origin.
+
120 C> - 6 resolution flag (right adj copy of octet 17).
+
121 C> - 7 la(2) latitude of last grid point.
+
122 C> - 8 lo(2) longitude of last grid point.
+
123 C> - 9 latit - latitude of projection intersection.
+
124 C> - 10 reserved.
+
125 C> - 11 scanning mode flag (right adj copy of octet 28).
+
126 C> - 12 longitudinal dir grid length.
+
127 C> - 13 latitudinal dir grid length.
+
128 C> - Lambert conformal grids.
+
129 C> - 2 nx nr points along x-axis.
+
130 C> - 3 ny nr points along y-axis.
+
131 C> - 4 la1 lat of origin (lower left).
+
132 C> - 5 lo1 lon of origin (lower left).
+
133 C> - 6 resolution (right adj copy of octet 17).
+
134 C> - 7 lov - orientation of grid.
+
135 C> - 8 dx - x-dir increment.
+
136 C> - 9 dy - y-dir increment.
+
137 C> - 10 projection center flag.
+
138 C> - 11 scanning mode flag (right adj copy of octet 28).
+
139 C> - 12 latin 1 - first lat from pole of secant cone inter.
+
140 C> - 13 latin 2 - second lat from pole of secant cone inter.
+
141 C> @param[in] jens integer (200) ensemble pds parms for which to search
+
142 C> (only searched if jpds(23)=2)
+
143 C> (=-1 for wildcard).
+
144 C> - 1 application identifier.
+
145 C> - 2 ensemble type.
+
146 C> - 3 ensemble identifier.
+
147 C> - 4 product identifier.
+
148 C> - 5 smoothing flag.
+
149 C> @param[in] mbuf integer length of index buffer in bytes.
+
150 C> @param[inout] nnum integer number of index records
+
151 C> (initialize by setting j=-1).
+
152 C> @param[inout] mnum integer number of index records skipped
+
153 C> (initialize by setting j=-1).
+
154 C> @param[inout] cbuf character*1 (mbuf) index buffer
+
155 C> (initialize by setting j=-1).
+
156 C> @param[inout] nlen integer length of each index record in bytes.
+
157 C> (initialize by setting j=-1).
+
158 C> @param[out] kf integer number of data points unpacked.
+
159 C> @param[out] k integer message number unpacked
+
160 C> (can be same as j in calling program
+
161 C> in order to facilitate multiple searches).
+
162 C> @param[out] kpds integer (200) unpacked pds parameters.
+
163 C> @param[out] kgds integer (200) unpacked gds parameters.
+
164 C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
165 C> @param[out] lb logical*1 (kf) unpacked bitmap if present.
+
166 C> @param[out] f real (kf) unpacked data.
+
167 C> @param[out] iret integer return code.
+
168 C> - 0 all ok.
+
169 C> - 96 error reading index file.
+
170 C> - 97 error reading grib file.
+
171 C> - 98 number of data points greater than jf.
+
172 C> - 99 request not found.
+
173 C> - other w3fi63 grib unpacker return code.
+
174 C>
+
175 C> @note Specify an index file if feasible to increase speed.
+
176 C> Subprogram can be called from a multiprocessing environment.
+
177 C> Do not engage the same logical unit from more than one processor.
+
178 C>
+
179 C-----------------------------------------------------------------------
+
180  SUBROUTINE getgbem(LUGB,LUGI,JF,J,JPDS,JGDS,JENS,
+
181  & MBUF,CBUF,NLEN,NNUM,MNUM,
+
182  & KF,K,KPDS,KGDS,KENS,LB,F,IRET)
+
183  INTEGER JPDS(200),JGDS(200),JENS(200)
+
184  INTEGER KPDS(200),KGDS(200),KENS(200)
+
185  CHARACTER CBUF(MBUF)
+
186  LOGICAL*1 LB(JF)
+
187  REAL F(JF)
+
188  parameter(msk1=32000,msk2=4000)
+
189 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
190 C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE
+
191  IF(j.GE.0) THEN
+
192  IF(mnum.GE.0) THEN
+
193  irgi=0
+
194  ELSE
+
195  mnum=-1-mnum
+
196  irgi=1
+
197  ENDIF
+
198  jr=j-mnum
+
199  IF(jr.GE.0.AND.(jr.LT.nnum.OR.irgi.EQ.0)) THEN
+
200  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
201  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
202  IF(irgs.EQ.0) k=kr+mnum
+
203  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
204  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
205  ELSE
+
206  mnum=j
+
207  irgi=1
+
208  irgs=1
+
209  ENDIF
+
210  ELSE
+
211  mnum=-1-j
+
212  irgi=1
+
213  irgs=1
+
214  ENDIF
+
215 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
216 C READ AND SEARCH NEXT INDEX BUFFER
+
217  jr=0
+
218  dowhile(irgi.EQ.1.AND.irgs.EQ.1)
+
219  IF(lugi.GT.0) THEN
+
220  CALL getgi(lugi,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
221  ELSE
+
222  CALL getgir(lugb,msk1,msk2,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
223  ENDIF
+
224  IF(irgi.LE.1) THEN
+
225  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
226  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
227  IF(irgs.EQ.0) k=kr+mnum
+
228  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
229  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
230  ENDIF
+
231  ENDDO
+
232 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
233 C READ AND UNPACK GRIB RECORD
+
234  IF(irgi.GT.1) THEN
+
235  iret=96
+
236  ELSEIF(irgs.NE.0) THEN
+
237  iret=99
+
238  ELSEIF(lengds(kgds).GT.jf) THEN
+
239  iret=98
+
240  ELSE
+
241  CALL getgb1r(lugb,lskip,lgrib,kf,kpds,kgds,kens,lb,f,nbits,
+
242  & iret)
+
243  ENDIF
+
244 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
245  RETURN
+
246  END
+
+
+
getgb1r
subroutine getgb1r(LUGB, LSKIP, LGRIB, KF, KPDS, KGDS, KENS, LB, F, NBITSS, IRET)
Program history log:
Definition: getgb1r.f:34
+
getgir
subroutine getgir(LUGB, MSK1, MSK2, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib file and return its index contents.
Definition: getgir.f:45
+
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
+
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+
getgb1s
subroutine getgb1s(CBUF, NLEN, NNUM, J, JPDS, JGDS, JENS, K, KPDS, KGDS, KENS, LSKIP, LGRIB, IRET)
Find a grib message.
Definition: getgb1s.f:44
+
getgbem
subroutine getgbem(LUGB, LUGI, JF, J, JPDS, JGDS, JENS, MBUF, CBUF, NLEN, NNUM, MNUM, KF, K, KPDS, KGDS, KENS, LB, F, IRET)
Find and unpack a grib message.
Definition: getgbem.f:183
+ + + + diff --git a/ver-2.10.0/getgbemh_8f.html b/ver-2.10.0/getgbemh_8f.html new file mode 100644 index 00000000..9c7500ae --- /dev/null +++ b/ver-2.10.0/getgbemh_8f.html @@ -0,0 +1,417 @@ + + + + + + + +NCEPLIBS-w3emc: getgbemh.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbemh.f File Reference
+
+
+ +

Find a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbemh (LUGB, LUGI, J, JPDS, JGDS, JENS, MBUF, CBUF, NLEN, NNUM, MNUM, KG, KF, K, KPDS, KGDS, KENS, IRET)
 Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. More...
 
+

Detailed Description

+

Find a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbemh.f.

+

Function/Subroutine Documentation

+ +

◆ getgbemh()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbemh ( LUGB,
 LUGI,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
integer, dimension(200) JENS,
 MBUF,
character, dimension(mbuf) CBUF,
 NLEN,
 NNUM,
 MNUM,
 KG,
 KF,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
 IRET 
)
+
+ +

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e.

+

table of contents) for the grib file. Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then its message number is returned along with the unpacked pds and gds parameters. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file
    • +
+
Parameters
+ + + + + + + + + + + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib data file (only used if lugi=0).
[in]lugiinteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages).
[in]jpdsinteger (200) pds parameters for which to search. (=-1 for wildcard).
    +
  • 1: id of center.
    • +
  • 2: generating process id number.
    • +
  • 3: grid definition.
    • +
  • 4: gds/bms flag (right adj copy of octet 8).
    • +
  • 5: indicator of parameter.
    • +
  • 6: type of level.
    • +
  • 7: height/pressure , etc of level.
    • +
  • 8: year including (century-1).
    • +
  • 9: month of year.
    • +
  • 10: day of month.
    • +
  • 11: hour of day.
    • +
  • 12: minute of hour.
    • +
  • 13: indicator of forecast time unit.
    • +
  • 14: time range 1.
    • +
  • 15: time range 2.
    • +
  • 16: time range flag.
    • +
  • 17: number included in average.
    • +
  • 18: version nr of grib specification.
    • +
  • 19: version nr of parameter table.
    • +
  • 20: nr missing from average/accumulation.
    • +
  • 21: century of reference time of data.
    • +
  • 22: units decimal scale factor.
    • +
  • 23: subcenter number.
    • +
  • 24: pds byte 29, for nmc ensemble products.
      +
    • 128: if forecast field error.
      • +
    • 64: if bias corrected fcst field.
      • +
    • 32: if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    +
    • +
  • 25: pds byte 30, not used.
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1: data representation type.
    • +
  • 19: number of vertical coordinate parameters.
    • +
  • 20: octet number of the list of vertical coordinate parameters or. octet number of the list of numbers of points in each row or. 255 if neither are present.
    • +
  • 21: for grids with pl, number of points in grid.
    • +
  • 22: number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: dj latitudinal direction increment.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: n: nr of circles pole to equator.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: nv: nr of vert coord parameters.
      • +
    • 13:
        +
      • pv: octet nr of list of vert coord parameters or.
        • +
      • pl:location of the list of numbers of points in each row (if no vert coord parameters are present) or.
        • +
      • 255: if neither are present.
        • +
      +
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2: n(i) nr points along lat circle.
      • +
    • 3: n(j) nr points along lon circle.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: lov grid orientation.
      • +
    • 8: dx - x direction increment.
      • +
    • 9: dy - y direction increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2: j pentagonal resolution parameter.
      • +
    • 3: k pentagonal resolution parameter.
      • +
    • 4: m pentagonal resolution parameter.
      • +
    • 5: representation type.
      • +
    • 6: coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of last grid point.
      • +
    • 8: lo(2) longitude of last grid point.
      • +
    • 9: latit - latitude of projection intersection.
      • +
    • 10: reserved.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: longitudinal dir grid length.
      • +
    • 13: latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2: nx nr points along x-axis.
      • +
    • 3: ny nr points along y-axis.
      • +
    • 4: la1 lat of origin (lower left).
      • +
    • 5: lo1 lon of origin (lower left).
      • +
    • 6: resolution (right adj copy of octet 17).
      • +
    • 7: lov - orientation of grid.
      • +
    • 8: dx - x-dir increment.
      • +
    • 9: dy - y-dir increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: latin 1 - first lat from pole of secant cone inter.
      • +
    • 13: latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]jensinteger (200) ensemble pds parms for which to search (only searched if jpds(23)=2). (=-1 for wildcard).
    +
  • 1: application identifier.
    • +
  • 2: ensemble type.
    • +
  • 3: ensemble identifier.
    • +
  • 4: product identifier.
    • +
  • 5: smoothing flag.
    • +
+
[in]mbufinteger length of index buffer in bytes.
[in,out]cbufcharacter*1 (mbuf) index buffer (initialize by setting j=-1).
[in,out]nleninteger length of each index record in bytes (initialize by setting j=-1).
[in,out]nnuminteger number of index records (initialize by setting j=-1).
[in,out]mnuminteger number of index records skipped (initialize by setting j=-1).
[out]kginteger number of bytes in the grib message.
[out]kfinteger number of data points in the message.
[out]kinteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]kensinteger (200) unpacked ensemble pds parms.
[out]iretinteger return code.
    +
  • 0: all ok.
    • +
  • 96: error reading index file.
    • +
  • 99: request not found.
    • +
+
+
+
+
Note
Specify an index file if feasible to increase speed. Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 177 of file getgbemh.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbemh_8f.js b/ver-2.10.0/getgbemh_8f.js new file mode 100644 index 00000000..552278f4 --- /dev/null +++ b/ver-2.10.0/getgbemh_8f.js @@ -0,0 +1,4 @@ +var getgbemh_8f = +[ + [ "getgbemh", "getgbemh_8f.html#af515ecda0ec8361b15a4596b5773bd5f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbemh_8f_source.html b/ver-2.10.0/getgbemh_8f_source.html new file mode 100644 index 00000000..32df23bf --- /dev/null +++ b/ver-2.10.0/getgbemh_8f_source.html @@ -0,0 +1,343 @@ + + + + + + + +NCEPLIBS-w3emc: getgbemh.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbemh.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Read a grib index file (or optionally the grib file itself)
+
6 C> to get the index buffer (i.e. table of contents) for the grib file.
+
7 C> Find in the index buffer a reference to the grib message requested.
+
8 C> The grib message request specifies the number of messages to skip
+
9 C> and the unpacked pds and gds parameters. (A requested parameter
+
10 C> of -1 means to allow any value of this parameter to be found.)
+
11 C> If the requested grib message is found, then its message number is
+
12 C> returned along with the unpacked pds and gds parameters. If the
+
13 C> grib message is not found, then the return code will be nonzero.
+
14 C>
+
15 C> Program history log:
+
16 C> - Mark Iredell 1994-04-01
+
17 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
18 C> and allowed for unspecified index file
+
19 C>
+
20 C> @param[in] lugb integer unit of the unblocked grib data file
+
21 C> (only used if lugi=0).
+
22 C> @param[in] lugi integer unit of the unblocked grib index file
+
23 C> (=0 to get index buffer from the grib file).
+
24 C> @param[in] j integer number of messages to skip
+
25 C> (=0 to search from beginning)
+
26 C> (<0 to read index buffer and skip -1-j messages).
+
27 C> @param[in] jpds integer (200) pds parameters for which to search.
+
28 C> (=-1 for wildcard).
+
29 C> - 1: id of center.
+
30 C> - 2: generating process id number.
+
31 C> - 3: grid definition.
+
32 C> - 4: gds/bms flag (right adj copy of octet 8).
+
33 C> - 5: indicator of parameter.
+
34 C> - 6: type of level.
+
35 C> - 7: height/pressure , etc of level.
+
36 C> - 8: year including (century-1).
+
37 C> - 9: month of year.
+
38 C> - 10: day of month.
+
39 C> - 11: hour of day.
+
40 C> - 12: minute of hour.
+
41 C> - 13: indicator of forecast time unit.
+
42 C> - 14: time range 1.
+
43 C> - 15: time range 2.
+
44 C> - 16: time range flag.
+
45 C> - 17: number included in average.
+
46 C> - 18: version nr of grib specification.
+
47 C> - 19: version nr of parameter table.
+
48 C> - 20: nr missing from average/accumulation.
+
49 C> - 21: century of reference time of data.
+
50 C> - 22: units decimal scale factor.
+
51 C> - 23: subcenter number.
+
52 C> - 24: pds byte 29, for nmc ensemble products.
+
53 C> - 128: if forecast field error.
+
54 C> - 64: if bias corrected fcst field.
+
55 C> - 32: if smoothed field.
+
56 C> - warning: can be combination of more than 1.
+
57 C> - 25: pds byte 30, not used.
+
58 C> @param[in] jgds integer (200) gds parameters for which to search
+
59 C> (only searched if jpds(3)=255)
+
60 C> (=-1 for wildcard).
+
61 C> - 1: data representation type.
+
62 C> - 19: number of vertical coordinate parameters.
+
63 C> - 20: octet number of the list of vertical coordinate parameters or.
+
64 C> octet number of the list of numbers of points in each row or.
+
65 C> 255 if neither are present.
+
66 C> - 21: for grids with pl, number of points in grid.
+
67 C> - 22: number of words in each row.
+
68 C> - Latitude/longitude grids.
+
69 C> - 2: n(i) nr points on latitude circle.
+
70 C> - 3: n(j) nr points on longitude meridian.
+
71 C> - 4: la(1) latitude of origin.
+
72 C> - 5: lo(1) longitude of origin.
+
73 C> - 6: resolution flag (right adj copy of octet 17).
+
74 C> - 7: la(2) latitude of extreme point.
+
75 C> - 8: lo(2) longitude of extreme point.
+
76 C> - 9: di longitudinal direction of increment.
+
77 C> - 10: dj latitudinal direction increment.
+
78 C> - 11: scanning mode flag (right adj copy of octet 28).
+
79 C> - Gaussian grids.
+
80 C> - 2: n(i) nr points on latitude circle.
+
81 C> - 3: n(j) nr points on longitude meridian.
+
82 C> - 4: la(1) latitude of origin.
+
83 C> - 5: lo(1) longitude of origin.
+
84 C> - 6: resolution flag (right adj copy of octet 17).
+
85 C> - 7: la(2) latitude of extreme point.
+
86 C> - 8: lo(2) longitude of extreme point.
+
87 C> - 9: di longitudinal direction of increment.
+
88 C> - 10: n: nr of circles pole to equator.
+
89 C> - 11: scanning mode flag (right adj copy of octet 28).
+
90 C> - 12: nv: nr of vert coord parameters.
+
91 C> - 13:
+
92 C> - pv: octet nr of list of vert coord parameters or.
+
93 C> - pl:location of the list of numbers of points in
+
94 C> each row (if no vert coord parameters are present) or.
+
95 C> - 255: if neither are present.
+
96 C> - Polar stereographic grids.
+
97 C> - 2: n(i) nr points along lat circle.
+
98 C> - 3: n(j) nr points along lon circle.
+
99 C> - 4: la(1) latitude of origin.
+
100 C> - 5: lo(1) longitude of origin.
+
101 C> - 6: resolution flag (right adj copy of octet 17).
+
102 C> - 7: lov grid orientation.
+
103 C> - 8: dx - x direction increment.
+
104 C> - 9: dy - y direction increment.
+
105 C> - 10: projection center flag.
+
106 C> - 11: scanning mode (right adj copy of octet 28).
+
107 C> - Spherical harmonic coefficients.
+
108 C> - 2: j pentagonal resolution parameter.
+
109 C> - 3: k pentagonal resolution parameter.
+
110 C> - 4: m pentagonal resolution parameter.
+
111 C> - 5: representation type.
+
112 C> - 6: coefficient storage mode.
+
113 C> - Mercator grids.
+
114 C> - 2: n(i) nr points on latitude circle.
+
115 C> - 3: n(j) nr points on longitude meridian.
+
116 C> - 4: la(1) latitude of origin.
+
117 C> - 5: lo(1) longitude of origin.
+
118 C> - 6: resolution flag (right adj copy of octet 17).
+
119 C> - 7: la(2) latitude of last grid point.
+
120 C> - 8: lo(2) longitude of last grid point.
+
121 C> - 9: latit - latitude of projection intersection.
+
122 C> - 10: reserved.
+
123 C> - 11: scanning mode flag (right adj copy of octet 28).
+
124 C> - 12: longitudinal dir grid length.
+
125 C> - 13: latitudinal dir grid length.
+
126 C> - Lambert conformal grids.
+
127 C> - 2: nx nr points along x-axis.
+
128 C> - 3: ny nr points along y-axis.
+
129 C> - 4: la1 lat of origin (lower left).
+
130 C> - 5: lo1 lon of origin (lower left).
+
131 C> - 6: resolution (right adj copy of octet 17).
+
132 C> - 7: lov - orientation of grid.
+
133 C> - 8: dx - x-dir increment.
+
134 C> - 9: dy - y-dir increment.
+
135 C> - 10: projection center flag.
+
136 C> - 11: scanning mode flag (right adj copy of octet 28).
+
137 C> - 12: latin 1 - first lat from pole of secant cone inter.
+
138 C> - 13: latin 2 - second lat from pole of secant cone inter.
+
139 C> @param[in] jens integer (200) ensemble pds parms for which to search
+
140 C> (only searched if jpds(23)=2).
+
141 C> (=-1 for wildcard).
+
142 C> - 1: application identifier.
+
143 C> - 2: ensemble type.
+
144 C> - 3: ensemble identifier.
+
145 C> - 4: product identifier.
+
146 C> - 5: smoothing flag.
+
147 C> @param[in] mbuf integer length of index buffer in bytes.
+
148 C> @param[inout] cbuf character*1 (mbuf) index buffer
+
149 C> (initialize by setting j=-1).
+
150 C> @param[inout] nlen integer length of each index record in bytes
+
151 C> (initialize by setting j=-1).
+
152 C> @param[inout] nnum integer number of index records
+
153 C> (initialize by setting j=-1).
+
154 C> @param[inout] mnum integer number of index records skipped
+
155 C> (initialize by setting j=-1).
+
156 C> @param[out] kg integer number of bytes in the grib message.
+
157 C> @param[out] kf integer number of data points in the message.
+
158 C> @param[out] k integer message number unpacked
+
159 C> (can be same as j in calling program in order to facilitate multiple searches).
+
160 C> @param[out] kpds integer (200) unpacked pds parameters.
+
161 C> @param[out] kgds integer (200) unpacked gds parameters.
+
162 C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
163 C> @param[out] iret integer return code.
+
164 C> - 0: all ok.
+
165 C> - 96: error reading index file.
+
166 C> - 99: request not found.
+
167 C>
+
168 C> @note Specify an index file if feasible to increase speed.
+
169 C> Subprogram can be called from a multiprocessing environment.
+
170 C> Do not engage the same logical unit from more than one processor.
+
171 C>
+
172 C> @author Mark Iredell @date 1994-04-01
+
173 C-----------------------------------------------------------------------
+
174  SUBROUTINE getgbemh(LUGB,LUGI,J,JPDS,JGDS,JENS,
+
175  & MBUF,CBUF,NLEN,NNUM,MNUM,
+
176  & KG,KF,K,KPDS,KGDS,KENS,IRET)
+
177  INTEGER JPDS(200),JGDS(200),JENS(200)
+
178  INTEGER KPDS(200),KGDS(200),KENS(200)
+
179  CHARACTER CBUF(MBUF)
+
180  parameter(msk1=32000,msk2=4000)
+
181 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
182 C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE
+
183  IF(j.GE.0) THEN
+
184  IF(mnum.GE.0) THEN
+
185  irgi=0
+
186  ELSE
+
187  mnum=-1-mnum
+
188  irgi=1
+
189  ENDIF
+
190  jr=j-mnum
+
191  IF(jr.GE.0.AND.(jr.LT.nnum.OR.irgi.EQ.0)) THEN
+
192  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
193  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
194  IF(irgs.EQ.0) k=kr+mnum
+
195  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
196  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
197  ELSE
+
198  mnum=j
+
199  irgi=1
+
200  irgs=1
+
201  ENDIF
+
202  ELSE
+
203  mnum=-1-j
+
204  irgi=1
+
205  irgs=1
+
206  ENDIF
+
207 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
208 C READ AND SEARCH NEXT INDEX BUFFER
+
209  jr=0
+
210  dowhile(irgi.EQ.1.AND.irgs.EQ.1)
+
211  IF(lugi.GT.0) THEN
+
212  CALL getgi(lugi,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
213  ELSE
+
214  CALL getgir(lugb,msk1,msk2,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
215  ENDIF
+
216  IF(irgi.LE.1) THEN
+
217  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
218  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
219  IF(irgs.EQ.0) k=kr+mnum
+
220  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
221  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
222  ENDIF
+
223  ENDDO
+
224 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
225 C READ GRIB RECORD
+
226  IF(irgi.GT.1) THEN
+
227  iret=96
+
228  ELSEIF(irgs.NE.0) THEN
+
229  iret=99
+
230  ELSE
+
231  kg=lgrib
+
232  kf=lengds(kgds)
+
233  iret=0
+
234  ENDIF
+
235 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
236  RETURN
+
237  END
+
+
+
getgir
subroutine getgir(LUGB, MSK1, MSK2, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib file and return its index contents.
Definition: getgir.f:45
+
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
+
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+
getgb1s
subroutine getgb1s(CBUF, NLEN, NNUM, J, JPDS, JGDS, JENS, K, KPDS, KGDS, KENS, LSKIP, LGRIB, IRET)
Find a grib message.
Definition: getgb1s.f:44
+
getgbemh
subroutine getgbemh(LUGB, LUGI, J, JPDS, JGDS, JENS, MBUF, CBUF, NLEN, NNUM, MNUM, KG, KF, K, KPDS, KGDS, KENS, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbemh.f:177
+ + + + diff --git a/ver-2.10.0/getgbemn_8f.html b/ver-2.10.0/getgbemn_8f.html new file mode 100644 index 00000000..91176cd8 --- /dev/null +++ b/ver-2.10.0/getgbemn_8f.html @@ -0,0 +1,437 @@ + + + + + + + +NCEPLIBS-w3emc: getgbemn.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbemn.f File Reference
+
+
+ +

Finds and unpacks a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbemn (LUGB, LUGI, JF, J, JPDS, JGDS, JENS, MBUF, CBUF, NLEN, NNUM, MNUM, KF, K, KPDS, KGDS, KENS, LB, F, NBITSS, IRET)
 Find and unpack a grib message. More...
 
+

Detailed Description

+

Finds and unpacks a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbemn.f.

+

Function/Subroutine Documentation

+ +

◆ getgbemn()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbemn ( LUGB,
 LUGI,
 JF,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
integer, dimension(200) JENS,
 MBUF,
character, dimension(mbuf) CBUF,
 NLEN,
 NNUM,
 MNUM,
 KF,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
logical*1, dimension(jf) LB,
real, dimension(jf) F,
 NBITSS,
 IRET 
)
+
+ +

Find and unpack a grib message.

+

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. table of contents) for the grib file. Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file and unpacked. Its message number is returned along with the unpacked pds and gds parameters, the unpacked bitmap (if any), and the unpacked data. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file
    • +
  • Chuang 2004-07-22 add packing bit number nbitss in the argument list because eta grib files need it to repack grib file
    • +
+
Parameters
+ + + + + + + + + + + + + + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib data file.
[in]lugiinteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jfinteger maximum number of data points to unpack.
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages).
[in]jpdsinteger (200) pds parameters for which to search (=-1 for wildcard).
    +
  • 1: id of center.
    • +
  • 2: generating process id number.
    • +
  • 3: grid definition.
    • +
  • 4: gds/bms flag (right adj copy of octet 8).
    • +
  • 5: indicator of parameter.
    • +
  • 6: type of level.
    • +
  • 7: height/pressure , etc of level.
    • +
  • 8: year including (century-1).
    • +
  • 9: month of year.
    • +
  • 10: day of month.
    • +
  • 11: hour of day.
    • +
  • 12: minute of hour.
    • +
  • 13: indicator of forecast time unit.
    • +
  • 14: time range 1.
    • +
  • 15: time range 2.
    • +
  • 16: time range flag.
    • +
  • 17: number included in average.
    • +
  • 18: version nr of grib specification.
    • +
  • 19: version nr of parameter table.
    • +
  • 20: nr missing from average/accumulation.
    • +
  • 21: century of reference time of data.
    • +
  • 22: units decimal scale factor.
    • +
  • 23: subcenter number.
    • +
  • 24: pds byte 29, for nmc ensemble products.
      +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • Warning: can be combination of more than 1.
      • +
    +
    • +
  • 25: pds byte 30, not used.
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1: data representation type.
    • +
  • 19: number of vertical coordinate parameters.
    • +
  • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
    • +
  • 21: for grids with pl, number of points in grid.
    • +
  • 22: number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: dj latitudinal direction increment.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: n - nr of circles pole to equator.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: nv - nr of vert coord parameters.
      • +
    • 13: pv - octet nr of list of vert coord parameters or pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2: n(i) nr points along lat circle.
      • +
    • 3: n(j) nr points along lon circle.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: lov grid orientation.
      • +
    • 8: dx - x direction increment.
      • +
    • 9: dy - y direction increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2: j pentagonal resolution parameter.
      • +
    • 3: k pentagonal resolution parameter.
      • +
    • 4: m pentagonal resolution parameter.
      • +
    • 5: representation type.
      • +
    • 6: coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of last grid point.
      • +
    • 8: lo(2) longitude of last grid point.
      • +
    • 9: latit - latitude of projection intersection.
      • +
    • 10: reserved.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: longitudinal dir grid length.
      • +
    • 13: latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2: nx nr points along x-axis.
      • +
    • 3: ny nr points along y-axis.
      • +
    • 4: la1 lat of origin (lower left).
      • +
    • 5: lo1 lon of origin (lower left).
      • +
    • 6: resolution (right adj copy of octet 17).
      • +
    • 7: lov - orientation of grid.
      • +
    • 8: dx - x-dir increment.
      • +
    • 9: dy - y-dir increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: latin 1 - first lat from pole of secant cone inter.
      • +
    • 13: latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]jensinteger (200) ensemble pds parms for which to search (only searched if jpds(23)=2) (=-1 for wildcard).
    +
  • 1: application identifier.
    • +
  • 2: ensemble type.
    • +
  • 3: ensemble identifier.
    • +
  • 4: product identifier.
    • +
  • 5: smoothing flag.
    • +
+
[in]mbufinteger length of index buffer in bytes.
[in]nbitssinteger.
[in,out]cbufcharacter*1 (mbuf) index buffer (initialize by setting j=-1).
[in,out]nleninteger length of each index record in bytes (initialize by setting j=-1).
[in,out]nnuminteger number of index records (initialize by setting j=-1).
[in,out]mnuminteger number of index records skipped (initialize by setting j=-1).
[out]kfinteger number of data points unpacked.
[out]kinteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]kensinteger (200) unpacked ensemble pds parms.
[out]lblogical*1 (kf) unpacked bitmap if present.
[out]freal (kf) unpacked data.
[out]iretinteger return code.
    +
  • 0 all ok.
    • +
  • 96 error reading index file.
    • +
  • 97 error reading grib file.
    • +
  • 98 number of data points greater than jf.
    • +
  • 99 request not found.
    • +
  • other w3fi63 grib unpacker return code.
    • +
+
+
+
+
Note
Specify an index file if feasible to increase speed. Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 186 of file getgbemn.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbemn_8f.js b/ver-2.10.0/getgbemn_8f.js new file mode 100644 index 00000000..5d4255d1 --- /dev/null +++ b/ver-2.10.0/getgbemn_8f.js @@ -0,0 +1,4 @@ +var getgbemn_8f = +[ + [ "getgbemn", "getgbemn_8f.html#aa8900c58b55dacd248734fa3e97c1482", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbemn_8f_source.html b/ver-2.10.0/getgbemn_8f_source.html new file mode 100644 index 00000000..44637f95 --- /dev/null +++ b/ver-2.10.0/getgbemn_8f_source.html @@ -0,0 +1,356 @@ + + + + + + + +NCEPLIBS-w3emc: getgbemn.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbemn.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Finds and unpacks a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Find and unpack a grib message.
+
6 C> Read a grib index file (or optionally the grib file itself)
+
7 C> to get the index buffer (i.e. table of contents) for the grib file.
+
8 C> Find in the index buffer a reference to the grib message requested.
+
9 C> The grib message request specifies the number of messages to skip
+
10 C> and the unpacked pds and gds parameters. (A requested parameter
+
11 C> of -1 means to allow any value of this parameter to be found.)
+
12 C> If the requested grib message is found, then it is read from the
+
13 C> grib file and unpacked. Its message number is returned along with
+
14 C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
15 C> and the unpacked data. If the grib message is not found, then the
+
16 C> return code will be nonzero.
+
17 C>
+
18 C> Program history log:
+
19 C> - Mark Iredell 1994-04-01
+
20 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
21 C> and allowed for unspecified index file
+
22 C> - Chuang 2004-07-22 add packing bit number nbitss in the argument
+
23 C> list because eta grib files need it to repack grib file
+
24 C>
+
25 C> @param[in] lugb integer unit of the unblocked grib data file.
+
26 C> @param[in] lugi integer unit of the unblocked grib index file
+
27 C> (=0 to get index buffer from the grib file).
+
28 C> @param[in] jf integer maximum number of data points to unpack.
+
29 C> @param[in] j integer number of messages to skip
+
30 C> (=0 to search from beginning)
+
31 C> (<0 to read index buffer and skip -1-j messages).
+
32 C> @param[in] jpds integer (200) pds parameters for which to search
+
33 C> (=-1 for wildcard).
+
34 C> - 1: id of center.
+
35 C> - 2: generating process id number.
+
36 C> - 3: grid definition.
+
37 C> - 4: gds/bms flag (right adj copy of octet 8).
+
38 C> - 5: indicator of parameter.
+
39 C> - 6: type of level.
+
40 C> - 7: height/pressure , etc of level.
+
41 C> - 8: year including (century-1).
+
42 C> - 9: month of year.
+
43 C> - 10: day of month.
+
44 C> - 11: hour of day.
+
45 C> - 12: minute of hour.
+
46 C> - 13: indicator of forecast time unit.
+
47 C> - 14: time range 1.
+
48 C> - 15: time range 2.
+
49 C> - 16: time range flag.
+
50 C> - 17: number included in average.
+
51 C> - 18: version nr of grib specification.
+
52 C> - 19: version nr of parameter table.
+
53 C> - 20: nr missing from average/accumulation.
+
54 C> - 21: century of reference time of data.
+
55 C> - 22: units decimal scale factor.
+
56 C> - 23: subcenter number.
+
57 C> - 24: pds byte 29, for nmc ensemble products.
+
58 C> - 128 if forecast field error.
+
59 C> - 64 if bias corrected fcst field.
+
60 C> - 32 if smoothed field.
+
61 C> - Warning: can be combination of more than 1.
+
62 C> - 25: pds byte 30, not used.
+
63 C> @param[in] jgds integer (200) gds parameters for which to search
+
64 C> (only searched if jpds(3)=255)
+
65 C> (=-1 for wildcard).
+
66 C> - 1: data representation type.
+
67 C> - 19: number of vertical coordinate parameters.
+
68 C> - 20: octet number of the list of vertical coordinate parameters or
+
69 C> octet number of the list of numbers of points in each row or
+
70 C> 255 if neither are present.
+
71 C> - 21: for grids with pl, number of points in grid.
+
72 C> - 22: number of words in each row.
+
73 C> - Latitude/longitude grids.
+
74 C> - 2: n(i) nr points on latitude circle.
+
75 C> - 3: n(j) nr points on longitude meridian.
+
76 C> - 4: la(1) latitude of origin.
+
77 C> - 5: lo(1) longitude of origin.
+
78 C> - 6: resolution flag (right adj copy of octet 17).
+
79 C> - 7: la(2) latitude of extreme point.
+
80 C> - 8: lo(2) longitude of extreme point.
+
81 C> - 9: di longitudinal direction of increment.
+
82 C> - 10: dj latitudinal direction increment.
+
83 C> - 11: scanning mode flag (right adj copy of octet 28).
+
84 C> - Gaussian grids.
+
85 C> - 2: n(i) nr points on latitude circle.
+
86 C> - 3: n(j) nr points on longitude meridian.
+
87 C> - 4: la(1) latitude of origin.
+
88 C> - 5: lo(1) longitude of origin.
+
89 C> - 6: resolution flag (right adj copy of octet 17).
+
90 C> - 7: la(2) latitude of extreme point.
+
91 C> - 8: lo(2) longitude of extreme point.
+
92 C> - 9: di longitudinal direction of increment.
+
93 C> - 10: n - nr of circles pole to equator.
+
94 C> - 11: scanning mode flag (right adj copy of octet 28).
+
95 C> - 12: nv - nr of vert coord parameters.
+
96 C> - 13: pv - octet nr of list of vert coord parameters or
+
97 C> pl - location of the list of numbers of points in each row
+
98 C> (if no vert coord parameters are present) or 255 if neither are present
+
99 C> - Polar stereographic grids.
+
100 C> - 2: n(i) nr points along lat circle.
+
101 C> - 3: n(j) nr points along lon circle.
+
102 C> - 4: la(1) latitude of origin.
+
103 C> - 5: lo(1) longitude of origin.
+
104 C> - 6: resolution flag (right adj copy of octet 17).
+
105 C> - 7: lov grid orientation.
+
106 C> - 8: dx - x direction increment.
+
107 C> - 9: dy - y direction increment.
+
108 C> - 10: projection center flag.
+
109 C> - 11: scanning mode (right adj copy of octet 28).
+
110 C> - Spherical harmonic coefficients.
+
111 C> - 2: j pentagonal resolution parameter.
+
112 C> - 3: k pentagonal resolution parameter.
+
113 C> - 4: m pentagonal resolution parameter.
+
114 C> - 5: representation type.
+
115 C> - 6: coefficient storage mode.
+
116 C> - Mercator grids.
+
117 C> - 2: n(i) nr points on latitude circle.
+
118 C> - 3: n(j) nr points on longitude meridian.
+
119 C> - 4: la(1) latitude of origin.
+
120 C> - 5: lo(1) longitude of origin.
+
121 C> - 6: resolution flag (right adj copy of octet 17).
+
122 C> - 7: la(2) latitude of last grid point.
+
123 C> - 8: lo(2) longitude of last grid point.
+
124 C> - 9: latit - latitude of projection intersection.
+
125 C> - 10: reserved.
+
126 C> - 11: scanning mode flag (right adj copy of octet 28).
+
127 C> - 12: longitudinal dir grid length.
+
128 C> - 13: latitudinal dir grid length.
+
129 C> - Lambert conformal grids.
+
130 C> - 2: nx nr points along x-axis.
+
131 C> - 3: ny nr points along y-axis.
+
132 C> - 4: la1 lat of origin (lower left).
+
133 C> - 5: lo1 lon of origin (lower left).
+
134 C> - 6: resolution (right adj copy of octet 17).
+
135 C> - 7: lov - orientation of grid.
+
136 C> - 8: dx - x-dir increment.
+
137 C> - 9: dy - y-dir increment.
+
138 C> - 10: projection center flag.
+
139 C> - 11: scanning mode flag (right adj copy of octet 28).
+
140 C> - 12: latin 1 - first lat from pole of secant cone inter.
+
141 C> - 13: latin 2 - second lat from pole of secant cone inter.
+
142 C> @param[in] jens integer (200) ensemble pds parms for which to search
+
143 C> (only searched if jpds(23)=2)
+
144 C> (=-1 for wildcard).
+
145 C> - 1: application identifier.
+
146 C> - 2: ensemble type.
+
147 C> - 3: ensemble identifier.
+
148 C> - 4: product identifier.
+
149 C> - 5: smoothing flag.
+
150 C> @param[in] mbuf integer length of index buffer in bytes.
+
151 C> @param[in] nbitss integer.
+
152 C> @param[inout] cbuf character*1 (mbuf) index buffer
+
153 C> (initialize by setting j=-1).
+
154 C> @param[inout] nlen integer length of each index record in bytes
+
155 C> (initialize by setting j=-1).
+
156 C> @param[inout] nnum integer number of index records
+
157 C> (initialize by setting j=-1).
+
158 C> @param[inout] mnum integer number of index records skipped
+
159 C> (initialize by setting j=-1).
+
160 C> @param[out] kf integer number of data points unpacked.
+
161 C> @param[out] k integer message number unpacked
+
162 C> (can be same as j in calling program
+
163 C> in order to facilitate multiple searches).
+
164 C> @param[out] kpds integer (200) unpacked pds parameters.
+
165 C> @param[out] kgds integer (200) unpacked gds parameters.
+
166 C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
167 C> @param[out] lb logical*1 (kf) unpacked bitmap if present.
+
168 C> @param[out] f real (kf) unpacked data.
+
169 C> @param[out] iret integer return code.
+
170 C> - 0 all ok.
+
171 C> - 96 error reading index file.
+
172 C> - 97 error reading grib file.
+
173 C> - 98 number of data points greater than jf.
+
174 C> - 99 request not found.
+
175 C> - other w3fi63 grib unpacker return code.
+
176 C>
+
177 C> @note Specify an index file if feasible to increase speed.
+
178 C> Subprogram can be called from a multiprocessing environment.
+
179 C> Do not engage the same logical unit from more than one processor.
+
180 C>
+
181 C> @author Mark Iredell @date 1994-04-01
+
182 C-----------------------------------------------------------------------
+
183  SUBROUTINE getgbemn(LUGB,LUGI,JF,J,JPDS,JGDS,JENS,
+
184  & MBUF,CBUF,NLEN,NNUM,MNUM,
+
185  & KF,K,KPDS,KGDS,KENS,LB,F,NBITSS,IRET)
+
186  INTEGER JPDS(200),JGDS(200),JENS(200)
+
187  INTEGER KPDS(200),KGDS(200),KENS(200)
+
188  CHARACTER CBUF(MBUF)
+
189  LOGICAL*1 LB(JF)
+
190  REAL F(JF)
+
191  parameter(msk1=32000,msk2=4000)
+
192 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
193 C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE
+
194  IF(j.GE.0) THEN
+
195  IF(mnum.GE.0) THEN
+
196  irgi=0
+
197  ELSE
+
198  mnum=-1-mnum
+
199  irgi=1
+
200  ENDIF
+
201  jr=j-mnum
+
202  IF(jr.GE.0.AND.(jr.LT.nnum.OR.irgi.EQ.0)) THEN
+
203  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
204  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
205  IF(irgs.EQ.0) k=kr+mnum
+
206  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
207  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
208  ELSE
+
209  mnum=j
+
210  irgi=1
+
211  irgs=1
+
212  ENDIF
+
213  ELSE
+
214  mnum=-1-j
+
215  irgi=1
+
216  irgs=1
+
217  ENDIF
+
218 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
219 C READ AND SEARCH NEXT INDEX BUFFER
+
220  jr=0
+
221  dowhile(irgi.EQ.1.AND.irgs.EQ.1)
+
222  IF(lugi.GT.0) THEN
+
223  CALL getgi(lugi,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
224  ELSE
+
225  CALL getgir(lugb,msk1,msk2,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
226  ENDIF
+
227  IF(irgi.LE.1) THEN
+
228  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
229  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
230  IF(irgs.EQ.0) k=kr+mnum
+
231  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
232  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
233  ENDIF
+
234  ENDDO
+
235 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
236 C READ AND UNPACK GRIB RECORD
+
237  IF(irgi.GT.1) THEN
+
238  iret=96
+
239  ELSEIF(irgs.NE.0) THEN
+
240  iret=99
+
241  ELSEIF(lengds(kgds).GT.jf) THEN
+
242  iret=98
+
243  ELSE
+
244  CALL getgb1r(lugb,lskip,lgrib,kf,kpds,kgds,kens,lb,f,nbitss
+
245  + ,iret)
+
246  ENDIF
+
247 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
248  RETURN
+
249  END
+
+
+
getgb1r
subroutine getgb1r(LUGB, LSKIP, LGRIB, KF, KPDS, KGDS, KENS, LB, F, NBITSS, IRET)
Program history log:
Definition: getgb1r.f:34
+
getgir
subroutine getgir(LUGB, MSK1, MSK2, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib file and return its index contents.
Definition: getgir.f:45
+
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
+
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+
getgb1s
subroutine getgb1s(CBUF, NLEN, NNUM, J, JPDS, JGDS, JENS, K, KPDS, KGDS, KENS, LSKIP, LGRIB, IRET)
Find a grib message.
Definition: getgb1s.f:44
+
getgbemn
subroutine getgbemn(LUGB, LUGI, JF, J, JPDS, JGDS, JENS, MBUF, CBUF, NLEN, NNUM, MNUM, KF, K, KPDS, KGDS, KENS, LB, F, NBITSS, IRET)
Find and unpack a grib message.
Definition: getgbemn.f:186
+ + + + diff --git a/ver-2.10.0/getgbemp_8f.html b/ver-2.10.0/getgbemp_8f.html new file mode 100644 index 00000000..9a68f45e --- /dev/null +++ b/ver-2.10.0/getgbemp_8f.html @@ -0,0 +1,425 @@ + + + + + + + +NCEPLIBS-w3emc: getgbemp.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbemp.f File Reference
+
+
+ +

Find a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbemp (LUGB, LUGI, JG, J, JPDS, JGDS, JENS, MBUF, CBUF, NLEN, NNUM, MNUM, KG, K, KPDS, KGDS, KENS, G, IRET)
 Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. More...
 
+

Detailed Description

+

Find a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbemp.f.

+

Function/Subroutine Documentation

+ +

◆ getgbemp()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbemp ( LUGB,
 LUGI,
 JG,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
integer, dimension(200) JENS,
 MBUF,
character, dimension(mbuf) CBUF,
 NLEN,
 NNUM,
 MNUM,
 KG,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
character, dimension(jg) G,
 IRET 
)
+
+ +

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e.

+

table of contents) for the grib file. Find in the index buffer a reference to the grib message requested. the grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file. Its message number is returned along with the unpacked pds and gds parameters and the packed grib message. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
+
Parameters
+ + + + + + + + + + + + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib data file.
[in]lugiinteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jginteger maximum number of bytes in the grib message.
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages).
[in]jpdsinteger (200) pds parameters for which to search (=-1 for wildcard).
    +
  • 1: id of center.
    • +
  • 2: generating process id number.
    • +
  • 3: grid definition.
    • +
  • 4: gds/bms flag (right adj copy of octet 8).
    • +
  • 5: indicator of parameter.
    • +
  • 6: type of level.
    • +
  • 7: height/pressure , etc of level.
    • +
  • 8: year including (century-1).
    • +
  • 9: month of year.
    • +
  • 10: day of month.
    • +
  • 11: hour of day.
    • +
  • 12: minute of hour.
    • +
  • 13: indicator of forecast time unit.
    • +
  • 14: time range 1.
    • +
  • 15: time range 2.
    • +
  • 16: time range flag.
    • +
  • 17: number included in average.
    • +
  • 18: version nr of grib specification.
    • +
  • 19: version nr of parameter table.
    • +
  • 20: nr missing from average/accumulation.
    • +
  • 21: century of reference time of data.
    • +
  • 22: units decimal scale factor.
    • +
  • 23: subcenter number.
    • +
  • 24: pds byte 29, for nmc ensemble products.
      +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    +
    • +
  • 25: pds byte 30, not used.
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1: data representation type.
    • +
  • 19: number of vertical coordinate parameters.
    • +
  • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
    • +
  • 21: for grids with pl, number of points in grid.
    • +
  • 22: number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: dj latitudinal direction increment.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: n - nr of circles pole to equator.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: nv - nr of vert coord parameters.
      • +
    • 13: pv - octet nr of list of vert coord parameters or.
        +
      • pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or
        • +
      • 255 if neither are present.
        • +
      +
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2: n(i) nr points along lat circle.
      • +
    • 3: n(j) nr points along lon circle.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: lov grid orientation.
      • +
    • 8: dx - x direction increment.
      • +
    • 9: dy - y direction increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2: j pentagonal resolution parameter.
      • +
    • 3: k pentagonal resolution parameter.
      • +
    • 4: m pentagonal resolution parameter.
      • +
    • 5: representation type.
      • +
    • 6: coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of last grid point.
      • +
    • 8: lo(2) longitude of last grid point.
      • +
    • 9: latit - latitude of projection intersection.
      • +
    • 10: reserved.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: longitudinal dir grid length.
      • +
    • 13: latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2: nx nr points along x-axis.
      • +
    • 3: ny nr points along y-axis.
      • +
    • 4: la1 lat of origin (lower left).
      • +
    • 5: lo1 lon of origin (lower left).
      • +
    • 6: resolution (right adj copy of octet 17).
      • +
    • 7: lov - orientation of grid.
      • +
    • 8: dx - x-dir increment.
      • +
    • 9: dy - y-dir increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: latin 1 - first lat from pole of secant cone inter.
      • +
    • 13: latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]jensinteger (200) ensemble pds parms for which to search (only searched if jpds(23)=2) (=-1 for wildcard).
    +
  • 1: application identifier.
    • +
  • 2: ensemble type.
    • +
  • 3: ensemble identifier.
    • +
  • 4: product identifier.
    • +
  • 5: smoothing flag.
    • +
+
[in]mbufinteger length of index buffer in bytes.
[in,out]cbufcharacter*1 (mbuf) index buffer (initialize by setting j=-1).
[in,out]nleninteger length of each index record in bytes (initialize by setting j=-1).
[in,out]nnuminteger number of index records (initialize by setting j=-1).
[in,out]mnuminteger number of index records skipped (initialize by setting j=-1).
[out]kginteger number of bytes in the grib message.
[out]kinteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]kensinteger (200) unpacked ensemble pds parms.
[out]gcharacter*1 (kg) grib message.
[out]iretinteger return code.
    +
  • 0: all ok.
    • +
  • 96: error reading index file.
    • +
  • 97: error reading grib file.
    • +
  • 98: number of bytes greater than jg.
    • +
  • 99: request not found.
    • +
+
+
+
+
Note
Specify an index file if feasible to increase speed. Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 180 of file getgbemp.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbemp_8f.js b/ver-2.10.0/getgbemp_8f.js new file mode 100644 index 00000000..b763637c --- /dev/null +++ b/ver-2.10.0/getgbemp_8f.js @@ -0,0 +1,4 @@ +var getgbemp_8f = +[ + [ "getgbemp", "getgbemp_8f.html#a3703b88e4d6f0e0dc3a8643d7662137c", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbemp_8f_source.html b/ver-2.10.0/getgbemp_8f_source.html new file mode 100644 index 00000000..ff89047a --- /dev/null +++ b/ver-2.10.0/getgbemp_8f_source.html @@ -0,0 +1,348 @@ + + + + + + + +NCEPLIBS-w3emc: getgbemp.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbemp.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Read a grib index file (or optionally the grib file itself)
+
6 C> to get the index buffer (i.e. table of contents) for the grib file.
+
7 C> Find in the index buffer a reference to the grib message requested.
+
8 C> the grib message request specifies the number of messages to skip
+
9 C> and the unpacked pds and gds parameters. (A requested parameter
+
10 C> of -1 means to allow any value of this parameter to be found.)
+
11 C> If the requested grib message is found, then it is read from the
+
12 C> grib file. Its message number is returned along with the unpacked
+
13 C> pds and gds parameters and the packed grib message. If the grib
+
14 C> message is not found, then the return code will be nonzero.
+
15 C>
+
16 C> Program history log:
+
17 C> - Mark Iredell 1994-04-01
+
18 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
19 C> and allowed for unspecified index file.
+
20 C>
+
21 C> @param[in] lugb integer unit of the unblocked grib data file.
+
22 C> @param[in] lugi integer unit of the unblocked grib index file
+
23 C> (=0 to get index buffer from the grib file).
+
24 C> @param[in] jg integer maximum number of bytes in the grib message.
+
25 C> @param[in] j integer number of messages to skip
+
26 C> (=0 to search from beginning)
+
27 C> (<0 to read index buffer and skip -1-j messages).
+
28 C> @param[in] jpds integer (200) pds parameters for which to search
+
29 C> (=-1 for wildcard).
+
30 C> - 1: id of center.
+
31 C> - 2: generating process id number.
+
32 C> - 3: grid definition.
+
33 C> - 4: gds/bms flag (right adj copy of octet 8).
+
34 C> - 5: indicator of parameter.
+
35 C> - 6: type of level.
+
36 C> - 7: height/pressure , etc of level.
+
37 C> - 8: year including (century-1).
+
38 C> - 9: month of year.
+
39 C> - 10: day of month.
+
40 C> - 11: hour of day.
+
41 C> - 12: minute of hour.
+
42 C> - 13: indicator of forecast time unit.
+
43 C> - 14: time range 1.
+
44 C> - 15: time range 2.
+
45 C> - 16: time range flag.
+
46 C> - 17: number included in average.
+
47 C> - 18: version nr of grib specification.
+
48 C> - 19: version nr of parameter table.
+
49 C> - 20: nr missing from average/accumulation.
+
50 C> - 21: century of reference time of data.
+
51 C> - 22: units decimal scale factor.
+
52 C> - 23: subcenter number.
+
53 C> - 24: pds byte 29, for nmc ensemble products.
+
54 C> - 128 if forecast field error.
+
55 C> - 64 if bias corrected fcst field.
+
56 C> - 32 if smoothed field.
+
57 C> - warning: can be combination of more than 1.
+
58 C> - 25: pds byte 30, not used.
+
59 C> @param[in] jgds integer (200) gds parameters for which to search
+
60 C> (only searched if jpds(3)=255)
+
61 C> (=-1 for wildcard).
+
62 C> - 1: data representation type.
+
63 C> - 19: number of vertical coordinate parameters.
+
64 C> - 20: octet number of the list of vertical coordinate parameters or
+
65 C> octet number of the list of numbers of points in each row or
+
66 C> 255 if neither are present.
+
67 C> - 21: for grids with pl, number of points in grid.
+
68 C> - 22: number of words in each row.
+
69 C> - Latitude/longitude grids.
+
70 C> - 2: n(i) nr points on latitude circle.
+
71 C> - 3: n(j) nr points on longitude meridian.
+
72 C> - 4: la(1) latitude of origin.
+
73 C> - 5: lo(1) longitude of origin.
+
74 C> - 6: resolution flag (right adj copy of octet 17).
+
75 C> - 7: la(2) latitude of extreme point.
+
76 C> - 8: lo(2) longitude of extreme point.
+
77 C> - 9: di longitudinal direction of increment.
+
78 C> - 10: dj latitudinal direction increment.
+
79 C> - 11: scanning mode flag (right adj copy of octet 28).
+
80 C> - Gaussian grids.
+
81 C> - 2: n(i) nr points on latitude circle.
+
82 C> - 3: n(j) nr points on longitude meridian.
+
83 C> - 4: la(1) latitude of origin.
+
84 C> - 5: lo(1) longitude of origin.
+
85 C> - 6: resolution flag (right adj copy of octet 17).
+
86 C> - 7: la(2) latitude of extreme point.
+
87 C> - 8: lo(2) longitude of extreme point.
+
88 C> - 9: di longitudinal direction of increment.
+
89 C> - 10: n - nr of circles pole to equator.
+
90 C> - 11: scanning mode flag (right adj copy of octet 28).
+
91 C> - 12: nv - nr of vert coord parameters.
+
92 C> - 13: pv - octet nr of list of vert coord parameters or.
+
93 C> - pl - location of the list of numbers of points in each row
+
94 C> (if no vert coord parameters are present) or
+
95 C> - 255 if neither are present.
+
96 C> - Polar stereographic grids.
+
97 C> - 2: n(i) nr points along lat circle.
+
98 C> - 3: n(j) nr points along lon circle.
+
99 C> - 4: la(1) latitude of origin.
+
100 C> - 5: lo(1) longitude of origin.
+
101 C> - 6: resolution flag (right adj copy of octet 17).
+
102 C> - 7: lov grid orientation.
+
103 C> - 8: dx - x direction increment.
+
104 C> - 9: dy - y direction increment.
+
105 C> - 10: projection center flag.
+
106 C> - 11: scanning mode (right adj copy of octet 28).
+
107 C> - Spherical harmonic coefficients.
+
108 C> - 2: j pentagonal resolution parameter.
+
109 C> - 3: k pentagonal resolution parameter.
+
110 C> - 4: m pentagonal resolution parameter.
+
111 C> - 5: representation type.
+
112 C> - 6: coefficient storage mode.
+
113 C> - Mercator grids.
+
114 C> - 2: n(i) nr points on latitude circle.
+
115 C> - 3: n(j) nr points on longitude meridian.
+
116 C> - 4: la(1) latitude of origin.
+
117 C> - 5: lo(1) longitude of origin.
+
118 C> - 6: resolution flag (right adj copy of octet 17).
+
119 C> - 7: la(2) latitude of last grid point.
+
120 C> - 8: lo(2) longitude of last grid point.
+
121 C> - 9: latit - latitude of projection intersection.
+
122 C> - 10: reserved.
+
123 C> - 11: scanning mode flag (right adj copy of octet 28).
+
124 C> - 12: longitudinal dir grid length.
+
125 C> - 13: latitudinal dir grid length.
+
126 C> - Lambert conformal grids.
+
127 C> - 2: nx nr points along x-axis.
+
128 C> - 3: ny nr points along y-axis.
+
129 C> - 4: la1 lat of origin (lower left).
+
130 C> - 5: lo1 lon of origin (lower left).
+
131 C> - 6: resolution (right adj copy of octet 17).
+
132 C> - 7: lov - orientation of grid.
+
133 C> - 8: dx - x-dir increment.
+
134 C> - 9: dy - y-dir increment.
+
135 C> - 10: projection center flag.
+
136 C> - 11: scanning mode flag (right adj copy of octet 28).
+
137 C> - 12: latin 1 - first lat from pole of secant cone inter.
+
138 C> - 13: latin 2 - second lat from pole of secant cone inter.
+
139 C> @param[in] jens integer (200) ensemble pds parms for which to search
+
140 C> (only searched if jpds(23)=2)
+
141 C> (=-1 for wildcard).
+
142 C> - 1: application identifier.
+
143 C> - 2: ensemble type.
+
144 C> - 3: ensemble identifier.
+
145 C> - 4: product identifier.
+
146 C> - 5: smoothing flag.
+
147 C> @param[in] mbuf integer length of index buffer in bytes.
+
148 C> @param[inout] cbuf character*1 (mbuf) index buffer
+
149 C> (initialize by setting j=-1).
+
150 C> @param[inout] nlen integer length of each index record in bytes
+
151 C> (initialize by setting j=-1).
+
152 C> @param[inout] nnum integer number of index records
+
153 C> (initialize by setting j=-1).
+
154 C> @param[inout] mnum integer number of index records skipped
+
155 C> (initialize by setting j=-1).
+
156 C> @param[out] kg integer number of bytes in the grib message.
+
157 C> @param[out] k integer message number unpacked
+
158 C> (can be same as j in calling program
+
159 C> in order to facilitate multiple searches).
+
160 C> @param[out] kpds integer (200) unpacked pds parameters.
+
161 C> @param[out] kgds integer (200) unpacked gds parameters.
+
162 C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
163 C> @param[out] g character*1 (kg) grib message.
+
164 C> @param[out] iret integer return code.
+
165 C> - 0: all ok.
+
166 C> - 96: error reading index file.
+
167 C> - 97: error reading grib file.
+
168 C> - 98: number of bytes greater than jg.
+
169 C> - 99: request not found.
+
170 C>
+
171 C> @note Specify an index file if feasible to increase speed.
+
172 C> Subprogram can be called from a multiprocessing environment.
+
173 C> Do not engage the same logical unit from more than one processor.
+
174 C>
+
175 C> @author Mark Iredell @date 1994-04-01
+
176 C-----------------------------------------------------------------------
+
177  SUBROUTINE getgbemp(LUGB,LUGI,JG,J,JPDS,JGDS,JENS,
+
178  & MBUF,CBUF,NLEN,NNUM,MNUM,
+
179  & KG,K,KPDS,KGDS,KENS,G,IRET)
+
180  INTEGER JPDS(200),JGDS(200),JENS(200)
+
181  INTEGER KPDS(200),KGDS(200),KENS(200)
+
182  CHARACTER CBUF(MBUF)
+
183  CHARACTER G(JG)
+
184  parameter(msk1=32000,msk2=4000)
+
185 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
186 C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE
+
187  IF(j.GE.0) THEN
+
188  IF(mnum.GE.0) THEN
+
189  irgi=0
+
190  ELSE
+
191  mnum=-1-mnum
+
192  irgi=1
+
193  ENDIF
+
194  jr=j-mnum
+
195  IF(jr.GE.0.AND.(jr.LT.nnum.OR.irgi.EQ.0)) THEN
+
196  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
197  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
198  IF(irgs.EQ.0) k=kr+mnum
+
199  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
200  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
201  ELSE
+
202  mnum=j
+
203  irgi=1
+
204  irgs=1
+
205  ENDIF
+
206  ELSE
+
207  mnum=-1-j
+
208  irgi=1
+
209  irgs=1
+
210  ENDIF
+
211 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
212 C READ AND SEARCH NEXT INDEX BUFFER
+
213  jr=0
+
214  dowhile(irgi.EQ.1.AND.irgs.EQ.1)
+
215  IF(lugi.GT.0) THEN
+
216  CALL getgi(lugi,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
217  ELSE
+
218  CALL getgir(lugb,msk1,msk2,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
219  ENDIF
+
220  IF(irgi.LE.1) THEN
+
221  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
222  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
223  IF(irgs.EQ.0) k=kr+mnum
+
224  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
225  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
226  ENDIF
+
227  ENDDO
+
228 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
229 C READ GRIB RECORD
+
230  IF(irgi.GT.1) THEN
+
231  iret=96
+
232  ELSEIF(irgs.NE.0) THEN
+
233  iret=99
+
234  ELSEIF(lgrib.GT.jg) THEN
+
235  iret=98
+
236  ELSE
+
237  iret=97
+
238  CALL baread(lugb,lskip,lgrib,kg,g)
+
239  IF(kg.EQ.lgrib) iret=0
+
240  ENDIF
+
241 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
242  RETURN
+
243  END
+
+
+
getgir
subroutine getgir(LUGB, MSK1, MSK2, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib file and return its index contents.
Definition: getgir.f:45
+
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
+
getgb1s
subroutine getgb1s(CBUF, NLEN, NNUM, J, JPDS, JGDS, JENS, K, KPDS, KGDS, KENS, LSKIP, LGRIB, IRET)
Find a grib message.
Definition: getgb1s.f:44
+
getgbemp
subroutine getgbemp(LUGB, LUGI, JG, J, JPDS, JGDS, JENS, MBUF, CBUF, NLEN, NNUM, MNUM, KG, K, KPDS, KGDS, KENS, G, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbemp.f:180
+ + + + diff --git a/ver-2.10.0/getgbens_8f.html b/ver-2.10.0/getgbens_8f.html new file mode 100644 index 00000000..403a62a6 --- /dev/null +++ b/ver-2.10.0/getgbens_8f.html @@ -0,0 +1,397 @@ + + + + + + + +NCEPLIBS-w3emc: getgbens.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbens.f File Reference
+
+
+ +

Find and unpack a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbens (LUGB, LUGI, JF, J, JPDS, JGDS, JENS, KF, K, KPDS, KGDS, KENS, LB, F, IRET)
 Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. More...
 
+

Detailed Description

+

Find and unpack a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbens.f.

+

Function/Subroutine Documentation

+ +

◆ getgbens()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbens ( LUGB,
 LUGI,
 JF,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
integer, dimension(200) JENS,
 KF,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
logical*1, dimension(jf) LB,
real, dimension(jf) F,
 IRET 
)
+
+ +

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e.

+

table of contents) for the grib file. (The index buffer is saved for use by future prospective calls.) Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file and unpacked. Its message number is returned along with the unpacked pds and gds parameters, the unpacked bitmap (if any), and the unpacked data. If the grib message is not found, then the return code will be nonzero. This obsolescent version has been replaced by getgbe.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
+
Parameters
+ + + + + + + + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib data file.
[in]lugiinteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jfinteger maximum number of data points to unpack.
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages).
[in]jpdsinteger (200) pds parameters for which to search (=-1 for wildcard).
    +
  • 1: id of center.
    • +
  • 2: generating process id number.
    • +
  • 3: grid definition.
    • +
  • 4: gds/bms flag (right adj copy of octet 8).
    • +
  • 5: indicator of parameter.
    • +
  • 6: type of level.
    • +
  • 7: height/pressure , etc of level.
    • +
  • 8: year including (century-1).
    • +
  • 9: month of year.
    • +
  • 10: day of month.
    • +
  • 11: hour of day.
    • +
  • 12: minute of hour.
    • +
  • 13: indicator of forecast time unit.
    • +
  • 14: time range 1.
    • +
  • 15: time range 2.
    • +
  • 16: time range flag.
    • +
  • 17: number included in average.
    • +
  • 18: version nr of grib specification.
    • +
  • 19: version nr of parameter table.
    • +
  • 20: nr missing from average/accumulation.
    • +
  • 21: century of reference time of data.
    • +
  • 22: units decimal scale factor.
    • +
  • 23: subcenter number.
    • +
  • 24: pds byte 29, for nmc ensemble products.
      +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    +
    • +
  • 25: pds byte 30, not used.
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1: data representation type.
    • +
  • 19: number of vertical coordinate parameters.
    • +
  • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
    • +
  • 21: for grids with pl, number of points in grid.
    • +
  • 22: number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: dj latitudinal direction increment.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: n - nr of circles pole to equator.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: nv - nr of vert coord parameters.
      • +
    • 13: pv - octet nr of list of vert coord parameters or
        +
      • pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present.
        • +
      +
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2: n(i) nr points along lat circle.
      • +
    • 3: n(j) nr points along lon circle.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: lov grid orientation.
      • +
    • 8: dx - x direction increment.
      • +
    • 9: dy - y direction increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2: j pentagonal resolution parameter.
      • +
    • 3: k pentagonal resolution parameter.
      • +
    • 4: m pentagonal resolution parameter.
      • +
    • 5: representation type.
      • +
    • 6: coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of last grid point.
      • +
    • 8: lo(2) longitude of last grid point.
      • +
    • 9: latit - latitude of projection intersection.
      • +
    • 10: reserved.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: longitudinal dir grid length.
      • +
    • 13: latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2: nx nr points along x-axis.
      • +
    • 3: ny nr points along y-axis.
      • +
    • 4: la1 lat of origin (lower left).
      • +
    • 5: lo1 lon of origin (lower left).
      • +
    • 6: resolution (right adj copy of octet 17).
      • +
    • 7: lov - orientation of grid.
      • +
    • 8: dx - x-dir increment.
      • +
    • 9: dy - y-dir increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: latin 1 - first lat from pole of secant cone inter.
      • +
    • 13: latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]jensinteger (200) ensemble pds parms for which to search (only searched if jpds(23)=2) (=-1 for wildcard).
    +
  • 1: application identifier.
    • +
  • 2: ensemble type.
    • +
  • 3: ensemble identifier.
    • +
  • 4: product identifier.
    • +
  • 5: smoothing flag.
    • +
+
[out]kfinteger number of data points unpacked.
[out]kinteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]kensinteger (200) unpacked ensemble pds parms.
[out]lblogical*1 (kf) unpacked bitmap if present.
[out]freal (kf) unpacked data.
[out]iretinteger return code.
    +
  • 0: all ok.
    • +
  • 96: error reading index file.
    • +
  • 97: error reading grib file.
    • +
  • 98: number of data points greater than jf.
    • +
  • 99: request not found.
    • +
  • other w3fi63 grib unpacker return code.
    • +
+
+
+
+
Note
In order to unpack grib from a multiprocessing environment where each processor is attempting to read from its own pair of logical units, one must directly call subprogram getgbem as below, allocating a private copy of cbuf, nlen and nnum to each processor. do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 177 of file getgbens.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbens_8f.js b/ver-2.10.0/getgbens_8f.js new file mode 100644 index 00000000..80117d1f --- /dev/null +++ b/ver-2.10.0/getgbens_8f.js @@ -0,0 +1,4 @@ +var getgbens_8f = +[ + [ "getgbens", "getgbens_8f.html#a0ab50ed386ca101b034a86b960de28b4", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbens_8f_source.html b/ver-2.10.0/getgbens_8f_source.html new file mode 100644 index 00000000..eefa3c6f --- /dev/null +++ b/ver-2.10.0/getgbens_8f_source.html @@ -0,0 +1,290 @@ + + + + + + + +NCEPLIBS-w3emc: getgbens.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbens.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find and unpack a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Read a grib index file (or optionally the grib file itself)
+
6 C> to get the index buffer (i.e. table of contents) for the grib file.
+
7 C> (The index buffer is saved for use by future prospective calls.)
+
8 C> Find in the index buffer a reference to the grib message requested.
+
9 C> The grib message request specifies the number of messages to skip
+
10 C> and the unpacked pds and gds parameters. (A requested parameter
+
11 C> of -1 means to allow any value of this parameter to be found.)
+
12 C> If the requested grib message is found, then it is read from the
+
13 C> grib file and unpacked. Its message number is returned along with
+
14 C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
15 C> and the unpacked data. If the grib message is not found, then the
+
16 C> return code will be nonzero.
+
17 C> This obsolescent version has been replaced by getgbe.
+
18 C>
+
19 C> Program history log:
+
20 C> - Mark Iredell 1994-04-01
+
21 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
22 C> and allowed for unspecified index file.
+
23 C>
+
24 C> @param[in] lugb integer unit of the unblocked grib data file.
+
25 C> @param[in] lugi integer unit of the unblocked grib index file
+
26 C> (=0 to get index buffer from the grib file).
+
27 C> @param[in] jf integer maximum number of data points to unpack.
+
28 C> @param[in] j integer number of messages to skip
+
29 C> (=0 to search from beginning)
+
30 C> (<0 to read index buffer and skip -1-j messages).
+
31 C> @param[in] jpds integer (200) pds parameters for which to search
+
32 C> (=-1 for wildcard).
+
33 C> - 1: id of center.
+
34 C> - 2: generating process id number.
+
35 C> - 3: grid definition.
+
36 C> - 4: gds/bms flag (right adj copy of octet 8).
+
37 C> - 5: indicator of parameter.
+
38 C> - 6: type of level.
+
39 C> - 7: height/pressure , etc of level.
+
40 C> - 8: year including (century-1).
+
41 C> - 9: month of year.
+
42 C> - 10: day of month.
+
43 C> - 11: hour of day.
+
44 C> - 12: minute of hour.
+
45 C> - 13: indicator of forecast time unit.
+
46 C> - 14: time range 1.
+
47 C> - 15: time range 2.
+
48 C> - 16: time range flag.
+
49 C> - 17: number included in average.
+
50 C> - 18: version nr of grib specification.
+
51 C> - 19: version nr of parameter table.
+
52 C> - 20: nr missing from average/accumulation.
+
53 C> - 21: century of reference time of data.
+
54 C> - 22: units decimal scale factor.
+
55 C> - 23: subcenter number.
+
56 C> - 24: pds byte 29, for nmc ensemble products.
+
57 C> - 128 if forecast field error.
+
58 C> - 64 if bias corrected fcst field.
+
59 C> - 32 if smoothed field.
+
60 C> - warning: can be combination of more than 1.
+
61 C> - 25: pds byte 30, not used.
+
62 C> @param[in] jgds integer (200) gds parameters for which to search
+
63 C> (only searched if jpds(3)=255)
+
64 C> (=-1 for wildcard).
+
65 C> - 1: data representation type.
+
66 C> - 19: number of vertical coordinate parameters.
+
67 C> - 20: octet number of the list of vertical coordinate parameters or
+
68 C> octet number of the list of numbers of points in each row or
+
69 C> 255 if neither are present.
+
70 C> - 21: for grids with pl, number of points in grid.
+
71 C> - 22: number of words in each row.
+
72 C> - Latitude/longitude grids.
+
73 C> - 2: n(i) nr points on latitude circle.
+
74 C> - 3: n(j) nr points on longitude meridian.
+
75 C> - 4: la(1) latitude of origin.
+
76 C> - 5: lo(1) longitude of origin.
+
77 C> - 6: resolution flag (right adj copy of octet 17).
+
78 C> - 7: la(2) latitude of extreme point.
+
79 C> - 8: lo(2) longitude of extreme point.
+
80 C> - 9: di longitudinal direction of increment.
+
81 C> - 10: dj latitudinal direction increment.
+
82 C> - 11: scanning mode flag (right adj copy of octet 28).
+
83 C> - Gaussian grids.
+
84 C> - 2: n(i) nr points on latitude circle.
+
85 C> - 3: n(j) nr points on longitude meridian.
+
86 C> - 4: la(1) latitude of origin.
+
87 C> - 5: lo(1) longitude of origin.
+
88 C> - 6: resolution flag (right adj copy of octet 17).
+
89 C> - 7: la(2) latitude of extreme point.
+
90 C> - 8: lo(2) longitude of extreme point.
+
91 C> - 9: di longitudinal direction of increment.
+
92 C> - 10: n - nr of circles pole to equator.
+
93 C> - 11: scanning mode flag (right adj copy of octet 28).
+
94 C> - 12: nv - nr of vert coord parameters.
+
95 C> - 13: pv - octet nr of list of vert coord parameters or
+
96 C> - pl - location of the list of numbers of points in each row
+
97 C> (if no vert coord parameters are present) or 255 if neither are present.
+
98 C> - Polar stereographic grids.
+
99 C> - 2: n(i) nr points along lat circle.
+
100 C> - 3: n(j) nr points along lon circle.
+
101 C> - 4: la(1) latitude of origin.
+
102 C> - 5: lo(1) longitude of origin.
+
103 C> - 6: resolution flag (right adj copy of octet 17).
+
104 C> - 7: lov grid orientation.
+
105 C> - 8: dx - x direction increment.
+
106 C> - 9: dy - y direction increment.
+
107 C> - 10: projection center flag.
+
108 C> - 11: scanning mode (right adj copy of octet 28).
+
109 C> - Spherical harmonic coefficients.
+
110 C> - 2: j pentagonal resolution parameter.
+
111 C> - 3: k pentagonal resolution parameter.
+
112 C> - 4: m pentagonal resolution parameter.
+
113 C> - 5: representation type.
+
114 C> - 6: coefficient storage mode.
+
115 C> - Mercator grids.
+
116 C> - 2: n(i) nr points on latitude circle.
+
117 C> - 3: n(j) nr points on longitude meridian.
+
118 C> - 4: la(1) latitude of origin.
+
119 C> - 5: lo(1) longitude of origin.
+
120 C> - 6: resolution flag (right adj copy of octet 17).
+
121 C> - 7: la(2) latitude of last grid point.
+
122 C> - 8: lo(2) longitude of last grid point.
+
123 C> - 9: latit - latitude of projection intersection.
+
124 C> - 10: reserved.
+
125 C> - 11: scanning mode flag (right adj copy of octet 28).
+
126 C> - 12: longitudinal dir grid length.
+
127 C> - 13: latitudinal dir grid length.
+
128 C> - Lambert conformal grids.
+
129 C> - 2: nx nr points along x-axis.
+
130 C> - 3: ny nr points along y-axis.
+
131 C> - 4: la1 lat of origin (lower left).
+
132 C> - 5: lo1 lon of origin (lower left).
+
133 C> - 6: resolution (right adj copy of octet 17).
+
134 C> - 7: lov - orientation of grid.
+
135 C> - 8: dx - x-dir increment.
+
136 C> - 9: dy - y-dir increment.
+
137 C> - 10: projection center flag.
+
138 C> - 11: scanning mode flag (right adj copy of octet 28).
+
139 C> - 12: latin 1 - first lat from pole of secant cone inter.
+
140 C> - 13: latin 2 - second lat from pole of secant cone inter.
+
141 C> @param[in] jens integer (200) ensemble pds parms for which to search
+
142 C> (only searched if jpds(23)=2)
+
143 C> (=-1 for wildcard).
+
144 C> - 1: application identifier.
+
145 C> - 2: ensemble type.
+
146 C> - 3: ensemble identifier.
+
147 C> - 4: product identifier.
+
148 C> - 5: smoothing flag.
+
149 C>
+
150 C> @param[out] kf integer number of data points unpacked.
+
151 C> @param[out] k integer message number unpacked
+
152 C> (can be same as j in calling program
+
153 C> in order to facilitate multiple searches).
+
154 C> @param[out] kpds integer (200) unpacked pds parameters.
+
155 C> @param[out] kgds integer (200) unpacked gds parameters.
+
156 C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
157 C> @param[out] lb logical*1 (kf) unpacked bitmap if present.
+
158 C> @param[out] f real (kf) unpacked data.
+
159 C> @param[out] iret integer return code.
+
160 C> - 0: all ok.
+
161 C> - 96: error reading index file.
+
162 C> - 97: error reading grib file.
+
163 C> - 98: number of data points greater than jf.
+
164 C> - 99: request not found.
+
165 C> - other w3fi63 grib unpacker return code.
+
166 C>
+
167 C> @note In order to unpack grib from a multiprocessing environment
+
168 C> where each processor is attempting to read from its own pair of
+
169 C> logical units, one must directly call subprogram getgbem as below,
+
170 C> allocating a private copy of cbuf, nlen and nnum to each processor.
+
171 C> do not engage the same logical unit from more than one processor.
+
172 C>
+
173 C> @author Mark Iredell @date 1994-04-01
+
174 C-----------------------------------------------------------------------
+
175  SUBROUTINE getgbens(LUGB,LUGI,JF,J,JPDS,JGDS,JENS,
+
176  & KF,K,KPDS,KGDS,KENS,LB,F,IRET)
+
177  INTEGER JPDS(200),JGDS(200),JENS(200)
+
178  INTEGER KPDS(200),KGDS(200),KENS(200)
+
179  LOGICAL*1 LB(JF)
+
180  REAL F(JF)
+
181 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
182  print *,'PLEASE USE GETGBE RATHER THAN GETGBENS'
+
183  CALL getgbe(lugb,lugi,jf,j,jpds,jgds,jens,
+
184  & kf,k,kpds,kgds,kens,lb,f,iret)
+
185 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
186  RETURN
+
187  END
+
+
+
getgbe
subroutine getgbe(LUGB, LUGI, JF, J, JPDS, JGDS, JENS, KF, K, KPDS, KGDS, KENS, LB, F, IRET)
Find and unpack a grib message.
Definition: getgbe.f:176
+
getgbens
subroutine getgbens(LUGB, LUGI, JF, J, JPDS, JGDS, JENS, KF, K, KPDS, KGDS, KENS, LB, F, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbens.f:177
+ + + + diff --git a/ver-2.10.0/getgbep_8f.html b/ver-2.10.0/getgbep_8f.html new file mode 100644 index 00000000..348eca55 --- /dev/null +++ b/ver-2.10.0/getgbep_8f.html @@ -0,0 +1,387 @@ + + + + + + + +NCEPLIBS-w3emc: getgbep.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbep.f File Reference
+
+
+ +

Find a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbep (LUGB, LUGI, JG, J, JPDS, JGDS, JENS, KG, K, KPDS, KGDS, KENS, G, IRET)
 Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. More...
 
+

Detailed Description

+

Find a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbep.f.

+

Function/Subroutine Documentation

+ +

◆ getgbep()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbep ( LUGB,
 LUGI,
 JG,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
integer, dimension(200) JENS,
 KG,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
character, dimension(jg) G,
 IRET 
)
+
+ +

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e.

+

table of contents) for the grib file. (The index buffer is saved for use by future prospective calls.) Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file. Its message number is returned along with the unpacked pds and gds parameters and the packed grib message. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
+
Parameters
+ + + + + + + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib data file.
[in]lugiinteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jginteger maximum number of bytes in the grib message.
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages).
[in]jpdsinteger (200) pds parameters for which to search. (=-1 for wildcard).
    +
  • 1: id of center.
    • +
  • 2: generating process id number.
    • +
  • 3: grid definition.
    • +
  • 4: gds/bms flag (right adj copy of octet 8).
    • +
  • 5: indicator of parameter.
    • +
  • 6: type of level.
    • +
  • 7: height/pressure , etc of level.
    • +
  • 8: year including (century-1).
    • +
  • 9: month of year.
    • +
  • 10: day of month.
    • +
  • 11: hour of day.
    • +
  • 12: minute of hour.
    • +
  • 13: indicator of forecast time unit.
    • +
  • 14: time range 1.
    • +
  • 15: time range 2.
    • +
  • 16: time range flag.
    • +
  • 17: number included in average.
    • +
  • 18: version nr of grib specification.
    • +
  • 19: version nr of parameter table.
    • +
  • 20: nr missing from average/accumulation.
    • +
  • 21: century of reference time of data.
    • +
  • 22: units decimal scale factor.
    • +
  • 23: subcenter number.
    • +
  • 24: pds byte 29, for nmc ensemble products.
      +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    +
    • +
  • 25: pds byte 30, not used.
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1: data representation type.
    • +
  • 19: number of vertical coordinate parameters.
    • +
  • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
    • +
  • 21: for grids with pl, number of points in grid.
    • +
  • 22: number of words in each row.
    • +
  • tu: ngitude grids.
    • +
  • 2: n(i) nr points on latitude circle.
    • +
  • 3: n(j) nr points on longitude meridian.
    • +
  • 4: la(1) latitude of origin.
    • +
  • 5: lo(1) longitude of origin.
    • +
  • 6: resolution flag (right adj copy of octet 17).
    • +
  • 7: la(2) latitude of extreme point.
    • +
  • 8: lo(2) longitude of extreme point.
    • +
  • 9: di longitudinal direction of increment.
    • +
  • 10: dj latitudinal direction increment.
    • +
  • 11: scanning mode flag (right adj copy of octet 28).
    • +
  • Gaussian grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: n - nr of circles pole to equator.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: nv - nr of vert coord parameters.
      • +
    • 13: pv - octet nr of list of vert coord parameters or
        +
      • pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present.
        • +
      +
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2: n(i) nr points along lat circle.
      • +
    • 3: n(j) nr points along lon circle.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: lov grid orientation.
      • +
    • 8: dx - x direction increment.
      • +
    • 9: dy - y direction increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2: j pentagonal resolution parameter.
      • +
    • 3: k pentagonal resolution parameter.
      • +
    • 4: m pentagonal resolution parameter.
      • +
    • 5: representation type.
      • +
    • 6: coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of last grid point.
      • +
    • 8: lo(2) longitude of last grid point.
      • +
    • 9: latit - latitude of projection intersection.
      • +
    • 10: reserved.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: longitudinal dir grid length.
      • +
    • 13: latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2: nx nr points along x-axis.
      • +
    • 3: ny nr points along y-axis.
      • +
    • 4: la1 lat of origin (lower left).
      • +
    • 5: lo1 lon of origin (lower left).
      • +
    • 6: resolution (right adj copy of octet 17).
      • +
    • 7: lov - orientation of grid.
      • +
    • 8: dx - x-dir increment.
      • +
    • 9: dy - y-dir increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: latin 1 - first lat from pole of secant cone inter.
      • +
    • 13: latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]jensinteger (200) ensemble pds parms for which to search (only searched if jpds(23)=2) (=-1 for wildcard).
    +
  • 1: application identifier.
    • +
  • 2: ensemble type.
    • +
  • 3: ensemble identifier.
    • +
  • 4: product identifier.
    • +
  • 5: smoothing flag.
    • +
+
[out]kginteger number of bytes in the grib message.
[out]kinteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]kensinteger (200) unpacked ensemble pds parms.
[out]gcharacter*1 (kg) grib message.
[out]iretinteger return code.
    +
  • 0: all ok.
    • +
  • 96: error reading index file.
    • +
  • 97: error reading grib file.
    • +
  • 98: number of bytes greater than jg.
    • +
  • 99: request not found.
    • +
+
+
+
+
Note
In order to unpack grib from a multiprocessing environment where each processor is attempting to read from its own pair of logical units, one must directly call subprogram getgbemp as below, allocating a private copy of cbuf, nlen and nnum to each processor. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 172 of file getgbep.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbep_8f.js b/ver-2.10.0/getgbep_8f.js new file mode 100644 index 00000000..3d1ffa45 --- /dev/null +++ b/ver-2.10.0/getgbep_8f.js @@ -0,0 +1,4 @@ +var getgbep_8f = +[ + [ "getgbep", "getgbep_8f.html#a0f50efcce1cf858f28518c9f3dd19b40", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbep_8f_source.html b/ver-2.10.0/getgbep_8f_source.html new file mode 100644 index 00000000..ff9c24aa --- /dev/null +++ b/ver-2.10.0/getgbep_8f_source.html @@ -0,0 +1,301 @@ + + + + + + + +NCEPLIBS-w3emc: getgbep.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbep.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Read a grib index file (or optionally the grib file itself)
+
6 C> to get the index buffer (i.e. table of contents) for the grib file.
+
7 C> (The index buffer is saved for use by future prospective calls.)
+
8 C> Find in the index buffer a reference to the grib message requested.
+
9 C> The grib message request specifies the number of messages to skip
+
10 C> and the unpacked pds and gds parameters. (A requested parameter
+
11 C> of -1 means to allow any value of this parameter to be found.)
+
12 C> If the requested grib message is found, then it is read from the
+
13 C> grib file. Its message number is returned along with the unpacked
+
14 C> pds and gds parameters and the packed grib message. If the grib
+
15 C> message is not found, then the return code will be nonzero.
+
16 C>
+
17 C> Program history log:
+
18 C> - Mark Iredell 1994-04-01
+
19 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
20 C> and allowed for unspecified index file.
+
21 C>
+
22 C> @param[in] lugb integer unit of the unblocked grib data file.
+
23 C> @param[in] lugi integer unit of the unblocked grib index file
+
24 C> (=0 to get index buffer from the grib file).
+
25 C> @param[in] jg integer maximum number of bytes in the grib message.
+
26 C> @param[in] j integer number of messages to skip
+
27 C> (=0 to search from beginning)
+
28 C> (<0 to read index buffer and skip -1-j messages).
+
29 C> @param[in] jpds integer (200) pds parameters for which to search.
+
30 C> (=-1 for wildcard).
+
31 C> - 1: id of center.
+
32 C> - 2: generating process id number.
+
33 C> - 3: grid definition.
+
34 C> - 4: gds/bms flag (right adj copy of octet 8).
+
35 C> - 5: indicator of parameter.
+
36 C> - 6: type of level.
+
37 C> - 7: height/pressure , etc of level.
+
38 C> - 8: year including (century-1).
+
39 C> - 9: month of year.
+
40 C> - 10: day of month.
+
41 C> - 11: hour of day.
+
42 C> - 12: minute of hour.
+
43 C> - 13: indicator of forecast time unit.
+
44 C> - 14: time range 1.
+
45 C> - 15: time range 2.
+
46 C> - 16: time range flag.
+
47 C> - 17: number included in average.
+
48 C> - 18: version nr of grib specification.
+
49 C> - 19: version nr of parameter table.
+
50 C> - 20: nr missing from average/accumulation.
+
51 C> - 21: century of reference time of data.
+
52 C> - 22: units decimal scale factor.
+
53 C> - 23: subcenter number.
+
54 C> - 24: pds byte 29, for nmc ensemble products.
+
55 C> - 128 if forecast field error.
+
56 C> - 64 if bias corrected fcst field.
+
57 C> - 32 if smoothed field.
+
58 C> - warning: can be combination of more than 1.
+
59 C> - 25: pds byte 30, not used.
+
60 C> @param[in] jgds integer (200) gds parameters for which to search
+
61 C> (only searched if jpds(3)=255)
+
62 C> (=-1 for wildcard).
+
63 C> - 1: data representation type.
+
64 C> - 19: number of vertical coordinate parameters.
+
65 C> - 20: octet number of the list of vertical coordinate parameters or
+
66 C> octet number of the list of numbers of points in each row or
+
67 C> 255 if neither are present.
+
68 C> - 21: for grids with pl, number of points in grid.
+
69 C> - 22: number of words in each row.
+
70 C> - tu: ngitude grids.
+
71 C> - 2: n(i) nr points on latitude circle.
+
72 C> - 3: n(j) nr points on longitude meridian.
+
73 C> - 4: la(1) latitude of origin.
+
74 C> - 5: lo(1) longitude of origin.
+
75 C> - 6: resolution flag (right adj copy of octet 17).
+
76 C> - 7: la(2) latitude of extreme point.
+
77 C> - 8: lo(2) longitude of extreme point.
+
78 C> - 9: di longitudinal direction of increment.
+
79 C> - 10: dj latitudinal direction increment.
+
80 C> - 11: scanning mode flag (right adj copy of octet 28).
+
81 C> - Gaussian grids.
+
82 C> - 2: n(i) nr points on latitude circle.
+
83 C> - 3: n(j) nr points on longitude meridian.
+
84 C> - 4: la(1) latitude of origin.
+
85 C> - 5: lo(1) longitude of origin.
+
86 C> - 6: resolution flag (right adj copy of octet 17).
+
87 C> - 7: la(2) latitude of extreme point.
+
88 C> - 8: lo(2) longitude of extreme point.
+
89 C> - 9: di longitudinal direction of increment.
+
90 C> - 10: n - nr of circles pole to equator.
+
91 C> - 11: scanning mode flag (right adj copy of octet 28).
+
92 C> - 12: nv - nr of vert coord parameters.
+
93 C> - 13: pv - octet nr of list of vert coord parameters or
+
94 C> - pl - location of the list of numbers of points in each row
+
95 C> (if no vert coord parameters are present) or 255 if neither are present.
+
96 C> - Polar stereographic grids.
+
97 C> - 2: n(i) nr points along lat circle.
+
98 C> - 3: n(j) nr points along lon circle.
+
99 C> - 4: la(1) latitude of origin.
+
100 C> - 5: lo(1) longitude of origin.
+
101 C> - 6: resolution flag (right adj copy of octet 17).
+
102 C> - 7: lov grid orientation.
+
103 C> - 8: dx - x direction increment.
+
104 C> - 9: dy - y direction increment.
+
105 C> - 10: projection center flag.
+
106 C> - 11: scanning mode (right adj copy of octet 28).
+
107 C> - Spherical harmonic coefficients.
+
108 C> - 2: j pentagonal resolution parameter.
+
109 C> - 3: k pentagonal resolution parameter.
+
110 C> - 4: m pentagonal resolution parameter.
+
111 C> - 5: representation type.
+
112 C> - 6: coefficient storage mode.
+
113 C> - Mercator grids.
+
114 C> - 2: n(i) nr points on latitude circle.
+
115 C> - 3: n(j) nr points on longitude meridian.
+
116 C> - 4: la(1) latitude of origin.
+
117 C> - 5: lo(1) longitude of origin.
+
118 C> - 6: resolution flag (right adj copy of octet 17).
+
119 C> - 7: la(2) latitude of last grid point.
+
120 C> - 8: lo(2) longitude of last grid point.
+
121 C> - 9: latit - latitude of projection intersection.
+
122 C> - 10: reserved.
+
123 C> - 11: scanning mode flag (right adj copy of octet 28).
+
124 C> - 12: longitudinal dir grid length.
+
125 C> - 13: latitudinal dir grid length.
+
126 C> - Lambert conformal grids.
+
127 C> - 2: nx nr points along x-axis.
+
128 C> - 3: ny nr points along y-axis.
+
129 C> - 4: la1 lat of origin (lower left).
+
130 C> - 5: lo1 lon of origin (lower left).
+
131 C> - 6: resolution (right adj copy of octet 17).
+
132 C> - 7: lov - orientation of grid.
+
133 C> - 8: dx - x-dir increment.
+
134 C> - 9: dy - y-dir increment.
+
135 C> - 10: projection center flag.
+
136 C> - 11: scanning mode flag (right adj copy of octet 28).
+
137 C> - 12: latin 1 - first lat from pole of secant cone inter.
+
138 C> - 13: latin 2 - second lat from pole of secant cone inter.
+
139 C> @param[in] jens integer (200) ensemble pds parms for which to search
+
140 C> (only searched if jpds(23)=2)
+
141 C> (=-1 for wildcard).
+
142 C> - 1: application identifier.
+
143 C> - 2: ensemble type.
+
144 C> - 3: ensemble identifier.
+
145 C> - 4: product identifier.
+
146 C> - 5: smoothing flag.
+
147 C> @param[out] kg integer number of bytes in the grib message.
+
148 C> @param[out] k integer message number unpacked
+
149 C> (can be same as j in calling program
+
150 C> in order to facilitate multiple searches).
+
151 C> @param[out] kpds integer (200) unpacked pds parameters.
+
152 C> @param[out] kgds integer (200) unpacked gds parameters.
+
153 C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
154 C> @param[out] g character*1 (kg) grib message.
+
155 C> @param[out] iret integer return code.
+
156 C> - 0: all ok.
+
157 C> - 96: error reading index file.
+
158 C> - 97: error reading grib file.
+
159 C> - 98: number of bytes greater than jg.
+
160 C> - 99: request not found.
+
161 C>
+
162 C> @note In order to unpack grib from a multiprocessing environment
+
163 C> where each processor is attempting to read from its own pair of
+
164 C> logical units, one must directly call subprogram getgbemp as below,
+
165 C> allocating a private copy of cbuf, nlen and nnum to each processor.
+
166 C> Do not engage the same logical unit from more than one processor.
+
167 C>
+
168 C> @author Mark Iredell @date 1994-04-01
+
169 C-----------------------------------------------------------------------
+
170  SUBROUTINE getgbep(LUGB,LUGI,JG,J,JPDS,JGDS,JENS,
+
171  & KG,K,KPDS,KGDS,KENS,G,IRET)
+
172  INTEGER JPDS(200),JGDS(200),JENS(200)
+
173  INTEGER KPDS(200),KGDS(200),KENS(200)
+
174  CHARACTER G(JG)
+
175  parameter(mbuf=256*1024)
+
176  CHARACTER CBUF(MBUF)
+
177  SAVE cbuf,nlen,nnum,mnum
+
178  DATA lux/0/
+
179 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
180 C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
+
181  IF(lugi.GT.0.AND.(j.LT.0.OR.lugi.NE.lux)) THEN
+
182  lux=lugi
+
183  jj=min(j,-1-j)
+
184  ELSEIF(lugi.LE.0.AND.(j.LT.0.OR.lugb.NE.lux)) THEN
+
185  lux=lugb
+
186  jj=min(j,-1-j)
+
187  ELSE
+
188  jj=j
+
189  ENDIF
+
190 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
191 C FIND AND UNPACK GRIB MESSAGE
+
192  CALL getgbemp(lugb,lugi,jg,jj,jpds,jgds,jens,
+
193  & mbuf,cbuf,nlen,nnum,mnum,
+
194  & kg,k,kpds,kgds,kens,g,iret)
+
195  IF(iret.EQ.96) lux=0
+
196 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
197  RETURN
+
198  END
+
+
+
getgbep
subroutine getgbep(LUGB, LUGI, JG, J, JPDS, JGDS, JENS, KG, K, KPDS, KGDS, KENS, G, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbep.f:172
+
getgbemp
subroutine getgbemp(LUGB, LUGI, JG, J, JPDS, JGDS, JENS, MBUF, CBUF, NLEN, NNUM, MNUM, KG, K, KPDS, KGDS, KENS, G, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbemp.f:180
+ + + + diff --git a/ver-2.10.0/getgbex_8f.html b/ver-2.10.0/getgbex_8f.html new file mode 100644 index 00000000..2916aaf9 --- /dev/null +++ b/ver-2.10.0/getgbex_8f.html @@ -0,0 +1,428 @@ + + + + + + + +NCEPLIBS-w3emc: getgbex.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbex.f File Reference
+
+
+ +

Find and unpack a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbex (LUGB, LUGI, JF, J, JPDS, JGDS, JENS, KF, K, KPDS, KGDS, KENS, KPROB, XPROB, KCLUST, KMEMBR, LB, F, IRET)
 Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. More...
 
+

Detailed Description

+

Find and unpack a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbex.f.

+

Function/Subroutine Documentation

+ +

◆ getgbex()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbex ( LUGB,
 LUGI,
 JF,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
integer, dimension(200) JENS,
 KF,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
integer, dimension(2) KPROB,
real, dimension(2) XPROB,
integer, dimension(16) KCLUST,
integer, dimension(80) KMEMBR,
logical*1, dimension(jf) LB,
real, dimension(jf) F,
 IRET 
)
+
+ +

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e.

+

table of contents) for the grib file. (The index buffer is saved for use by future prospective calls.) Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file and unpacked. Its message number is returned along with the unpacked pds and gds parameters, the unpacked bitmap (if any), and the unpacked data. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
  • Y. Zhu 1997-02-11 Included probability and cluster arguments.
    • +
+
Parameters
+ + + + + + + + + + + + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib data file.
[in]lugiinteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jfinteger maximum number of data points to unpack.
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages).
[in]jpdsinteger (200) pds parameters for which to search (=-1 for wildcard).
    +
  • 1: id of center.
    • +
  • 2: generating process id number.
    • +
  • 3: grid definition.
    • +
  • 4: gds/bms flag (right adj copy of octet 8).
    • +
  • 5: indicator of parameter.
    • +
  • 6: type of level.
    • +
  • 7: height/pressure , etc of level.
    • +
  • 8: year including (century-1).
    • +
  • 9: month of year.
    • +
  • 10: day of month.
    • +
  • 11: hour of day.
    • +
  • 12: minute of hour.
    • +
  • 13: indicator of forecast time unit.
    • +
  • 14: time range 1.
    • +
  • 15: time range 2.
    • +
  • 16: time range flag.
    • +
  • 17: number included in average.
    • +
  • 18: version nr of grib specification.
    • +
  • 19: version nr of parameter table.
    • +
  • 20: nr missing from average/accumulation.
    • +
  • 21: century of reference time of data.
    • +
  • 22: units decimal scale factor.
    • +
  • 23: subcenter number.
    • +
  • 24: pds byte 29, for nmc ensemble products.
      +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    +
    • +
  • 25: pds byte 30, not used.
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1: data representation type.
    • +
  • 19: number of vertical coordinate parameters.
    • +
  • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
    • +
  • 21: for grids with pl, number of points in grid.
    • +
  • 22: number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: dj latitudinal direction increment.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: n - nr of circles pole to equator.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: nv - nr of vert coord parameters.
      • +
    • 13:
        +
      • pv - octet nr of list of vert coord parameters or.
        • +
      • pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or.
        • +
      • 255 if neither are present.
        • +
      +
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2: n(i) nr points along lat circle.
      • +
    • 3: n(j) nr points along lon circle.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: lov grid orientation.
      • +
    • 8: dx - x direction increment.
      • +
    • 9: dy - y direction increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2: j pentagonal resolution parameter.
      • +
    • 3: k pentagonal resolution parameter.
      • +
    • 4: m pentagonal resolution parameter.
      • +
    • 5: representation type.
      • +
    • 6: coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of last grid point.
      • +
    • 8: lo(2) longitude of last grid point.
      • +
    • 9: latit - latitude of projection intersection.
      • +
    • 10: reserved.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: longitudinal dir grid length.
      • +
    • 13: latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2: nx nr points along x-axis.
      • +
    • 3: ny nr points along y-axis.
      • +
    • 4: la1 lat of origin (lower left).
      • +
    • 5: lo1 lon of origin (lower left).
      • +
    • 6: resolution (right adj copy of octet 17).
      • +
    • 7: lov - orientation of grid.
      • +
    • 8: dx - x-dir increment.
      • +
    • 9: dy - y-dir increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: latin 1 - first lat from pole of secant cone inter.
      • +
    • 13: latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]jensinteger (200) ensemble pds parms for which to search (only searched if jpds(23)=2) (=-1 for wildcard).
    +
  • 1: application identifier.
    • +
  • 2: ensemble type.
    • +
  • 3: ensemble identifier.
    • +
  • 4: product identifier.
    • +
  • 5: smoothing flag.
    • +
+
[out]kfinteger number of data points unpacked.
[out]kinteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]kensinteger (200) unpacked ensemble pds parms.
[out]kprobinteger (2) probability ensemble parms.
[out]xprobreal (2) probability ensemble parms.
[out]kclustinteger (16) cluster ensemble parms.
[out]kmembrinteger (8) cluster ensemble parms.
[out]lblogical*1 (kf) unpacked bitmap if present.
[out]freal (kf) unpacked data.
[out]iretinteger return code.
    +
  • 0: all ok.
    • +
  • 96: error reading index file.
    • +
  • 97: error reading grib file.
    • +
  • 98: number of data points greater than jf.
    • +
  • 99: request not found.
    • +
  • other w3fi63 grib unpacker return code.
    • +
+
+
+
+
Note
In order to unpack grib from a multiprocessing environment where each processor is attempting to read from its own pair of logical units, one must directly call subprogram getgbexm as below, allocating a private copy of cbuf, nlen and nnum to each processor. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 184 of file getgbex.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbex_8f.js b/ver-2.10.0/getgbex_8f.js new file mode 100644 index 00000000..9449e6ae --- /dev/null +++ b/ver-2.10.0/getgbex_8f.js @@ -0,0 +1,4 @@ +var getgbex_8f = +[ + [ "getgbex", "getgbex_8f.html#a2dec8fa1731d77d4d81cd9609f04f8f5", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbex_8f_source.html b/ver-2.10.0/getgbex_8f_source.html new file mode 100644 index 00000000..b1791543 --- /dev/null +++ b/ver-2.10.0/getgbex_8f_source.html @@ -0,0 +1,317 @@ + + + + + + + +NCEPLIBS-w3emc: getgbex.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbex.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find and unpack a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Read a grib index file (or optionally the grib file itself)
+
6 C> to get the index buffer (i.e. table of contents) for the grib file.
+
7 C> (The index buffer is saved for use by future prospective calls.)
+
8 C> Find in the index buffer a reference to the grib message requested.
+
9 C> The grib message request specifies the number of messages to skip
+
10 C> and the unpacked pds and gds parameters. (A requested parameter
+
11 C> of -1 means to allow any value of this parameter to be found.)
+
12 C> If the requested grib message is found, then it is read from the
+
13 C> grib file and unpacked. Its message number is returned along with
+
14 C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
15 C> and the unpacked data. If the grib message is not found, then the
+
16 C> return code will be nonzero.
+
17 C>
+
18 C> Program history log:
+
19 C> - Mark Iredell 1994-04-01
+
20 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
21 C> and allowed for unspecified index file.
+
22 C> - Y. Zhu 1997-02-11 Included probability and cluster arguments.
+
23 C>
+
24 C> @param[in] lugb integer unit of the unblocked grib data file.
+
25 C> @param[in] lugi integer unit of the unblocked grib index file
+
26 C> (=0 to get index buffer from the grib file).
+
27 C> @param[in] jf integer maximum number of data points to unpack.
+
28 C> @param[in] j integer number of messages to skip
+
29 C> (=0 to search from beginning)
+
30 C> (<0 to read index buffer and skip -1-j messages).
+
31 C> @param[in] jpds integer (200) pds parameters for which to search
+
32 C> (=-1 for wildcard).
+
33 C> - 1: id of center.
+
34 C> - 2: generating process id number.
+
35 C> - 3: grid definition.
+
36 C> - 4: gds/bms flag (right adj copy of octet 8).
+
37 C> - 5: indicator of parameter.
+
38 C> - 6: type of level.
+
39 C> - 7: height/pressure , etc of level.
+
40 C> - 8: year including (century-1).
+
41 C> - 9: month of year.
+
42 C> - 10: day of month.
+
43 C> - 11: hour of day.
+
44 C> - 12: minute of hour.
+
45 C> - 13: indicator of forecast time unit.
+
46 C> - 14: time range 1.
+
47 C> - 15: time range 2.
+
48 C> - 16: time range flag.
+
49 C> - 17: number included in average.
+
50 C> - 18: version nr of grib specification.
+
51 C> - 19: version nr of parameter table.
+
52 C> - 20: nr missing from average/accumulation.
+
53 C> - 21: century of reference time of data.
+
54 C> - 22: units decimal scale factor.
+
55 C> - 23: subcenter number.
+
56 C> - 24: pds byte 29, for nmc ensemble products.
+
57 C> - 128 if forecast field error.
+
58 C> - 64 if bias corrected fcst field.
+
59 C> - 32 if smoothed field.
+
60 C> - warning: can be combination of more than 1.
+
61 C> - 25: pds byte 30, not used.
+
62 C> @param[in] jgds integer (200) gds parameters for which to search
+
63 C> (only searched if jpds(3)=255)
+
64 C> (=-1 for wildcard).
+
65 C> - 1: data representation type.
+
66 C> - 19: number of vertical coordinate parameters.
+
67 C> - 20: octet number of the list of vertical coordinate parameters or
+
68 C> octet number of the list of numbers of points in each row or
+
69 C> 255 if neither are present.
+
70 C> - 21: for grids with pl, number of points in grid.
+
71 C> - 22: number of words in each row.
+
72 C> - Latitude/longitude grids.
+
73 C> - 2: n(i) nr points on latitude circle.
+
74 C> - 3: n(j) nr points on longitude meridian.
+
75 C> - 4: la(1) latitude of origin.
+
76 C> - 5: lo(1) longitude of origin.
+
77 C> - 6: resolution flag (right adj copy of octet 17).
+
78 C> - 7: la(2) latitude of extreme point.
+
79 C> - 8: lo(2) longitude of extreme point.
+
80 C> - 9: di longitudinal direction of increment.
+
81 C> - 10: dj latitudinal direction increment.
+
82 C> - 11: scanning mode flag (right adj copy of octet 28).
+
83 C> - Gaussian grids.
+
84 C> - 2: n(i) nr points on latitude circle.
+
85 C> - 3: n(j) nr points on longitude meridian.
+
86 C> - 4: la(1) latitude of origin.
+
87 C> - 5: lo(1) longitude of origin.
+
88 C> - 6: resolution flag (right adj copy of octet 17).
+
89 C> - 7: la(2) latitude of extreme point.
+
90 C> - 8: lo(2) longitude of extreme point.
+
91 C> - 9: di longitudinal direction of increment.
+
92 C> - 10: n - nr of circles pole to equator.
+
93 C> - 11: scanning mode flag (right adj copy of octet 28).
+
94 C> - 12: nv - nr of vert coord parameters.
+
95 C> - 13:
+
96 C> - pv - octet nr of list of vert coord parameters or.
+
97 C> - pl - location of the list of numbers of points in each row
+
98 C> (if no vert coord parameters are present) or.
+
99 C> - 255 if neither are present.
+
100 C> - Polar stereographic grids.
+
101 C> - 2: n(i) nr points along lat circle.
+
102 C> - 3: n(j) nr points along lon circle.
+
103 C> - 4: la(1) latitude of origin.
+
104 C> - 5: lo(1) longitude of origin.
+
105 C> - 6: resolution flag (right adj copy of octet 17).
+
106 C> - 7: lov grid orientation.
+
107 C> - 8: dx - x direction increment.
+
108 C> - 9: dy - y direction increment.
+
109 C> - 10: projection center flag.
+
110 C> - 11: scanning mode (right adj copy of octet 28).
+
111 C> - Spherical harmonic coefficients.
+
112 C> - 2: j pentagonal resolution parameter.
+
113 C> - 3: k pentagonal resolution parameter.
+
114 C> - 4: m pentagonal resolution parameter.
+
115 C> - 5: representation type.
+
116 C> - 6: coefficient storage mode.
+
117 C> - Mercator grids.
+
118 C> - 2: n(i) nr points on latitude circle.
+
119 C> - 3: n(j) nr points on longitude meridian.
+
120 C> - 4: la(1) latitude of origin.
+
121 C> - 5: lo(1) longitude of origin.
+
122 C> - 6: resolution flag (right adj copy of octet 17).
+
123 C> - 7: la(2) latitude of last grid point.
+
124 C> - 8: lo(2) longitude of last grid point.
+
125 C> - 9: latit - latitude of projection intersection.
+
126 C> - 10: reserved.
+
127 C> - 11: scanning mode flag (right adj copy of octet 28).
+
128 C> - 12: longitudinal dir grid length.
+
129 C> - 13: latitudinal dir grid length.
+
130 C> - Lambert conformal grids.
+
131 C> - 2: nx nr points along x-axis.
+
132 C> - 3: ny nr points along y-axis.
+
133 C> - 4: la1 lat of origin (lower left).
+
134 C> - 5: lo1 lon of origin (lower left).
+
135 C> - 6: resolution (right adj copy of octet 17).
+
136 C> - 7: lov - orientation of grid.
+
137 C> - 8: dx - x-dir increment.
+
138 C> - 9: dy - y-dir increment.
+
139 C> - 10: projection center flag.
+
140 C> - 11: scanning mode flag (right adj copy of octet 28).
+
141 C> - 12: latin 1 - first lat from pole of secant cone inter.
+
142 C> - 13: latin 2 - second lat from pole of secant cone inter.
+
143 C> @param[in] jens integer (200) ensemble pds parms for which to search
+
144 C> (only searched if jpds(23)=2)
+
145 C> (=-1 for wildcard).
+
146 C> - 1: application identifier.
+
147 C> - 2: ensemble type.
+
148 C> - 3: ensemble identifier.
+
149 C> - 4: product identifier.
+
150 C> - 5: smoothing flag.
+
151 C>
+
152 C> @param[out] kf integer number of data points unpacked.
+
153 C> @param[out] k integer message number unpacked
+
154 C> (can be same as j in calling program
+
155 C> in order to facilitate multiple searches).
+
156 C> @param[out] kpds integer (200) unpacked pds parameters.
+
157 C> @param[out] kgds integer (200) unpacked gds parameters.
+
158 C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
159 C> @param[out] kprob integer (2) probability ensemble parms.
+
160 C> @param[out] xprob real (2) probability ensemble parms.
+
161 C> @param[out] kclust integer (16) cluster ensemble parms.
+
162 C> @param[out] kmembr integer (8) cluster ensemble parms.
+
163 C> @param[out] lb logical*1 (kf) unpacked bitmap if present.
+
164 C> @param[out] f real (kf) unpacked data.
+
165 C> @param[out] iret integer return code.
+
166 C> - 0: all ok.
+
167 C> - 96: error reading index file.
+
168 C> - 97: error reading grib file.
+
169 C> - 98: number of data points greater than jf.
+
170 C> - 99: request not found.
+
171 C> - other w3fi63 grib unpacker return code.
+
172 C>
+
173 C> @note In order to unpack grib from a multiprocessing environment
+
174 C> where each processor is attempting to read from its own pair of
+
175 C> logical units, one must directly call subprogram getgbexm as below,
+
176 C> allocating a private copy of cbuf, nlen and nnum to each processor.
+
177 C> Do not engage the same logical unit from more than one processor.
+
178 C>
+
179 C> @author Mark Iredell @date 1994-04-01
+
180 C-----------------------------------------------------------------------
+
181  SUBROUTINE getgbex(LUGB,LUGI,JF,J,JPDS,JGDS,JENS,
+
182  & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR,
+
183  & LB,F,IRET)
+
184  INTEGER JPDS(200),JGDS(200),JENS(200)
+
185  INTEGER KPDS(200),KGDS(200),KENS(200)
+
186  INTEGER KPROB(2),KCLUST(16),KMEMBR(80)
+
187  REAL XPROB(2)
+
188  LOGICAL*1 LB(JF)
+
189  REAL F(JF)
+
190  parameter(mbuf=256*1024)
+
191  CHARACTER CBUF(MBUF)
+
192  SAVE cbuf,nlen,nnum,mnum
+
193  DATA lux/0/
+
194 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
195 C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
+
196  IF(lugi.GT.0.AND.(j.LT.0.OR.lugi.NE.lux)) THEN
+
197  lux=lugi
+
198  jj=min(j,-1-j)
+
199  ELSEIF(lugi.LE.0.AND.(j.LT.0.OR.lugb.NE.lux)) THEN
+
200  lux=lugb
+
201  jj=min(j,-1-j)
+
202  ELSE
+
203  jj=j
+
204  ENDIF
+
205 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
206 C FIND AND UNPACK GRIB MESSAGE
+
207  CALL getgbexm(lugb,lugi,jf,jj,jpds,jgds,jens,
+
208  & mbuf,cbuf,nlen,nnum,mnum,
+
209  & kf,k,kpds,kgds,kens,kprob,xprob,kclust,kmembr,
+
210  & lb,f,iret)
+
211  IF(iret.EQ.96) lux=0
+
212 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
213  RETURN
+
214  END
+
+
+
getgbex
subroutine getgbex(LUGB, LUGI, JF, J, JPDS, JGDS, JENS, KF, K, KPDS, KGDS, KENS, KPROB, XPROB, KCLUST, KMEMBR, LB, F, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbex.f:184
+
getgbexm
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)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbexm.f:188
+ + + + diff --git a/ver-2.10.0/getgbexm_8f.html b/ver-2.10.0/getgbexm_8f.html new file mode 100644 index 00000000..c42372fc --- /dev/null +++ b/ver-2.10.0/getgbexm_8f.html @@ -0,0 +1,461 @@ + + + + + + + +NCEPLIBS-w3emc: getgbexm.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbexm.f File Reference
+
+
+ +

Find and unpack a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

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)
 Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. More...
 
+

Detailed Description

+

Find and unpack a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbexm.f.

+

Function/Subroutine Documentation

+ +

◆ getgbexm()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbexm ( LUGB,
 LUGI,
 JF,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
integer, dimension(200) JENS,
 MBUF,
character, dimension(mbuf) CBUF,
 NLEN,
 NNUM,
 MNUM,
 KF,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
integer, dimension(200) KENS,
integer, dimension(2) KPROB,
real, dimension(2) XPROB,
integer, dimension(16) KCLUST,
integer, dimension(80) KMEMBR,
logical*1, dimension(jf) LB,
real, dimension(jf) F,
 IRET 
)
+
+ +

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e.

+

table of contents) for the grib file. Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file and unpacked. Its message number is returned along with the unpacked pds and gds parameters, the unpacked bitmap (if any), and the unpacked data. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
  • Y. Zhu 1997-02-11 Included probability and cluster arguments.
    • +
+
Parameters
+ + + + + + + + + + + + + + + + + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib data file.
[in]lugiinteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jfinteger maximum number of data points to unpack.
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages).
[in]jpdsinteger (200) pds parameters for which to search (=-1 for wildcard).
    +
  • 1): id of center.
    • +
  • 2): generating process id number.
    • +
  • 3): grid definition.
    • +
  • 4): gds/bms flag (right adj copy of octet 8).
    • +
  • 5): indicator of parameter.
    • +
  • 6): type of level.
    • +
  • 7): height/pressure , etc of level.
    • +
  • 8): year including (century-1).
    • +
  • 9): month of year.
    • +
  • 10: day of month.
    • +
  • 11: hour of day.
    • +
  • 12: minute of hour.
    • +
  • 13: indicator of forecast time unit.
    • +
  • 14: time range 1.
    • +
  • 15: time range 2.
    • +
  • 16: time range flag.
    • +
  • 17: number included in average.
    • +
  • 18: version nr of grib specification.
    • +
  • 19: version nr of parameter table.
    • +
  • 20: nr missing from average/accumulation.
    • +
  • 21: century of reference time of data.
    • +
  • 22: units decimal scale factor.
    • +
  • 23: subcenter number.
    • +
  • 24: pds byte 29, for nmc ensemble products.
      +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    +
    • +
  • 25: pds byte 30, not used.
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1): data representation type.
    • +
  • 19: number of vertical coordinate parameters.
    • +
  • 20: octet number of the list of vertical coordinate parameters or. octet number of the list of numbers of points in each row or. 255 if neither are present.
    • +
  • 21: for grids with pl, number of points in grid.
    • +
  • 22: number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: dj latitudinal direction increment.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: n - nr of circles pole to equator.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: nv - nr of vert coord parameters.
      • +
    • 13: pv - octet nr of list of vert coord parameters or.
        +
      • pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present.
        • +
      +
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2: n(i) nr points along lat circle.
      • +
    • 3: n(j) nr points along lon circle.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: lov grid orientation.
      • +
    • 8: dx - x direction increment.
      • +
    • 9: dy - y direction increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2: j pentagonal resolution parameter.
      • +
    • 3: k pentagonal resolution parameter.
      • +
    • 4: m pentagonal resolution parameter.
      • +
    • 5: representation type.
      • +
    • 6: coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of last grid point.
      • +
    • 8: lo(2) longitude of last grid point.
      • +
    • 9: latit - latitude of projection intersection.
      • +
    • 10: reserved.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: longitudinal dir grid length.
      • +
    • 13: latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2: nx nr points along x-axis.
      • +
    • 3: ny nr points along y-axis.
      • +
    • 4: la1 lat of origin (lower left).
      • +
    • 5: lo1 lon of origin (lower left).
      • +
    • 6: resolution (right adj copy of octet 17).
      • +
    • 7: lov - orientation of grid.
      • +
    • 8: dx - x-dir increment.
      • +
    • 9: dy - y-dir increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: latin 1 - first lat from pole of secant cone inter.
      • +
    • 13: latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]jensinteger (200) ensemble pds parms for which to search (only searched if jpds(23)=2) (=-1 for wildcard).
    +
  • 1: application identifier.
    • +
  • 2: ensemble type.
    • +
  • 3: ensemble identifier.
    • +
  • 4: product identifier.
    • +
  • 5: smoothing flag.
    • +
+
[in]mbufinteger length of index buffer in bytes.
[in,out]cbufcharacter*1 (mbuf) index buffer (initialize by setting j=-1).
[in,out]nleninteger length of each index record in bytes (initialize by setting j=-1).
[in,out]nnuminteger number of index records (initialize by setting j=-1).
[in,out]mnuminteger number of index records skipped (initialize by setting j=-1).
[out]kfinteger number of data points unpacked.
[out]kinteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]kensinteger (200) unpacked ensemble pds parms.
[out]kprobinteger (2) probability ensemble parms.
[out]xprobreal (2) probability ensemble parms.
[out]kclustinteger (16) cluster ensemble parms.
[out]kmembrinteger (8) cluster ensemble parms.
[out]lblogical*1 (kf) unpacked bitmap if present.
[out]freal (kf) unpacked data.
[out]iretinteger return code.
    +
  • 0 all ok.
    • +
  • 96 error reading index file.
    • +
  • 97 error reading grib file.
    • +
  • 98 number of data points greater than jf.
    • +
  • 99 request not found.
    • +
  • other w3fi63 grib unpacker return code.
    • +
+
+
+
+
Note
Specify an index file if feasible to increase speed. Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 188 of file getgbexm.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbexm_8f.js b/ver-2.10.0/getgbexm_8f.js new file mode 100644 index 00000000..0d45eeec --- /dev/null +++ b/ver-2.10.0/getgbexm_8f.js @@ -0,0 +1,4 @@ +var getgbexm_8f = +[ + [ "getgbexm", "getgbexm_8f.html#ab15467040c53a0346d4857a0496c4762", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbexm_8f_source.html b/ver-2.10.0/getgbexm_8f_source.html new file mode 100644 index 00000000..5103c942 --- /dev/null +++ b/ver-2.10.0/getgbexm_8f_source.html @@ -0,0 +1,360 @@ + + + + + + + +NCEPLIBS-w3emc: getgbexm.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbexm.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find and unpack a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Read a grib index file (or optionally the grib file itself)
+
6 C> to get the index buffer (i.e. table of contents) for the grib file.
+
7 C> Find in the index buffer a reference to the grib message requested.
+
8 C> The grib message request specifies the number of messages to skip
+
9 C> and the unpacked pds and gds parameters. (A requested parameter
+
10 C> of -1 means to allow any value of this parameter to be found.)
+
11 C> If the requested grib message is found, then it is read from the
+
12 C> grib file and unpacked. Its message number is returned along with
+
13 C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
14 C> and the unpacked data. If the grib message is not found, then the
+
15 C> return code will be nonzero.
+
16 C>
+
17 C> Program history log:
+
18 C> - Mark Iredell 1994-04-01
+
19 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
20 C> and allowed for unspecified index file.
+
21 C> - Y. Zhu 1997-02-11 Included probability and cluster arguments.
+
22 C>
+
23 C> @param[in] lugb integer unit of the unblocked grib data file.
+
24 C> @param[in] lugi integer unit of the unblocked grib index file
+
25 C> (=0 to get index buffer from the grib file).
+
26 C> @param[in] jf integer maximum number of data points to unpack.
+
27 C> @param[in] j integer number of messages to skip
+
28 C> (=0 to search from beginning)
+
29 C> (<0 to read index buffer and skip -1-j messages).
+
30 C> @param[in] jpds integer (200) pds parameters for which to search
+
31 C> (=-1 for wildcard).
+
32 C> - 1): id of center.
+
33 C> - 2): generating process id number.
+
34 C> - 3): grid definition.
+
35 C> - 4): gds/bms flag (right adj copy of octet 8).
+
36 C> - 5): indicator of parameter.
+
37 C> - 6): type of level.
+
38 C> - 7): height/pressure , etc of level.
+
39 C> - 8): year including (century-1).
+
40 C> - 9): month of year.
+
41 C> - 10: day of month.
+
42 C> - 11: hour of day.
+
43 C> - 12: minute of hour.
+
44 C> - 13: indicator of forecast time unit.
+
45 C> - 14: time range 1.
+
46 C> - 15: time range 2.
+
47 C> - 16: time range flag.
+
48 C> - 17: number included in average.
+
49 C> - 18: version nr of grib specification.
+
50 C> - 19: version nr of parameter table.
+
51 C> - 20: nr missing from average/accumulation.
+
52 C> - 21: century of reference time of data.
+
53 C> - 22: units decimal scale factor.
+
54 C> - 23: subcenter number.
+
55 C> - 24: pds byte 29, for nmc ensemble products.
+
56 C> - 128 if forecast field error.
+
57 C> - 64 if bias corrected fcst field.
+
58 C> - 32 if smoothed field.
+
59 C> - warning: can be combination of more than 1.
+
60 C> - 25: pds byte 30, not used.
+
61 C> @param[in] jgds integer (200) gds parameters for which to search
+
62 C> (only searched if jpds(3)=255)
+
63 C> (=-1 for wildcard).
+
64 C> - 1): data representation type.
+
65 C> - 19: number of vertical coordinate parameters.
+
66 C> - 20: octet number of the list of vertical coordinate parameters or.
+
67 C> octet number of the list of numbers of points in each row or.
+
68 C> 255 if neither are present.
+
69 C> - 21: for grids with pl, number of points in grid.
+
70 C> - 22: number of words in each row.
+
71 C> - Latitude/longitude grids.
+
72 C> - 2: n(i) nr points on latitude circle.
+
73 C> - 3: n(j) nr points on longitude meridian.
+
74 C> - 4: la(1) latitude of origin.
+
75 C> - 5: lo(1) longitude of origin.
+
76 C> - 6: resolution flag (right adj copy of octet 17).
+
77 C> - 7: la(2) latitude of extreme point.
+
78 C> - 8: lo(2) longitude of extreme point.
+
79 C> - 9: di longitudinal direction of increment.
+
80 C> - 10: dj latitudinal direction increment.
+
81 C> - 11: scanning mode flag (right adj copy of octet 28).
+
82 C> - Gaussian grids.
+
83 C> - 2: n(i) nr points on latitude circle.
+
84 C> - 3: n(j) nr points on longitude meridian.
+
85 C> - 4: la(1) latitude of origin.
+
86 C> - 5: lo(1) longitude of origin.
+
87 C> - 6: resolution flag (right adj copy of octet 17).
+
88 C> - 7: la(2) latitude of extreme point.
+
89 C> - 8: lo(2) longitude of extreme point.
+
90 C> - 9: di longitudinal direction of increment.
+
91 C> - 10: n - nr of circles pole to equator.
+
92 C> - 11: scanning mode flag (right adj copy of octet 28).
+
93 C> - 12: nv - nr of vert coord parameters.
+
94 C> - 13: pv - octet nr of list of vert coord parameters or.
+
95 C> - pl - location of the list of numbers of points in each row
+
96 C> (if no vert coord parameters are present) or 255 if neither are present.
+
97 C> - Polar stereographic grids.
+
98 C> - 2: n(i) nr points along lat circle.
+
99 C> - 3: n(j) nr points along lon circle.
+
100 C> - 4: la(1) latitude of origin.
+
101 C> - 5: lo(1) longitude of origin.
+
102 C> - 6: resolution flag (right adj copy of octet 17).
+
103 C> - 7: lov grid orientation.
+
104 C> - 8: dx - x direction increment.
+
105 C> - 9: dy - y direction increment.
+
106 C> - 10: projection center flag.
+
107 C> - 11: scanning mode (right adj copy of octet 28).
+
108 C> - Spherical harmonic coefficients.
+
109 C> - 2: j pentagonal resolution parameter.
+
110 C> - 3: k pentagonal resolution parameter.
+
111 C> - 4: m pentagonal resolution parameter.
+
112 C> - 5: representation type.
+
113 C> - 6: coefficient storage mode.
+
114 C> - Mercator grids.
+
115 C> - 2: n(i) nr points on latitude circle.
+
116 C> - 3: n(j) nr points on longitude meridian.
+
117 C> - 4: la(1) latitude of origin.
+
118 C> - 5: lo(1) longitude of origin.
+
119 C> - 6: resolution flag (right adj copy of octet 17).
+
120 C> - 7: la(2) latitude of last grid point.
+
121 C> - 8: lo(2) longitude of last grid point.
+
122 C> - 9: latit - latitude of projection intersection.
+
123 C> - 10: reserved.
+
124 C> - 11: scanning mode flag (right adj copy of octet 28).
+
125 C> - 12: longitudinal dir grid length.
+
126 C> - 13: latitudinal dir grid length.
+
127 C> - Lambert conformal grids.
+
128 C> - 2: nx nr points along x-axis.
+
129 C> - 3: ny nr points along y-axis.
+
130 C> - 4: la1 lat of origin (lower left).
+
131 C> - 5: lo1 lon of origin (lower left).
+
132 C> - 6: resolution (right adj copy of octet 17).
+
133 C> - 7: lov - orientation of grid.
+
134 C> - 8: dx - x-dir increment.
+
135 C> - 9: dy - y-dir increment.
+
136 C> - 10: projection center flag.
+
137 C> - 11: scanning mode flag (right adj copy of octet 28).
+
138 C> - 12: latin 1 - first lat from pole of secant cone inter.
+
139 C> - 13: latin 2 - second lat from pole of secant cone inter.
+
140 C> @param[in] jens integer (200) ensemble pds parms for which to search
+
141 C> (only searched if jpds(23)=2)
+
142 C> (=-1 for wildcard).
+
143 C> - 1: application identifier.
+
144 C> - 2: ensemble type.
+
145 C> - 3: ensemble identifier.
+
146 C> - 4: product identifier.
+
147 C> - 5: smoothing flag.
+
148 C> @param[in] mbuf integer length of index buffer in bytes.
+
149 C> @param[inout] cbuf character*1 (mbuf) index buffer
+
150 C> (initialize by setting j=-1).
+
151 C> @param[inout] nlen integer length of each index record in bytes
+
152 C> (initialize by setting j=-1).
+
153 C> @param[inout] nnum integer number of index records
+
154 C> (initialize by setting j=-1).
+
155 C> @param[inout] mnum integer number of index records skipped
+
156 C> (initialize by setting j=-1).
+
157 C> @param[out] kf integer number of data points unpacked.
+
158 C> @param[out] k integer message number unpacked
+
159 C> (can be same as j in calling program
+
160 C> in order to facilitate multiple searches).
+
161 C> @param[out] kpds integer (200) unpacked pds parameters.
+
162 C> @param[out] kgds integer (200) unpacked gds parameters.
+
163 C> @param[out] kens integer (200) unpacked ensemble pds parms.
+
164 C> @param[out] kprob integer (2) probability ensemble parms.
+
165 C> @param[out] xprob real (2) probability ensemble parms.
+
166 C> @param[out] kclust integer (16) cluster ensemble parms.
+
167 C> @param[out] kmembr integer (8) cluster ensemble parms.
+
168 C> @param[out] lb logical*1 (kf) unpacked bitmap if present.
+
169 C> @param[out] f real (kf) unpacked data.
+
170 C> @param[out] iret integer return code.
+
171 C> - 0 all ok.
+
172 C> - 96 error reading index file.
+
173 C> - 97 error reading grib file.
+
174 C> - 98 number of data points greater than jf.
+
175 C> - 99 request not found.
+
176 C> - other w3fi63 grib unpacker return code.
+
177 C>
+
178 C> @note Specify an index file if feasible to increase speed.
+
179 C> Subprogram can be called from a multiprocessing environment.
+
180 C> Do not engage the same logical unit from more than one processor.
+
181 C>
+
182 C> @author Mark Iredell @date 1994-04-01
+
183 C-----------------------------------------------------------------------
+
184  SUBROUTINE getgbexm(LUGB,LUGI,JF,J,JPDS,JGDS,JENS,
+
185  & MBUF,CBUF,NLEN,NNUM,MNUM,
+
186  & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR,
+
187  & LB,F,IRET)
+
188  INTEGER JPDS(200),JGDS(200),JENS(200)
+
189  INTEGER KPDS(200),KGDS(200),KENS(200)
+
190  INTEGER KPROB(2),KCLUST(16),KMEMBR(80)
+
191  REAL XPROB(2)
+
192  CHARACTER CBUF(MBUF)
+
193  LOGICAL*1 LB(JF)
+
194  REAL F(JF)
+
195  parameter(msk1=32000,msk2=4000)
+
196 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
197 C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE
+
198  IF(j.GE.0) THEN
+
199  IF(mnum.GE.0) THEN
+
200  irgi=0
+
201  ELSE
+
202  mnum=-1-mnum
+
203  irgi=1
+
204  ENDIF
+
205  jr=j-mnum
+
206  IF(jr.GE.0.AND.(jr.LT.nnum.OR.irgi.EQ.0)) THEN
+
207  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
208  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
209  IF(irgs.EQ.0) k=kr+mnum
+
210  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
211  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
212  ELSE
+
213  mnum=j
+
214  irgi=1
+
215  irgs=1
+
216  ENDIF
+
217  ELSE
+
218  mnum=-1-j
+
219  irgi=1
+
220  irgs=1
+
221  ENDIF
+
222 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
223 C READ AND SEARCH NEXT INDEX BUFFER
+
224  jr=0
+
225  dowhile(irgi.EQ.1.AND.irgs.EQ.1)
+
226  IF(lugi.GT.0) THEN
+
227  CALL getgi(lugi,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
228  ELSE
+
229  CALL getgir(lugb,msk1,msk2,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
230  ENDIF
+
231  IF(irgi.LE.1) THEN
+
232  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
233  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
234  IF(irgs.EQ.0) k=kr+mnum
+
235  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
236  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
237  ENDIF
+
238  ENDDO
+
239 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
240 C READ AND UNPACK GRIB RECORD
+
241  IF(irgi.GT.1) THEN
+
242  iret=96
+
243  ELSEIF(irgs.NE.0) THEN
+
244  iret=99
+
245  ELSEIF(lengds(kgds).GT.jf) THEN
+
246  iret=98
+
247  ELSE
+
248  CALL getgb1re(lugb,lskip,lgrib,kf,kpds,kgds,kens,
+
249  & kprob,xprob,kclust,kmembr,lb,f,iret)
+
250  ENDIF
+
251 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
252  RETURN
+
253  END
+
+
+
getgir
subroutine getgir(LUGB, MSK1, MSK2, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib file and return its index contents.
Definition: getgir.f:45
+
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
+
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+
getgb1s
subroutine getgb1s(CBUF, NLEN, NNUM, J, JPDS, JGDS, JENS, K, KPDS, KGDS, KENS, LSKIP, LGRIB, IRET)
Find a grib message.
Definition: getgb1s.f:44
+
getgb1re
subroutine getgb1re(LUGB, LSKIP, LGRIB, KF, KPDS, KGDS, KENS, KPROB, XPROB, KCLUST, KMEMBR, LB, F, IRET)
Reads and unpacks a grib message.
Definition: getgb1re.f:38
+
getgbexm
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)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbexm.f:188
+ + + + diff --git a/ver-2.10.0/getgbh_8f.html b/ver-2.10.0/getgbh_8f.html new file mode 100644 index 00000000..9cb1ef0b --- /dev/null +++ b/ver-2.10.0/getgbh_8f.html @@ -0,0 +1,354 @@ + + + + + + + +NCEPLIBS-w3emc: getgbh.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbh.f File Reference
+
+
+ +

Find a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbh (LUGB, LUGI, J, JPDS, JGDS, KG, KF, K, KPDS, KGDS, IRET)
 Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. More...
 
+

Detailed Description

+

Find a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbh.f.

+

Function/Subroutine Documentation

+ +

◆ getgbh()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbh ( LUGB,
 LUGI,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
 KG,
 KF,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
 IRET 
)
+
+ +

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e.

+

table of contents) for the grib file. (The index buffer is saved for use by future prospective calls.) Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then its message number is returned along with the unpacked pds and gds parameters. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
+
Parameters
+ + + + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib data file (only used if lugi=0).
[in]lugiinteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages)
[in]jpdsinteger (200) pds parameters for which to search (=-1 for wildcard).
    +
  • 1: id of center.
    • +
  • 2: generating process id number.
    • +
  • 3: grid definition.
    • +
  • 4: gds/bms flag (right adj copy of octet 8).
    • +
  • 5: indicator of parameter.
    • +
  • 6: type of level.
    • +
  • 7: height/pressure , etc of level.
    • +
  • 8: year including (century-1).
    • +
  • 9: month of year.
    • +
  • 10: day of month.
    • +
  • 11: hour of day.
    • +
  • 12: minute of hour.
    • +
  • 13: indicator of forecast time unit.
    • +
  • 14: time range 1.
    • +
  • 15: time range 2.
    • +
  • 16: time range flag.
    • +
  • 17: number included in average.
    • +
  • 18: version nr of grib specification.
    • +
  • 19: version nr of parameter table.
    • +
  • 20: nr missing from average/accumulation.
    • +
  • 21: century of reference time of data.
    • +
  • 22: units decimal scale factor.
    • +
  • 23: subcenter number.
    • +
  • 24: pds byte 29, for nmc ensemble products.
      +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    +
    • +
  • 25: pds byte 30, not used
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1: data representation type.
    • +
  • 19: number of vertical coordinate parameters.
    • +
  • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
    • +
  • 21: for grids with pl, number of points in grid.
    • +
  • 22: number of words in each row.
    • +
  • tu: ngitude grids.
    • +
  • 2: n(i) nr points on latitude circle.
    • +
  • 3: n(j) nr points on longitude meridian.
    • +
  • 4: la(1) latitude of origin.
    • +
  • 5: lo(1) longitude of origin.
    • +
  • 6: resolution flag (right adj copy of octet 17).
    • +
  • 7: la(2) latitude of extreme point.
    • +
  • 8: lo(2) longitude of extreme point.
    • +
  • 9: di longitudinal direction of increment.
    • +
  • 10: dj latitudinal direction increment.
    • +
  • 11: scanning mode flag (right adj copy of octet 28).
    • +
  • Gaussian grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: n - nr of circles pole to equator.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: nv - nr of vert coord parameters.
      • +
    • 13: pv - octet nr of list of vert coord parameters or pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2: n(i) nr points along lat circle.
      • +
    • 3: n(j) nr points along lon circle.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: lov grid orientation.
      • +
    • 8: dx - x direction increment.
      • +
    • 9: dy - y direction increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2: j pentagonal resolution parameter.
      • +
    • 3: k pentagonal resolution parameter.
      • +
    • 4: m pentagonal resolution parameter.
      • +
    • 5: representation type.
      • +
    • 6: coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of last grid point.
      • +
    • 8: lo(2) longitude of last grid point.
      • +
    • 9: latit - latitude of projection intersection.
      • +
    • 10: reserved.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: longitudinal dir grid length.
      • +
    • 13: latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2: nx nr points along x-axis.
      • +
    • 3: ny nr points along y-axis.
      • +
    • 4: la1 lat of origin (lower left).
      • +
    • 5: lo1 lon of origin (lower left).
      • +
    • 6: resolution (right adj copy of octet 17).
      • +
    • 7: lov - orientation of grid.
      • +
    • 8: dx - x-dir increment.
      • +
    • 9: dy - y-dir increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: latin 1 - first lat from pole of secant cone inter.
      • +
    • 13: latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[out]kginteger number of bytes in the grib message.
[out]kfinteger number of data points in the message.
[out]kinteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]iretinteger return code.
    +
  • 0: all ok.
    • +
  • 96: error reading index file.
    • +
  • 99: request not found.
    • +
+
+
+
+
Note
In order to unpack grib from a multiprocessing environment where each processor is attempting to read from its own pair of logical units, one must directly call subprogram getgbmh as below, allocating a private copy of cbuf, nlen and nnum to each processor. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 160 of file getgbh.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbh_8f.js b/ver-2.10.0/getgbh_8f.js new file mode 100644 index 00000000..bd51f914 --- /dev/null +++ b/ver-2.10.0/getgbh_8f.js @@ -0,0 +1,4 @@ +var getgbh_8f = +[ + [ "getgbh", "getgbh_8f.html#ad15e85bb8f0d1057394c1732840fa128", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbh_8f_source.html b/ver-2.10.0/getgbh_8f_source.html new file mode 100644 index 00000000..c7c84dbf --- /dev/null +++ b/ver-2.10.0/getgbh_8f_source.html @@ -0,0 +1,288 @@ + + + + + + + +NCEPLIBS-w3emc: getgbh.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbh.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Read a grib index file (or optionally the grib file itself)
+
6 C> to get the index buffer (i.e. table of contents) for the grib file.
+
7 C> (The index buffer is saved for use by future prospective calls.)
+
8 C> Find in the index buffer a reference to the grib message requested.
+
9 C> The grib message request specifies the number of messages to skip
+
10 C> and the unpacked pds and gds parameters. (A requested parameter
+
11 C> of -1 means to allow any value of this parameter to be found.)
+
12 C> If the requested grib message is found, then its message number is
+
13 C> returned along with the unpacked pds and gds parameters. If the
+
14 C> grib message is not found, then the return code will be nonzero.
+
15 C>
+
16 C> Program history log:
+
17 C> - Mark Iredell 1994-04-01
+
18 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
19 C> and allowed for unspecified index file.
+
20 C>
+
21 C> @param[in] lugb integer unit of the unblocked grib data file
+
22 C> (only used if lugi=0).
+
23 C> @param[in] lugi integer unit of the unblocked grib index file
+
24 C> (=0 to get index buffer from the grib file).
+
25 C> @param[in] j integer number of messages to skip
+
26 C> (=0 to search from beginning)
+
27 C> (<0 to read index buffer and skip -1-j messages)
+
28 C> @param[in] jpds integer (200) pds parameters for which to search
+
29 C> (=-1 for wildcard).
+
30 C> - 1: id of center.
+
31 C> - 2: generating process id number.
+
32 C> - 3: grid definition.
+
33 C> - 4: gds/bms flag (right adj copy of octet 8).
+
34 C> - 5: indicator of parameter.
+
35 C> - 6: type of level.
+
36 C> - 7: height/pressure , etc of level.
+
37 C> - 8: year including (century-1).
+
38 C> - 9: month of year.
+
39 C> - 10: day of month.
+
40 C> - 11: hour of day.
+
41 C> - 12: minute of hour.
+
42 C> - 13: indicator of forecast time unit.
+
43 C> - 14: time range 1.
+
44 C> - 15: time range 2.
+
45 C> - 16: time range flag.
+
46 C> - 17: number included in average.
+
47 C> - 18: version nr of grib specification.
+
48 C> - 19: version nr of parameter table.
+
49 C> - 20: nr missing from average/accumulation.
+
50 C> - 21: century of reference time of data.
+
51 C> - 22: units decimal scale factor.
+
52 C> - 23: subcenter number.
+
53 C> - 24: pds byte 29, for nmc ensemble products.
+
54 C> - 128 if forecast field error.
+
55 C> - 64 if bias corrected fcst field.
+
56 C> - 32 if smoothed field.
+
57 C> - warning: can be combination of more than 1.
+
58 C> - 25: pds byte 30, not used
+
59 C> @param[in] jgds integer (200) gds parameters for which to search
+
60 C> (only searched if jpds(3)=255)
+
61 C> (=-1 for wildcard).
+
62 C> - 1: data representation type.
+
63 C> - 19: number of vertical coordinate parameters.
+
64 C> - 20: octet number of the list of vertical coordinate parameters or
+
65 C> octet number of the list of numbers of points in each row or
+
66 C> 255 if neither are present.
+
67 C> - 21: for grids with pl, number of points in grid.
+
68 C> - 22: number of words in each row.
+
69 C> - tu: ngitude grids.
+
70 C> - 2: n(i) nr points on latitude circle.
+
71 C> - 3: n(j) nr points on longitude meridian.
+
72 C> - 4: la(1) latitude of origin.
+
73 C> - 5: lo(1) longitude of origin.
+
74 C> - 6: resolution flag (right adj copy of octet 17).
+
75 C> - 7: la(2) latitude of extreme point.
+
76 C> - 8: lo(2) longitude of extreme point.
+
77 C> - 9: di longitudinal direction of increment.
+
78 C> - 10: dj latitudinal direction increment.
+
79 C> - 11: scanning mode flag (right adj copy of octet 28).
+
80 C> - Gaussian grids.
+
81 C> - 2: n(i) nr points on latitude circle.
+
82 C> - 3: n(j) nr points on longitude meridian.
+
83 C> - 4: la(1) latitude of origin.
+
84 C> - 5: lo(1) longitude of origin.
+
85 C> - 6: resolution flag (right adj copy of octet 17).
+
86 C> - 7: la(2) latitude of extreme point.
+
87 C> - 8: lo(2) longitude of extreme point.
+
88 C> - 9: di longitudinal direction of increment.
+
89 C> - 10: n - nr of circles pole to equator.
+
90 C> - 11: scanning mode flag (right adj copy of octet 28).
+
91 C> - 12: nv - nr of vert coord parameters.
+
92 C> - 13: pv - octet nr of list of vert coord parameters or
+
93 C> pl - location of the list of numbers of points in
+
94 C> each row (if no vert coord parameters are present) or
+
95 C> 255 if neither are present
+
96 C> - Polar stereographic grids.
+
97 C> - 2: n(i) nr points along lat circle.
+
98 C> - 3: n(j) nr points along lon circle.
+
99 C> - 4: la(1) latitude of origin.
+
100 C> - 5: lo(1) longitude of origin.
+
101 C> - 6: resolution flag (right adj copy of octet 17).
+
102 C> - 7: lov grid orientation.
+
103 C> - 8: dx - x direction increment.
+
104 C> - 9: dy - y direction increment.
+
105 C> - 10: projection center flag.
+
106 C> - 11: scanning mode (right adj copy of octet 28).
+
107 C> - Spherical harmonic coefficients.
+
108 C> - 2: j pentagonal resolution parameter.
+
109 C> - 3: k pentagonal resolution parameter.
+
110 C> - 4: m pentagonal resolution parameter.
+
111 C> - 5: representation type.
+
112 C> - 6: coefficient storage mode.
+
113 C> - Mercator grids.
+
114 C> - 2: n(i) nr points on latitude circle.
+
115 C> - 3: n(j) nr points on longitude meridian.
+
116 C> - 4: la(1) latitude of origin.
+
117 C> - 5: lo(1) longitude of origin.
+
118 C> - 6: resolution flag (right adj copy of octet 17).
+
119 C> - 7: la(2) latitude of last grid point.
+
120 C> - 8: lo(2) longitude of last grid point.
+
121 C> - 9: latit - latitude of projection intersection.
+
122 C> - 10: reserved.
+
123 C> - 11: scanning mode flag (right adj copy of octet 28).
+
124 C> - 12: longitudinal dir grid length.
+
125 C> - 13: latitudinal dir grid length.
+
126 C> - Lambert conformal grids.
+
127 C> - 2: nx nr points along x-axis.
+
128 C> - 3: ny nr points along y-axis.
+
129 C> - 4: la1 lat of origin (lower left).
+
130 C> - 5: lo1 lon of origin (lower left).
+
131 C> - 6: resolution (right adj copy of octet 17).
+
132 C> - 7: lov - orientation of grid.
+
133 C> - 8: dx - x-dir increment.
+
134 C> - 9: dy - y-dir increment.
+
135 C> - 10: projection center flag.
+
136 C> - 11: scanning mode flag (right adj copy of octet 28).
+
137 C> - 12: latin 1 - first lat from pole of secant cone inter.
+
138 C> - 13: latin 2 - second lat from pole of secant cone inter.
+
139 C> @param[out] kg integer number of bytes in the grib message.
+
140 C> @param[out] kf integer number of data points in the message.
+
141 C> @param[out] k integer message number unpacked
+
142 C> (can be same as j in calling program in order to facilitate multiple searches).
+
143 C> @param[out] kpds integer (200) unpacked pds parameters.
+
144 C> @param[out] kgds integer (200) unpacked gds parameters.
+
145 C> @param[out] iret integer return code.
+
146 C> - 0: all ok.
+
147 C> - 96: error reading index file.
+
148 C> - 99: request not found.
+
149 C>
+
150 C> @note In order to unpack grib from a multiprocessing environment
+
151 C> where each processor is attempting to read from its own pair of
+
152 C> logical units, one must directly call subprogram getgbmh as below,
+
153 C> allocating a private copy of cbuf, nlen and nnum to each processor.
+
154 C> Do not engage the same logical unit from more than one processor.
+
155 C>
+
156 C> @author Mark Iredell @date 1994-04-01
+
157 C-----------------------------------------------------------------------
+
158  SUBROUTINE getgbh(LUGB,LUGI,J,JPDS,JGDS,
+
159  & KG,KF,K,KPDS,KGDS,IRET)
+
160  INTEGER JPDS(200),JGDS(200)
+
161  INTEGER KPDS(200),KGDS(200)
+
162  parameter(mbuf=256*1024)
+
163  CHARACTER CBUF(MBUF)
+
164  SAVE cbuf,nlen,nnum,mnum
+
165  DATA lux/0/
+
166 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
167 C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
+
168  IF(lugi.GT.0.AND.(j.LT.0.OR.lugi.NE.lux)) THEN
+
169  lux=lugi
+
170  jj=min(j,-1-j)
+
171  ELSEIF(lugi.LE.0.AND.(j.LT.0.OR.lugb.NE.lux)) THEN
+
172  lux=lugb
+
173  jj=min(j,-1-j)
+
174  ELSE
+
175  jj=j
+
176  ENDIF
+
177 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
178 C FIND AND UNPACK GRIB MESSAGE
+
179  CALL getgbmh(lugb,lugi,jj,jpds,jgds,
+
180  & mbuf,cbuf,nlen,nnum,mnum,
+
181  & kg,kf,k,kpds,kgds,iret)
+
182  IF(iret.EQ.96) lux=0
+
183 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
184  RETURN
+
185  END
+
+
+
getgbmh
subroutine getgbmh(LUGB, LUGI, J, JPDS, JGDS, MBUF, CBUF, NLEN, NNUM, MNUM, KG, KF, K, KPDS, KGDS, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbmh.f:167
+
getgbh
subroutine getgbh(LUGB, LUGI, J, JPDS, JGDS, KG, KF, K, KPDS, KGDS, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbh.f:160
+ + + + diff --git a/ver-2.10.0/getgbm_8f.html b/ver-2.10.0/getgbm_8f.html new file mode 100644 index 00000000..280c6c33 --- /dev/null +++ b/ver-2.10.0/getgbm_8f.html @@ -0,0 +1,410 @@ + + + + + + + +NCEPLIBS-w3emc: getgbm.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbm.f File Reference
+
+
+ +

Find and unpack a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbm (LUGB, LUGI, JF, J, JPDS, JGDS, MBUF, CBUF, NLEN, NNUM, MNUM, KF, K, KPDS, KGDS, LB, F, IRET)
 Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. More...
 
+

Detailed Description

+

Find and unpack a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbm.f.

+

Function/Subroutine Documentation

+ +

◆ getgbm()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbm ( LUGB,
 LUGI,
 JF,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
 MBUF,
character, dimension(mbuf) CBUF,
 NLEN,
 NNUM,
 MNUM,
 KF,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
logical*1, dimension(jf) LB,
real, dimension(jf) F,
 IRET 
)
+
+ +

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e.

+

table of contents) for the grib file. Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file and unpacked. Its message number is returned along with the unpacked pds and gds parameters, the unpacked bitmap (if any), and the unpacked data. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
  • Chuang 2004-07-22 Add nbitss to the argument list of getgb1r that is called in this subroutine.
    • +
  • Wang 2010-03-02 wang Increase msk1 to 256000000 for nemsio files.
    • +
+
Parameters
+ + + + + + + + + + + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib data file.
[in]lugiinteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jfinteger maximum number of data points to unpack.
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages).
[in]jpdsinteger (200) pds parameters for which to search (=-1 for wildcard).
    +
  • 1: id of center.
    • +
  • 2: generating process id number.
    • +
  • 3: grid definition.
    • +
  • 4: gds/bms flag (right adj copy of octet 8).
    • +
  • 5: indicator of parameter.
    • +
  • 6: type of level.
    • +
  • 7: height/pressure , etc of level.
    • +
  • 8: year including (century-1).
    • +
  • 9: month of year.
    • +
  • 10: day of month.
    • +
  • 11: hour of day.
    • +
  • 12: minute of hour.
    • +
  • 13: indicator of forecast time unit.
    • +
  • 14: time range 1.
    • +
  • 15: time range 2.
    • +
  • 16: time range flag.
    • +
  • 17: number included in average.
    • +
  • 18: version nr of grib specification.
    • +
  • 19: version nr of parameter table.
    • +
  • 20: nr missing from average/accumulation.
    • +
  • 21: century of reference time of data.
    • +
  • 22: units decimal scale factor.
    • +
  • 23: subcenter number.
    • +
  • 24: pds byte 29, for nmc ensemble products.
      +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    +
    • +
  • 25: pds byte 30, not used.
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1): data representation type.
    • +
  • 19: number of vertical coordinate parameters.
    • +
  • 20: octet number of the list of vertical coordinate parameters or. octet number of the list of numbers of points in each row or. 255 if neither are present.
    • +
  • 21: for grids with pl, number of points in grid.
    • +
  • 22: number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2): n(i) nr points on latitude circle.
      • +
    • 3): n(j) nr points on longitude meridian.
      • +
    • 4): la(1) latitude of origin.
      • +
    • 5): lo(1) longitude of origin.
      • +
    • 6): resolution flag (right adj copy of octet 17).
      • +
    • 7): la(2) latitude of extreme point.
      • +
    • 8): lo(2) longitude of extreme point.
      • +
    • 9): di longitudinal direction of increment.
      • +
    • 10: dj latitudinal direction increment.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids.
      +
    • 2): n(i) nr points on latitude circle.
      • +
    • 3): n(j) nr points on longitude meridian.
      • +
    • 4): la(1) latitude of origin.
      • +
    • 5): lo(1) longitude of origin.
      • +
    • 6): resolution flag (right adj copy of octet 17).
      • +
    • 7): la(2) latitude of extreme point.
      • +
    • 8): lo(2) longitude of extreme point.
      • +
    • 9): di longitudinal direction of increment.
      • +
    • 10: n - nr of circles pole to equator.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: nv - nr of vert coord parameters.
      • +
    • 13: pv - octet nr of list of vert coord parameters or pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2): n(i) nr points along lat circle.
      • +
    • 3): n(j) nr points along lon circle.
      • +
    • 4): la(1) latitude of origin.
      • +
    • 5): lo(1) longitude of origin.
      • +
    • 6): resolution flag (right adj copy of octet 17).
      • +
    • 7): lov grid orientation.
      • +
    • 8): dx - x direction increment.
      • +
    • 9): dy - y direction increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2): j pentagonal resolution parameter.
      • +
    • 3): k pentagonal resolution parameter.
      • +
    • 4): m pentagonal resolution parameter.
      • +
    • 5): representation type.
      • +
    • 6): coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2): n(i) nr points on latitude circle.
      • +
    • 3): n(j) nr points on longitude meridian.
      • +
    • 4): la(1) latitude of origin.
      • +
    • 5): lo(1) longitude of origin.
      • +
    • 6): resolution flag (right adj copy of octet 17).
      • +
    • 7): la(2) latitude of last grid point.
      • +
    • 8): lo(2) longitude of last grid point.
      • +
    • 9): latit - latitude of projection intersection.
      • +
    • 10: reserved.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: longitudinal dir grid length.
      • +
    • 13: latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2): nx nr points along x-axis.
      • +
    • 3): ny nr points along y-axis.
      • +
    • 4): la1 lat of origin (lower left).
      • +
    • 5): lo1 lon of origin (lower left).
      • +
    • 6): resolution (right adj copy of octet 17).
      • +
    • 7): lov - orientation of grid.
      • +
    • 8): dx - x-dir increment.
      • +
    • 9): dy - y-dir increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: latin 1 - first lat from pole of secant cone inter.
      • +
    • 13: latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]mbufinteger length of index buffer in bytes.
[in,out]cbufcharacter*1 (mbuf) index buffer (initialize by setting j=-1).
[in,out]nleninteger length of each index record in bytes (initialize by setting j=-1).
[in,out]nnuminteger number of index records (initialize by setting j=-1).
[in,out]mnuminteger number of index records skipped (initialize by setting j=-1).
[out]kfinteger number of data points unpacked.
[out]kinteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]lblogical*1 (kf) unpacked bitmap if present.
[out]freal (kf) unpacked data.
[out]iretinteger return code.
    +
  • 0: all ok.
    • +
  • 96: error reading index file.
    • +
  • 97: error reading grib file.
    • +
  • 98: number of data points greater than jf.
    • +
  • 99: request not found.
    • +
  • other w3fi63 grib unpacker return code.
    • +
+
+
+
+
Note
Specify an index file if feasible to increase speed. Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 176 of file getgbm.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbm_8f.js b/ver-2.10.0/getgbm_8f.js new file mode 100644 index 00000000..2f08c7b7 --- /dev/null +++ b/ver-2.10.0/getgbm_8f.js @@ -0,0 +1,4 @@ +var getgbm_8f = +[ + [ "getgbm", "getgbm_8f.html#ac004e0201adb9928c5fada5c7372fd78", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbm_8f_source.html b/ver-2.10.0/getgbm_8f_source.html new file mode 100644 index 00000000..b5ac3ba1 --- /dev/null +++ b/ver-2.10.0/getgbm_8f_source.html @@ -0,0 +1,348 @@ + + + + + + + +NCEPLIBS-w3emc: getgbm.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbm.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Find and unpack a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Read a grib index file (or optionally the grib file itself)
+
6 C> to get the index buffer (i.e. table of contents) for the grib file.
+
7 C> Find in the index buffer a reference to the grib message requested.
+
8 C> The grib message request specifies the number of messages to skip
+
9 C> and the unpacked pds and gds parameters. A requested parameter
+
10 C> of -1 means to allow any value of this parameter to be found.)
+
11 C> If the requested grib message is found, then it is read from the
+
12 C> grib file and unpacked. Its message number is returned along with
+
13 C> the unpacked pds and gds parameters, the unpacked bitmap (if any),
+
14 C> and the unpacked data. If the grib message is not found, then the
+
15 C> return code will be nonzero.
+
16 C>
+
17 C> Program history log:
+
18 C> - Mark Iredell 1994-04-01
+
19 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
20 C> and allowed for unspecified index file.
+
21 C> - Chuang 2004-07-22 Add nbitss to the argument list of getgb1r that
+
22 C> is called in this subroutine.
+
23 C> - Wang 2010-03-02 wang Increase msk1 to 256000000 for nemsio files.
+
24 C>
+
25 C> @param[in] lugb integer unit of the unblocked grib data file.
+
26 C> @param[in] lugi integer unit of the unblocked grib index file
+
27 C> (=0 to get index buffer from the grib file).
+
28 C> @param[in] jf integer maximum number of data points to unpack.
+
29 C> @param[in] j integer number of messages to skip
+
30 C> (=0 to search from beginning)
+
31 C> (<0 to read index buffer and skip -1-j messages).
+
32 C> @param[in] jpds integer (200) pds parameters for which to search
+
33 C> (=-1 for wildcard).
+
34 C> - 1: id of center.
+
35 C> - 2: generating process id number.
+
36 C> - 3: grid definition.
+
37 C> - 4: gds/bms flag (right adj copy of octet 8).
+
38 C> - 5: indicator of parameter.
+
39 C> - 6: type of level.
+
40 C> - 7: height/pressure , etc of level.
+
41 C> - 8: year including (century-1).
+
42 C> - 9: month of year.
+
43 C> - 10: day of month.
+
44 C> - 11: hour of day.
+
45 C> - 12: minute of hour.
+
46 C> - 13: indicator of forecast time unit.
+
47 C> - 14: time range 1.
+
48 C> - 15: time range 2.
+
49 C> - 16: time range flag.
+
50 C> - 17: number included in average.
+
51 C> - 18: version nr of grib specification.
+
52 C> - 19: version nr of parameter table.
+
53 C> - 20: nr missing from average/accumulation.
+
54 C> - 21: century of reference time of data.
+
55 C> - 22: units decimal scale factor.
+
56 C> - 23: subcenter number.
+
57 C> - 24: pds byte 29, for nmc ensemble products.
+
58 C> - 128 if forecast field error.
+
59 C> - 64 if bias corrected fcst field.
+
60 C> - 32 if smoothed field.
+
61 C> - warning: can be combination of more than 1.
+
62 C> - 25: pds byte 30, not used.
+
63 C> @param[in] jgds integer (200) gds parameters for which to search
+
64 C> (only searched if jpds(3)=255)
+
65 C> (=-1 for wildcard).
+
66 C> - 1): data representation type.
+
67 C> - 19: number of vertical coordinate parameters.
+
68 C> - 20: octet number of the list of vertical coordinate parameters or.
+
69 C> octet number of the list of numbers of points in each row or.
+
70 C> 255 if neither are present.
+
71 C> - 21: for grids with pl, number of points in grid.
+
72 C> - 22: number of words in each row.
+
73 C> - Latitude/longitude grids.
+
74 C> - 2): n(i) nr points on latitude circle.
+
75 C> - 3): n(j) nr points on longitude meridian.
+
76 C> - 4): la(1) latitude of origin.
+
77 C> - 5): lo(1) longitude of origin.
+
78 C> - 6): resolution flag (right adj copy of octet 17).
+
79 C> - 7): la(2) latitude of extreme point.
+
80 C> - 8): lo(2) longitude of extreme point.
+
81 C> - 9): di longitudinal direction of increment.
+
82 C> - 10: dj latitudinal direction increment.
+
83 C> - 11: scanning mode flag (right adj copy of octet 28).
+
84 C> - Gaussian grids.
+
85 C> - 2): n(i) nr points on latitude circle.
+
86 C> - 3): n(j) nr points on longitude meridian.
+
87 C> - 4): la(1) latitude of origin.
+
88 C> - 5): lo(1) longitude of origin.
+
89 C> - 6): resolution flag (right adj copy of octet 17).
+
90 C> - 7): la(2) latitude of extreme point.
+
91 C> - 8): lo(2) longitude of extreme point.
+
92 C> - 9): di longitudinal direction of increment.
+
93 C> - 10: n - nr of circles pole to equator.
+
94 C> - 11: scanning mode flag (right adj copy of octet 28).
+
95 C> - 12: nv - nr of vert coord parameters.
+
96 C> - 13: pv - octet nr of list of vert coord parameters or
+
97 C> pl - location of the list of numbers of points in each row
+
98 C> (if no vert coord parameters are present) or
+
99 C> 255 if neither are present
+
100 C> - Polar stereographic grids.
+
101 C> - 2): n(i) nr points along lat circle.
+
102 C> - 3): n(j) nr points along lon circle.
+
103 C> - 4): la(1) latitude of origin.
+
104 C> - 5): lo(1) longitude of origin.
+
105 C> - 6): resolution flag (right adj copy of octet 17).
+
106 C> - 7): lov grid orientation.
+
107 C> - 8): dx - x direction increment.
+
108 C> - 9): dy - y direction increment.
+
109 C> - 10: projection center flag.
+
110 C> - 11: scanning mode (right adj copy of octet 28).
+
111 C> - Spherical harmonic coefficients.
+
112 C> - 2): j pentagonal resolution parameter.
+
113 C> - 3): k pentagonal resolution parameter.
+
114 C> - 4): m pentagonal resolution parameter.
+
115 C> - 5): representation type.
+
116 C> - 6): coefficient storage mode.
+
117 C> - Mercator grids.
+
118 C> - 2): n(i) nr points on latitude circle.
+
119 C> - 3): n(j) nr points on longitude meridian.
+
120 C> - 4): la(1) latitude of origin.
+
121 C> - 5): lo(1) longitude of origin.
+
122 C> - 6): resolution flag (right adj copy of octet 17).
+
123 C> - 7): la(2) latitude of last grid point.
+
124 C> - 8): lo(2) longitude of last grid point.
+
125 C> - 9): latit - latitude of projection intersection.
+
126 C> - 10: reserved.
+
127 C> - 11: scanning mode flag (right adj copy of octet 28).
+
128 C> - 12: longitudinal dir grid length.
+
129 C> - 13: latitudinal dir grid length.
+
130 C> - Lambert conformal grids.
+
131 C> - 2): nx nr points along x-axis.
+
132 C> - 3): ny nr points along y-axis.
+
133 C> - 4): la1 lat of origin (lower left).
+
134 C> - 5): lo1 lon of origin (lower left).
+
135 C> - 6): resolution (right adj copy of octet 17).
+
136 C> - 7): lov - orientation of grid.
+
137 C> - 8): dx - x-dir increment.
+
138 C> - 9): dy - y-dir increment.
+
139 C> - 10: projection center flag.
+
140 C> - 11: scanning mode flag (right adj copy of octet 28).
+
141 C> - 12: latin 1 - first lat from pole of secant cone inter.
+
142 C> - 13: latin 2 - second lat from pole of secant cone inter.
+
143 C> @param[in] mbuf integer length of index buffer in bytes.
+
144 C> @param[inout] cbuf character*1 (mbuf) index buffer
+
145 C> (initialize by setting j=-1).
+
146 C> @param[inout] nlen integer length of each index record in bytes
+
147 C> (initialize by setting j=-1).
+
148 C> @param[inout] nnum integer number of index records
+
149 C> (initialize by setting j=-1).
+
150 C> @param[inout] mnum integer number of index records skipped
+
151 C> (initialize by setting j=-1).
+
152 C> @param[out] kf integer number of data points unpacked.
+
153 C> @param[out] k integer message number unpacked
+
154 C> (can be same as j in calling program in order to facilitate multiple searches).
+
155 C> @param[out] kpds integer (200) unpacked pds parameters.
+
156 C> @param[out] kgds integer (200) unpacked gds parameters.
+
157 C> @param[out] lb logical*1 (kf) unpacked bitmap if present.
+
158 C> @param[out] f real (kf) unpacked data.
+
159 C> @param[out] iret integer return code.
+
160 C> - 0: all ok.
+
161 C> - 96: error reading index file.
+
162 C> - 97: error reading grib file.
+
163 C> - 98: number of data points greater than jf.
+
164 C> - 99: request not found.
+
165 C> - other w3fi63 grib unpacker return code.
+
166 C>
+
167 C> @note Specify an index file if feasible to increase speed.
+
168 C> Subprogram can be called from a multiprocessing environment.
+
169 C> Do not engage the same logical unit from more than one processor.
+
170 C>
+
171 C> @author Mark Iredell @date 1994-04-01
+
172 C-----------------------------------------------------------------------
+
173  SUBROUTINE getgbm(LUGB,LUGI,JF,J,JPDS,JGDS,
+
174  & MBUF,CBUF,NLEN,NNUM,MNUM,
+
175  & KF,K,KPDS,KGDS,LB,F,IRET)
+
176  INTEGER JPDS(200),JGDS(200)
+
177  INTEGER KPDS(200),KGDS(200)
+
178  CHARACTER CBUF(MBUF)
+
179  LOGICAL*1 LB(JF)
+
180  REAL F(JF)
+
181  parameter(msk1=256000000,msk2=4000)
+
182  INTEGER JENS(200),KENS(200)
+
183 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
184 C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE
+
185  jens=-1
+
186  IF(j.GE.0) THEN
+
187  IF(mnum.GE.0) THEN
+
188  irgi=0
+
189  ELSE
+
190  mnum=-1-mnum
+
191  irgi=1
+
192  ENDIF
+
193  jr=j-mnum
+
194  IF(jr.GE.0.AND.(jr.LT.nnum.OR.irgi.EQ.0)) THEN
+
195  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
196  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
197  IF(irgs.EQ.0) k=kr+mnum
+
198  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
199  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
200  ELSE
+
201  mnum=j
+
202  irgi=1
+
203  irgs=1
+
204  ENDIF
+
205  ELSE
+
206  mnum=-1-j
+
207  irgi=1
+
208  irgs=1
+
209  ENDIF
+
210 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
211 C READ AND SEARCH NEXT INDEX BUFFER
+
212  jr=0
+
213  dowhile(irgi.EQ.1.AND.irgs.EQ.1)
+
214  IF(lugi.GT.0) THEN
+
215  CALL getgi(lugi,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
216  ELSE
+
217  CALL getgir(lugb,msk1,msk2,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
218  ENDIF
+
219  IF(irgi.LE.1) THEN
+
220  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
221  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
222  IF(irgs.EQ.0) k=kr+mnum
+
223  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
224  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
225  ENDIF
+
226  ENDDO
+
227 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
228 C READ AND UNPACK GRIB RECORD
+
229  IF(irgi.GT.1) THEN
+
230  iret=96
+
231  ELSEIF(irgs.NE.0) THEN
+
232  iret=99
+
233  ELSEIF(lengds(kgds).GT.jf) THEN
+
234  iret=98
+
235  ELSE
+
236  CALL getgb1r(lugb,lskip,lgrib,kf,kpds,kgds,kens,lb,f,nbitss
+
237  + ,iret)
+
238  ENDIF
+
239 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
240  RETURN
+
241  END
+
+
+
getgb1r
subroutine getgb1r(LUGB, LSKIP, LGRIB, KF, KPDS, KGDS, KENS, LB, F, NBITSS, IRET)
Program history log:
Definition: getgb1r.f:34
+
getgbm
subroutine getgbm(LUGB, LUGI, JF, J, JPDS, JGDS, MBUF, CBUF, NLEN, NNUM, MNUM, KF, K, KPDS, KGDS, LB, F, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbm.f:176
+
getgir
subroutine getgir(LUGB, MSK1, MSK2, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib file and return its index contents.
Definition: getgir.f:45
+
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
+
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+
getgb1s
subroutine getgb1s(CBUF, NLEN, NNUM, J, JPDS, JGDS, JENS, K, KPDS, KGDS, KENS, LSKIP, LGRIB, IRET)
Find a grib message.
Definition: getgb1s.f:44
+ + + + diff --git a/ver-2.10.0/getgbmh_8f.html b/ver-2.10.0/getgbmh_8f.html new file mode 100644 index 00000000..2cca7e69 --- /dev/null +++ b/ver-2.10.0/getgbmh_8f.html @@ -0,0 +1,391 @@ + + + + + + + +NCEPLIBS-w3emc: getgbmh.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbmh.f File Reference
+
+
+ +

Finds a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbmh (LUGB, LUGI, J, JPDS, JGDS, MBUF, CBUF, NLEN, NNUM, MNUM, KG, KF, K, KPDS, KGDS, IRET)
 Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. More...
 
+

Detailed Description

+

Finds a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbmh.f.

+

Function/Subroutine Documentation

+ +

◆ getgbmh()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbmh ( LUGB,
 LUGI,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
 MBUF,
character, dimension(mbuf) CBUF,
 NLEN,
 NNUM,
 MNUM,
 KG,
 KF,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
 IRET 
)
+
+ +

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e.

+

table of contents) for the grib file. Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then its message number is returned along with the unpacked pds and gds parameters. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
+
Parameters
+ + + + + + + + + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib data file (only used if lugi=0).
[in]lugiinteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages).
[in]jpdsinteger (200) pds parameters for which to search (=-1 for wildcard).
    +
  • 1: id of center.
    • +
  • 2: generating process id number.
    • +
  • 3: grid definition.
    • +
  • 4: gds/bms flag (right adj copy of octet 8).
    • +
  • 5: indicator of parameter.
    • +
  • 6: type of level.
    • +
  • 7: height/pressure , etc of level.
    • +
  • 8: year including (century-1).
    • +
  • 9: month of year.
    • +
  • 10: day of month.
    • +
  • 11: hour of day.
    • +
  • 12: minute of hour.
    • +
  • 13: indicator of forecast time unit.
    • +
  • 14: time range 1.
    • +
  • 15: time range 2.
    • +
  • 16: time range flag.
    • +
  • 17: number included in average.
    • +
  • 18: version nr of grib specification.
    • +
  • 19: version nr of parameter table.
    • +
  • 20: nr missing from average/accumulation.
    • +
  • 21: century of reference time of data.
    • +
  • 22: units decimal scale factor.
    • +
  • 23: subcenter number.
    • +
  • 24: pds byte 29, for nmc ensemble products.
      +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    +
    • +
  • 25: pds byte 30, not used.
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1: data representation type.
    • +
  • 19: number of vertical coordinate parameters.
    • +
  • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
    • +
  • 21: for grids with pl, number of points in grid.
    • +
  • 22: number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: dj latitudinal direction increment.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: n - nr of circles pole to equator.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: nv - nr of vert coord parameters.
      • +
    • 13: pv - octet nr of list of vert coord parameters or pl - location of the list of numbers of points in each row (if no vert coord parameters are present or 255 if neither are present
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2: n(i) nr points along lat circle.
      • +
    • 3: n(j) nr points along lon circle.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: lov grid orientation.
      • +
    • 8: dx - x direction increment.
      • +
    • 9: dy - y direction increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2): j pentagonal resolution parameter.
      • +
    • 3): k pentagonal resolution parameter.
      • +
    • 4): m pentagonal resolution parameter.
      • +
    • 5): representation type.
      • +
    • 6): coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of last grid point.
      • +
    • 8: lo(2) longitude of last grid point.
      • +
    • 9: latit - latitude of projection intersection.
      • +
    • 10: reserved.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: longitudinal dir grid length.
      • +
    • 13: latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2: nx nr points along x-axis.
      • +
    • 3: ny nr points along y-axis.
      • +
    • 4: la1 lat of origin (lower left).
      • +
    • 5: lo1 lon of origin (lower left).
      • +
    • 6: resolution (right adj copy of octet 17).
      • +
    • 7: lov - orientation of grid.
      • +
    • 8: dx - x-dir increment.
      • +
    • 9: dy - y-dir increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: latin 1 - first lat from pole of secant cone inter.
      • +
    • 13: latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]mbufinteger length of index buffer in bytes.
[in,out]cbufcharacter*1 (mbuf) index buffer (initialize by setting j=-1).
[in,out]nleninteger length of each index record in bytes (initialize by setting j=-1).
[in,out]nnuminteger number of index records (initialize by setting j=-1).
[in,out]mnuminteger number of index records skipped (initialize by setting j=-1).
[out]kginteger number of bytes in the grib message.
[out]kfinteger number of data points in the message.
[out]kinteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]iretinteger return code.
    +
  • 0: all ok.
    • +
  • 96: error reading index file.
    • +
  • 99: request not found.
    • +
+
+
+
+
Note
Specify an index file if feasible to increase speed. Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 167 of file getgbmh.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbmh_8f.js b/ver-2.10.0/getgbmh_8f.js new file mode 100644 index 00000000..c6b9bbfd --- /dev/null +++ b/ver-2.10.0/getgbmh_8f.js @@ -0,0 +1,4 @@ +var getgbmh_8f = +[ + [ "getgbmh", "getgbmh_8f.html#ac4c2d81dcaf427548139d55ca7041022", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbmh_8f_source.html b/ver-2.10.0/getgbmh_8f_source.html new file mode 100644 index 00000000..e81492c5 --- /dev/null +++ b/ver-2.10.0/getgbmh_8f_source.html @@ -0,0 +1,335 @@ + + + + + + + +NCEPLIBS-w3emc: getgbmh.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbmh.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Finds a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Read a grib index file (or optionally the grib file itself)
+
6 C> to get the index buffer (i.e. table of contents) for the grib file.
+
7 C> Find in the index buffer a reference to the grib message requested.
+
8 C> The grib message request specifies the number of messages to skip
+
9 C> and the unpacked pds and gds parameters. (A requested parameter
+
10 C> of -1 means to allow any value of this parameter to be found.)
+
11 C> If the requested grib message is found, then its message number is
+
12 C> returned along with the unpacked pds and gds parameters. If the
+
13 C> grib message is not found, then the return code will be nonzero.
+
14 C>
+
15 C> Program history log:
+
16 C> - Mark Iredell 1994-04-01
+
17 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
18 C> and allowed for unspecified index file.
+
19 C>
+
20 C> @param[in] lugb integer unit of the unblocked grib data file
+
21 C> (only used if lugi=0).
+
22 C> @param[in] lugi integer unit of the unblocked grib index file
+
23 C> (=0 to get index buffer from the grib file).
+
24 C> @param[in] j integer number of messages to skip
+
25 C> (=0 to search from beginning)
+
26 C> (<0 to read index buffer and skip -1-j messages).
+
27 C> @param[in] jpds integer (200) pds parameters for which to search
+
28 C> (=-1 for wildcard).
+
29 C> - 1: id of center.
+
30 C> - 2: generating process id number.
+
31 C> - 3: grid definition.
+
32 C> - 4: gds/bms flag (right adj copy of octet 8).
+
33 C> - 5: indicator of parameter.
+
34 C> - 6: type of level.
+
35 C> - 7: height/pressure , etc of level.
+
36 C> - 8: year including (century-1).
+
37 C> - 9: month of year.
+
38 C> - 10: day of month.
+
39 C> - 11: hour of day.
+
40 C> - 12: minute of hour.
+
41 C> - 13: indicator of forecast time unit.
+
42 C> - 14: time range 1.
+
43 C> - 15: time range 2.
+
44 C> - 16: time range flag.
+
45 C> - 17: number included in average.
+
46 C> - 18: version nr of grib specification.
+
47 C> - 19: version nr of parameter table.
+
48 C> - 20: nr missing from average/accumulation.
+
49 C> - 21: century of reference time of data.
+
50 C> - 22: units decimal scale factor.
+
51 C> - 23: subcenter number.
+
52 C> - 24: pds byte 29, for nmc ensemble products.
+
53 C> - 128 if forecast field error.
+
54 C> - 64 if bias corrected fcst field.
+
55 C> - 32 if smoothed field.
+
56 C> - warning: can be combination of more than 1.
+
57 C> - 25: pds byte 30, not used.
+
58 C> @param[in] jgds integer (200) gds parameters for which to search
+
59 C> (only searched if jpds(3)=255)
+
60 C> (=-1 for wildcard).
+
61 C> - 1: data representation type.
+
62 C> - 19: number of vertical coordinate parameters.
+
63 C> - 20: octet number of the list of vertical coordinate parameters or
+
64 C> octet number of the list of numbers of points in each row or
+
65 C> 255 if neither are present.
+
66 C> - 21: for grids with pl, number of points in grid.
+
67 C> - 22: number of words in each row.
+
68 C> - Latitude/longitude grids.
+
69 C> - 2: n(i) nr points on latitude circle.
+
70 C> - 3: n(j) nr points on longitude meridian.
+
71 C> - 4: la(1) latitude of origin.
+
72 C> - 5: lo(1) longitude of origin.
+
73 C> - 6: resolution flag (right adj copy of octet 17).
+
74 C> - 7: la(2) latitude of extreme point.
+
75 C> - 8: lo(2) longitude of extreme point.
+
76 C> - 9: di longitudinal direction of increment.
+
77 C> - 10: dj latitudinal direction increment.
+
78 C> - 11: scanning mode flag (right adj copy of octet 28).
+
79 C> - Gaussian grids.
+
80 C> - 2: n(i) nr points on latitude circle.
+
81 C> - 3: n(j) nr points on longitude meridian.
+
82 C> - 4: la(1) latitude of origin.
+
83 C> - 5: lo(1) longitude of origin.
+
84 C> - 6: resolution flag (right adj copy of octet 17).
+
85 C> - 7: la(2) latitude of extreme point.
+
86 C> - 8: lo(2) longitude of extreme point.
+
87 C> - 9: di longitudinal direction of increment.
+
88 C> - 10: n - nr of circles pole to equator.
+
89 C> - 11: scanning mode flag (right adj copy of octet 28).
+
90 C> - 12: nv - nr of vert coord parameters.
+
91 C> - 13: pv - octet nr of list of vert coord parameters or
+
92 C> pl - location of the list of numbers of points in each row
+
93 C> (if no vert coord parameters are present or
+
94 C> 255 if neither are present
+
95 C> - Polar stereographic grids.
+
96 C> - 2: n(i) nr points along lat circle.
+
97 C> - 3: n(j) nr points along lon circle.
+
98 C> - 4: la(1) latitude of origin.
+
99 C> - 5: lo(1) longitude of origin.
+
100 C> - 6: resolution flag (right adj copy of octet 17).
+
101 C> - 7: lov grid orientation.
+
102 C> - 8: dx - x direction increment.
+
103 C> - 9: dy - y direction increment.
+
104 C> - 10: projection center flag.
+
105 C> - 11: scanning mode (right adj copy of octet 28).
+
106 C> - Spherical harmonic coefficients.
+
107 C> - 2): j pentagonal resolution parameter.
+
108 C> - 3): k pentagonal resolution parameter.
+
109 C> - 4): m pentagonal resolution parameter.
+
110 C> - 5): representation type.
+
111 C> - 6): coefficient storage mode.
+
112 C> - Mercator grids.
+
113 C> - 2: n(i) nr points on latitude circle.
+
114 C> - 3: n(j) nr points on longitude meridian.
+
115 C> - 4: la(1) latitude of origin.
+
116 C> - 5: lo(1) longitude of origin.
+
117 C> - 6: resolution flag (right adj copy of octet 17).
+
118 C> - 7: la(2) latitude of last grid point.
+
119 C> - 8: lo(2) longitude of last grid point.
+
120 C> - 9: latit - latitude of projection intersection.
+
121 C> - 10: reserved.
+
122 C> - 11: scanning mode flag (right adj copy of octet 28).
+
123 C> - 12: longitudinal dir grid length.
+
124 C> - 13: latitudinal dir grid length.
+
125 C> - Lambert conformal grids.
+
126 C> - 2: nx nr points along x-axis.
+
127 C> - 3: ny nr points along y-axis.
+
128 C> - 4: la1 lat of origin (lower left).
+
129 C> - 5: lo1 lon of origin (lower left).
+
130 C> - 6: resolution (right adj copy of octet 17).
+
131 C> - 7: lov - orientation of grid.
+
132 C> - 8: dx - x-dir increment.
+
133 C> - 9: dy - y-dir increment.
+
134 C> - 10: projection center flag.
+
135 C> - 11: scanning mode flag (right adj copy of octet 28).
+
136 C> - 12: latin 1 - first lat from pole of secant cone inter.
+
137 C> - 13: latin 2 - second lat from pole of secant cone inter.
+
138 C> @param[in] mbuf integer length of index buffer in bytes.
+
139 C> @param[inout] cbuf character*1 (mbuf) index buffer
+
140 C> (initialize by setting j=-1).
+
141 C> @param[inout] nlen integer length of each index record in bytes
+
142 C> (initialize by setting j=-1).
+
143 C> @param[inout] nnum integer number of index records
+
144 C> (initialize by setting j=-1).
+
145 C> @param[inout] mnum integer number of index records skipped
+
146 C> (initialize by setting j=-1).
+
147 C> @param[out] kg integer number of bytes in the grib message.
+
148 C> @param[out] kf integer number of data points in the message.
+
149 C> @param[out] k integer message number unpacked
+
150 C> (can be same as j in calling program in order to facilitate multiple searches).
+
151 C> @param[out] kpds integer (200) unpacked pds parameters.
+
152 C> @param[out] kgds integer (200) unpacked gds parameters.
+
153 C> @param[out] iret integer return code.
+
154 C> - 0: all ok.
+
155 C> - 96: error reading index file.
+
156 C> - 99: request not found.
+
157 C>
+
158 C> @note Specify an index file if feasible to increase speed.
+
159 C> Subprogram can be called from a multiprocessing environment.
+
160 C> Do not engage the same logical unit from more than one processor.
+
161 C>
+
162 C> @author Mark Iredell @date 1994-04-01
+
163 C-----------------------------------------------------------------------
+
164  SUBROUTINE getgbmh(LUGB,LUGI,J,JPDS,JGDS,
+
165  & MBUF,CBUF,NLEN,NNUM,MNUM,
+
166  & KG,KF,K,KPDS,KGDS,IRET)
+
167  INTEGER JPDS(200),JGDS(200)
+
168  INTEGER KPDS(200),KGDS(200)
+
169  CHARACTER CBUF(MBUF)
+
170  parameter(msk1=32000,msk2=4000)
+
171  INTEGER JENS(200),KENS(200)
+
172 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
173 C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE
+
174  jens=-1
+
175  IF(j.GE.0) THEN
+
176  IF(mnum.GE.0) THEN
+
177  irgi=0
+
178  ELSE
+
179  mnum=-1-mnum
+
180  irgi=1
+
181  ENDIF
+
182  jr=j-mnum
+
183  IF(jr.GE.0.AND.(jr.LT.nnum.OR.irgi.EQ.0)) THEN
+
184  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
185  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
186  IF(irgs.EQ.0) k=kr+mnum
+
187  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
188  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
189  ELSE
+
190  mnum=j
+
191  irgi=1
+
192  irgs=1
+
193  ENDIF
+
194  ELSE
+
195  mnum=-1-j
+
196  irgi=1
+
197  irgs=1
+
198  ENDIF
+
199 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
200 C READ AND SEARCH NEXT INDEX BUFFER
+
201  jr=0
+
202  dowhile(irgi.EQ.1.AND.irgs.EQ.1)
+
203  IF(lugi.GT.0) THEN
+
204  CALL getgi(lugi,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
205  ELSE
+
206  CALL getgir(lugb,msk1,msk2,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
207  ENDIF
+
208  IF(irgi.LE.1) THEN
+
209  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
210  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
211  IF(irgs.EQ.0) k=kr+mnum
+
212  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
213  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
214  ENDIF
+
215  ENDDO
+
216 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
217 C READ GRIB RECORD
+
218  IF(irgi.GT.1) THEN
+
219  iret=96
+
220  ELSEIF(irgs.NE.0) THEN
+
221  iret=99
+
222  ELSE
+
223  kg=lgrib
+
224  kf=lengds(kgds)
+
225  iret=0
+
226  ENDIF
+
227 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
228  RETURN
+
229  END
+
+
+
getgbmh
subroutine getgbmh(LUGB, LUGI, J, JPDS, JGDS, MBUF, CBUF, NLEN, NNUM, MNUM, KG, KF, K, KPDS, KGDS, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbmh.f:167
+
getgir
subroutine getgir(LUGB, MSK1, MSK2, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib file and return its index contents.
Definition: getgir.f:45
+
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
+
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+
getgb1s
subroutine getgb1s(CBUF, NLEN, NNUM, J, JPDS, JGDS, JENS, K, KPDS, KGDS, KENS, LSKIP, LGRIB, IRET)
Find a grib message.
Definition: getgb1s.f:44
+ + + + diff --git a/ver-2.10.0/getgbmp_8f.html b/ver-2.10.0/getgbmp_8f.html new file mode 100644 index 00000000..ba188066 --- /dev/null +++ b/ver-2.10.0/getgbmp_8f.html @@ -0,0 +1,400 @@ + + + + + + + +NCEPLIBS-w3emc: getgbmp.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbmp.f File Reference
+
+
+ +

Finds a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbmp (LUGB, LUGI, JG, J, JPDS, JGDS, MBUF, CBUF, NLEN, NNUM, MNUM, KG, K, KPDS, KGDS, G, IRET)
 Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. More...
 
+

Detailed Description

+

Finds a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbmp.f.

+

Function/Subroutine Documentation

+ +

◆ getgbmp()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbmp ( LUGB,
 LUGI,
 JG,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
 MBUF,
character, dimension(mbuf) CBUF,
 NLEN,
 NNUM,
 MNUM,
 KG,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
character, dimension(jg) G,
 IRET 
)
+
+ +

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e.

+

table of contents) for the grib file. Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file. Its message number is returned along with the unpacked pds and gds parameters and the packed grib message. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01 iredell
    • +
  • Mark Iredell 1995-10-31 iredell Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
+
Parameters
+ + + + + + + + + + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib data file.
[in]lugiinteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jginteger maximum number of bytes in the grib message.
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages).
[in]jpdsinteger (200) pds parameters for which to search (=-1 for wildcard).
    +
  • 1): id of center.
    • +
  • 2): generating process id number.
    • +
  • 3): grid definition.
    • +
  • 4): gds/bms flag (right adj copy of octet 8).
    • +
  • 5): indicator of parameter.
    • +
  • 6): type of level.
    • +
  • 7): height/pressure , etc of level.
    • +
  • 8): year including (century-1).
    • +
  • 9): month of year.
    • +
  • 10: day of month.
    • +
  • 11: hour of day.
    • +
  • 12: minute of hour.
    • +
  • 13: indicator of forecast time unit.
    • +
  • 14: time range 1.
    • +
  • 15: time range 2.
    • +
  • 16: time range flag.
    • +
  • 17: number included in average.
    • +
  • 18: version nr of grib specification.
    • +
  • 19: version nr of parameter table.
    • +
  • 20: nr missing from average/accumulation.
    • +
  • 21: century of reference time of data.
    • +
  • 22: units decimal scale factor.
    • +
  • 23: subcenter number.
    • +
  • 24: pds byte 29, for nmc ensemble products.
      +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    +
    • +
  • 25: pds byte 30, not used.
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1): data representation type.
    • +
  • 19: number of vertical coordinate parameters.
    • +
  • 20: octet number of the list of vertical coordinate parameters or. octet number of the list of numbers of points in each row or. 255 if neither are present.
    • +
  • 21: for grids with pl, number of points in grid.
    • +
  • 22: number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2): n(i) nr points on latitude circle.
      • +
    • 3): n(j) nr points on longitude meridian.
      • +
    • 4): la(1) latitude of origin.
      • +
    • 5): lo(1) longitude of origin.
      • +
    • 6): resolution flag (right adj copy of octet 17).
      • +
    • 7): la(2) latitude of extreme point.
      • +
    • 8): lo(2) longitude of extreme point.
      • +
    • 9): di longitudinal direction of increment.
      • +
    • 10: dj latitudinal direction increment.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids.
      +
    • 2): n(i) nr points on latitude circle.
      • +
    • 3): n(j) nr points on longitude meridian.
      • +
    • 4): la(1) latitude of origin.
      • +
    • 5): lo(1) longitude of origin.
      • +
    • 6): resolution flag (right adj copy of octet 17).
      • +
    • 7): la(2) latitude of extreme point.
      • +
    • 8): lo(2) longitude of extreme point.
      • +
    • 9): di longitudinal direction of increment.
      • +
    • 10: n - nr of circles pole to equator.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: nv - nr of vert coord parameters.
      • +
    • 13: pv - octet nr of list of vert coord parameters or pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present.
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2): n(i) nr points along lat circle.
      • +
    • 3): n(j) nr points along lon circle.
      • +
    • 4): la(1) latitude of origin.
      • +
    • 5): lo(1) longitude of origin.
      • +
    • 6): resolution flag (right adj copy of octet 17).
      • +
    • 7): lov grid orientation.
      • +
    • 8): dx - x direction increment.
      • +
    • 9): dy - y direction increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2): j pentagonal resolution parameter.
      • +
    • 3): k pentagonal resolution parameter.
      • +
    • 4): m pentagonal resolution parameter.
      • +
    • 5): representation type.
      • +
    • 6): coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2): n(i) nr points on latitude circle.
      • +
    • 3): n(j) nr points on longitude meridian.
      • +
    • 4): la(1) latitude of origin.
      • +
    • 5): lo(1) longitude of origin.
      • +
    • 6): resolution flag (right adj copy of octet 17).
      • +
    • 7): la(2) latitude of last grid point.
      • +
    • 8): lo(2) longitude of last grid point.
      • +
    • 9): latit - latitude of projection intersection.
      • +
    • 10: reserved.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: longitudinal dir grid length.
      • +
    • 13: latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2): nx nr points along x-axis.
      • +
    • 3): ny nr points along y-axis.
      • +
    • 4): la1 lat of origin (lower left).
      • +
    • 5): lo1 lon of origin (lower left).
      • +
    • 6): resolution (right adj copy of octet 17).
      • +
    • 7): lov - orientation of grid.
      • +
    • 8): dx - x-dir increment.
      • +
    • 9): dy - y-dir increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: latin 1 - first lat from pole of secant cone inter.
      • +
    • 13: latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[in]mbufinteger length of index buffer in bytes.
[in,out]cbufcharacter*1 (mbuf) index buffer (initialize by setting j=-1).
[in,out]nleninteger length of each index record in bytes (initialize by setting j=-1).
[in,out]nnuminteger number of index records (initialize by setting j=-1).
[in,out]mnuminteger number of index records skipped (initialize by setting j=-1).
[out]kginteger number of bytes in the grib message.
[out]kinteger message number unpacked (can be same as j in calling programin order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]gcharacter*1 (kg) grib message.
[out]iretinteger return code.
    +
  • 0: all ok.
    • +
  • 96: error reading index file.
    • +
  • 97: error reading grib file.
    • +
  • 98: number of bytes greater than jg.
    • +
  • 99: request not found.
    • +
+
+
+
+
Note
Specify an index file if feasible to increase speed. Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 170 of file getgbmp.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbmp_8f.js b/ver-2.10.0/getgbmp_8f.js new file mode 100644 index 00000000..e2fbf085 --- /dev/null +++ b/ver-2.10.0/getgbmp_8f.js @@ -0,0 +1,4 @@ +var getgbmp_8f = +[ + [ "getgbmp", "getgbmp_8f.html#a3dce03b33b45a2c4f9c859774615cb5a", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbmp_8f_source.html b/ver-2.10.0/getgbmp_8f_source.html new file mode 100644 index 00000000..c36da5da --- /dev/null +++ b/ver-2.10.0/getgbmp_8f_source.html @@ -0,0 +1,340 @@ + + + + + + + +NCEPLIBS-w3emc: getgbmp.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbmp.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Finds a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Read a grib index file (or optionally the grib file itself)
+
6 C> to get the index buffer (i.e. table of contents) for the grib file.
+
7 C> Find in the index buffer a reference to the grib message requested.
+
8 C> The grib message request specifies the number of messages to skip
+
9 C> and the unpacked pds and gds parameters. (A requested parameter
+
10 C> of -1 means to allow any value of this parameter to be found.)
+
11 C> If the requested grib message is found, then it is read from the
+
12 C> grib file. Its message number is returned along with the unpacked
+
13 C> pds and gds parameters and the packed grib message. If the grib
+
14 C> message is not found, then the return code will be nonzero.
+
15 C>
+
16 C> Program history log:
+
17 C> - Mark Iredell 1994-04-01 iredell
+
18 C> - Mark Iredell 1995-10-31 iredell Modularized portions of code into subprograms
+
19 C> and allowed for unspecified index file.
+
20 C>
+
21 C> @param[in] lugb integer unit of the unblocked grib data file.
+
22 C> @param[in] lugi integer unit of the unblocked grib index file
+
23 C> (=0 to get index buffer from the grib file).
+
24 C> @param[in] jg integer maximum number of bytes in the grib message.
+
25 C> @param[in] j integer number of messages to skip
+
26 C> (=0 to search from beginning)
+
27 C> (<0 to read index buffer and skip -1-j messages).
+
28 C> @param[in] jpds integer (200) pds parameters for which to search
+
29 C> (=-1 for wildcard).
+
30 C> - 1): id of center.
+
31 C> - 2): generating process id number.
+
32 C> - 3): grid definition.
+
33 C> - 4): gds/bms flag (right adj copy of octet 8).
+
34 C> - 5): indicator of parameter.
+
35 C> - 6): type of level.
+
36 C> - 7): height/pressure , etc of level.
+
37 C> - 8): year including (century-1).
+
38 C> - 9): month of year.
+
39 C> - 10: day of month.
+
40 C> - 11: hour of day.
+
41 C> - 12: minute of hour.
+
42 C> - 13: indicator of forecast time unit.
+
43 C> - 14: time range 1.
+
44 C> - 15: time range 2.
+
45 C> - 16: time range flag.
+
46 C> - 17: number included in average.
+
47 C> - 18: version nr of grib specification.
+
48 C> - 19: version nr of parameter table.
+
49 C> - 20: nr missing from average/accumulation.
+
50 C> - 21: century of reference time of data.
+
51 C> - 22: units decimal scale factor.
+
52 C> - 23: subcenter number.
+
53 C> - 24: pds byte 29, for nmc ensemble products.
+
54 C> - 128 if forecast field error.
+
55 C> - 64 if bias corrected fcst field.
+
56 C> - 32 if smoothed field.
+
57 C> - warning: can be combination of more than 1.
+
58 C> - 25: pds byte 30, not used.
+
59 C> @param[in] jgds integer (200) gds parameters for which to search
+
60 C> (only searched if jpds(3)=255)
+
61 C> (=-1 for wildcard).
+
62 C> - 1): data representation type.
+
63 C> - 19: number of vertical coordinate parameters.
+
64 C> - 20: octet number of the list of vertical coordinate parameters or.
+
65 C> octet number of the list of numbers of points in each row or.
+
66 C> 255 if neither are present.
+
67 C> - 21: for grids with pl, number of points in grid.
+
68 C> - 22: number of words in each row.
+
69 C> - Latitude/longitude grids.
+
70 C> - 2): n(i) nr points on latitude circle.
+
71 C> - 3): n(j) nr points on longitude meridian.
+
72 C> - 4): la(1) latitude of origin.
+
73 C> - 5): lo(1) longitude of origin.
+
74 C> - 6): resolution flag (right adj copy of octet 17).
+
75 C> - 7): la(2) latitude of extreme point.
+
76 C> - 8): lo(2) longitude of extreme point.
+
77 C> - 9): di longitudinal direction of increment.
+
78 C> - 10: dj latitudinal direction increment.
+
79 C> - 11: scanning mode flag (right adj copy of octet 28).
+
80 C> - Gaussian grids.
+
81 C> - 2): n(i) nr points on latitude circle.
+
82 C> - 3): n(j) nr points on longitude meridian.
+
83 C> - 4): la(1) latitude of origin.
+
84 C> - 5): lo(1) longitude of origin.
+
85 C> - 6): resolution flag (right adj copy of octet 17).
+
86 C> - 7): la(2) latitude of extreme point.
+
87 C> - 8): lo(2) longitude of extreme point.
+
88 C> - 9): di longitudinal direction of increment.
+
89 C> - 10: n - nr of circles pole to equator.
+
90 C> - 11: scanning mode flag (right adj copy of octet 28).
+
91 C> - 12: nv - nr of vert coord parameters.
+
92 C> - 13: pv - octet nr of list of vert coord parameters or
+
93 C> pl - location of the list of numbers of points in each row
+
94 C> (if no vert coord parameters are present) or
+
95 C> 255 if neither are present.
+
96 C> - Polar stereographic grids.
+
97 C> - 2): n(i) nr points along lat circle.
+
98 C> - 3): n(j) nr points along lon circle.
+
99 C> - 4): la(1) latitude of origin.
+
100 C> - 5): lo(1) longitude of origin.
+
101 C> - 6): resolution flag (right adj copy of octet 17).
+
102 C> - 7): lov grid orientation.
+
103 C> - 8): dx - x direction increment.
+
104 C> - 9): dy - y direction increment.
+
105 C> - 10: projection center flag.
+
106 C> - 11: scanning mode (right adj copy of octet 28).
+
107 C> - Spherical harmonic coefficients.
+
108 C> - 2): j pentagonal resolution parameter.
+
109 C> - 3): k pentagonal resolution parameter.
+
110 C> - 4): m pentagonal resolution parameter.
+
111 C> - 5): representation type.
+
112 C> - 6): coefficient storage mode.
+
113 C> - Mercator grids.
+
114 C> - 2): n(i) nr points on latitude circle.
+
115 C> - 3): n(j) nr points on longitude meridian.
+
116 C> - 4): la(1) latitude of origin.
+
117 C> - 5): lo(1) longitude of origin.
+
118 C> - 6): resolution flag (right adj copy of octet 17).
+
119 C> - 7): la(2) latitude of last grid point.
+
120 C> - 8): lo(2) longitude of last grid point.
+
121 C> - 9): latit - latitude of projection intersection.
+
122 C> - 10: reserved.
+
123 C> - 11: scanning mode flag (right adj copy of octet 28).
+
124 C> - 12: longitudinal dir grid length.
+
125 C> - 13: latitudinal dir grid length.
+
126 C> - Lambert conformal grids.
+
127 C> - 2): nx nr points along x-axis.
+
128 C> - 3): ny nr points along y-axis.
+
129 C> - 4): la1 lat of origin (lower left).
+
130 C> - 5): lo1 lon of origin (lower left).
+
131 C> - 6): resolution (right adj copy of octet 17).
+
132 C> - 7): lov - orientation of grid.
+
133 C> - 8): dx - x-dir increment.
+
134 C> - 9): dy - y-dir increment.
+
135 C> - 10: projection center flag.
+
136 C> - 11: scanning mode flag (right adj copy of octet 28).
+
137 C> - 12: latin 1 - first lat from pole of secant cone inter.
+
138 C> - 13: latin 2 - second lat from pole of secant cone inter.
+
139 C> @param[in] mbuf integer length of index buffer in bytes.
+
140 C> @param[inout] cbuf character*1 (mbuf) index buffer
+
141 C> (initialize by setting j=-1).
+
142 C> @param[inout] nlen integer length of each index record in bytes
+
143 C> (initialize by setting j=-1).
+
144 C> @param[inout] nnum integer number of index records
+
145 C> (initialize by setting j=-1).
+
146 C> @param[inout] mnum integer number of index records skipped
+
147 C> (initialize by setting j=-1).
+
148 C> @param[out] kg integer number of bytes in the grib message.
+
149 C> @param[out] k integer message number unpacked
+
150 C> (can be same as j in calling programin order to facilitate multiple searches).
+
151 C> @param[out] kpds integer (200) unpacked pds parameters.
+
152 C> @param[out] kgds integer (200) unpacked gds parameters.
+
153 C> @param[out] g character*1 (kg) grib message.
+
154 C> @param[out] iret integer return code.
+
155 C> - 0: all ok.
+
156 C> - 96: error reading index file.
+
157 C> - 97: error reading grib file.
+
158 C> - 98: number of bytes greater than jg.
+
159 C> - 99: request not found.
+
160 C>
+
161 C> @note Specify an index file if feasible to increase speed.
+
162 C> Subprogram can be called from a multiprocessing environment.
+
163 C> Do not engage the same logical unit from more than one processor.
+
164 C>
+
165 C> @author Mark Iredell @date 1994-04-01
+
166 C-----------------------------------------------------------------------
+
167  SUBROUTINE getgbmp(LUGB,LUGI,JG,J,JPDS,JGDS,
+
168  & MBUF,CBUF,NLEN,NNUM,MNUM,
+
169  & KG,K,KPDS,KGDS,G,IRET)
+
170  INTEGER JPDS(200),JGDS(200)
+
171  INTEGER KPDS(200),KGDS(200)
+
172  CHARACTER CBUF(MBUF)
+
173  CHARACTER G(JG)
+
174  parameter(msk1=32000,msk2=4000)
+
175  INTEGER JENS(200),KENS(200)
+
176 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
177 C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE
+
178  jens=-1
+
179  IF(j.GE.0) THEN
+
180  IF(mnum.GE.0) THEN
+
181  irgi=0
+
182  ELSE
+
183  mnum=-1-mnum
+
184  irgi=1
+
185  ENDIF
+
186  jr=j-mnum
+
187  IF(jr.GE.0.AND.(jr.LT.nnum.OR.irgi.EQ.0)) THEN
+
188  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
189  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
190  IF(irgs.EQ.0) k=kr+mnum
+
191  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
192  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
193  ELSE
+
194  mnum=j
+
195  irgi=1
+
196  irgs=1
+
197  ENDIF
+
198  ELSE
+
199  mnum=-1-j
+
200  irgi=1
+
201  irgs=1
+
202  ENDIF
+
203 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
204 C READ AND SEARCH NEXT INDEX BUFFER
+
205  jr=0
+
206  dowhile(irgi.EQ.1.AND.irgs.EQ.1)
+
207  IF(lugi.GT.0) THEN
+
208  CALL getgi(lugi,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
209  ELSE
+
210  CALL getgir(lugb,msk1,msk2,mnum,mbuf,cbuf,nlen,nnum,irgi)
+
211  ENDIF
+
212  IF(irgi.LE.1) THEN
+
213  CALL getgb1s(cbuf,nlen,nnum,jr,jpds,jgds,jens,
+
214  & kr,kpds,kgds,kens,lskip,lgrib,irgs)
+
215  IF(irgs.EQ.0) k=kr+mnum
+
216  IF(irgi.EQ.1.AND.irgs.EQ.0) mnum=-1-mnum
+
217  IF(irgi.EQ.1.AND.irgs.GT.0) mnum=mnum+nnum
+
218  ENDIF
+
219  ENDDO
+
220 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
221 C READ GRIB RECORD
+
222  IF(irgi.GT.1) THEN
+
223  iret=96
+
224  ELSEIF(irgs.NE.0) THEN
+
225  iret=99
+
226  ELSEIF(lgrib.GT.jg) THEN
+
227  iret=98
+
228  ELSE
+
229  iret=97
+
230  CALL baread(lugb,lskip,lgrib,kg,g)
+
231  IF(kg.EQ.lgrib) iret=0
+
232  ENDIF
+
233 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
234  RETURN
+
235  END
+
+
+
getgir
subroutine getgir(LUGB, MSK1, MSK2, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib file and return its index contents.
Definition: getgir.f:45
+
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
+
getgb1s
subroutine getgb1s(CBUF, NLEN, NNUM, J, JPDS, JGDS, JENS, K, KPDS, KGDS, KENS, LSKIP, LGRIB, IRET)
Find a grib message.
Definition: getgb1s.f:44
+
getgbmp
subroutine getgbmp(LUGB, LUGI, JG, J, JPDS, JGDS, MBUF, CBUF, NLEN, NNUM, MNUM, KG, K, KPDS, KGDS, G, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbmp.f:170
+ + + + diff --git a/ver-2.10.0/getgbp_8f.html b/ver-2.10.0/getgbp_8f.html new file mode 100644 index 00000000..35443d44 --- /dev/null +++ b/ver-2.10.0/getgbp_8f.html @@ -0,0 +1,365 @@ + + + + + + + +NCEPLIBS-w3emc: getgbp.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgbp.f File Reference
+
+
+ +

Finds a grib message. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgbp (LUGB, LUGI, JG, J, JPDS, JGDS, KG, K, KPDS, KGDS, G, IRET)
 Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e. More...
 
+

Detailed Description

+

Finds a grib message.

+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition in file getgbp.f.

+

Function/Subroutine Documentation

+ +

◆ getgbp()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgbp ( LUGB,
 LUGI,
 JG,
 J,
integer, dimension(200) JPDS,
integer, dimension(200) JGDS,
 KG,
 K,
integer, dimension(200) KPDS,
integer, dimension(200) KGDS,
character, dimension(jg) G,
 IRET 
)
+
+ +

Read a grib index file (or optionally the grib file itself) to get the index buffer (i.e.

+

table of contents) for the grib file. (The index buffer is saved for use by future prospective calls.) Find in the index buffer a reference to the grib message requested. The grib message request specifies the number of messages to skip and the unpacked pds and gds parameters. (A requested parameter of -1 means to allow any value of this parameter to be found.) If the requested grib message is found, then it is read from the grib file. Its message number is returned along with the unpacked pds and gds parameters and the packed grib message. If the grib message is not found, then the return code will be nonzero.

+

Program history log:

    +
  • Mark Iredell 1994-04-01
    • +
  • Mark Iredell 1995-10-31 Modularized portions of code into subprograms and allowed for unspecified index file.
    • +
+
Parameters
+ + + + + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib data file.
[in]lugiinteger unit of the unblocked grib index file (=0 to get index buffer from the grib file).
[in]jginteger maximum number of bytes in the grib message.
[in]jinteger number of messages to skip (=0 to search from beginning) (<0 to read index buffer and skip -1-j messages).
[in]jpdsinteger (200) pds parameters for which to search. (=-1 for wildcard).
    +
  • 1): id of center.
    • +
  • 2): generating process id number.
    • +
  • 3): grid definition.
    • +
  • 4): gds/bms flag (right adj copy of octet 8).
    • +
  • 5): indicator of parameter.
    • +
  • 6): type of level.
    • +
  • 7): height/pressure , etc of level.
    • +
  • 8): year including (century-1).
    • +
  • 9): month of year.
    • +
  • 10: day of month.
    • +
  • 11: hour of day.
    • +
  • 12: minute of hour.
    • +
  • 13: indicator of forecast time unit.
    • +
  • 14: time range 1.
    • +
  • 15: time range 2.
    • +
  • 16: time range flag.
    • +
  • 17: number included in average.
    • +
  • 18: version nr of grib specification.
    • +
  • 19: version nr of parameter table.
    • +
  • 20: nr missing from average/accumulation.
    • +
  • 21: century of reference time of data.
    • +
  • 22: units decimal scale factor.
    • +
  • 23: subcenter number.
    • +
  • 24: pds byte 29, for nmc ensemble products.
      +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    +
    • +
  • 25: pds byte 30, not used.
    • +
+
[in]jgdsinteger (200) gds parameters for which to search (only searched if jpds(3)=255) (=-1 for wildcard).
    +
  • 1): data representation type.
    • +
  • 19: number of vertical coordinate parameters.
    • +
  • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
    • +
  • 21: for grids with pl, number of points in grid.
    • +
  • 22: number of words in each row.
    • +
  • Latitude/longitude grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: dj latitudinal direction increment.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    +
    • +
  • Gaussian grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of extreme point.
      • +
    • 8: lo(2) longitude of extreme point.
      • +
    • 9: di longitudinal direction of increment.
      • +
    • 10: n - nr of circles pole to equator.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: nv - nr of vert coord parameters.
      • +
    • 13: pv - octet nr of list of vert coord parameters or pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present
      • +
    +
    • +
  • Polar stereographic grids.
      +
    • 2: n(i) nr points along lat circle.
      • +
    • 3: n(j) nr points along lon circle.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: lov grid orientation.
      • +
    • 8: dx - x direction increment.
      • +
    • 9: dy - y direction increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode (right adj copy of octet 28).
      • +
    +
    • +
  • Spherical harmonic coefficients.
      +
    • 2: j pentagonal resolution parameter.
      • +
    • 3: k pentagonal resolution parameter.
      • +
    • 4: m pentagonal resolution parameter.
      • +
    • 5: representation type.
      • +
    • 6: coefficient storage mode.
      • +
    +
    • +
  • Mercator grids.
      +
    • 2: n(i) nr points on latitude circle.
      • +
    • 3: n(j) nr points on longitude meridian.
      • +
    • 4: la(1) latitude of origin.
      • +
    • 5: lo(1) longitude of origin.
      • +
    • 6: resolution flag (right adj copy of octet 17).
      • +
    • 7: la(2) latitude of last grid point.
      • +
    • 8: lo(2) longitude of last grid point.
      • +
    • 9: latit - latitude of projection intersection.
      • +
    • 10: reserved.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: longitudinal dir grid length.
      • +
    • 13: latitudinal dir grid length.
      • +
    +
    • +
  • Lambert conformal grids.
      +
    • 2): nx nr points along x-axis.
      • +
    • 3): ny nr points along y-axis.
      • +
    • 4): la1 lat of origin (lower left).
      • +
    • 5): lo1 lon of origin (lower left).
      • +
    • 6): resolution (right adj copy of octet 17).
      • +
    • 7): lov - orientation of grid.
      • +
    • 8): dx - x-dir increment.
      • +
    • 9): dy - y-dir increment.
      • +
    • 10: projection center flag.
      • +
    • 11: scanning mode flag (right adj copy of octet 28).
      • +
    • 12: latin 1 - first lat from pole of secant cone inter.
      • +
    • 13: latin 2 - second lat from pole of secant cone inter.
      • +
    +
    • +
+
[out]kginteger number of bytes in the grib message.
[out]kinteger message number unpacked (can be same as j in calling program in order to facilitate multiple searches).
[out]kpdsinteger (200) unpacked pds parameters.
[out]kgdsinteger (200) unpacked gds parameters.
[out]gcharacter*1 (kg) grib message.
[out]iretinteger return code.
    +
  • 0: all ok.
    • +
  • 96: error reading index file.
    • +
  • 97: error reading grib file.
    • +
  • 98: number of bytes greater than jg.
    • +
  • 99: request not found.
    • +
+
+
+
+
Note
In order to unpack grib from a multiprocessing environment where each processor is attempting to read from its own pair of logical units, one must directly call subprogram getgbmp as below, allocating a private copy of cbuf, nlen and nnum to each processor. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1994-04-01
+ +

Definition at line 163 of file getgbp.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgbp_8f.js b/ver-2.10.0/getgbp_8f.js new file mode 100644 index 00000000..349a3607 --- /dev/null +++ b/ver-2.10.0/getgbp_8f.js @@ -0,0 +1,4 @@ +var getgbp_8f = +[ + [ "getgbp", "getgbp_8f.html#afc5ba2c9bbd49e77d7a725bf08bcccfd", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgbp_8f_source.html b/ver-2.10.0/getgbp_8f_source.html new file mode 100644 index 00000000..8d17c2f1 --- /dev/null +++ b/ver-2.10.0/getgbp_8f_source.html @@ -0,0 +1,291 @@ + + + + + + + +NCEPLIBS-w3emc: getgbp.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgbp.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Finds a grib message.
+
3 C> @author Mark Iredell @date 1994-04-01
+
4 
+
5 C> Read a grib index file (or optionally the grib file itself)
+
6 C> to get the index buffer (i.e. table of contents) for the grib file.
+
7 C> (The index buffer is saved for use by future prospective calls.)
+
8 C> Find in the index buffer a reference to the grib message requested.
+
9 C> The grib message request specifies the number of messages to skip
+
10 C> and the unpacked pds and gds parameters. (A requested parameter
+
11 C> of -1 means to allow any value of this parameter to be found.)
+
12 C> If the requested grib message is found, then it is read from the
+
13 C> grib file. Its message number is returned along with the unpacked
+
14 C> pds and gds parameters and the packed grib message. If the grib
+
15 C> message is not found, then the return code will be nonzero.
+
16 C>
+
17 C> Program history log:
+
18 C> - Mark Iredell 1994-04-01
+
19 C> - Mark Iredell 1995-10-31 Modularized portions of code into subprograms
+
20 C> and allowed for unspecified index file.
+
21 C>
+
22 C> @param[in] lugb integer unit of the unblocked grib data file.
+
23 C> @param[in] lugi integer unit of the unblocked grib index file
+
24 C> (=0 to get index buffer from the grib file).
+
25 C> @param[in] jg integer maximum number of bytes in the grib message.
+
26 C> @param[in] j integer number of messages to skip
+
27 C> (=0 to search from beginning)
+
28 C> (<0 to read index buffer and skip -1-j messages).
+
29 C> @param[in] jpds integer (200) pds parameters for which to search.
+
30 C> (=-1 for wildcard).
+
31 C> - 1): id of center.
+
32 C> - 2): generating process id number.
+
33 C> - 3): grid definition.
+
34 C> - 4): gds/bms flag (right adj copy of octet 8).
+
35 C> - 5): indicator of parameter.
+
36 C> - 6): type of level.
+
37 C> - 7): height/pressure , etc of level.
+
38 C> - 8): year including (century-1).
+
39 C> - 9): month of year.
+
40 C> - 10: day of month.
+
41 C> - 11: hour of day.
+
42 C> - 12: minute of hour.
+
43 C> - 13: indicator of forecast time unit.
+
44 C> - 14: time range 1.
+
45 C> - 15: time range 2.
+
46 C> - 16: time range flag.
+
47 C> - 17: number included in average.
+
48 C> - 18: version nr of grib specification.
+
49 C> - 19: version nr of parameter table.
+
50 C> - 20: nr missing from average/accumulation.
+
51 C> - 21: century of reference time of data.
+
52 C> - 22: units decimal scale factor.
+
53 C> - 23: subcenter number.
+
54 C> - 24: pds byte 29, for nmc ensemble products.
+
55 C> - 128 if forecast field error.
+
56 C> - 64 if bias corrected fcst field.
+
57 C> - 32 if smoothed field.
+
58 C> - warning: can be combination of more than 1.
+
59 C> - 25: pds byte 30, not used.
+
60 C> @param[in] jgds integer (200) gds parameters for which to search
+
61 C> (only searched if jpds(3)=255)
+
62 C> (=-1 for wildcard).
+
63 C> - 1): data representation type.
+
64 C> - 19: number of vertical coordinate parameters.
+
65 C> - 20: octet number of the list of vertical coordinate parameters or
+
66 C> octet number of the list of numbers of points in each row or
+
67 C> 255 if neither are present.
+
68 C> - 21: for grids with pl, number of points in grid.
+
69 C> - 22: number of words in each row.
+
70 C> - Latitude/longitude grids.
+
71 C> - 2: n(i) nr points on latitude circle.
+
72 C> - 3: n(j) nr points on longitude meridian.
+
73 C> - 4: la(1) latitude of origin.
+
74 C> - 5: lo(1) longitude of origin.
+
75 C> - 6: resolution flag (right adj copy of octet 17).
+
76 C> - 7: la(2) latitude of extreme point.
+
77 C> - 8: lo(2) longitude of extreme point.
+
78 C> - 9: di longitudinal direction of increment.
+
79 C> - 10: dj latitudinal direction increment.
+
80 C> - 11: scanning mode flag (right adj copy of octet 28).
+
81 C> - Gaussian grids.
+
82 C> - 2: n(i) nr points on latitude circle.
+
83 C> - 3: n(j) nr points on longitude meridian.
+
84 C> - 4: la(1) latitude of origin.
+
85 C> - 5: lo(1) longitude of origin.
+
86 C> - 6: resolution flag (right adj copy of octet 17).
+
87 C> - 7: la(2) latitude of extreme point.
+
88 C> - 8: lo(2) longitude of extreme point.
+
89 C> - 9: di longitudinal direction of increment.
+
90 C> - 10: n - nr of circles pole to equator.
+
91 C> - 11: scanning mode flag (right adj copy of octet 28).
+
92 C> - 12: nv - nr of vert coord parameters.
+
93 C> - 13: pv - octet nr of list of vert coord parameters or
+
94 C> pl - location of the list of numbers of points in each row
+
95 C> (if no vert coord parameters are present) or
+
96 C> 255 if neither are present
+
97 C> - Polar stereographic grids.
+
98 C> - 2: n(i) nr points along lat circle.
+
99 C> - 3: n(j) nr points along lon circle.
+
100 C> - 4: la(1) latitude of origin.
+
101 C> - 5: lo(1) longitude of origin.
+
102 C> - 6: resolution flag (right adj copy of octet 17).
+
103 C> - 7: lov grid orientation.
+
104 C> - 8: dx - x direction increment.
+
105 C> - 9: dy - y direction increment.
+
106 C> - 10: projection center flag.
+
107 C> - 11: scanning mode (right adj copy of octet 28).
+
108 C> - Spherical harmonic coefficients.
+
109 C> - 2: j pentagonal resolution parameter.
+
110 C> - 3: k pentagonal resolution parameter.
+
111 C> - 4: m pentagonal resolution parameter.
+
112 C> - 5: representation type.
+
113 C> - 6: coefficient storage mode.
+
114 C> - Mercator grids.
+
115 C> - 2: n(i) nr points on latitude circle.
+
116 C> - 3: n(j) nr points on longitude meridian.
+
117 C> - 4: la(1) latitude of origin.
+
118 C> - 5: lo(1) longitude of origin.
+
119 C> - 6: resolution flag (right adj copy of octet 17).
+
120 C> - 7: la(2) latitude of last grid point.
+
121 C> - 8: lo(2) longitude of last grid point.
+
122 C> - 9: latit - latitude of projection intersection.
+
123 C> - 10: reserved.
+
124 C> - 11: scanning mode flag (right adj copy of octet 28).
+
125 C> - 12: longitudinal dir grid length.
+
126 C> - 13: latitudinal dir grid length.
+
127 C> - Lambert conformal grids.
+
128 C> - 2): nx nr points along x-axis.
+
129 C> - 3): ny nr points along y-axis.
+
130 C> - 4): la1 lat of origin (lower left).
+
131 C> - 5): lo1 lon of origin (lower left).
+
132 C> - 6): resolution (right adj copy of octet 17).
+
133 C> - 7): lov - orientation of grid.
+
134 C> - 8): dx - x-dir increment.
+
135 C> - 9): dy - y-dir increment.
+
136 C> - 10: projection center flag.
+
137 C> - 11: scanning mode flag (right adj copy of octet 28).
+
138 C> - 12: latin 1 - first lat from pole of secant cone inter.
+
139 C> - 13: latin 2 - second lat from pole of secant cone inter.
+
140 C> @param[out] kg integer number of bytes in the grib message.
+
141 C> @param[out] k integer message number unpacked
+
142 C> (can be same as j in calling program in order to facilitate multiple searches).
+
143 C> @param[out] kpds integer (200) unpacked pds parameters.
+
144 C> @param[out] kgds integer (200) unpacked gds parameters.
+
145 C> @param[out] g character*1 (kg) grib message.
+
146 C> @param[out] iret integer return code.
+
147 C> - 0: all ok.
+
148 C> - 96: error reading index file.
+
149 C> - 97: error reading grib file.
+
150 C> - 98: number of bytes greater than jg.
+
151 C> - 99: request not found.
+
152 C>
+
153 C> @note In order to unpack grib from a multiprocessing environment
+
154 C> where each processor is attempting to read from its own pair of
+
155 C> logical units, one must directly call subprogram getgbmp as below,
+
156 C> allocating a private copy of cbuf, nlen and nnum to each processor.
+
157 C> Do not engage the same logical unit from more than one processor.
+
158 C>
+
159 C> @author Mark Iredell @date 1994-04-01
+
160 C-----------------------------------------------------------------------
+
161  SUBROUTINE getgbp(LUGB,LUGI,JG,J,JPDS,JGDS,
+
162  & KG,K,KPDS,KGDS,G,IRET)
+
163  INTEGER JPDS(200),JGDS(200),KPDS(200),KGDS(200)
+
164  CHARACTER G(JG)
+
165  parameter(mbuf=256*1024)
+
166  CHARACTER CBUF(MBUF)
+
167  SAVE cbuf,nlen,nnum,mnum
+
168  DATA lux/0/
+
169 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
170 C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED
+
171  IF(lugi.GT.0.AND.(j.LT.0.OR.lugi.NE.lux)) THEN
+
172  lux=lugi
+
173  jj=min(j,-1-j)
+
174  ELSEIF(lugi.LE.0.AND.(j.LT.0.OR.lugb.NE.lux)) THEN
+
175  lux=lugb
+
176  jj=min(j,-1-j)
+
177  ELSE
+
178  jj=j
+
179  ENDIF
+
180 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
181 C FIND AND UNPACK GRIB MESSAGE
+
182  CALL getgbmp(lugb,lugi,jg,jj,jpds,jgds,
+
183  & mbuf,cbuf,nlen,nnum,mnum,
+
184  & kg,k,kpds,kgds,g,iret)
+
185  IF(iret.EQ.96) lux=0
+
186 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
187  RETURN
+
188  END
+
+
+
getgbp
subroutine getgbp(LUGB, LUGI, JG, J, JPDS, JGDS, KG, K, KPDS, KGDS, G, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbp.f:163
+
getgbmp
subroutine getgbmp(LUGB, LUGI, JG, J, JPDS, JGDS, MBUF, CBUF, NLEN, NNUM, MNUM, KG, K, KPDS, KGDS, G, IRET)
Read a grib index file (or optionally the grib file itself) to get the index buffer (i....
Definition: getgbmp.f:170
+ + + + diff --git a/ver-2.10.0/getgi_8f.html b/ver-2.10.0/getgi_8f.html new file mode 100644 index 00000000..d9963b1a --- /dev/null +++ b/ver-2.10.0/getgi_8f.html @@ -0,0 +1,225 @@ + + + + + + + +NCEPLIBS-w3emc: getgi.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgi.f File Reference
+
+
+ +

Read a grib index file and return its contents. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgi (LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
 Read a grib index file and return its contents. More...
 
+

Detailed Description

+

Read a grib index file and return its contents.

+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition in file getgi.f.

+

Function/Subroutine Documentation

+ +

◆ getgi()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgi ( LUGI,
 MNUM,
 MBUF,
character, dimension(mbuf) CBUF,
 NLEN,
 NNUM,
 IRET 
)
+
+ +

Read a grib index file and return its contents.

+

Version 1 of the index file has the following format: 81-byte s.lord header with 'gb1ix1' in columns 42-47 followed by 81-byte header with number of bytes to skip before index records, number of bytes in each index record, number of index records, and grib file basename written in format ('ix1form:',3i10,2x,a40). Each following index record corresponds to a grib message and has the internal format:

    +
  • byte 001-004: bytes to skip in data file before grib message.
    • +
  • byte 005-008: bytes to skip in message before pds.
    • +
  • byte 009-012: bytes to skip in message before gds (0 if no gds).
    • +
  • byte 013-016: bytes to skip in message before bms (0 if no bms).
    • +
  • byte 017-020: bytes to skip in message before bds.
    • +
  • byte 021-024: bytes total in the message.
    • +
  • byte 025-025: grib version number.
    • +
  • byte 026-053: product definition section (pds).
    • +
  • byte 054-095: grid definition section (gds) (or nulls).
    • +
  • byte 096-101: first part of the bit map section (bms) (or nulls).
    • +
  • byte 102-112: first part of the binary data section (bds).
    • +
  • byte 113-172: (optional) bytes 41-100 of the pds.
    • +
  • byte 173-184: (optional) bytes 29-40 of the pds.
    • +
  • byte 185-320: (optional) bytes 43-178 of the gds.
    • +
+

Program history log:

    +
  • Mark Iredell 1995-10-31
    • +
  • Mark Iredell 1996-10-31 Augmented optional definitions to byte 320.
    • +
+
Parameters
+ + + + + + + + +
[in]lugiinteger unit of the unblocked grib index file.
[in]mnuminteger number of index records to skip (usually 0).
[in]mbufinteger length of cbuf in bytes.
[out]cbufcharacter*1 (mbuf) buffer to receive index data.
[out]nleninteger length of each index record in bytes.
[out]nnuminteger number of index records.
[out]iretinteger return code.
    +
  • 0: all ok.
    • +
  • 1: cbuf too small to hold index buffer.
    • +
  • 2: error reading index file buffer.
    • +
  • 3: error reading index file header.
    • +
+
+
+
+
Note
Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition at line 50 of file getgi.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgi_8f.js b/ver-2.10.0/getgi_8f.js new file mode 100644 index 00000000..b1e5a660 --- /dev/null +++ b/ver-2.10.0/getgi_8f.js @@ -0,0 +1,4 @@ +var getgi_8f = +[ + [ "getgi", "getgi_8f.html#aa6b511267e410648a9961a1aa2e4d27f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgi_8f_source.html b/ver-2.10.0/getgi_8f_source.html new file mode 100644 index 00000000..473fb73a --- /dev/null +++ b/ver-2.10.0/getgi_8f_source.html @@ -0,0 +1,179 @@ + + + + + + + +NCEPLIBS-w3emc: getgi.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgi.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Read a grib index file and return its contents.
+
3 C> @author Mark Iredell @date 1995-10-31
+
4 
+
5 C> Read a grib index file and return its contents.
+
6 C> Version 1 of the index file has the following format:
+
7 C> 81-byte s.lord header with 'gb1ix1' in columns 42-47 followed by
+
8 C> 81-byte header with number of bytes to skip before index records,
+
9 C> number of bytes in each index record, number of index records,
+
10 C> and grib file basename written in format ('ix1form:',3i10,2x,a40).
+
11 C> Each following index record corresponds to a grib message
+
12 C> and has the internal format:
+
13 C> - byte 001-004: bytes to skip in data file before grib message.
+
14 C> - byte 005-008: bytes to skip in message before pds.
+
15 C> - byte 009-012: bytes to skip in message before gds (0 if no gds).
+
16 C> - byte 013-016: bytes to skip in message before bms (0 if no bms).
+
17 C> - byte 017-020: bytes to skip in message before bds.
+
18 C> - byte 021-024: bytes total in the message.
+
19 C> - byte 025-025: grib version number.
+
20 C> - byte 026-053: product definition section (pds).
+
21 C> - byte 054-095: grid definition section (gds) (or nulls).
+
22 C> - byte 096-101: first part of the bit map section (bms) (or nulls).
+
23 C> - byte 102-112: first part of the binary data section (bds).
+
24 C> - byte 113-172: (optional) bytes 41-100 of the pds.
+
25 C> - byte 173-184: (optional) bytes 29-40 of the pds.
+
26 C> - byte 185-320: (optional) bytes 43-178 of the gds.
+
27 C>
+
28 C> Program history log:
+
29 C> - Mark Iredell 1995-10-31
+
30 C> - Mark Iredell 1996-10-31 Augmented optional definitions to byte 320.
+
31 C>
+
32 C> @param[in] lugi integer unit of the unblocked grib index file.
+
33 C> @param[in] mnum integer number of index records to skip (usually 0).
+
34 C> @param[in] mbuf integer length of cbuf in bytes.
+
35 C> @param[out] cbuf character*1 (mbuf) buffer to receive index data.
+
36 C> @param[out] nlen integer length of each index record in bytes.
+
37 C> @param[out] nnum integer number of index records.
+
38 C> @param[out] iret integer return code.
+
39 C> - 0: all ok.
+
40 C> - 1: cbuf too small to hold index buffer.
+
41 C> - 2: error reading index file buffer.
+
42 C> - 3: error reading index file header.
+
43 C>
+
44 C> @note Subprogram can be called from a multiprocessing environment.
+
45 C> Do not engage the same logical unit from more than one processor.
+
46 C>
+
47 C> @author Mark Iredell @date 1995-10-31
+
48 C-----------------------------------------------------------------------
+
49  SUBROUTINE getgi(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRET)
+
50  CHARACTER CBUF(MBUF)
+
51  CHARACTER CHEAD*162
+
52 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
53  nlen=0
+
54  nnum=0
+
55  iret=3
+
56  CALL baread(lugi,0,162,lhead,chead)
+
57  IF(lhead.EQ.162.AND.chead(42:47).EQ.'GB1IX1') THEN
+
58  READ(chead(82:162),'(8X,3I10,2X,A40)',iostat=ios) nskp,nlen,nnum
+
59  IF(ios.EQ.0) THEN
+
60  nskp=nskp+mnum*nlen
+
61  nnum=nnum-mnum
+
62  nbuf=nnum*nlen
+
63  iret=0
+
64  IF(nbuf.GT.mbuf) THEN
+
65  nnum=mbuf/nlen
+
66  nbuf=nnum*nlen
+
67  iret=1
+
68  ENDIF
+
69  IF(nbuf.GT.0) THEN
+
70  CALL baread(lugi,nskp,nbuf,lbuf,cbuf)
+
71  IF(lbuf.NE.nbuf) iret=2
+
72  ENDIF
+
73  ENDIF
+
74  ENDIF
+
75 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
76  RETURN
+
77  END
+
+
+
getgi
subroutine getgi(LUGI, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib index file and return its contents.
Definition: getgi.f:50
+ + + + diff --git a/ver-2.10.0/getgir_8f.html b/ver-2.10.0/getgir_8f.html new file mode 100644 index 00000000..00230a0d --- /dev/null +++ b/ver-2.10.0/getgir_8f.html @@ -0,0 +1,237 @@ + + + + + + + +NCEPLIBS-w3emc: getgir.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
getgir.f File Reference
+
+
+ +

Read a grib index file and return its index contents. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine getgir (LUGB, MSK1, MSK2, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
 Read a grib file and return its index contents. More...
 
+

Detailed Description

+

Read a grib index file and return its index contents.

+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition in file getgir.f.

+

Function/Subroutine Documentation

+ +

◆ getgir()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine getgir ( LUGB,
 MSK1,
 MSK2,
 MNUM,
 MBUF,
character, dimension(mbuf) CBUF,
 NLEN,
 NNUM,
 IRET 
)
+
+ +

Read a grib file and return its index contents.

+

The index buffer returned contains index records with the internal format:

    +
  • byte 001-004: bytes to skip in data file before grib message.
    • +
  • byte 005-008: bytes to skip in message before pds.
    • +
  • byte 009-012: bytes to skip in message before gds (0 if no gds).
    • +
  • byte 013-016: bytes to skip in message before bms (0 if no bms).
    • +
  • byte 017-020: bytes to skip in message before bds.
    • +
  • byte 021-024: bytes total in the message.
    • +
  • byte 025-025: grib version number.
    • +
  • byte 026-053: product definition section (pds).
    • +
  • byte 054-095: grid definition section (gds) (or nulls).
    • +
  • byte 096-101: first part of the bit map section (bms) (or nulls).
    • +
  • byte 102-112: first part of the binary data section (bds).
    • +
  • byte 113-172: (optional) bytes 41-100 of the pds.
    • +
  • byte 173-184: (optional) bytes 29-40 of the pds.
    • +
  • byte 185-320: (optional) bytes 43-178 of the gds.
    • +
+

Program history log:

    +
  • Mark Iredell 1995-10-31
    • +
  • Mark Iredell 1996-10-31 Augmented optional definitions to byte 320.
    • +
+
Parameters
+ + + + + + + + + + +
[in]lugbinteger unit of the unblocked grib file.
[in]msk1integer number of bytes to search for first message.
[in]msk2integer number of bytes to search for other messages.
[in]mnuminteger number of index records to skip (usually 0).
[in]mbufinteger length of cbuf in bytes.
[out]cbufcharacter*1 (mbuf) buffer to receive index data.
[out]nleninteger length of each index record in bytes.
[out]nnuminteger number of index records (=0 if no grib messages are found).
[out]iretinteger return code.
    +
  • 0: all ok.
    • +
  • 1: cbuf too small to hold index data.
    • +
+
+
+
+
Note
Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
+
Author
Mark Iredell
+
Date
1995-10-31
+ +

Definition at line 45 of file getgir.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/getgir_8f.js b/ver-2.10.0/getgir_8f.js new file mode 100644 index 00000000..92a1afe8 --- /dev/null +++ b/ver-2.10.0/getgir_8f.js @@ -0,0 +1,4 @@ +var getgir_8f = +[ + [ "getgir", "getgir_8f.html#abcd2305cabdf6bb6a000fbb948c608a1", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/getgir_8f_source.html b/ver-2.10.0/getgir_8f_source.html new file mode 100644 index 00000000..168024ae --- /dev/null +++ b/ver-2.10.0/getgir_8f_source.html @@ -0,0 +1,182 @@ + + + + + + + +NCEPLIBS-w3emc: getgir.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
getgir.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Read a grib index file and return its index contents.
+
3 C> @author Mark Iredell @date 1995-10-31
+
4 
+
5 C> Read a grib file and return its index contents.
+
6 C> The index buffer returned contains index records with the internal format:
+
7 C> - byte 001-004: bytes to skip in data file before grib message.
+
8 C> - byte 005-008: bytes to skip in message before pds.
+
9 C> - byte 009-012: bytes to skip in message before gds (0 if no gds).
+
10 C> - byte 013-016: bytes to skip in message before bms (0 if no bms).
+
11 C> - byte 017-020: bytes to skip in message before bds.
+
12 C> - byte 021-024: bytes total in the message.
+
13 C> - byte 025-025: grib version number.
+
14 C> - byte 026-053: product definition section (pds).
+
15 C> - byte 054-095: grid definition section (gds) (or nulls).
+
16 C> - byte 096-101: first part of the bit map section (bms) (or nulls).
+
17 C> - byte 102-112: first part of the binary data section (bds).
+
18 C> - byte 113-172: (optional) bytes 41-100 of the pds.
+
19 C> - byte 173-184: (optional) bytes 29-40 of the pds.
+
20 C> - byte 185-320: (optional) bytes 43-178 of the gds.
+
21 C>
+
22 C> Program history log:
+
23 C> - Mark Iredell 1995-10-31
+
24 C> - Mark Iredell 1996-10-31 Augmented optional definitions to byte 320.
+
25 C>
+
26 C> @param[in] lugb integer unit of the unblocked grib file.
+
27 C> @param[in] msk1 integer number of bytes to search for first message.
+
28 C> @param[in] msk2 integer number of bytes to search for other messages.
+
29 C> @param[in] mnum integer number of index records to skip (usually 0).
+
30 C> @param[in] mbuf integer length of cbuf in bytes.
+
31 C> @param[out] cbuf character*1 (mbuf) buffer to receive index data.
+
32 C> @param[out] nlen integer length of each index record in bytes.
+
33 C> @param[out] nnum integer number of index records
+
34 C> (=0 if no grib messages are found).
+
35 C> @param[out] iret integer return code.
+
36 C> - 0: all ok.
+
37 C> - 1: cbuf too small to hold index data.
+
38 C>
+
39 C> @note Subprogram can be called from a multiprocessing environment.
+
40 C> Do not engage the same logical unit from more than one processor.
+
41 C>
+
42 C> @author Mark Iredell @date 1995-10-31
+
43 C-----------------------------------------------------------------------
+
44  SUBROUTINE getgir(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRET)
+
45  CHARACTER CBUF(MBUF)
+
46  parameter(mindex=320)
+
47 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
48 C SEARCH FOR FIRST GRIB MESSAGE
+
49  iseek=0
+
50  CALL skgb(lugb,iseek,msk1,lskip,lgrib)
+
51  IF(lgrib.GT.0.AND.mindex.LE.mbuf) THEN
+
52  CALL ixgb(lugb,lskip,lgrib,mindex,1,nlen,cbuf)
+
53  ELSE
+
54  nlen=mindex
+
55  ENDIF
+
56  DO m=1,mnum
+
57  IF(lgrib.GT.0) THEN
+
58  iseek=lskip+lgrib
+
59  CALL skgb(lugb,iseek,msk2,lskip,lgrib)
+
60  ENDIF
+
61  ENDDO
+
62 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
63 C MAKE AN INDEX RECORD FOR EVERY GRIB RECORD FOUND
+
64  nnum=0
+
65  iret=0
+
66  dowhile(iret.EQ.0.AND.lgrib.GT.0)
+
67  IF(nlen*(nnum+1).LE.mbuf) THEN
+
68  nnum=nnum+1
+
69  CALL ixgb(lugb,lskip,lgrib,nlen,nnum,mlen,cbuf)
+
70  iseek=lskip+lgrib
+
71  CALL skgb(lugb,iseek,msk2,lskip,lgrib)
+
72  ELSE
+
73  iret=1
+
74  ENDIF
+
75  ENDDO
+
76 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
77  RETURN
+
78  END
+
+
+
ixgb
subroutine ixgb(LUGB, LSKIP, LGRIB, NLEN, NNUM, MLEN, CBUF)
Byte 001-004: Bytes to skip in data file before grib message.
Definition: ixgb.f:36
+
getgir
subroutine getgir(LUGB, MSK1, MSK2, MNUM, MBUF, CBUF, NLEN, NNUM, IRET)
Read a grib file and return its index contents.
Definition: getgir.f:45
+
skgb
subroutine skgb(LUGB, ISEEK, MSEEK, LSKIP, LGRIB)
This subprogram searches a file for the next grib 1 message.
Definition: skgb.f:27
+ + + + diff --git a/ver-2.10.0/globals.html b/ver-2.10.0/globals.html new file mode 100644 index 00000000..3d9fe414 --- /dev/null +++ b/ver-2.10.0/globals.html @@ -0,0 +1,127 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- a -

+
+
+ + + + diff --git a/ver-2.10.0/globals_b.html b/ver-2.10.0/globals_b.html new file mode 100644 index 00000000..4c1dc86b --- /dev/null +++ b/ver-2.10.0/globals_b.html @@ -0,0 +1,103 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- b -

+
+
+ + + + diff --git a/ver-2.10.0/globals_c.html b/ver-2.10.0/globals_c.html new file mode 100644 index 00000000..c032532c --- /dev/null +++ b/ver-2.10.0/globals_c.html @@ -0,0 +1,109 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- c -

+
+
+ + + + diff --git a/ver-2.10.0/globals_dup.js b/ver-2.10.0/globals_dup.js new file mode 100644 index 00000000..0b557117 --- /dev/null +++ b/ver-2.10.0/globals_dup.js @@ -0,0 +1,21 @@ +var globals_dup = +[ + [ "a", "globals.html", null ], + [ "b", "globals_b.html", null ], + [ "c", "globals_c.html", null ], + [ "e", "globals_e.html", null ], + [ "f", "globals_f.html", null ], + [ "g", "globals_g.html", null ], + [ "i", "globals_i.html", null ], + [ "l", "globals_l.html", null ], + [ "m", "globals_m.html", null ], + [ "o", "globals_o.html", null ], + [ "p", "globals_p.html", null ], + [ "q", "globals_q.html", null ], + [ "r", "globals_r.html", null ], + [ "s", "globals_s.html", null ], + [ "u", "globals_u.html", null ], + [ "v", "globals_v.html", null ], + [ "w", "globals_w.html", null ], + [ "x", "globals_x.html", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/globals_e.html b/ver-2.10.0/globals_e.html new file mode 100644 index 00000000..102d6781 --- /dev/null +++ b/ver-2.10.0/globals_e.html @@ -0,0 +1,112 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- e -

+
+
+ + + + diff --git a/ver-2.10.0/globals_f.html b/ver-2.10.0/globals_f.html new file mode 100644 index 00000000..79688501 --- /dev/null +++ b/ver-2.10.0/globals_f.html @@ -0,0 +1,277 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- f -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func.html b/ver-2.10.0/globals_func.html new file mode 100644 index 00000000..9cf715f6 --- /dev/null +++ b/ver-2.10.0/globals_func.html @@ -0,0 +1,127 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- a -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func.js b/ver-2.10.0/globals_func.js new file mode 100644 index 00000000..4e519869 --- /dev/null +++ b/ver-2.10.0/globals_func.js @@ -0,0 +1,21 @@ +var globals_func = +[ + [ "a", "globals_func.html", null ], + [ "b", "globals_func_b.html", null ], + [ "c", "globals_func_c.html", null ], + [ "e", "globals_func_e.html", null ], + [ "f", "globals_func_f.html", null ], + [ "g", "globals_func_g.html", null ], + [ "i", "globals_func_i.html", null ], + [ "l", "globals_func_l.html", null ], + [ "m", "globals_func_m.html", null ], + [ "o", "globals_func_o.html", null ], + [ "p", "globals_func_p.html", null ], + [ "q", "globals_func_q.html", null ], + [ "r", "globals_func_r.html", null ], + [ "s", "globals_func_s.html", null ], + [ "u", "globals_func_u.html", null ], + [ "v", "globals_func_v.html", null ], + [ "w", "globals_func_w.html", null ], + [ "x", "globals_func_x.html", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/globals_func_b.html b/ver-2.10.0/globals_func_b.html new file mode 100644 index 00000000..c94ae600 --- /dev/null +++ b/ver-2.10.0/globals_func_b.html @@ -0,0 +1,103 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- b -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_c.html b/ver-2.10.0/globals_func_c.html new file mode 100644 index 00000000..061763ee --- /dev/null +++ b/ver-2.10.0/globals_func_c.html @@ -0,0 +1,109 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- c -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_e.html b/ver-2.10.0/globals_func_e.html new file mode 100644 index 00000000..5d904ade --- /dev/null +++ b/ver-2.10.0/globals_func_e.html @@ -0,0 +1,112 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- e -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_f.html b/ver-2.10.0/globals_func_f.html new file mode 100644 index 00000000..19590a3d --- /dev/null +++ b/ver-2.10.0/globals_func_f.html @@ -0,0 +1,277 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- f -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_g.html b/ver-2.10.0/globals_func_g.html new file mode 100644 index 00000000..b3670856 --- /dev/null +++ b/ver-2.10.0/globals_func_g.html @@ -0,0 +1,181 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- g -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_i.html b/ver-2.10.0/globals_func_i.html new file mode 100644 index 00000000..857120e5 --- /dev/null +++ b/ver-2.10.0/globals_func_i.html @@ -0,0 +1,133 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- i -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_l.html b/ver-2.10.0/globals_func_l.html new file mode 100644 index 00000000..237227e4 --- /dev/null +++ b/ver-2.10.0/globals_func_l.html @@ -0,0 +1,112 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- l -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_m.html b/ver-2.10.0/globals_func_m.html new file mode 100644 index 00000000..b96ba7c6 --- /dev/null +++ b/ver-2.10.0/globals_func_m.html @@ -0,0 +1,124 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- m -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_o.html b/ver-2.10.0/globals_func_o.html new file mode 100644 index 00000000..d1f569ba --- /dev/null +++ b/ver-2.10.0/globals_func_o.html @@ -0,0 +1,103 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- o -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_p.html b/ver-2.10.0/globals_func_p.html new file mode 100644 index 00000000..56edc2f0 --- /dev/null +++ b/ver-2.10.0/globals_func_p.html @@ -0,0 +1,127 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- p -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_q.html b/ver-2.10.0/globals_func_q.html new file mode 100644 index 00000000..8312fb0d --- /dev/null +++ b/ver-2.10.0/globals_func_q.html @@ -0,0 +1,109 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- q -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_r.html b/ver-2.10.0/globals_func_r.html new file mode 100644 index 00000000..59334df1 --- /dev/null +++ b/ver-2.10.0/globals_func_r.html @@ -0,0 +1,118 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- r -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_s.html b/ver-2.10.0/globals_func_s.html new file mode 100644 index 00000000..42655e58 --- /dev/null +++ b/ver-2.10.0/globals_func_s.html @@ -0,0 +1,127 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- s -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_u.html b/ver-2.10.0/globals_func_u.html new file mode 100644 index 00000000..20330aa9 --- /dev/null +++ b/ver-2.10.0/globals_func_u.html @@ -0,0 +1,127 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- u -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_v.html b/ver-2.10.0/globals_func_v.html new file mode 100644 index 00000000..1200160a --- /dev/null +++ b/ver-2.10.0/globals_func_v.html @@ -0,0 +1,103 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- v -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_w.html b/ver-2.10.0/globals_func_w.html new file mode 100644 index 00000000..ef256cd1 --- /dev/null +++ b/ver-2.10.0/globals_func_w.html @@ -0,0 +1,523 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- w -

+
+
+ + + + diff --git a/ver-2.10.0/globals_func_x.html b/ver-2.10.0/globals_func_x.html new file mode 100644 index 00000000..abf16da1 --- /dev/null +++ b/ver-2.10.0/globals_func_x.html @@ -0,0 +1,109 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+  + +

- x -

+
+
+ + + + diff --git a/ver-2.10.0/globals_g.html b/ver-2.10.0/globals_g.html new file mode 100644 index 00000000..c0432783 --- /dev/null +++ b/ver-2.10.0/globals_g.html @@ -0,0 +1,181 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- g -

+
+
+ + + + diff --git a/ver-2.10.0/globals_i.html b/ver-2.10.0/globals_i.html new file mode 100644 index 00000000..93805ed1 --- /dev/null +++ b/ver-2.10.0/globals_i.html @@ -0,0 +1,133 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- i -

+
+
+ + + + diff --git a/ver-2.10.0/globals_l.html b/ver-2.10.0/globals_l.html new file mode 100644 index 00000000..438f3979 --- /dev/null +++ b/ver-2.10.0/globals_l.html @@ -0,0 +1,112 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- l -

+
+
+ + + + diff --git a/ver-2.10.0/globals_m.html b/ver-2.10.0/globals_m.html new file mode 100644 index 00000000..d0c2126e --- /dev/null +++ b/ver-2.10.0/globals_m.html @@ -0,0 +1,124 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- m -

+
+
+ + + + diff --git a/ver-2.10.0/globals_o.html b/ver-2.10.0/globals_o.html new file mode 100644 index 00000000..c42d58e2 --- /dev/null +++ b/ver-2.10.0/globals_o.html @@ -0,0 +1,103 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- o -

+
+
+ + + + diff --git a/ver-2.10.0/globals_p.html b/ver-2.10.0/globals_p.html new file mode 100644 index 00000000..822e587d --- /dev/null +++ b/ver-2.10.0/globals_p.html @@ -0,0 +1,127 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- p -

+
+
+ + + + diff --git a/ver-2.10.0/globals_q.html b/ver-2.10.0/globals_q.html new file mode 100644 index 00000000..71f69012 --- /dev/null +++ b/ver-2.10.0/globals_q.html @@ -0,0 +1,109 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- q -

+
+
+ + + + diff --git a/ver-2.10.0/globals_r.html b/ver-2.10.0/globals_r.html new file mode 100644 index 00000000..f61720fe --- /dev/null +++ b/ver-2.10.0/globals_r.html @@ -0,0 +1,118 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- r -

+
+
+ + + + diff --git a/ver-2.10.0/globals_s.html b/ver-2.10.0/globals_s.html new file mode 100644 index 00000000..a5ed455e --- /dev/null +++ b/ver-2.10.0/globals_s.html @@ -0,0 +1,127 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- s -

+
+
+ + + + diff --git a/ver-2.10.0/globals_u.html b/ver-2.10.0/globals_u.html new file mode 100644 index 00000000..d0959e87 --- /dev/null +++ b/ver-2.10.0/globals_u.html @@ -0,0 +1,127 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- u -

+
+
+ + + + diff --git a/ver-2.10.0/globals_v.html b/ver-2.10.0/globals_v.html new file mode 100644 index 00000000..ebe8d185 --- /dev/null +++ b/ver-2.10.0/globals_v.html @@ -0,0 +1,103 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- v -

+
+
+ + + + diff --git a/ver-2.10.0/globals_w.html b/ver-2.10.0/globals_w.html new file mode 100644 index 00000000..25db7197 --- /dev/null +++ b/ver-2.10.0/globals_w.html @@ -0,0 +1,523 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- w -

+
+
+ + + + diff --git a/ver-2.10.0/globals_x.html b/ver-2.10.0/globals_x.html new file mode 100644 index 00000000..1dd95ae2 --- /dev/null +++ b/ver-2.10.0/globals_x.html @@ -0,0 +1,109 @@ + + + + + + + +NCEPLIBS-w3emc: Globals + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
Here is a list of all documented functions, variables, defines, enums, and typedefs with links to the documentation:
+ +

- x -

+
+
+ + + + diff --git a/ver-2.10.0/gtbits_8f.html b/ver-2.10.0/gtbits_8f.html new file mode 100644 index 00000000..d0c1a287 --- /dev/null +++ b/ver-2.10.0/gtbits_8f.html @@ -0,0 +1,216 @@ + + + + + + + +NCEPLIBS-w3emc: gtbits.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
gtbits.f File Reference
+
+
+ +

The number of bits required to pack a given field. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine gtbits (IBM, IDS, LEN, MG, G, GROUND, GMIN, GMAX, NBIT)
 The number of bits required to pack a given field at a particular decimal scaling is computed using the field range. More...
 
+

Detailed Description

+

The number of bits required to pack a given field.

+
Author
Mark Iredell
+
Date
1992-10-31
+ +

Definition in file gtbits.f.

+

Function/Subroutine Documentation

+ +

◆ gtbits()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine gtbits ( IBM,
 IDS,
 LEN,
dimension(len) MG,
dimension(len) G,
dimension(len) GROUND,
 GMIN,
 GMAX,
 NBIT 
)
+
+ +

The number of bits required to pack a given field at a particular decimal scaling is computed using the field range.

+

The field is rounded off to the decimal scaling for packing. The minimum and maximum rounded field values are also returned. Grib bitmap masking for valid data is optionally used.

+

Program history log:

    +
  • Mark Iredell 1992-10-31
    • +
+
Parameters
+ + + + + + + + + + +
[in]ibminteger bitmap flag (=0 for no bitmap).
[in]idsinteger decimal scaling (e.g. ids=3 to round field to nearest milli-value).
[in]leninteger length of the field and bitmap.
[in]mginteger (len) bitmap if ibm=1 (0 to skip, 1 to keep).
[in]greal (len) field.
[out]groundreal (len) field rounded to decimal scaling (set to zero where bitmap is 0 if ibm=1).
[out]gminreal minimum valid rounded field value.
[out]gmaxreal maximum valid rounded field value.
[out]nbitinteger number of bits to pack.
+
+
+
Author
Mark Iredell
+
Date
1992-10-31
+ +

Definition at line 28 of file gtbits.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/gtbits_8f.js b/ver-2.10.0/gtbits_8f.js new file mode 100644 index 00000000..c278be66 --- /dev/null +++ b/ver-2.10.0/gtbits_8f.js @@ -0,0 +1,4 @@ +var gtbits_8f = +[ + [ "gtbits", "gtbits_8f.html#a31c0ebc8937002fb7b104298f8c439ec", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/gtbits_8f_source.html b/ver-2.10.0/gtbits_8f_source.html new file mode 100644 index 00000000..fc4a2352 --- /dev/null +++ b/ver-2.10.0/gtbits_8f_source.html @@ -0,0 +1,175 @@ + + + + + + + +NCEPLIBS-w3emc: gtbits.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
gtbits.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief The number of bits required to pack a given field.
+
3 C> @author Mark Iredell @date 1992-10-31
+
4 
+
5 C> The number of bits required to pack a given field
+
6 c> at a particular decimal scaling is computed using the field range.
+
7 C> The field is rounded off to the decimal scaling for packing.
+
8 C> The minimum and maximum rounded field values are also returned.
+
9 C> Grib bitmap masking for valid data is optionally used.
+
10 C>
+
11 C> Program history log:
+
12 C> - Mark Iredell 1992-10-31
+
13 C>
+
14 C> @param[in] ibm integer bitmap flag (=0 for no bitmap).
+
15 c> @param[in] ids integer decimal scaling
+
16 c> (e.g. ids=3 to round field to nearest milli-value).
+
17 c> @param[in] len integer length of the field and bitmap.
+
18 c> @param[in] mg integer (len) bitmap if ibm=1 (0 to skip, 1 to keep).
+
19 c> @param[in] g real (len) field.
+
20 c> @param[out] ground real (len) field rounded to decimal scaling
+
21 c> (set to zero where bitmap is 0 if ibm=1).
+
22 c> @param[out] gmin real minimum valid rounded field value.
+
23 c> @param[out] gmax real maximum valid rounded field value.
+
24 c> @param[out] nbit integer number of bits to pack.
+
25 C>
+
26 C> @author Mark Iredell @date 1992-10-31
+
27  SUBROUTINE gtbits(IBM,IDS,LEN,MG,G,GROUND,GMIN,GMAX,NBIT)
+
28  dimension mg(len),g(len),ground(len)
+
29 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
30 C ROUND FIELD AND DETERMINE EXTREMES WHERE BITMAP IS ON
+
31  ds=10.**ids
+
32  IF(ibm.EQ.0) THEN
+
33  ground(1)=nint(g(1)*ds)/ds
+
34  gmax=ground(1)
+
35  gmin=ground(1)
+
36  DO i=2,len
+
37  ground(i)=nint(g(i)*ds)/ds
+
38  gmax=max(gmax,ground(i))
+
39  gmin=min(gmin,ground(i))
+
40  ENDDO
+
41  ELSE
+
42  i1=isrchne(len,mg,1,0)
+
43  IF(i1.GT.0.AND.i1.LE.len) THEN
+
44  DO i=1,i1-1
+
45  ground(i)=0.
+
46  ENDDO
+
47  ground(i1)=nint(g(i1)*ds)/ds
+
48  gmax=ground(i1)
+
49  gmin=ground(i1)
+
50  DO i=i1+1,len
+
51  IF(mg(i).NE.0) THEN
+
52  ground(i)=nint(g(i)*ds)/ds
+
53  gmax=max(gmax,ground(i))
+
54  gmin=min(gmin,ground(i))
+
55  ELSE
+
56  ground(i)=0.
+
57  ENDIF
+
58  ENDDO
+
59  ELSE
+
60  DO i=1,len
+
61  ground(i)=0.
+
62  ENDDO
+
63  gmax=0.
+
64  gmin=0.
+
65  ENDIF
+
66  ENDIF
+
67 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
68 C COMPUTE NUMBER OF BITS
+
69  nbit=log((gmax-gmin)*ds+0.9)/log(2.)+1.
+
70 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
71  RETURN
+
72  END
+
+
+
isrchne
function isrchne(N, X, INCX, TARGET)
Program history log:
Definition: isrchne.f:21
+
gtbits
subroutine gtbits(IBM, IDS, LEN, MG, G, GROUND, GMIN, GMAX, NBIT)
The number of bits required to pack a given field at a particular decimal scaling is computed using t...
Definition: gtbits.f:28
+ + + + diff --git a/ver-2.10.0/idsdef_8f.html b/ver-2.10.0/idsdef_8f.html new file mode 100644 index 00000000..33833949 --- /dev/null +++ b/ver-2.10.0/idsdef_8f.html @@ -0,0 +1,167 @@ + + + + + + + +NCEPLIBS-w3emc: idsdef.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
idsdef.f File Reference
+
+
+ +

Sets decimal scalings defaults for various parameters. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine idsdef (IPTV, IDS)
 Sets decimal scalings defaults for various parameters. More...
 
+

Detailed Description

+

Sets decimal scalings defaults for various parameters.

+
Author
Mark Iredell
+
Date
1992-10-31
+ +

Definition in file idsdef.f.

+

Function/Subroutine Documentation

+ +

◆ idsdef()

+ +
+
+ + + + + + + + + + + + + + + + + + +
subroutine idsdef ( IPTV,
dimension(255) IDS 
)
+
+ +

Sets decimal scalings defaults for various parameters.

+

A decimal scaling of -3 means data is packed in kilo-si units.

+

Program history log:

    +
  • Mark Iredell 1992-10-31
    • +
+
Parameters
+ + + +
[in]IPTVparameter table version (only 1 or 2 is recognized).
[out]IDSinteger (255) decimal scalings (unknown decimal scalings will not be set).
+
+
+
Author
Mark Iredell
+
Date
1992-10-31
+ +

Definition at line 17 of file idsdef.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/idsdef_8f.js b/ver-2.10.0/idsdef_8f.js new file mode 100644 index 00000000..53ade0cd --- /dev/null +++ b/ver-2.10.0/idsdef_8f.js @@ -0,0 +1,4 @@ +var idsdef_8f = +[ + [ "idsdef", "idsdef_8f.html#a55d6afd1ffb535e0b76701cd33c997e3", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/idsdef_8f_source.html b/ver-2.10.0/idsdef_8f_source.html new file mode 100644 index 00000000..afa86ee5 --- /dev/null +++ b/ver-2.10.0/idsdef_8f_source.html @@ -0,0 +1,380 @@ + + + + + + + +NCEPLIBS-w3emc: idsdef.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
idsdef.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Sets decimal scalings defaults for various parameters.
+
3 C> @author Mark Iredell @date 1992-10-31
+
4 
+
5 C> Sets decimal scalings defaults for various parameters.
+
6 C> A decimal scaling of -3 means data is packed in kilo-si units.
+
7 C>
+
8 C> Program history log:
+
9 C> - Mark Iredell 1992-10-31
+
10 C>
+
11 C> @param[in] IPTV parameter table version (only 1 or 2 is recognized).
+
12 C> @param[out] IDS integer (255) decimal scalings
+
13 C> (unknown decimal scalings will not be set).
+
14 C>
+
15 C> @author Mark Iredell @date 1992-10-31
+
16  SUBROUTINE idsdef(IPTV,IDS)
+
17  dimension ids(255)
+
18 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
19  IF(iptv.EQ.1.OR.iptv.EQ.2) THEN
+
20  ids(001)=-1 ! PRESSURE (PA)
+
21  ids(002)=-1 ! SEA-LEVEL PRESSURE (PA)
+
22  ids(003)=3 ! PRESSURE TENDENCY (PA/S)
+
23  !
+
24  !
+
25  ids(006)=-1 ! GEOPOTENTIAL (M2/S2)
+
26  ids(007)=0 ! GEOPOTENTIAL HEIGHT (M)
+
27  ids(008)=0 ! GEOMETRIC HEIGHT (M)
+
28  ids(009)=0 ! STANDARD DEVIATION OF HEIGHT (M)
+
29  !
+
30  ids(011)=1 ! TEMPERATURE (K)
+
31  ids(012)=1 ! VIRTUAL TEMPERATURE (K)
+
32  ids(013)=1 ! POTENTIAL TEMPERATURE (K)
+
33  ids(014)=1 ! PSEUDO-ADIABATIC POTENTIAL TEMPERATURE (K)
+
34  ids(015)=1 ! MAXIMUM TEMPERATURE (K)
+
35  ids(016)=1 ! MINIMUM TEMPERATURE (K)
+
36  ids(017)=1 ! DEWPOINT TEMPERATURE (K)
+
37  ids(018)=1 ! DEWPOINT DEPRESSION (K)
+
38  ids(019)=4 ! TEMPERATURE LAPSE RATE (K/M)
+
39  ids(020)=0 ! VISIBILITY (M)
+
40  ! RADAR SPECTRA 1 ()
+
41  ! RADAR SPECTRA 2 ()
+
42  ! RADAR SPECTRA 3 ()
+
43  !
+
44  ids(025)=1 ! TEMPERATURE ANOMALY (K)
+
45  ids(026)=-1 ! PRESSURE ANOMALY (PA)
+
46  ids(027)=0 ! GEOPOTENTIAL HEIGHT ANOMALY (M)
+
47  ! WAVE SPECTRA 1 ()
+
48  ! WAVE SPECTRA 2 ()
+
49  ! WAVE SPECTRA 3 ()
+
50  ids(031)=0 ! WIND DIRECTION (DEGREES)
+
51  ids(032)=1 ! WIND SPEED (M/S)
+
52  ids(033)=1 ! ZONAL WIND (M/S)
+
53  ids(034)=1 ! MERIDIONAL WIND (M/S)
+
54  ids(035)=-4 ! STREAMFUNCTION (M2/S)
+
55  ids(036)=-4 ! VELOCITY POTENTIAL (M2/S)
+
56  ids(037)=-1 ! MONTGOMERY STREAM FUNCTION (M2/S2)
+
57  ids(038)=8 ! SIGMA VERTICAL VELOCITY (1/S)
+
58  ids(039)=3 ! PRESSURE VERTICAL VELOCITY (PA/S)
+
59  ids(040)=4 ! GEOMETRIC VERTICAL VELOCITY (M/S)
+
60  ids(041)=6 ! ABSOLUTE VORTICITY (1/S)
+
61  ids(042)=6 ! ABSOLUTE DIVERGENCE (1/S)
+
62  ids(043)=6 ! RELATIVE VORTICITY (1/S)
+
63  ids(044)=6 ! RELATIVE DIVERGENCE (1/S)
+
64  ids(045)=4 ! VERTICAL U SHEAR (1/S)
+
65  ids(046)=4 ! VERTICAL V SHEAR (1/S)
+
66  ids(047)=0 ! DIRECTION OF CURRENT (DEGREES)
+
67  ! SPEED OF CURRENT (M/S)
+
68  ! U OF CURRENT (M/S)
+
69  ! V OF CURRENT (M/S)
+
70  ids(051)=4 ! SPECIFIC HUMIDITY (KG/KG)
+
71  ids(052)=0 ! RELATIVE HUMIDITY (PERCENT)
+
72  ids(053)=4 ! HUMIDITY MIXING RATIO (KG/KG)
+
73  ids(054)=1 ! PRECIPITABLE WATER (KG/M2)
+
74  ids(055)=-1 ! VAPOR PRESSURE (PA)
+
75  ids(056)=-1 ! SATURATION DEFICIT (PA)
+
76  ids(057)=1 ! EVAPORATION (KG/M2)
+
77  ids(058)=1 ! CLOUD ICE (KG/M2)
+
78  ids(059)=6 ! PRECIPITATION RATE (KG/M2/S)
+
79  ids(060)=0 ! THUNDERSTORM PROBABILITY (PERCENT)
+
80  ids(061)=1 ! TOTAL PRECIPITATION (KG/M2)
+
81  ids(062)=1 ! LARGE-SCALE PRECIPITATION (KG/M2)
+
82  ids(063)=1 ! CONVECTIVE PRECIPITATION (KG/M2)
+
83  ids(064)=6 ! WATER EQUIVALENT SNOWFALL RATE (KG/M2/S)
+
84  ids(065)=0 ! WATER EQUIVALENT OF SNOW DEPTH (KG/M2)
+
85  ids(066)=2 ! SNOW DEPTH (M)
+
86  ! MIXED-LAYER DEPTH (M)
+
87  ! TRANSIENT THERMOCLINE DEPTH (M)
+
88  ! MAIN THERMOCLINE DEPTH (M)
+
89  ! MAIN THERMOCLINE ANOMALY (M)
+
90  ids(071)=0 ! TOTAL CLOUD COVER (PERCENT)
+
91  ids(072)=0 ! CONVECTIVE CLOUD COVER (PERCENT)
+
92  ids(073)=0 ! LOW CLOUD COVER (PERCENT)
+
93  ids(074)=0 ! MIDDLE CLOUD COVER (PERCENT)
+
94  ids(075)=0 ! HIGH CLOUD COVER (PERCENT)
+
95  ids(076)=1 ! CLOUD WATER (KG/M2)
+
96  !
+
97  ids(078)=1 ! CONVECTIVE SNOW (KG/M2)
+
98  ids(079)=1 ! LARGE SCALE SNOW (KG/M2)
+
99  ids(080)=1 ! WATER TEMPERATURE (K)
+
100  ids(081)=0 ! SEA-LAND MASK ()
+
101  ! DEVIATION OF SEA LEVEL FROM MEAN (M)
+
102  ids(083)=5 ! ROUGHNESS (M)
+
103  ids(084)=1 ! ALBEDO (PERCENT)
+
104  ids(085)=1 ! SOIL TEMPERATURE (K)
+
105  ids(086)=0 ! SOIL WETNESS (KG/M2)
+
106  ids(087)=0 ! VEGETATION (PERCENT)
+
107  ! SALINITY (KG/KG)
+
108  ids(089)=4 ! DENSITY (KG/M3)
+
109  ids(090)=1 ! RUNOFF (KG/M2)
+
110  ids(091)=0 ! ICE CONCENTRATION ()
+
111  ! ICE THICKNESS (M)
+
112  ids(093)=0 ! DIRECTION OF ICE DRIFT (DEGREES)
+
113  ! SPEED OF ICE DRIFT (M/S)
+
114  ! U OF ICE DRIFT (M/S)
+
115  ! V OF ICE DRIFT (M/S)
+
116  ! ICE GROWTH (M)
+
117  ! ICE DIVERGENCE (1/S)
+
118  ids(099)=1 ! SNOW MELT (KG/M2)
+
119  ! SIG HEIGHT OF WAVES AND SWELL (M)
+
120  ids(101)=0 ! DIRECTION OF WIND WAVES (DEGREES)
+
121  ! SIG HEIGHT OF WIND WAVES (M)
+
122  ! MEAN PERIOD OF WIND WAVES (S)
+
123  ids(104)=0 ! DIRECTION OF SWELL WAVES (DEGREES)
+
124  ! SIG HEIGHT OF SWELL WAVES (M)
+
125  ! MEAN PERIOD OF SWELL WAVES (S)
+
126  ids(107)=0 ! PRIMARY WAVE DIRECTION (DEGREES)
+
127  ! PRIMARY WAVE MEAN PERIOD (S)
+
128  ids(109)=0 ! SECONDARY WAVE DIRECTION (DEGREES)
+
129  ! SECONDARY WAVE MEAN PERIOD (S)
+
130  ids(111)=0 ! NET SOLAR RADIATIVE FLUX AT SURFACE (W/M2)
+
131  ids(112)=0 ! NET LONGWAVE RADIATIVE FLUX AT SURFACE (W/M2)
+
132  ids(113)=0 ! NET SOLAR RADIATIVE FLUX AT TOP (W/M2)
+
133  ids(114)=0 ! NET LONGWAVE RADIATIVE FLUX AT TOP (W/M2)
+
134  ids(115)=0 ! NET LONGWAVE RADIATIVE FLUX (W/M2)
+
135  ids(116)=0 ! NET SOLAR RADIATIVE FLUX (W/M2)
+
136  ids(117)=0 ! TOTAL RADIATIVE FLUX (W/M2)
+
137  !
+
138  !
+
139  !
+
140  ids(121)=0 ! LATENT HEAT FLUX (W/M2)
+
141  ids(122)=0 ! SENSIBLE HEAT FLUX (W/M2)
+
142  ids(123)=0 ! BOUNDARY LAYER DISSIPATION (W/M2)
+
143  ids(124)=3 ! U WIND STRESS (N/M2)
+
144  ids(125)=3 ! V WIND STRESS (N/M2)
+
145  ! WIND MIXING ENERGY (J)
+
146  ! IMAGE DATA ()
+
147  ids(128)=-1 ! MEAN SEA-LEVEL PRESSURE (STDATM) (PA)
+
148  ids(129)=-1 ! MEAN SEA-LEVEL PRESSURE (MAPS) (PA)
+
149  ids(130)=-1 ! MEAN SEA-LEVEL PRESSURE (ETA) (PA)
+
150  ids(131)=1 ! SURFACE LIFTED INDEX (K)
+
151  ids(132)=1 ! BEST LIFTED INDEX (K)
+
152  ids(133)=1 ! K INDEX (K)
+
153  ids(134)=1 ! SWEAT INDEX (K)
+
154  ids(135)=10 ! HORIZONTAL MOISTURE DIVERGENCE (KG/KG/S)
+
155  ids(136)=4 ! SPEED SHEAR (1/S)
+
156  ids(137)=3 ! 3-HR PRESSURE TENDENCY (PA/S)
+
157  ids(138)=6 ! BRUNT-VAISALA FREQUENCY SQUARED (1/S2)
+
158  ids(139)=11 ! POTENTIAL VORTICITY (MASS-WEIGHTED) (1/S/M)
+
159  ids(140)=0 ! RAIN MASK ()
+
160  ids(141)=0 ! FREEZING RAIN MASK ()
+
161  ids(142)=0 ! ICE PELLETS MASK ()
+
162  ids(143)=0 ! SNOW MASK ()
+
163  ids(144)=3 ! VOLUMETRIC SOIL MOISTURE CONTENT (FRACTION)
+
164  ids(145)=0 ! POTENTIAL EVAPORATION RATE (W/M2)
+
165  ids(146)=0 ! CLOUD WORKFUNCTION (J/KG)
+
166  ids(147)=3 ! U GRAVITY WAVE STRESS (N/M2)
+
167  ids(148)=3 ! V GRAVITY WAVE STRESS (N/M2)
+
168  ids(149)=10 ! POTENTIAL VORTICITY (M2/S/KG)
+
169  ! COVARIANCE BETWEEN V AND U (M2/S2)
+
170  ! COVARIANCE BETWEEN U AND T (K*M/S)
+
171  ! COVARIANCE BETWEEN V AND T (K*M/S)
+
172  !
+
173  !
+
174  ids(155)=0 ! GROUND HEAT FLUX (W/M2)
+
175  ids(156)=0 ! CONVECTIVE INHIBITION (W/M2)
+
176  ids(157)=0 ! CONVECTIVE APE (J/KG)
+
177  ids(158)=0 ! TURBULENT KE (J/KG)
+
178  ids(159)=-1 ! CONDENSATION PRESSURE OF LIFTED PARCEL (PA)
+
179  ids(160)=0 ! CLEAR SKY UPWARD SOLAR FLUX (W/M2)
+
180  ids(161)=0 ! CLEAR SKY DOWNWARD SOLAR FLUX (W/M2)
+
181  ids(162)=0 ! CLEAR SKY UPWARD LONGWAVE FLUX (W/M2)
+
182  ids(163)=0 ! CLEAR SKY DOWNWARD LONGWAVE FLUX (W/M2)
+
183  ids(164)=0 ! CLOUD FORCING NET SOLAR FLUX (W/M2)
+
184  ids(165)=0 ! CLOUD FORCING NET LONGWAVE FLUX (W/M2)
+
185  ids(166)=0 ! VISIBLE BEAM DOWNWARD SOLAR FLUX (W/M2)
+
186  ids(167)=0 ! VISIBLE DIFFUSE DOWNWARD SOLAR FLUX (W/M2)
+
187  ids(168)=0 ! NEAR IR BEAM DOWNWARD SOLAR FLUX (W/M2)
+
188  ids(169)=0 ! NEAR IR DIFFUSE DOWNWARD SOLAR FLUX (W/M2)
+
189  !
+
190  !
+
191  ids(172)=3 ! MOMENTUM FLUX (N/M2)
+
192  ids(173)=0 ! MASS POINT MODEL SURFACE ()
+
193  ids(174)=0 ! VELOCITY POINT MODEL SURFACE ()
+
194  ids(175)=0 ! SIGMA LAYER NUMBER ()
+
195  ids(176)=2 ! LATITUDE (DEGREES)
+
196  ids(177)=2 ! EAST LONGITUDE (DEGREES)
+
197  !
+
198  !
+
199  !
+
200  ids(181)=9 ! X-GRADIENT LOG PRESSURE (1/M)
+
201  ids(182)=9 ! Y-GRADIENT LOG PRESSURE (1/M)
+
202  ids(183)=5 ! X-GRADIENT HEIGHT (M/M)
+
203  ids(184)=5 ! Y-GRADIENT HEIGHT (M/M)
+
204  !
+
205  !
+
206  !
+
207  !
+
208  !
+
209  !
+
210  !
+
211  !
+
212  !
+
213  !
+
214  !
+
215  !
+
216  !
+
217  !
+
218  !
+
219  !
+
220  ids(201)=0 ! ICE-FREE WATER SURCACE (PERCENT)
+
221  !
+
222  !
+
223  ids(204)=0 ! DOWNWARD SOLAR RADIATIVE FLUX (W/M2)
+
224  ids(205)=0 ! DOWNWARD LONGWAVE RADIATIVE FLUX (W/M2)
+
225  !
+
226  ids(207)=0 ! MOISTURE AVAILABILITY (PERCENT)
+
227  ! EXCHANGE COEFFICIENT (KG/M2/S)
+
228  ids(209)=0 ! NUMBER OF MIXED LAYER NEXT TO SFC ()
+
229  !
+
230  ids(211)=0 ! UPWARD SOLAR RADIATIVE FLUX (W/M2)
+
231  ids(212)=0 ! UPWARD LONGWAVE RADIATIVE FLUX (W/M2)
+
232  ids(213)=0 ! NON-CONVECTIVE CLOUD COVER (PERCENT)
+
233  ids(214)=6 ! CONVECTIVE PRECIPITATION RATE (KG/M2/S)
+
234  ids(215)=7 ! TOTAL DIABATIC HEATING RATE (K/S)
+
235  ids(216)=7 ! TOTAL RADIATIVE HEATING RATE (K/S)
+
236  ids(217)=7 ! TOTAL DIABATIC NONRADIATIVE HEATING RATE (K/S)
+
237  ids(218)=2 ! PRECIPITATION INDEX (FRACTION)
+
238  ids(219)=1 ! STD DEV OF IR T OVER 1X1 DEG AREA (K)
+
239  ids(220)=4 ! NATURAL LOG OF SURFACE PRESSURE OVER 1 KPA ()
+
240  !
+
241  ids(222)=0 ! 5-WAVE GEOPOTENTIAL HEIGHT (M)
+
242  ids(223)=1 ! PLANT CANOPY SURFACE WATER (KG/M2)
+
243  !
+
244  !
+
245  ! BLACKADARS MIXING LENGTH (M)
+
246  ! ASYMPTOTIC MIXING LENGTH (M)
+
247  ids(228)=1 ! POTENTIAL EVAPORATION (KG/M2)
+
248  ids(229)=0 ! SNOW PHASE-CHANGE HEAT FLUX (W/M2)
+
249  !
+
250  ids(231)=3 ! CONVECTIVE CLOUD MASS FLUX (PA/S)
+
251  ids(232)=0 ! DOWNWARD TOTAL RADIATION FLUX (W/M2)
+
252  ids(233)=0 ! UPWARD TOTAL RADIATION FLUX (W/M2)
+
253  ids(224)=1 ! BASEFLOW-GROUNDWATER RUNOFF (KG/M2)
+
254  ids(225)=1 ! STORM SURFACE RUNOFF (KG/M2)
+
255  !
+
256  !
+
257  ids(238)=0 ! SNOW COVER (PERCENT)
+
258  ids(239)=1 ! SNOW TEMPERATURE (K)
+
259  !
+
260  ids(241)=7 ! LARGE SCALE CONDENSATION HEATING RATE (K/S)
+
261  ids(242)=7 ! DEEP CONVECTIVE HEATING RATE (K/S)
+
262  ids(243)=10 ! DEEP CONVECTIVE MOISTENING RATE (KG/KG/S)
+
263  ids(244)=7 ! SHALLOW CONVECTIVE HEATING RATE (K/S)
+
264  ids(245)=10 ! SHALLOW CONVECTIVE MOISTENING RATE (KG/KG/S)
+
265  ids(246)=7 ! VERTICAL DIFFUSION HEATING RATE (KG/KG/S)
+
266  ids(247)=7 ! VERTICAL DIFFUSION ZONAL ACCELERATION (M/S/S)
+
267  ids(248)=7 ! VERTICAL DIFFUSION MERID ACCELERATION (M/S/S)
+
268  ids(249)=10 ! VERTICAL DIFFUSION MOISTENING RATE (KG/KG/S)
+
269  ids(250)=7 ! SOLAR RADIATIVE HEATING RATE (K/S)
+
270  ids(251)=7 ! LONGWAVE RADIATIVE HEATING RATE (K/S)
+
271  ! DRAG COEFFICIENT ()
+
272  ! FRICTION VELOCITY (M/S)
+
273  ! RICHARDSON NUMBER ()
+
274  !
+
275  ENDIF
+
276 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
277  RETURN
+
278  END
+
+
+
idsdef
subroutine idsdef(IPTV, IDS)
Sets decimal scalings defaults for various parameters.
Definition: idsdef.f:17
+ + + + diff --git a/ver-2.10.0/index.html b/ver-2.10.0/index.html new file mode 100644 index 00000000..f3a73a23 --- /dev/null +++ b/ver-2.10.0/index.html @@ -0,0 +1,112 @@ + + + + + + + +NCEPLIBS-w3emc: Main Page + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
NCEPLIBS-w3emc Documentation
+
+
+

+NCEPLIBS-w3emc

+

+Documentation for Previous Versions

+ +

+Introduction

+

This library contains Fortran 90 decoder/encoder routines for GRIB edition 1.

+
+
+
+ + + + diff --git a/ver-2.10.0/instrument_8f.html b/ver-2.10.0/instrument_8f.html new file mode 100644 index 00000000..acec0831 --- /dev/null +++ b/ver-2.10.0/instrument_8f.html @@ -0,0 +1,201 @@ + + + + + + + +NCEPLIBS-w3emc: instrument.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
instrument.f File Reference
+
+
+ +

Monitor wall-clock times, etc. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine instrument (K, KALL, TTOT, TMIN, TMAX)
 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. More...
 
+

Detailed Description

+

Monitor wall-clock times, etc.

+
Author
Mark Iredell
+
Date
1998-07-16
+ +

Definition in file instrument.f.

+

Function/Subroutine Documentation

+ +

◆ instrument()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine instrument (integer, intent(in) K,
integer, intent(out) KALL,
real, intent(out) TTOT,
real, intent(out) TMIN,
real, intent(out) TMAX 
)
+
+ +

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:

    +
  • Mark Iredell 1998-07-16
    • +
  • Frimel and Kalina 2019-09-17 Decompose return statistcs if statement
    • +
  • Boi Vuong 2020-04-02 Check for ka > 0 and modifiled ifblock statement into two separate ifblock statements.
    Parameters
    + + + + + + +
    [in]KInteger 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.
    [out]KALLinteger number of times section is called.
    [out]TTOTreal total seconds spent in section.
    [out]TMINreal minimum seconds spent in section.
    [out]TMAXreal maximum seconds spent in section.
    +
    +
    +
    Note
    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
+
    • +
+
Author
Mark Iredell
+
Date
1998-07-16
+ +

Definition at line 48 of file instrument.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/instrument_8f.js b/ver-2.10.0/instrument_8f.js new file mode 100644 index 00000000..5e182f96 --- /dev/null +++ b/ver-2.10.0/instrument_8f.js @@ -0,0 +1,4 @@ +var instrument_8f = +[ + [ "instrument", "instrument_8f.html#a1bf5314dfe3e0adf03773a63dadf6173", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/instrument_8f_source.html b/ver-2.10.0/instrument_8f_source.html new file mode 100644 index 00000000..1ed453ed --- /dev/null +++ b/ver-2.10.0/instrument_8f_source.html @@ -0,0 +1,177 @@ + + + + + + + +NCEPLIBS-w3emc: instrument.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
instrument.f
+
+
+Go to the documentation of this file.
1 
+
4 
+
47  SUBROUTINE instrument(K,KALL,TTOT,TMIN,TMAX)
+
48  IMPLICIT NONE
+
49  INTEGER,INTENT(IN):: K
+
50  INTEGER,INTENT(OUT):: KALL
+
51  REAL,INTENT(OUT):: TTOT,TMIN,TMAX
+
52  INTEGER,SAVE:: KMAX=0
+
53  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE:: KALLS
+
54  REAL,DIMENSION(:),ALLOCATABLE,SAVE:: TTOTS,TMINS,TMAXS
+
55  INTEGER,DIMENSION(8),SAVE:: IDAT
+
56  INTEGER,DIMENSION(8):: JDAT
+
57  REAL,DIMENSION(5):: RINC
+
58  INTEGER:: KA
+
59 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
60  ka=abs(k)
+
61 ! ALLOCATE MONITORING ARRAYS IF INITIAL INVOCATION
+
62  IF(kmax.EQ.0) THEN
+
63  kmax=k
+
64  ALLOCATE(kalls(kmax))
+
65  ALLOCATE(ttots(kmax))
+
66  ALLOCATE(tmins(kmax))
+
67  ALLOCATE(tmaxs(kmax))
+
68  kalls=0
+
69  ka=0
+
70 ! OR RESET ALL STATISTICS BACK TO ZERO
+
71  ELSEIF(k.EQ.0) THEN
+
72  kalls=0
+
73 ! OR COUNT TIME SINCE LAST INVOCATION AGAINST THIS SECTION
+
74  ELSEIF(k.GT.0) THEN
+
75  CALL w3utcdat(jdat)
+
76  CALL w3difdat(jdat,idat,4,rinc)
+
77  kalls(k)=kalls(k)+1
+
78  IF(kalls(k).EQ.1) THEN
+
79  ttots(k)=rinc(4)
+
80  tmins(k)=rinc(4)
+
81  tmaxs(k)=rinc(4)
+
82  ELSE
+
83  ttots(k)=ttots(k)+rinc(4)
+
84  tmins(k)=min(tmins(k),rinc(4))
+
85  tmaxs(k)=max(tmaxs(k),rinc(4))
+
86  ENDIF
+
87  ENDIF
+
88 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
89 ! RETURN STATISTICS
+
90 
+
91 ! FRIMEL and KALINA, DECOMPOSE THE IF STATEMENT, SAFER FOR SOME
+
92 ! COMPILERS. Since No Guarantee on order of evaluation, and when
+
93 ! evaluation will stop.
+
94 ! MAKE SURE KA.GE.1 BEFORE TESTING IF KALLS(KA).GT.0, ELSE
+
95 ! MAY ENCOUNTER A RUNTIME SIGSEGV SEGEMENTATION FAULT.
+
96 ! Since Subscript #1 of the array KALLS can have value 0 which
+
97 ! is less than the lower bound of 1
+
98 ! IF(KA.GE.1.AND.KA.LE.KMAX.AND.KALLS(KA).GT.0) THEN
+
99 
+
100  IF(ka.GE.1.AND.ka.LE.kmax) THEN
+
101  IF(kalls(ka).GT.0) THEN
+
102  kall=kalls(ka)
+
103  ttot=ttots(ka)
+
104  tmin=tmins(ka)
+
105  tmax=tmaxs(ka)
+
106  ENDIF
+
107  IF(kalls(ka).LE.0) THEN
+
108  kall=0
+
109  ttot=0
+
110  tmin=0
+
111  tmax=0
+
112  ENDIF
+
113  END IF
+
114 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
115 ! KEEP CURRENT TIME FOR NEXT INVOCATION
+
116  IF(k.GE.0) CALL w3utcdat(idat)
+
117  END SUBROUTINE instrument
+
+
+
instrument
subroutine instrument(K, KALL, TTOT, TMIN, TMAX)
This subprogram is useful in instrumenting a code by monitoring the number of times each given sectio...
Definition: instrument.f:48
+
w3utcdat
subroutine w3utcdat(idat)
This subprogram returns the utc (greenwich) date and time in the NCEP absolute date and time data str...
Definition: w3utcdat.f:23
+
w3difdat
subroutine w3difdat(jdat, idat, it, rinc)
Returns the elapsed time interval from an NCEP absolute date and time given in the second argument un...
Definition: w3difdat.f:29
+ + + + diff --git a/ver-2.10.0/interfaceargs__mod_1_1getarg.html b/ver-2.10.0/interfaceargs__mod_1_1getarg.html new file mode 100644 index 00000000..ecec4cf5 --- /dev/null +++ b/ver-2.10.0/interfaceargs__mod_1_1getarg.html @@ -0,0 +1,119 @@ + + + + + + + +NCEPLIBS-w3emc: args_mod::getarg Interface Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Public Member Functions
+
+
args_mod::getarg Interface Reference
+
+
+ + + + + + +

+Public Member Functions

+subroutine getarg (k, c)
 
+subroutine getarg_8 (k, c)
 
+

Detailed Description

+
+

Definition at line 14 of file args_mod.f.

+
The documentation for this interface was generated from the following file: +
+
+ + + + diff --git a/ver-2.10.0/interfaceargs__mod_1_1getarg.js b/ver-2.10.0/interfaceargs__mod_1_1getarg.js new file mode 100644 index 00000000..94b37ca0 --- /dev/null +++ b/ver-2.10.0/interfaceargs__mod_1_1getarg.js @@ -0,0 +1,5 @@ +var interfaceargs__mod_1_1getarg = +[ + [ "getarg", "interfaceargs__mod_1_1getarg.html#aeb54b5295376abb7ec7b2a6a2de13613", null ], + [ "getarg_8", "interfaceargs__mod_1_1getarg.html#a61fa2902b253a2ff76970e6ff787ee18", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/interfaceargs__mod_1_1iargc.html b/ver-2.10.0/interfaceargs__mod_1_1iargc.html new file mode 100644 index 00000000..c0311f65 --- /dev/null +++ b/ver-2.10.0/interfaceargs__mod_1_1iargc.html @@ -0,0 +1,116 @@ + + + + + + + +NCEPLIBS-w3emc: args_mod::iargc Interface Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Public Member Functions
+
+
args_mod::iargc Interface Reference
+
+
+ + + + +

+Public Member Functions

+integer(8) function iargc_8 ()
 
+

Detailed Description

+
+

Definition at line 11 of file args_mod.f.

+
The documentation for this interface was generated from the following file: +
+
+ + + + diff --git a/ver-2.10.0/interfaceargs__mod_1_1iargc.js b/ver-2.10.0/interfaceargs__mod_1_1iargc.js new file mode 100644 index 00000000..169cb099 --- /dev/null +++ b/ver-2.10.0/interfaceargs__mod_1_1iargc.js @@ -0,0 +1,4 @@ +var interfaceargs__mod_1_1iargc = +[ + [ "iargc_8", "interfaceargs__mod_1_1iargc.html#af4538b3ec9b539460c2490f71df060c9", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/isrchne_8f.html b/ver-2.10.0/isrchne_8f.html new file mode 100644 index 00000000..27eead4f --- /dev/null +++ b/ver-2.10.0/isrchne_8f.html @@ -0,0 +1,182 @@ + + + + + + + +NCEPLIBS-w3emc: isrchne.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
isrchne.f File Reference
+
+
+ +

Searches a vector for the first element not equal to a target. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

function isrchne (N, X, INCX, TARGET)
 Program history log: More...
 
+

Detailed Description

+

Searches a vector for the first element not equal to a target.

+
Author
Stephen Gilbert
+
Date
1999-02-11
+ +

Definition in file isrchne.f.

+

Function/Subroutine Documentation

+ +

◆ isrchne()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
function isrchne ( N,
integer, dimension(*) X,
 INCX,
integer TARGET 
)
+
+ +

Program history log:

+
    +
  • Stephen Gilbert 1999-02-11
    • +
+
Parameters
+ + + + + +
[in]nNumber of elements to be searched.
[in]xReal or integer array of dimension (n-1) * |incx| + 1. Array x contains the vector to be searched.
[in]incxIncrement between elements of the searched array.
[in]targetValue for which to search in the array.
+
+
+
Returns
index Index of the first element equal or not equal to target. If target is not found, n+1 is returned. If n <= 0, 0 is returned.
+
Note
This code and documentation was taken directly from the man page for routine ISRCHNE on a CRAY UNICOS system.
+
Author
Stephen Gilbert
+
Date
1999-02-11
+ +

Definition at line 21 of file isrchne.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/isrchne_8f.js b/ver-2.10.0/isrchne_8f.js new file mode 100644 index 00000000..25f3df0e --- /dev/null +++ b/ver-2.10.0/isrchne_8f.js @@ -0,0 +1,4 @@ +var isrchne_8f = +[ + [ "isrchne", "isrchne_8f.html#aa2ad73a774eaa79cc4134b5a30210c19", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/isrchne_8f_source.html b/ver-2.10.0/isrchne_8f_source.html new file mode 100644 index 00000000..ec6c4425 --- /dev/null +++ b/ver-2.10.0/isrchne_8f_source.html @@ -0,0 +1,134 @@ + + + + + + + +NCEPLIBS-w3emc: isrchne.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
isrchne.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Searches a vector for the first element not equal to a target
+
3 C> @author Stephen Gilbert @date 1999-02-11
+
4 
+
5 C> Program history log:
+
6 C> - Stephen Gilbert 1999-02-11
+
7 C>
+
8 C> @param[in] n Number of elements to be searched.
+
9 C> @param[in] x Real or integer array of dimension (n-1) * |incx| + 1.
+
10 C> Array x contains the vector to be searched.
+
11 C> @param[in] incx Increment between elements of the searched array.
+
12 C> @param[in] target Value for which to search in the array.
+
13 C> @return index Index of the first element equal or not equal to target.
+
14 C> If target is not found, n+1 is returned. If n <= 0, 0 is returned.
+
15 C>
+
16 C> @note This code and documentation was taken directly from the
+
17 C> man page for routine ISRCHNE on a CRAY UNICOS system.
+
18 C>
+
19 C> @author Stephen Gilbert @date 1999-02-11
+
20  FUNCTION isrchne(N,X,INCX,TARGET)
+
21  INTEGER x(*), target
+
22  j=1
+
23  isrchne=0
+
24  IF(n.LE.0) RETURN
+
25  IF(incx.LT.0) j=1-(n-1)*incx
+
26  DO 100 i=1,n
+
27  IF(x(j).NE.TARGET) GO TO 200
+
28  j=j+incx
+
29  100 CONTINUE
+
30  200 isrchne=i
+
31  RETURN
+
32  END
+
+
+
isrchne
function isrchne(N, X, INCX, TARGET)
Program history log:
Definition: isrchne.f:21
+ + + + diff --git a/ver-2.10.0/iw3jdn_8f.html b/ver-2.10.0/iw3jdn_8f.html new file mode 100644 index 00000000..45a5e769 --- /dev/null +++ b/ver-2.10.0/iw3jdn_8f.html @@ -0,0 +1,181 @@ + + + + + + + +NCEPLIBS-w3emc: iw3jdn.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
iw3jdn.f File Reference
+
+
+ +

Computes julian day number from year (4 digits), month, and day. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

function iw3jdn (IYEAR, MONTH, IDAY)
 Computes julian day number from year (4 digits), month, and day. More...
 
+

Detailed Description

+

Computes julian day number from year (4 digits), month, and day.

+
Author
Ralph Jones
+
Date
1987-03-29
+ +

Definition in file iw3jdn.f.

+

Function/Subroutine Documentation

+ +

◆ iw3jdn()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
function iw3jdn ( IYEAR,
 MONTH,
 IDAY 
)
+
+ +

Computes julian day number from year (4 digits), month, and day.

+

iw3jdn is valid for years 1583 a.d. to 3300 a.d. Julian day number can be used to compute day of week, day of year, record numbers in an archive, replace day of century, find the number of days between two dates.

+

Program history log:

    +
  • Ralph Jones 1987-03-29
    • +
  • Ralph Jones 1989-10-25 Convert to cray cft77 fortran.
    • +
+
Parameters
+ + + + +
[in]IYEARInteger year (4 Digits)
[in]MONTHInteger month of year (1 - 12)
[in]IDAYInteger day of month (1 - 31)
+
+
+
Returns
IW3JDN Integer Julian day number
    +
  • Jan 1, 1960 is Julian day number 2436935
    • +
  • Jan 1, 1987 is Julian day number 2446797
    • +
+
+
Note
Julian period was devised by joseph scaliger in 1582. Julian day number #1 started on Jan. 1,4713 B.C. Three major chronological cycles begin on the same day. A 28-year solar cycle, a 19-year luner cycle, a 15-year indiction cycle, used in ancient rome to regulate taxes. It will take 7980 years to complete the period, the product of 28, 19, and 15. scaliger named the period, date, and number after his father Julius (not after the julian calendar). This seems to have caused a lot of confusion in text books. Scaliger name is spelled three different ways. Julian date and Julian day number are interchanged. A Julian date is used by astronomers to compute accurate time, it has a fraction. When truncated to an integer it is called an Julian day number. This function was in a letter to the editor of the communications of the acm volume 11 / number 10 / october 1968. The Julian day number can be converted to a year, month, day, day of week, day of year by calling subroutine w3fs26.
+
Author
Ralph Jones
+
Date
1987-03-29
+ +

Definition at line 42 of file iw3jdn.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/iw3jdn_8f.js b/ver-2.10.0/iw3jdn_8f.js new file mode 100644 index 00000000..64ccefc6 --- /dev/null +++ b/ver-2.10.0/iw3jdn_8f.js @@ -0,0 +1,4 @@ +var iw3jdn_8f = +[ + [ "iw3jdn", "iw3jdn_8f.html#accbe8d5a05413129a72efa183f1fa3b6", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/iw3jdn_8f_source.html b/ver-2.10.0/iw3jdn_8f_source.html new file mode 100644 index 00000000..fc6471b8 --- /dev/null +++ b/ver-2.10.0/iw3jdn_8f_source.html @@ -0,0 +1,150 @@ + + + + + + + +NCEPLIBS-w3emc: iw3jdn.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
iw3jdn.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Computes julian day number from year (4 digits), month, and day.
+
3 C> @author Ralph Jones @date 1987-03-29
+
4 
+
5 C> Computes julian day number from year (4 digits), month,
+
6 C> and day. iw3jdn is valid for years 1583 a.d. to 3300 a.d.
+
7 C> Julian day number can be used to compute day of week, day of
+
8 C> year, record numbers in an archive, replace day of century,
+
9 C> find the number of days between two dates.
+
10 C>
+
11 C> Program history log:
+
12 C> - Ralph Jones 1987-03-29
+
13 C> - Ralph Jones 1989-10-25 Convert to cray cft77 fortran.
+
14 C>
+
15 C> @param[in] IYEAR Integer year (4 Digits)
+
16 C> @param[in] MONTH Integer month of year (1 - 12)
+
17 C> @param[in] IDAY Integer day of month (1 - 31)
+
18 C> @return IW3JDN Integer Julian day number
+
19 C> - Jan 1, 1960 is Julian day number 2436935
+
20 C> - Jan 1, 1987 is Julian day number 2446797
+
21 C>
+
22 C> @note Julian period was devised by joseph scaliger in 1582.
+
23 C> Julian day number #1 started on Jan. 1,4713 B.C. Three major
+
24 C> chronological cycles begin on the same day. A 28-year solar
+
25 C> cycle, a 19-year luner cycle, a 15-year indiction cycle, used
+
26 C> in ancient rome to regulate taxes. It will take 7980 years
+
27 C> to complete the period, the product of 28, 19, and 15.
+
28 C> scaliger named the period, date, and number after his father
+
29 C> Julius (not after the julian calendar). This seems to have
+
30 C> caused a lot of confusion in text books. Scaliger name is
+
31 C> spelled three different ways. Julian date and Julian day
+
32 C> number are interchanged. A Julian date is used by astronomers
+
33 C> to compute accurate time, it has a fraction. When truncated to
+
34 C> an integer it is called an Julian day number. This function
+
35 C> was in a letter to the editor of the communications of the acm
+
36 C> volume 11 / number 10 / october 1968. The Julian day number
+
37 C> can be converted to a year, month, day, day of week, day of
+
38 C> year by calling subroutine w3fs26.
+
39 C>
+
40 C> @author Ralph Jones @date 1987-03-29
+
41  FUNCTION iw3jdn(IYEAR,MONTH,IDAY)
+
42 C
+
43  iw3jdn = iday - 32075
+
44  & + 1461 * (iyear + 4800 + (month - 14) / 12) / 4
+
45  & + 367 * (month - 2 - (month -14) / 12 * 12) / 12
+
46  & - 3 * ((iyear + 4900 + (month - 14) / 12) / 100) / 4
+
47  RETURN
+
48  END
+
+
+
iw3jdn
function iw3jdn(IYEAR, MONTH, IDAY)
Computes julian day number from year (4 digits), month, and day.
Definition: iw3jdn.f:42
+ + + + diff --git a/ver-2.10.0/iw3mat_8f.html b/ver-2.10.0/iw3mat_8f.html new file mode 100644 index 00000000..8d5fea14 --- /dev/null +++ b/ver-2.10.0/iw3mat_8f.html @@ -0,0 +1,175 @@ + + + + + + + +NCEPLIBS-w3emc: iw3mat.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
iw3mat.f File Reference
+
+
+ +

Test n words starting at l1, l2 for equality, return .true. if all equal; otherwise .false. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

logical function iw3mat (L1, L2, N)
 Program history log: More...
 
+

Detailed Description

+

Test n words starting at l1, l2 for equality, return .true. if all equal; otherwise .false.

+
Author
J.D. Stackpole
+
Date
1986-01-13
+ +

Definition in file iw3mat.f.

+

Function/Subroutine Documentation

+ +

◆ iw3mat()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
logical function iw3mat (integer, dimension(*) L1,
integer, dimension(*) L2,
 N 
)
+
+ +

Program history log:

+
    +
  • J.D. Stackpole 1986-01-13
    • +
  • Ralph Jones 1990-03-15 Convert to cray cft77 fortran.
    • +
+
Parameters
+ + + + +
[in]L1Integer array to match with l2.
[in]L2Integer array to match with l1.
[in]NNumber of integer words to test for match.
+
+
+
Returns
IW3MAT Logical .true. if l1 and l2 match on all words, logical .false. if not match on any word.
+
Author
J.D. Stackpole
+
Date
1986-01-13
+ +

Definition at line 18 of file iw3mat.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/iw3mat_8f.js b/ver-2.10.0/iw3mat_8f.js new file mode 100644 index 00000000..e1d1768d --- /dev/null +++ b/ver-2.10.0/iw3mat_8f.js @@ -0,0 +1,4 @@ +var iw3mat_8f = +[ + [ "iw3mat", "iw3mat_8f.html#a2fba35a09957d0d2a2e37b8c63e9ef4f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/iw3mat_8f_source.html b/ver-2.10.0/iw3mat_8f_source.html new file mode 100644 index 00000000..71d76f8d --- /dev/null +++ b/ver-2.10.0/iw3mat_8f_source.html @@ -0,0 +1,133 @@ + + + + + + + +NCEPLIBS-w3emc: iw3mat.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
iw3mat.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Test n words starting at l1, l2 for equality, return .true.
+
3 C> if all equal; otherwise .false.
+
4 C> @author J.D. Stackpole @date 1986-01-13
+
5 
+
6 C> Program history log:
+
7 C> - J.D. Stackpole 1986-01-13
+
8 C> - Ralph Jones 1990-03-15 Convert to cray cft77 fortran.
+
9 C>
+
10 C> @param[in] L1 Integer array to match with l2.
+
11 C> @param[in] L2 Integer array to match with l1.
+
12 C> @param[in] N Number of integer words to test for match.
+
13 C> @return IW3MAT Logical .true. if l1 and l2 match on all words,
+
14 C> logical .false. if not match on any word.
+
15 C>
+
16 C> @author J.D. Stackpole @date 1986-01-13
+
17  LOGICAL FUNCTION iw3mat(L1, L2, N)
+
18 C
+
19  INTEGER l1(*)
+
20  INTEGER l2(*)
+
21 C
+
22  iw3mat = .true.
+
23  DO 10 i = 1,n
+
24  IF (l1(i).NE.l2(i)) GO TO 20
+
25  10 CONTINUE
+
26  RETURN
+
27 C
+
28  20 CONTINUE
+
29  iw3mat = .false.
+
30  RETURN
+
31  END
+
+
+
iw3mat
logical function iw3mat(L1, L2, N)
Program history log:
Definition: iw3mat.f:18
+ + + + diff --git a/ver-2.10.0/iw3pds_8f.html b/ver-2.10.0/iw3pds_8f.html new file mode 100644 index 00000000..e71f33fe --- /dev/null +++ b/ver-2.10.0/iw3pds_8f.html @@ -0,0 +1,145 @@ + + + + + + + +NCEPLIBS-w3emc: iw3pds.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
iw3pds.f File Reference
+
+
+ +

Test two pds (grib product definition section) to see if all equal; otherwise .false. +More...

+ +

Go to the source code of this file.

+ + + + +

+Functions/Subroutines

+logical function iw3pds (L1, L2, KEY)
 
+

Detailed Description

+

Test two pds (grib product definition section) to see if all equal; otherwise .false.

+
Author
Ralph Jones
+
Date
1988-02-22 FUNCTION: IW3PDS TEST FOR MATCH OF TWO PDS AUTHOR: JONES, R.E. ORG: W342 DATE: 88-02-22
+

Test two pds (grib product definition section) to see if all equal; otherwise .false. if key = 1, all 24 characters are tested, if key = 0 , the date (characters 13-17) are not tested. If key = 2, 11 of 1st 12 bytes are tested. Byte 4 is is not tested, so table version number can change and your program will still work. If key=3, test bytes 1-3, 7-12.

+

Program history log:

    +
  • Ralph Jones 1988-02-22
    • +
  • Ralph Jones 1989-08-29 Add entry iw3pds, an alias name.
    • +
  • Ralph Jones 1989-08-29 Change to cray cft77 fortran, make iw3pds the function name, iw3pdb the alias.
    • +
  • Ralph Jones 1994-02-10 Add key=2, test only 11 of 1st 12 bytes. Byte 4 (table version no.) is not tested.
    • +
  • Ralph Jones 1994-07-07 Add key=3, test bytes 1-3, 7-12.
    • +
+

USAGE: II = IW3PDS(L1,L2,KEY) II = IW3PDB(L1,L2,KEY) ALIAS

+
Parameters
+ + + + + +
[in]L1character array to match with l2, l1 can also be a 3 word integer array.
[in]L2character array to match with l1, l2 can also be a 3 word integer array.
[in]KEY0, DO NOT INCLUDE THE DATE (BYTES 13-17) IN MATCH.
    +
  • 1, match 24 bytes of pds
    • +
  • 2, match bytes 1-3, 5-12 of pds
    • +
  • 3, match bytes 1-3, 7-12 of pds
    • +
+
[out]IW3PDBlogical .true. if l1 and l2 match on all char., logical .false. if not match on any char.
+
+
+
Note
Alias added because of name change in grib write up. Name of pdb (product definition block) was changd to pds (product definition section).
+ +

Definition in file iw3pds.f.

+
+
+ + + + diff --git a/ver-2.10.0/iw3pds_8f.js b/ver-2.10.0/iw3pds_8f.js new file mode 100644 index 00000000..e71b2db0 --- /dev/null +++ b/ver-2.10.0/iw3pds_8f.js @@ -0,0 +1,4 @@ +var iw3pds_8f = +[ + [ "iw3pds", "iw3pds_8f.html#a445f0e2409ada1e8ece3e1a24f9cd361", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/iw3pds_8f_source.html b/ver-2.10.0/iw3pds_8f_source.html new file mode 100644 index 00000000..7bdb351c --- /dev/null +++ b/ver-2.10.0/iw3pds_8f_source.html @@ -0,0 +1,247 @@ + + + + + + + +NCEPLIBS-w3emc: iw3pds.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
iw3pds.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Test two pds (grib product definition section) to see
+
3 C> if all equal; otherwise .false.
+
4 C> @author Ralph Jones @date 1988-02-22
+
5 C> FUNCTION: IW3PDS TEST FOR MATCH OF TWO PDS
+
6 C> AUTHOR: JONES, R.E. ORG: W342 DATE: 88-02-22
+
7 C>
+
8 C> Test two pds (grib product definition section) to see
+
9 C> if all equal; otherwise .false. if key = 1, all 24 characters
+
10 C> are tested, if key = 0 , the date (characters 13-17) are not
+
11 C> tested. If key = 2, 11 of 1st 12 bytes are tested. Byte 4 is
+
12 C> is not tested, so table version number can change and your
+
13 C> program will still work. If key=3, test bytes 1-3, 7-12.
+
14 C>
+
15 C> Program history log:
+
16 C> - Ralph Jones 1988-02-22
+
17 C> - Ralph Jones 1989-08-29 Add entry iw3pds, an alias name.
+
18 C> - Ralph Jones 1989-08-29 Change to cray cft77 fortran, make iw3pds
+
19 C> the function name, iw3pdb the alias.
+
20 C> - Ralph Jones 1994-02-10 Add key=2, test only 11 of 1st 12 bytes.
+
21 C> Byte 4 (table version no.) is not tested.
+
22 C> - Ralph Jones 1994-07-07 Add key=3, test bytes 1-3, 7-12.
+
23 C>
+
24 C> USAGE: II = IW3PDS(L1,L2,KEY)
+
25 C> II = IW3PDB(L1,L2,KEY) ALIAS
+
26 C>
+
27 C> @param[in] L1 character array to match with l2,
+
28 C> l1 can also be a 3 word integer array.
+
29 C> @param[in] L2 character array to match with l1,
+
30 C> l2 can also be a 3 word integer array.
+
31 C> @param[in] KEY 0, DO NOT INCLUDE THE DATE (BYTES 13-17) IN MATCH.
+
32 C> - 1, match 24 bytes of pds
+
33 C> - 2, match bytes 1-3, 5-12 of pds
+
34 C> - 3, match bytes 1-3, 7-12 of pds
+
35 C> @param[out] IW3PDB logical .true. if l1 and l2 match on all char.,
+
36 C> logical .false. if not match on any char.
+
37 C>
+
38 C> @note Alias added because of name change in grib write up.
+
39 C> Name of pdb (product definition block) was changd to pds
+
40 C> (product definition section).
+
41 C>
+
42  LOGICAL FUNCTION iw3pds(L1, L2, KEY)
+
43 C
+
44  CHARACTER*1 L1(24)
+
45  CHARACTER*1 L2(24)
+
46 C
+
47  LOGICAL IW3PDB
+
48 C
+
49  SAVE
+
50 C
+
51  iw3pds = .true.
+
52 C
+
53  IF (key.EQ.1) THEN
+
54  DO 10 i = 1,3
+
55  IF (l1(i).NE.l2(i)) GO TO 70
+
56  10 CONTINUE
+
57 C
+
58  DO 20 i = 5,24
+
59  IF (l1(i).NE.l2(i)) GO TO 70
+
60  20 CONTINUE
+
61 C
+
62  ELSE
+
63 C
+
64  DO 30 i = 1,3
+
65  IF (l1(i).NE.l2(i)) GO TO 70
+
66  30 CONTINUE
+
67 C
+
68 C DO NOT TEST BYTE 4, 5, 6 PDS VER. NO., COUNTRY
+
69 C MODEL NUMBER. U.S., U.K., FNOC WAFS DATA WILL
+
70 C WORK.
+
71 C
+
72  IF (key.EQ.3) THEN
+
73  DO i = 7,12
+
74  IF (l1(i).NE.l2(i)) GO TO 70
+
75  END DO
+
76  GO TO 60
+
77  END IF
+
78 C
+
79 C DO NOT TEST PDS VERSION NUMBER, IT MAY BE 1 O 2
+
80 C
+
81  DO 40 i = 5,12
+
82  IF (l1(i).NE.l2(i)) GO TO 70
+
83  40 CONTINUE
+
84  IF (key.EQ.2) GO TO 60
+
85 C
+
86  DO 50 i = 18,24
+
87  IF (l1(i).NE.l2(i)) GO TO 70
+
88  50 CONTINUE
+
89  ENDIF
+
90 C
+
91  60 CONTINUE
+
92  RETURN
+
93 C
+
94  70 CONTINUE
+
95  iw3pds = .false.
+
96  RETURN
+
97 C
+
98  entry iw3pdb(l1, l2, key)
+
99 C
+
100  iw3pdb = .true.
+
101 C
+
102  IF (key.EQ.1) THEN
+
103  DO 80 i = 1,3
+
104  IF (l1(i).NE.l2(i)) GO TO 140
+
105  80 CONTINUE
+
106 C
+
107  DO 90 i = 5,24
+
108  IF (l1(i).NE.l2(i)) GO TO 140
+
109  90 CONTINUE
+
110 C
+
111  ELSE
+
112 C
+
113  DO 100 i = 1,3
+
114  IF (l1(i).NE.l2(i)) GO TO 140
+
115  100 CONTINUE
+
116 C
+
117 C DO NOT TEST BYTE 4, 5, 6 PDS VER. NO., COUNTRY
+
118 C MODEL NUMBER. U.S., U.K., FNOC WAFS DATA WILL
+
119 C WORK.
+
120 C
+
121  IF (key.EQ.3) THEN
+
122  DO i = 7,12
+
123  IF (l1(i).NE.l2(i)) GO TO 140
+
124  END DO
+
125  GO TO 130
+
126  END IF
+
127 C
+
128 C DO NOT TEST PDS VERSION NUMBER, IT MAY BE 1 O 2
+
129 C
+
130  DO 110 i = 5,12
+
131  IF (l1(i).NE.l2(i)) GO TO 140
+
132  110 CONTINUE
+
133  IF (key.EQ.2) GO TO 130
+
134 C
+
135  DO 120 i = 18,24
+
136  IF (l1(i).NE.l2(i)) GO TO 140
+
137  120 CONTINUE
+
138  ENDIF
+
139 C
+
140  130 CONTINUE
+
141  RETURN
+
142 C
+
143  140 CONTINUE
+
144  iw3pdb = .false.
+
145  RETURN
+
146  END
+
+
+ + + + diff --git a/ver-2.10.0/iw3unp29_8f.html b/ver-2.10.0/iw3unp29_8f.html new file mode 100644 index 00000000..1f645bb6 --- /dev/null +++ b/ver-2.10.0/iw3unp29_8f.html @@ -0,0 +1,639 @@ + + + + + + + +NCEPLIBS-w3emc: iw3unp29.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
iw3unp29.f File Reference
+
+
+ +

Reads and unpacks one report into the unpacked office note 29/124 format. +More...

+ +

Go to the source code of this file.

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

+Functions/Subroutines

character *6 function c01o29 (SUBSET)
 This function read subset and returns group name. More...
 
+character *8 function c02o29 ()
 
function i01o29 (LUNIT, HDR, IER)
 This function read obs files and returns error message. More...
 
function i02o29 (LUNIT, OBS, IER)
 This function read obs files and returns error message. More...
 
function i03o29 (NUNIT, OBS, IER)
 This function reads a true (see *) on29/124 data set and unpacks one report into the unpacked office note 29/124 format. More...
 
+function i04o29 (P)
 
function i05o29 (STRING, NUM, CHAR)
 This function finds the location of the next numeric character in a string of characters. More...
 
function iw3unp29 (LUNIT, OBS, IER)
 This routine has not been tested reading input data from any dump type in ON29/124 format on WCOSS. More...
 
+logical function l01o29 ()
 
function r01o29 (SUBSET, LUNIT, OBS)
 This function read subset and returns corresponding file data. More...
 
+function r02o29 ()
 
+function r03o29 (LUNIT, OBS)
 
+function r04o29 (LUNIT, OBS)
 
+function r05o29 (LUNIT, OBS)
 
+function r06o29 (LUNIT, OBS)
 
+function r07o29 (LUNIT, OBS)
 
+subroutine s01o29 (SID, XOB, YOB, RHR, RCH, RSV, RSV2, ELV, ITP, RTP)
 
+subroutine s02o29 (ICAT, N,)
 
+subroutine s03o29 (UNP, SUBSET,,)
 
+subroutine s04o29
 
+subroutine s05o29
 
subroutine s06o29 (IDEN, ID)
 This subrountine modifies amdar reports so that last character ends with 'Z'. More...
 
+

Detailed Description

+

Reads and unpacks one report into the unpacked office note 29/124 format.

+
Author
Dennis Keyser
+
Date
2013-03-20
+ +

Definition in file iw3unp29.f.

+

Function/Subroutine Documentation

+ +

◆ c01o29()

+ +
+
+ + + + + + + + +
character*6 function c01o29 (character*(*) SUBSET)
+
+ +

This function read subset and returns group name.

+
Parameters
+ + +
SUBSETsubset
+
+
+
Returns
group name
+
Author
Dennis Keyser
+
Date
2013-03-20
+ +

Definition at line 930 of file iw3unp29.f.

+ +
+
+ +

◆ i01o29()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
function i01o29 ( LUNIT,
dimension(*) HDR,
 IER 
)
+
+ +

This function read obs files and returns error message.

+
Parameters
+ + + + +
LUNITfull path of file
HDRheader of file
IERmissing or invalid data indicator
+
+
+
Returns
Y2K COMPLIANT
+
Author
Dennis Keyser
+
Date
2013-03-20
+ +

Definition at line 477 of file iw3unp29.f.

+ +
+
+ +

◆ i02o29()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
function i02o29 ( LUNIT,
dimension(1608) OBS,
 IER 
)
+
+ +

This function read obs files and returns error message.

+
Parameters
+ + + + +
LUNITfull path of file
OBSdata output
IERmissing or invalid data indicator
+
+
+
Returns
Y2K COMPLIANT
+
Author
Dennis Keyser
+
Date
2013-03-20
+ +

Definition at line 546 of file iw3unp29.f.

+ +
+
+ +

◆ i03o29()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
function i03o29 ( NUNIT,
integer, dimension(*) OBS,
 IER 
)
+
+ +

This function reads a true (see *) on29/124 data set and unpacks one report into the unpacked office note 29/124 format.

+

the input and output arguments here have the same meaning as for iw3unp29. repeated calls of function will return a sequence of unpacked on29/124 reports. * - unlike original "true" on29/124 data sets, the "expected" file header label is a y2k compliant 40-byte pseudo-on85 version - if this is not encountered this code, as a temporary measure during the y2k transition period, will look for the original non-y2k compliant 32-byte on85 header label and use the "windowing" technique to convert the 2-digit year to a 4-digit year in preparation for returning a 40-byte pseudo-on85 label in the first C call. (see iw3unp29 docblock for format of 40-byte pseudo-on85 header label.)

+

Program History Log: -1991-07-23 Dennis Keyser w3fi64 (f77) internal read error no longer causes calling program to fail but will move to next record if can't recover to next report -1993-10-07 Dennis Keyser – adapted for use on cray (added save statement, removed ibm-specific code, etc.) -1993-10-15 R. E. Jones added code so if file is ebcdic it converts it to ascii -1996-10-04 Jack Woollen changed name to i03gad and incorporated into new w3lib routine iw3gad -2013-03-20 Dennis Keyser changes to run on wcoss

+
Parameters
+ + + + +
[in]nunitfortran unit number for sequential data set containing packed and blocked office note 29/124 reports
[out]obsarray containing one report in unpacked office note
    +
  • 29/124 format is mixed, user must equivalence
    • +
  • integer and character arrays to this array (see
    • +
  • docblock for w3fi64 in /nwprod/lib/sorc/w3nco
    • +
  • or writeups on w3fi64, on29, on124 for help)
    • +
  • the length of the array should be at least 1608
    • +
+
[out]ierreturn flag (equal to function value) in iw3unp29 docblock
+
+
+
Returns
Y2K COMPLIANT
+
Note
aa unit number specified by input argument "nunit") called by subprogram iw3unp29.
+
Author
keyser
+
Date
2013-03-20
+ +

Definition at line 696 of file iw3unp29.f.

+ +
+
+ +

◆ i05o29()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
function i05o29 (character*1, dimension(1) STRING,
 NUM,
character*1 CHAR 
)
+
+ +

This function finds the location of the next numeric character in a string of characters.

+
Parameters
+ + + + +
[in]STRINGCharacter array.
[in]NUMNumber of characters to search in string.
[out]CHARCharacter found.
+
+
+
Returns
I05O29 Integer*4 location of alphanumeric character, = 0 if not found.
+
Author
Ray Crayton
+
Date
1989-07-07
+ +

Definition at line 4585 of file iw3unp29.f.

+ +
+
+ +

◆ iw3unp29()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
function iw3unp29 ( LUNIT,
dimension(*) OBS,
 IER 
)
+
+ +

This routine has not been tested reading input data from any dump type in ON29/124 format on WCOSS.

+

It likely will not work when attempting to read ON29/124 format dumps on WCOSS. It has also not been tested reading any dump file other than ADPUPA (BUFR input only) on WCOSS. It does work reading BUFR ADPUPA dump files on WCOSS. It will hopefully working reading other BUFR (only) dump files on WCOSS. Also, this routine is only known to work correctly when compiled using 8 byte machine words (real and integer).

+

Reads and unpacks one report into the unpacked office note 29/124 format. The input data may be packed into either bufr or true on29/124 format with a y2k compliant pseudo-on85 header label. (Note: as a temporary measure, this code will still operate on a true on29/124 format file with a non-y2k compliant on85 header label. The code will use the "windowing" technique to obtain a 4-digit year.) This routine will determine the format of the input data and take the appropriate action. It returns the unpacked report to the calling program in the array 'obs'. Various contingencies are covered by return value of the function and parameter 'ier' - function and ier have same value. Repeated calls of function will return a sequence of unpacked on29/124 reports. The calling program may switch to a new 'nunit' at any time, that dataset will then be read in sequence. If user switches back to a previous 'nunit', that data set will be read from the beginning, not from where the user left off (this is a 'software tool', not an entire i/o system).

+

Program history log:

    +
  • Jack Woollen 1996-12-13 (gsc) Note this new version of iw3gad incorporates the earlier version which was written by j. stackpole and dealt only with true on29/124 data as input - this option is still available but is a small part of the new routine which was written from scratch to read in bufr data.
    • +
  • Dennis Keyser 1997-01-27 Changes to more closely duplicate format obtained when reading from true on29/124 data sets.
    • +
  • Dennis Keyser 1997-02-04 Drops with missing stnid get stnid set to "drp88a"; satwnds with zero pressure are tossed.
    • +
  • Dennis Keyser 1997-02-12 To get around the 3-bit limitation to the on29 pressure q.m. mnemonic "qmpr", an sdmedit/quips purge or reject flag on pressure is changed from 12 or 14 to 6 in order to fit into 3-bits, see function e35o29; interprets sdmedit and quips purge/keep/change flags properly for all data types; can now process cat. 6 and cat. 2/3 type flight-level reccos (before skipped these); tests for missing lat, lon, obtime decoded from bufr and retains missing value on these in unpacked on29/124 format (before no missing check, led to possible non- missing but incorrect values for these); the check for drops with missing stnid removed since decoder fixed for this.
    • +
  • Dennis Keyser 1997-05-01 Looks for duplicate levels when processing on29 cat. 2, 3, and 4 (in all data on level) and removes duplicate level; in processing on29 cat. 3 levels, removes all levels where wind is missing; fixed bug in aircraft (airep/pirep/amdar) quality mark assignment (was not assigning keep flag to report if pressure had a keep q.m. but temperature q.m. was missing).
    • +
  • Dennis Keyser 1997-05-30 For aircft: (only acars right now) - seconds are decoded (if avail.) and used to obtain report time; only asdar/amdar - new cat. 8 code figs. o-put 917 (char. 1 & 2 of actual stnid), 918 (char. 3 & 4 of actual stnid), 919 (char. 5 & 6 of actual stnid); asdar/amdar and acars - new cat. 8 code fig. o-put 920 (char. 7 & 8 of actual stnid); only acars - new cat. 8 code fig. o-put 921 (report time to nearest 1000'th of an hour); only some acars - new mnemonic "ialt" now exists and can (if line not commented out) be used to obtain unpacked on29 cat. 6.
    • +
  • Dennis Keyser 1997-07-02 Removed filtering of aircraft data as follows: air france amdars no longer filtered, amdar/ asdar below 7500 ft. no longer filtered, airep/pirep below 100 meters no longer filtered, all aircraft with missing wind but valid temperature are no longer filtered; reprocesses u.s. satwnd stn. ids to conform with previous on29 appearance except now 8-char (tag char. 1 & 6 not changed from bufr stn. id) - never any dupl. ids now for u.s. satwnds decoded from a single bufr file; streamlined/eliminated some do loops to speed up a bit.
    • +
  • Dennis Keyser 1997-09-18 Corrected errors in reformatting surface data into unpacked on124, specifically-header: inst. type (synoptic fmt flg, auto stn. type, converted hrly flg), indicators (precip., wind speed, wx/auto stn), cat51: p-tend, horiz. viz., present/past wx, cloud info, max/ min temp, cat52: precip., snow dpth, wave info, ship course/speed, cat8: code figs. 81-85,98; corrected problem which coded upper-air mandatory level winds as cat. 3 instead of cat. 1 when mass data (only) was reported on same mandatory level in a separate reported level in the raw bulletin.
    • +
  • Dennis Keyser 1997-10-06 Updated logic to read and process nesdis hi-density satellite winds properly.
    • +
  • Dennis Keyser 1997-10-30 Added gross check on u-air pressure, all levels with reported pressure .le. zero now tossed; sfc cat. 52 sea-sfc temperature now read from hierarchy of sst in bufr {1st choice - hi-res sst ('sst2'), 2nd choice - lo-res sst ('sst1'), 3rd choice - sea temp ('stmp')}, before only read 'sst1'.
    • +
  • Dennis Keyser 1998-01-26 Changed pqm processing for adpupa types such that sdmedit flags are now honored (before, pqm was always hardwired to 2 for adpupa types); bumped limit for number of levels that can be processed from 100 to 150 and added diagnostic print when the limit is exceeded.
    • +
  • Dennis Keyser 1998-05-19 Y2k compliant version of iw3gad routine accomplished by redefining original 32-character on85 header label to be a 40-character label that contains a full 4-digit year, can still read "true" on29/124 data sets provided their header label is in this modified form.
    • +
  • Dennis Keyser 1998-07-22 Minor modifications to account for corrections in y2k/f90 bufrlib (mainly related to bufrlib routine dumpbf).
    • +
  • Dennis Keyser 1998-08-04 Fixed a bug that resulted in code being clobbered in certain situations for recco reports; minor modifications to give same answers on cray as on sgi; allowed code to read true on29/124 files with non-y2k compliant on85 label (a temporary measure during transition of main programs to y2k); added call to "aea" which converts ebcdic characters to ascii for input true on29/124 data set processing of sgi (which does not support "-cebcdic" in assign statement).
    • +
  • Dennis Keyser 1999-02-25 Added ability to read reprocessed ssm/i bufr data set (spssmi); added ability to read mean sea-level pressure bogus (paobs) data set (sfcbog).
    • +
  • Dennis Keyser 1999-05-14 Made changes necessary to port this routine to the ibm sp.
    • +
  • Dennis Keyser 1999-06-18 Can now process water vapor satwnds from foreign producers; stn. id for foreign satwnds now reprocessed in same way as for nesdis/goes satwnds, character 1 of stn. id now defines even vs. odd satellite while character 6 of stn. id now defines ir cloud-drft vs. visible cloud drft vs. water vapor.
    • +
  • Dennis Keyser 2002-03-05 Removed entry "e02o29", now performs height to press. conversion directly in code for cat. 7; test for missing "rpid" corrected for adpupa data (now checks ufbint return code rather than value=bmiss); accounts for changes in input adpupa, adpsfc, aircft and aircar bufr dump files after 3/2002: cat. 7 and cat. 51 use mnemonic "hblcs" to get height of cloud base if mnemonic "hocb" not available (and it will not be for all cat. 7 and some cat. 51 reports); mnemonic "tiwm" replaces "suws" in header for surface data; mnemonic "borg" replaces "icli" in cat. 8 for aircraft data (will still work properly for input adpupa, adpsfc, aircft and aircar dump files prior to 3/2002).
    • +
  • Dennis Keyser 2013-03-20 Changes to run on wcoss, obtain value of bmiss set in calling program via call to bufrlib routine getbmiss rather than hardwiring it to 10e08 (or 10e10); use formatted print statements where previously unformatted print was used (wcoss splits unformatted print at 80 characters).
    • +
+
Parameters
+ + + + +
[in]lunitfortran unit number for sequential data set containing packed bufr reports or packed and blocked office note 29/124 reports
[out]obsarray containing one report in unpacked office note 29/124 format. Format is mixed, user must equivalence integer and character arrays to this array (see docblock for w3fi64 in /nwprod/lib/sorc/w3nco or writeups on w3fi64, on29, on124 for help) the length of the array should be at least 1608.
[out]ierreturn flag (equal to function value)
+
+
+

Input files:

    +
  • unit aa sequential bufr or office note 29/124 data set ("aa" is unit number specified by input argument "nunit")
    • +
+

Output files:

    +
  • unit 06 printout
    • +
+
Note
    +
  • if input data set is on29/124, it should be assigned in this way:
      +
    • cray:
        +
      • assign -a adpupa -fcos -cebcdic fort.xx
        • +
      +
      • +
    • sgi:
        +
      • assign -a adpupa -fcos fort.xx (note: -cebcdic is not possible on sgi, so call to w3nco routine "aea" takes care of the conversion as each on29 record is read in)
        • +
      +
      • +
    +
    • +
  • if input data set is bufr, it should be assigned in this way:
      +
    • cray:
        +
      • assign -a adpupa fort.xx
        • +
      +
      • +
    • sgi:
        +
      • assign -a adpupa -f cos fort.xx
        • +
      +
      • +
    +
    • +
+
+

For input on29/124 data sets, a contingency has been built into this subroutine to perform the conversion from ebcdic to ascii in the event the assign does not perform the conversion the return flags in ier (and function iw3unp29 itself) are:

    +
  • 0 Observation read and unpacked into location 'obs'. see writeup of w3fi64 for contents. (all character words are left-justified.) Next call to iw3unp29 will return next observation in data set.
    • +
  • 1 A 40 byte header in the format described here (y2k compliant pseudo-office note 85) is returned in the first 10 words of 'obs' on a 4-byte machine (ibm) and in the first 5 words of 'obs' on an 8-byte machine (cray). Next call to iw3unp29 will return first obs. in this data set. (note: if input data set is a true on29/124 file with the y2k compliant pseudo-on85 header record, then the pseudo-on85 header record is actually read in and returned; if input data set is a true on29/124 file with a non-y2k compliant on85 header record, then a y2k compliant pseudo-on85 header record is constructed from it using the "windowing" technique to obtain a 4-digit year from a 2-digit year.) format for y2k compliant pseudo-on85 header record returned (40 bytes in character):
      +
    • bytes 1- 8 – data set name (as defined in on85 except up to eight ascii char., left justified with blank fill)
      • +
    • bytes 9-10 – set type (as defined in on85)
      • +
    • bytes 11-20 – center (analysis) date for data set (ten ascii characters in form "yyyymmddhh")
      • +
    • bytes 21-24 – set initialize (dump) time, as dedined in on85)
      • +
    • bytes 25-34 – always "washington" (as in on85)
      • +
    • bytes 35-36 – source machine (as defined in on85)
      • +
    • bytes 37-40 – blank fill characters
      • +
    +
    • +
  • 2 end-of-file (never an empty or null file):
      +
    • input on29/124 data set: the "endof file" record is encountered - no useful information in 'obs' array. next call to iw3unp29 will return physical end of file for data set in 'nunit' (see ier=3 below).
      • +
    • input bufr data set: the physical end of file is encountered. -3 end-of-file: Physical end of file encountered on data set - this can only happen for an empty (null) data set or for a true on29/124 data set. There are no more reports (or never were any if null) associated with data set in this unit number - no useful information in 'obs' array. Either all done (if no more unit numbers are to be read in), or reset 'nunit' to point to a new data set (in which case next call to iw3unp29 should return with ier=1).
      • +
    +
    • +
  • 4 only valid for input on29/124 data set - i/o error reading the next record of reports - no useful information in 'obs' array. Calling program can choose to stop or again call iw3unp29 which will attempt to unpack the first observation in the next record of reports.
    • +
  • 999 applies only to non-empty data sets:
      +
    • input on29/124 data set: first choice y2k compliant pseudo-on85 file header label not encountered where expected, and second choice non-y2k compliant on85 file header label also not encountered.
      • +
    • input bufr data set either header label in format of pseudo-on85 could not be returned, or an abnormal error occurred in the attempt to decode an observation. For either input data set type, no useful information in 'obs' array. Calling program can choose to stop with non-zero condition code or reset 'nunit' to point to a new data set (in which case next call to iw3unp29 should return with ier=1).
      • +
    • input data set neither on29/124 nor bufr speaks for itself.
      • +
    +
    • +
+
Author
Dennis Keyser
+
Date
2013-03-20
+ +

Definition at line 271 of file iw3unp29.f.

+ +
+
+ +

◆ r01o29()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + +
function r01o29 (character*(*) SUBSET,
 LUNIT,
dimension(*) OBS 
)
+
+ +

This function read subset and returns corresponding file data.

+
Parameters
+ + + + +
SUBSETsubset
LUNITfull path of file
OBSdata output
+
+
+
Returns
file data
+
Author
Dennis Keyser
+
Date
2013-03-20
+ +

Definition at line 982 of file iw3unp29.f.

+ +
+
+ +

◆ s06o29()

+ +
+
+ + + + + + + + + + + + + + + + + + +
subroutine s06o29 (character*8 IDEN,
character*8 ID 
)
+
+ +

This subrountine modifies amdar reports so that last character ends with 'Z'.

+
Parameters
+ + + +
[in]IDENAcft id
[out]IDModified aircraft id.
+
+
+
Author
RAY CRAYTON
+
Date
1992-02-16
+ +

Definition at line 4482 of file iw3unp29.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/iw3unp29_8f.js b/ver-2.10.0/iw3unp29_8f.js new file mode 100644 index 00000000..dfec93ac --- /dev/null +++ b/ver-2.10.0/iw3unp29_8f.js @@ -0,0 +1,25 @@ +var iw3unp29_8f = +[ + [ "c01o29", "iw3unp29_8f.html#ade469dc7a458658c23096016179ff9e2", null ], + [ "c02o29", "iw3unp29_8f.html#a128244e0131b7729a0cd5a8394884823", null ], + [ "i01o29", "iw3unp29_8f.html#a0d3c45449c312f0e99cdb92777a3220a", null ], + [ "i02o29", "iw3unp29_8f.html#ae9e0c357df4d0c782d851fdd8ce09e14", null ], + [ "i03o29", "iw3unp29_8f.html#af0213dc1cf8d73c372bcacc88c16fdf9", null ], + [ "i04o29", "iw3unp29_8f.html#a8734122f4e8dc4d7c3bee6b20163dc3f", null ], + [ "i05o29", "iw3unp29_8f.html#a89e6f36d2a7dae698c0dff8a77b078a2", null ], + [ "iw3unp29", "iw3unp29_8f.html#a1de5e205645a3843697845185ffaaeb1", null ], + [ "l01o29", "iw3unp29_8f.html#a7ae1a11087922d6d32c47d99994dc861", null ], + [ "r01o29", "iw3unp29_8f.html#af252340bc4d8811a4d6e799bdf1c3790", null ], + [ "r02o29", "iw3unp29_8f.html#ae23b98e3d9c9097a9ea45e9473aee287", null ], + [ "r03o29", "iw3unp29_8f.html#abf74c81fb101796c5ab245b59b0ab2ad", null ], + [ "r04o29", "iw3unp29_8f.html#a46e52ce72580afe04ee309c16200108b", null ], + [ "r05o29", "iw3unp29_8f.html#a46ccc2cccd3cb6bcd7b03d70675f4ca1", null ], + [ "r06o29", "iw3unp29_8f.html#a416026063ded48e8480b8e3b0896e74c", null ], + [ "r07o29", "iw3unp29_8f.html#a93f8486c638db70b2a2a61ac05bcdcac", null ], + [ "s01o29", "iw3unp29_8f.html#a50f37364b576374fbe3c899bf5ba8d0b", null ], + [ "s02o29", "iw3unp29_8f.html#abde82aa52df7bac07bc64ff10e069651", null ], + [ "s03o29", "iw3unp29_8f.html#ada2cb47a16ee97b27de331a013882382", null ], + [ "s04o29", "iw3unp29_8f.html#a2ad28b39cd4d3b38df93a51a15a56555", null ], + [ "s05o29", "iw3unp29_8f.html#ac80679ca645813f0da98c23fe6bc79a4", null ], + [ "s06o29", "iw3unp29_8f.html#a2d15cb33d16ceab9921e8add94c30a42", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/iw3unp29_8f_source.html b/ver-2.10.0/iw3unp29_8f_source.html new file mode 100644 index 00000000..8d1d06cd --- /dev/null +++ b/ver-2.10.0/iw3unp29_8f_source.html @@ -0,0 +1,4714 @@ + + + + + + + +NCEPLIBS-w3emc: iw3unp29.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
iw3unp29.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief Reads and unpacks one report into the unpacked office note
+
3 C> 29/124 format
+
4 C> @author Dennis Keyser @date 2013-03-20
+
5 
+
6 C> This routine has not been tested reading input data from any dump
+
7 C> type in ON29/124 format on WCOSS. It likely will not work when
+
8 C> attempting to read ON29/124 format dumps on WCOSS. It has also
+
9 C> not been tested reading any dump file other than ADPUPA (BUFR
+
10 C> input only) on WCOSS. It does work reading BUFR ADPUPA dump files
+
11 C> on WCOSS. It will hopefully working reading other BUFR (only)
+
12 C> dump files on WCOSS. Also, this routine is only known to work correctly
+
13 C> when compiled using 8 byte machine words (real and integer).
+
14 C>
+
15 C> Reads and unpacks one report into the unpacked office note
+
16 C> 29/124 format. The input data may be packed into either bufr or
+
17 C> true on29/124 format with a y2k compliant pseudo-on85 header label.
+
18 C> (Note: as a temporary measure, this code will still operate on a
+
19 C> true on29/124 format file with a non-y2k compliant on85 header
+
20 C> label. The code will use the "windowing" technique to obtain a
+
21 C> 4-digit year.) This routine will determine the format of the
+
22 C> input data and take the appropriate action. It returns the
+
23 C> unpacked report to the calling program in the array 'obs'.
+
24 C> Various contingencies are covered by return value of the function
+
25 C> and parameter 'ier' - function and ier have same value. Repeated
+
26 C> calls of function will return a sequence of unpacked on29/124
+
27 C> reports. The calling program may switch to a new 'nunit' at any
+
28 C> time, that dataset will then be read in sequence. If user
+
29 C> switches back to a previous 'nunit', that data set will be read
+
30 C> from the beginning, not from where the user left off (this is a
+
31 C> 'software tool', not an entire i/o system).
+
32 C>
+
33 C> Program history log:
+
34 C> - Jack Woollen 1996-12-13 (gsc) Note this new
+
35 C> version of iw3gad incorporates the earlier version which
+
36 C> was written by j. stackpole and dealt only with true
+
37 C> on29/124 data as input - this option is still available
+
38 C> but is a small part of the new routine which was written
+
39 C> from scratch to read in bufr data.
+
40 C> - Dennis Keyser 1997-01-27 Changes to more closely duplicate format
+
41 C> obtained when reading from true on29/124 data sets.
+
42 C> - Dennis Keyser 1997-02-04 Drops with missing stnid get stnid set to
+
43 C> "drp88a"; satwnds with zero pressure are tossed.
+
44 C> - Dennis Keyser 1997-02-12 To get around the 3-bit limitation to
+
45 C> the on29 pressure q.m. mnemonic "qmpr", an sdmedit/quips
+
46 C> purge or reject flag on pressure is changed from 12 or 14
+
47 C> to 6 in order to fit into 3-bits, see function e35o29;
+
48 C> interprets sdmedit and quips purge/keep/change flags
+
49 C> properly for all data types; can now process cat. 6 and
+
50 C> cat. 2/3 type flight-level reccos (before skipped these);
+
51 C> tests for missing lat, lon, obtime decoded from bufr and
+
52 C> retains missing value on these in unpacked on29/124
+
53 C> format (before no missing check, led to possible non-
+
54 C> missing but incorrect values for these); the check for
+
55 C> drops with missing stnid removed since decoder fixed for
+
56 C> this.
+
57 C> - Dennis Keyser 1997-05-01 Looks for duplicate levels when
+
58 C> processing on29 cat. 2, 3, and 4 (in all data on level)
+
59 C> and removes duplicate level; in processing on29 cat. 3
+
60 C> levels, removes all levels where wind is missing; fixed
+
61 C> bug in aircraft (airep/pirep/amdar) quality mark
+
62 C> assignment (was not assigning keep flag to report if
+
63 C> pressure had a keep q.m. but temperature q.m. was
+
64 C> missing).
+
65 C> - Dennis Keyser 1997-05-30 For aircft: (only acars right now) -
+
66 C> seconds are decoded (if avail.) and used to obtain
+
67 C> report time; only asdar/amdar - new cat. 8 code figs.
+
68 C> o-put 917 (char. 1 & 2 of actual stnid), 918 (char. 3 &
+
69 C> 4 of actual stnid), 919 (char. 5 & 6 of actual stnid);
+
70 C> asdar/amdar and acars - new cat. 8 code fig. o-put 920
+
71 C> (char. 7 & 8 of actual stnid); only acars - new cat. 8
+
72 C> code fig. o-put 921 (report time to nearest 1000'th of
+
73 C> an hour); only some acars - new mnemonic "ialt" now
+
74 C> exists and can (if line not commented out) be used to
+
75 C> obtain unpacked on29 cat. 6.
+
76 C> - Dennis Keyser 1997-07-02 Removed filtering of aircraft data as
+
77 C> follows: air france amdars no longer filtered, amdar/
+
78 C> asdar below 7500 ft. no longer filtered, airep/pirep
+
79 C> below 100 meters no longer filtered, all aircraft with
+
80 C> missing wind but valid temperature are no longer
+
81 C> filtered; reprocesses u.s. satwnd stn. ids to conform
+
82 C> with previous on29 appearance except now 8-char (tag
+
83 C> char. 1 & 6 not changed from bufr stn. id) - never any
+
84 C> dupl. ids now for u.s. satwnds decoded from a single
+
85 C> bufr file; streamlined/eliminated some do loops to
+
86 C> speed up a bit.
+
87 C> - Dennis Keyser 1997-09-18 Corrected errors in reformatting surface
+
88 C> data into unpacked on124, specifically-header: inst. type
+
89 C> (synoptic fmt flg, auto stn. type, converted hrly flg),
+
90 C> indicators (precip., wind speed, wx/auto stn), cat51:
+
91 C> p-tend, horiz. viz., present/past wx, cloud info, max/
+
92 C> min temp, cat52: precip., snow dpth, wave info, ship
+
93 C> course/speed, cat8: code figs. 81-85,98; corrected
+
94 C> problem which coded upper-air mandatory level winds
+
95 C> as cat. 3 instead of cat. 1 when mass data (only) was
+
96 C> reported on same mandatory level in a separate reported
+
97 C> level in the raw bulletin.
+
98 C> - Dennis Keyser 1997-10-06 Updated logic to read and process nesdis
+
99 C> hi-density satellite winds properly.
+
100 C> - Dennis Keyser 1997-10-30 Added gross check on u-air pressure, all
+
101 C> levels with reported pressure .le. zero now tossed; sfc
+
102 C> cat. 52 sea-sfc temperature now read from hierarchy of
+
103 C> sst in bufr {1st choice - hi-res sst ('sst2'), 2nd
+
104 C> choice - lo-res sst ('sst1'), 3rd choice - sea temp
+
105 C> ('stmp')}, before only read 'sst1'.
+
106 C> - Dennis Keyser 1998-01-26 Changed pqm processing for adpupa types
+
107 C> such that sdmedit flags are now honored (before, pqm
+
108 C> was always hardwired to 2 for adpupa types); bumped
+
109 C> limit for number of levels that can be processed from
+
110 C> 100 to 150 and added diagnostic print when the limit
+
111 C> is exceeded.
+
112 C> - Dennis Keyser 1998-05-19 Y2k compliant version of iw3gad routine
+
113 C> accomplished by redefining original 32-character on85
+
114 C> header label to be a 40-character label that contains a
+
115 C> full 4-digit year, can still read "true" on29/124 data
+
116 C> sets provided their header label is in this modified
+
117 C> form.
+
118 C> - Dennis Keyser 1998-07-22 Minor modifications to account for
+
119 C> corrections in y2k/f90 bufrlib (mainly related to
+
120 C> bufrlib routine dumpbf).
+
121 C> - Dennis Keyser 1998-08-04 Fixed a bug that resulted in code being
+
122 C> clobbered in certain situations for recco reports; minor
+
123 C> modifications to give same answers on cray as on sgi;
+
124 C> allowed code to read true on29/124 files with non-y2k
+
125 C> compliant on85 label (a temporary measure during
+
126 C> transition of main programs to y2k); added call to "aea"
+
127 C> which converts ebcdic characters to ascii for input
+
128 C> true on29/124 data set processing of sgi (which does
+
129 C> not support "-cebcdic" in assign statement).
+
130 C> - Dennis Keyser 1999-02-25 Added ability to read reprocessed ssm/i
+
131 C> bufr data set (spssmi); added ability to read mean
+
132 C> sea-level pressure bogus (paobs) data set (sfcbog).
+
133 C> - Dennis Keyser 1999-05-14 Made changes necessary to port this
+
134 C> routine to the ibm sp.
+
135 C> - Dennis Keyser 1999-06-18 Can now process water vapor satwnds
+
136 C> from foreign producers; stn. id for foreign satwnds
+
137 C> now reprocessed in same way as for nesdis/goes satwnds,
+
138 C> character 1 of stn. id now defines even vs. odd
+
139 C> satellite while character 6 of stn. id now defines
+
140 C> ir cloud-drft vs. visible cloud drft vs. water vapor.
+
141 C> - Dennis Keyser 2002-03-05 Removed entry "e02o29", now performs
+
142 C> height to press. conversion directly in code for cat. 7;
+
143 C> test for missing "rpid" corrected for adpupa data (now
+
144 C> checks ufbint return code rather than value=bmiss);
+
145 C> accounts for changes in input adpupa, adpsfc, aircft
+
146 C> and aircar bufr dump files after 3/2002: cat. 7 and cat.
+
147 C> 51 use mnemonic "hblcs" to get height of cloud base if
+
148 C> mnemonic "hocb" not available (and it will not be for all
+
149 C> cat. 7 and some cat. 51 reports); mnemonic "tiwm"
+
150 C> replaces "suws" in header for surface data; mnemonic
+
151 C> "borg" replaces "icli" in cat. 8 for aircraft data (will
+
152 C> still work properly for input adpupa, adpsfc, aircft and
+
153 C> aircar dump files prior to 3/2002).
+
154 C> - Dennis Keyser 2013-03-20 Changes to run on wcoss, obtain value of
+
155 C> bmiss set in calling program via call to bufrlib routine
+
156 C> getbmiss rather than hardwiring it to 10e08 (or 10e10);
+
157 C> use formatted print statements where previously
+
158 C> unformatted print was used (wcoss splits unformatted
+
159 C> print at 80 characters).
+
160 C>
+
161 C> @param[in] lunit fortran unit number for sequential data set containing
+
162 C> packed bufr reports or packed and blocked office note 29/124 reports
+
163 C> @param[out] obs array containing one report in unpacked office note
+
164 C> 29/124 format. Format is mixed, user must equivalence
+
165 C> integer and character arrays to this array (see
+
166 C> docblock for w3fi64 in /nwprod/lib/sorc/w3nco
+
167 C> or writeups on w3fi64, on29, on124 for help)
+
168 C> the length of the array should be at least 1608.
+
169 C> @param[out] ier return flag (equal to function value)
+
170 C>
+
171 C> Input files:
+
172 C> - unit aa sequential bufr or office note 29/124 data set ("aa"
+
173 C> is unit number specified by input argument "nunit")
+
174 C>
+
175 C> Output files:
+
176 C> - unit 06 printout
+
177 C>
+
178 C> @note
+
179 C> - if input data set is on29/124, it should be assigned in this way:
+
180 C> - cray:
+
181 C> - assign -a adpupa -fcos -cebcdic fort.xx
+
182 C> - sgi:
+
183 C> - assign -a adpupa -fcos fort.xx
+
184 C> (note: -cebcdic is not possible on sgi, so call to w3nco
+
185 C> routine "aea" takes care of the conversion as each
+
186 C> on29 record is read in)
+
187 C> - if input data set is bufr, it should be assigned in this way:
+
188 C> - cray:
+
189 C> - assign -a adpupa fort.xx
+
190 C> - sgi:
+
191 C> - assign -a adpupa -f cos fort.xx
+
192 C>
+
193 C> For input on29/124 data sets, a contingency has been built
+
194 C> into this subroutine to perform the conversion from ebcdic to
+
195 C> ascii in the event the assign does not perform the conversion
+
196 C> the return flags in ier (and function iw3unp29 itself) are:
+
197 C> - 0 Observation read and unpacked into location 'obs'.
+
198 C> see writeup of w3fi64 for contents. (all character
+
199 C> words are left-justified.) Next call to iw3unp29
+
200 C> will return next observation in data set.
+
201 C> - 1 A 40 byte header in the format described here
+
202 C> (y2k compliant pseudo-office note 85) is returned
+
203 C> in the first 10 words of 'obs' on a 4-byte machine
+
204 C> (ibm) and in the first 5 words of 'obs' on an
+
205 C> 8-byte machine (cray). Next call to
+
206 C> iw3unp29 will return first obs. in this data set.
+
207 C> (note: if input data set is a true on29/124 file
+
208 C> with the y2k compliant pseudo-on85 header record,
+
209 C> then the pseudo-on85 header record is actually
+
210 C> read in and returned; if input data set is a true
+
211 C> on29/124 file with a non-y2k compliant on85 header
+
212 C> record, then a y2k compliant pseudo-on85 header
+
213 C> record is constructed from it using the "windowing"
+
214 C> technique to obtain a 4-digit year from a 2-digit
+
215 C> year.)
+
216 C> format for y2k compliant pseudo-on85 header record
+
217 C> returned (40 bytes in character):
+
218 C> - bytes 1- 8 -- data set name (as defined in on85 except up to
+
219 C> eight ascii char., left justified with blank fill)
+
220 C> - bytes 9-10 -- set type (as defined in on85)
+
221 C> - bytes 11-20 -- center (analysis) date for data
+
222 C> set (ten ascii characters in form "yyyymmddhh")
+
223 C> - bytes 21-24 -- set initialize (dump) time, as dedined in on85)
+
224 C> - bytes 25-34 -- always "washington" (as in on85)
+
225 C> - bytes 35-36 -- source machine (as defined in on85)
+
226 C> - bytes 37-40 -- blank fill characters
+
227 C> - 2 end-of-file (never an empty or null file):
+
228 C> - input on29/124 data set: the "endof file" record is
+
229 C> encountered - no useful information in 'obs' array.
+
230 C> next call to iw3unp29 will return physical end of
+
231 C> file for data set in 'nunit' (see ier=3 below).
+
232 C> - input bufr data set: the physical end of file is
+
233 C> encountered.
+
234 C> -3 end-of-file:
+
235 C> Physical end of file encountered on data set -
+
236 C> this can only happen for an empty (null) data set
+
237 C> or for a true on29/124 data set. There are no
+
238 C> more reports (or never were any if null) associated
+
239 C> with data set in this unit number - no useful
+
240 C> information in 'obs' array. Either all done (if
+
241 C> no more unit numbers are to be read in), or reset
+
242 C> 'nunit' to point to a new data set (in which case
+
243 C> next call to iw3unp29 should return with ier=1).
+
244 C> - 4 only valid for input on29/124 data set - i/o error
+
245 C> reading the next record of reports - no useful
+
246 C> information in 'obs' array. Calling program can
+
247 C> choose to stop or again call iw3unp29 which will
+
248 C> attempt to unpack the first observation in the next
+
249 C> record of reports.
+
250 C> - 999 applies only to non-empty data sets:
+
251 C> - input on29/124 data set: first choice y2k compliant
+
252 C> pseudo-on85 file header label not encountered where
+
253 C> expected, and second choice non-y2k compliant on85
+
254 C> file header label also not encountered.
+
255 C> - input bufr data set either header label in
+
256 C> format of pseudo-on85 could not be returned, or an
+
257 C> abnormal error occurred in the attempt to decode an
+
258 C> observation. For either input data set type, no
+
259 C> useful information in 'obs' array. Calling program
+
260 C> can choose to stop with non-zero condition code or
+
261 C> reset 'nunit' to point to a new data set (in which
+
262 C> case next call to iw3unp29 should return with
+
263 C> ier=1).
+
264 C> - input data set neither on29/124 nor bufr speaks for
+
265 C> itself.
+
266 C>
+
267 C> @author Dennis Keyser @date 2013-03-20
+
268 C>
+
269 
+
270  FUNCTION iw3unp29(LUNIT,OBS,IER)
+
271 
+
272  common/io29aa/jwfile(100),lastf
+
273  common/io29bb/kndx,kskacf(8),kskupa,ksksfc,ksksat,ksksmi
+
274  common/io29cc/subset,idat10
+
275  common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
+
276  common/io29ee/robs(255,11)
+
277  common/io29ff/qms(255,9)
+
278  common/io29gg/sfo(34)
+
279  common/io29hh/sfq(5)
+
280  common/io29ii/pwmin
+
281  common/io29jj/iset,manlin(1001)
+
282  common/io29kk/kount(499,18)
+
283  common/io29ll/bmiss
+
284 
+
285  dimension obs(*)
+
286  REAL(8) bmiss,getbmiss
+
287 
+
288  SAVE
+
289 
+
290  DATA itimes/0/
+
291 
+
292  IF(itimes.EQ.0) THEN
+
293 
+
294 C THE FIRST TIME IN, INITIALIZE SOME DATA
+
295 C (NOTE: FORTRAN 77/90 STANDARD DOES NOT ALLOW COMMON BLOCK VARIABLES
+
296 C TO BE INITIALIZED VIA DATA STATEMENTS, AND, FOR SOME REASON,
+
297 C THE BLOCK DATA DOES NOT INITIALIZE DATA IN THE W3NCO LIBRARY
+
298 C AVOID BLOCK DATA IN W3NCO/W3EMC)
+
299 C --------------------------------------------------------------------
+
300 
+
301  itimes = 1
+
302  jwfile = 0
+
303  lastf = 0
+
304  kndx = 0
+
305  kskacf = 0
+
306  kskupa = 0
+
307  ksksfc = 0
+
308  ksksat = 0
+
309  ksksmi = 0
+
310  kount = 0
+
311  ikat(1) = 1
+
312  ikat(2) = 2
+
313  ikat(3) = 3
+
314  ikat(4) = 4
+
315  ikat(5) = 5
+
316  ikat(6) = 6
+
317  ikat(7) = 7
+
318  ikat(8) = 8
+
319  ikat(9) = 51
+
320  ikat(10) = 52
+
321  ikat(11) = 9
+
322  mcat(1) = 6
+
323  mcat(2) = 4
+
324  mcat(3) = 4
+
325  mcat(4) = 4
+
326  mcat(5) = 6
+
327  mcat(6) = 6
+
328  mcat(7) = 3
+
329  mcat(8) = 3
+
330  mcat(9) = 21
+
331  mcat(10) = 15
+
332  mcat(11) = 3
+
333  iset = 0
+
334  END IF
+
335 
+
336 C UNIT NUMBER OUT OF RANGE RETURNS A 999
+
337 C --------------------------------------
+
338 
+
339  IF(lunit.LT.1 .OR. lunit.GT.100) THEN
+
340  print'(" ##IW3UNP29 - UNIT NUMBER ",I0," OUT OF RANGE -- ",
+
341  $ "IER = 999")', lunit
+
342  GO TO 9999
+
343  END IF
+
344  IF(lastf.NE.lunit .AND. lastf.GT.0) THEN
+
345  CALL closbf(lastf)
+
346  jwfile(lastf) = 0
+
347  END IF
+
348  lastf = lunit
+
349 
+
350 C THE JWFILE INDICATOR: =0 IF UNOPENED; =1 IF ON29; =2 IF BUFR
+
351 C ------------------------------------------------------------
+
352 
+
353  IF(jwfile(lunit).EQ.0) THEN
+
354  print'(" ===> IW3UNP29 - WCOSS VERSION: 03-20-2013")'
+
355 
+
356  bmiss = getbmiss()
+
357  print'(1X)'
+
358  print'(" BUFRLIB value for missing passed into IW3UNP29 is: ",
+
359  $ G0)', bmiss
+
360  print'(1X)'
+
361 
+
362  IF(i03o29(lunit,obs,ier).EQ.1) THEN
+
363  print'(" IW3UNP29 - OPENED A TRUE OFFICE NOTE 29 FILE IN ",
+
364  $ "UNIT ",I0)', lunit
+
365  jwfile(lunit) = 1
+
366  ier = 1
+
367  iw3unp29 = 1
+
368  ELSEIF(i03o29(lunit,obs,ier).EQ.3) THEN
+
369  print 107, lunit
+
370  107 FORMAT(/,' ##IW3UNP29 - FILE IN UNIT',i3,' IS EMPTY OR NULL -- ',
+
371  $ 'IER = 3'/)
+
372  ier = 3
+
373  iw3unp29 = 3
+
374  ELSEIF(i02o29(lunit,obs,ier).EQ.1) THEN
+
375  print'(" IW3UNP29 - OPENED A BUFR FILE IN UNIT ",I0)', lunit
+
376 
+
377  jwfile(lunit) = 2
+
378  kndx = 0
+
379  kskacf = 0
+
380  kskupa = 0
+
381  ksksfc = 0
+
382  ksksat = 0
+
383  ksksmi = 0
+
384  ier = 1
+
385  iw3unp29 = 1
+
386  ELSEIF(i03o29(lunit,obs,ier).EQ.999) THEN
+
387  print'(" IW3UNP29 - OPENED A TRUE OFFICE NOTE 29 FILE IN ",
+
388  $ "UNIT ",I0)', lunit
+
389  print 88
+
390  88 FORMAT(/' ##IW3UNP29/I03O29 - NEITHER EXPECTED Y2K COMPLIANT ',
+
391  $ 'PSEUDO-ON85 LABEL NOR SECOND CHOICE NON-Y2K COMPLIANT ON85 ',
+
392  $ 'LABEL FOUND IN'/21x,'FIRST RECORD OF FILE -- IER = 999'/)
+
393  GO TO 9999
+
394  ELSE
+
395  print 108, lunit
+
396  108 FORMAT(/,' ##IW3UNP29 - FILE IN UNIT',i3,' IS NEITHER BUFR NOR ',
+
397  $ 'TRUE OFFICE NOTE 29 -- IER = 999'/)
+
398  GO TO 9999
+
399  END IF
+
400  ELSEIF(jwfile(lunit).EQ.1) THEN
+
401  IF(i03o29(lunit,obs,ier).NE.0) jwfile(lunit) = 0
+
402  IF(ier.GT.0) CLOSE (lunit)
+
403  iw3unp29 = ier
+
404  ELSEIF(jwfile(lunit).EQ.2) THEN
+
405  IF(i02o29(lunit,obs,ier).NE.0) jwfile(lunit) = 0
+
406  IF(ier.GT.0) CALL closbf(lunit)
+
407  IF(ier.EQ.2.OR.ier.EQ.3) THEN
+
408  IF(kskacf(1).GT.0) print'(" IW3UNP29 - NO. OF AIRCFT/",
+
409  $ "AIRCAR REPORTS TOSSED DUE TO ZERO CAT. 6 LVLS = ",I0)',
+
410  $ kskacf(1)
+
411  IF(kskacf(2).GT.0) print'(" IW3UNP29 - NO. OF AIRCFT ",
+
412  $ "REPORTS TOSSED DUE TO BEING ""LFPW"" AMDAR = ",I0)',
+
413  $ kskacf(2)
+
414  IF(kskacf(8).GT.0) print'(" IW3UNP29 - NO. OF AIRCFT ",
+
415  $ "REPORTS TOSSED DUE TO BEING ""PHWR"" AIREP = ",I0)',
+
416  $ kskacf(8)
+
417  IF(kskacf(3).GT.0) print'(" IW3UNP29 - NO. OF AIRCFT ",
+
418  $ "REPORTS TOSSED DUE TO BEING CARSWELL AMDAR = ",I0)',
+
419  $ kskacf(3)
+
420  IF(kskacf(4).GT.0) print'(" IW3UNP29 - NO. OF AIRCFT ",
+
421  $ "REPORTS TOSSED DUE TO BEING CARSWELL ACARS = ",I0)',
+
422  $ kskacf(4)
+
423  IF(kskacf(5).GT.0) print'(" IW3UNP29 - NO. OF AIRCFT/",
+
424  $ "AIRCAR REPORTS TOSSED DUE TO HAVING MISSING WIND = ",I0)',
+
425  $ kskacf(5)
+
426  IF(kskacf(6).GT.0) print'(" IW3UNP29 - NO. OF AIRCFT ",
+
427  $ "REPORTS TOSSED DUE TO BEING AMDAR < 2286 M = ",I0)',
+
428  $ kskacf(6)
+
429  IF(kskacf(7).GT.0) print'(" IW3UNP29 - NO. OF AIRCFT ",
+
430  $ "REPORTS TOSSED DUE TO BEING AIREP < 100 M = ",I0)',
+
431  $ kskacf(7)
+
432  IF(kskacf(1)+kskacf(2)+kskacf(3)+kskacf(4)+kskacf(5)+
+
433  $ kskacf(6)+kskacf(7)+kskacf(8).GT.0)
+
434  $ print'(" IW3UNP29 - TOTAL NO. OF AIRCFT/AIRCAR REPORTS ",
+
435  $ "TOSSED = ",I0)',
+
436  $ kskacf(1)+kskacf(2)+kskacf(3)+kskacf(4)+
+
437  $ kskacf(5)+kskacf(6)+kskacf(7)+kskacf(8)
+
438  IF(kskupa.GT.0) print'(" IW3UNP29 - TOTAL NO. OF ADPUPA ",
+
439  $ "REPORTS TOSSED = ",I0)', kskupa
+
440  IF(ksksfc.GT.0) print'(" IW3UNP29 - TOTAL NO. OF ADPSFC/",
+
441  $ "SFCSHP/SFCBOG REPORTS TOSSED = ",I0)', ksksfc
+
442  IF(ksksat.GT.0) print'(" IW3UNP29 - TOTAL NO. OF SATWND ",
+
443  $ "REPORTS TOSSED = ",I0)', ksksat
+
444  IF(ksksmi.GT.0) print'(" IW3UNP29 - TOTAL NO. OF SPSSMI ",
+
445  $ "REPORTS TOSSED = ",I0)', ksksmi
+
446  kndx = 0
+
447  kskacf = 0
+
448  kskupa = 0
+
449  ksksfc = 0
+
450  ksksat = 0
+
451  ksksmi = 0
+
452  END IF
+
453  iw3unp29 = ier
+
454  END IF
+
455 
+
456  RETURN
+
457 
+
458  9999 CONTINUE
+
459  ier = 999
+
460  iw3unp29 = 999
+
461  RETURN
+
462 
+
463  END
+
464 C***********************************************************************
+
465 C***********************************************************************
+
466 C***********************************************************************
+
467 C> This function read obs files and returns error message.
+
468 C> @param LUNIT full path of file
+
469 C> @param HDR header of file
+
470 C> @param IER missing or invalid data indicator
+
471 C> @return Y2K COMPLIANT
+
472 C>
+
473 C> @author Dennis Keyser @date 2013-03-20
+
474 C>
+
475 C-----------------------------------------------------------------------
+
476  FUNCTION i01o29(LUNIT,HDR,IER)
+
477 C ---> formerly FUNCTION IW3HDR
+
478 
+
479  common/io29aa/jwfile(100),lastf
+
480 
+
481  dimension hdr(*)
+
482 
+
483  SAVE
+
484 
+
485 C UNIT NUMBER OUT OF RANGE RETURNS A 999
+
486 C --------------------------------------
+
487 
+
488  IF(lunit.LT.1 .OR. lunit.GT.100) THEN
+
489  print'(" ##IW3UNP29/I01O29 - UNIT NUMBER ",I0," OUT OF RANGE ",
+
490  $ "-- IER = 999")', lunit
+
491  GO TO 9999
+
492  END IF
+
493 
+
494 C THE JWFILE INDICATOR: =0 IF UNOPENED; =1 IF ON29; =2 IF BUFR
+
495 C ------------------------------------------------------------
+
496 
+
497  IF(jwfile(lunit).EQ.0) THEN
+
498  IF(i03o29(lunit,hdr,ier).EQ.1) THEN
+
499  i01o29 = i03o29(0,hdr,ier)
+
500  i01o29 = 1
+
501  RETURN
+
502  ELSEIF(i02o29(lunit,hdr,ier).EQ.1) THEN
+
503  CALL closbf(lunit)
+
504  i01o29 = 1
+
505  RETURN
+
506  ELSE
+
507 
+
508 C CAN'T READ FILE HEADER RETURNS A 999
+
509 C ------------------------------------
+
510 
+
511  print'(" ##IW3UNP29/I01O29 - CAN""T READ FILE HEADER -- ",
+
512  $ "IER = 999")'
+
513  GO TO 9999
+
514  END IF
+
515  ELSE
+
516 
+
517 C FILE ALREADY OPEN RETURNS A 999
+
518 C -------------------------------
+
519 
+
520  print'(" ##IW3UNP29/I01O29 - FILE ALREADY OPEN -- IER = 999")'
+
521  GO TO 9999
+
522  END IF
+
523 
+
524  RETURN
+
525 
+
526  9999 CONTINUE
+
527  ier = 999
+
528  i01o29 = 999
+
529  RETURN
+
530 
+
531  END
+
532 C***********************************************************************
+
533 C***********************************************************************
+
534 C***********************************************************************
+
535 
+
536 C> This function read obs files and returns error message.
+
537 C> @param LUNIT full path of file
+
538 C> @param OBS data output
+
539 C> @param IER missing or invalid data indicator
+
540 C> @return Y2K COMPLIANT
+
541 C>
+
542 C> @author Dennis Keyser @date 2013-03-20
+
543 C>
+
544 
+
545  FUNCTION i02o29(LUNIT,OBS,IER)
+
546 C ---> formerly FUNCTION JW3O29
+
547 
+
548  common/io29cc/subset,idat10
+
549 
+
550  CHARACTER*40 on85
+
551  CHARACTER*10 cdate
+
552  CHARACTER*8 subset,cbufr
+
553  CHARACTER*6 c01o29
+
554  CHARACTER*4 cdump
+
555  dimension obs(1608),ron85(16),jdate(5),jdump(5)
+
556  equivalence(ron85(1),on85)
+
557 
+
558  SAVE
+
559 
+
560  DATA on85/' '/
+
561 
+
562  jdate = -1
+
563  jdump = -1
+
564 
+
565 C IF FILE IS CLOSED TRY TO OPEN IT AND RETURN A Y2K COMPLIANT
+
566 C PSEUDO-ON85 LABEL
+
567 C -----------------------------------------------------------
+
568 
+
569  CALL status(lunit,lun,il,im)
+
570 
+
571  IF(il.EQ.0) THEN
+
572  iret = -1
+
573  i02o29 = 2
+
574  rewind lunit
+
575  READ(lunit,END=10,ERR=10,FMT='(A8)') cbufr
+
576  IF(cbufr(1:4).EQ.'BUFR') THEN
+
577  print'(" IW3UNP29/I02O29 - INPUT FILE ON UNIT ",I0, " IS",
+
578  $ " UNBLOCKED NCEP BUFR"/)', lunit
+
579  ELSE IF(cbufr(5:8).EQ.'BUFR') THEN
+
580  print'(" IW3UNP29/I02O29 - INPUT FILE ON UNIT ",I0, " IS",
+
581  $ " BLOCKED NCEP BUFR"/)', lunit
+
582  ELSE
+
583  rewind lunit
+
584  GO TO 10
+
585  END IF
+
586  call datelen(10)
+
587  CALL dumpbf(lunit,jdate,jdump)
+
588 cppppp
+
589  print'(" CENTER DATE (JDATE) = ",I4,4I3.2/" DUMP DATE (JDUMP)",
+
590  $ " (year not used anywhere) = "I4,4I3.2)',jdate,jdump
+
591 cppppp
+
592  IF(jdate(1).GT.999) THEN
+
593  WRITE(cdate,'(I4.4,3I2.2)') (jdate(i),i=1,4)
+
594  ELSE IF(jdate(1).GT.0) THEN
+
595 
+
596 C If 2-digit year returned in JDATE(1), must use "windowing" technique
+
597 C 2 create a 4-digit year
+
598 
+
599  print'(" ##IW3UNP29/I02O29 - 2-DIGIT YEAR IN JDATE(1) ",
+
600  $ "RETURNED FROM DUMPBF (JDATE IS: ",I4.4,3I2.2,") - USE ",
+
601  $ "WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR")', jdate
+
602  IF(jdate(1).GT.20) THEN
+
603  WRITE(cdate,'("19",4I2.2)') (jdate(i),i=1,4)
+
604  ELSE
+
605  WRITE(cdate,'("20",4I2.2)') (jdate(i),i=1,4)
+
606  ENDIF
+
607  print'(" ##IW3UNP29/I02O29 - CORRECTED JDATE(1) WITH ",
+
608  $ "4-DIGIT YEAR, JDATE NOW IS: ",I4.4,3I2.2)', jdate
+
609  ELSE
+
610  GO TO 10
+
611  ENDIF
+
612 
+
613  CALL openbf(lunit,'IN',lunit)
+
614 
+
615 C This next call, I believe, is needed only because SUBSET is not
+
616 C returned in DUMPBF ...
+
617  call readmg(lunit,subset,idat10,iret)
+
618 
+
619  WRITE(cdump,'(2I2.2)') jdump(4),100*jdump(5)/60
+
620  IF(jdump(1).LT.0) cdump = '9999'
+
621  on85=c01o29(subset)//' C2'//cdate//cdump//'WASHINGTONCR '
+
622  obs(1:16) = ron85
+
623  i02o29 = 1
+
624  10 CONTINUE
+
625  ier = i02o29
+
626  RETURN
+
627  END IF
+
628 
+
629 C IF THE FILE IS ALREADY OPENED FOR INPUT TRY TO READ THE NEXT SUBSET
+
630 C -------------------------------------------------------------------
+
631 
+
632  IF(il.LT.0) THEN
+
633  7822 CONTINUE
+
634  CALL readns(lunit,subset,idat10,iret)
+
635  IF(iret.EQ.0) i02o29 = r01o29(subset,lunit,obs)
+
636  IF(iret.NE.0) i02o29 = 2
+
637  IF(i02o29.EQ.-9999) GO TO 7822
+
638  ier = i02o29
+
639  RETURN
+
640  END IF
+
641 
+
642 C FILE MUST BE OPEN FOR INPUT!
+
643 C ----------------------------
+
644 
+
645  print'(" ##IW3UNP29/I02O29 - FILE ON UNIT ",I0," IS OPENED FOR ",
+
646  $ "OUTPUT -- IER = 999")', lunit
+
647  i02o29 = 999
+
648  ier = 999
+
649  RETURN
+
650 
+
651  END
+
652 
+
653 C> This function reads a true (see *) on29/124 data set and unpacks one
+
654 C> report into the unpacked office note 29/124 format. the input and
+
655 C> output arguments here have the same meaning as for iw3unp29.
+
656 C> repeated calls of function will return a sequence of unpacked
+
657 C> on29/124 reports. * - unlike original "true" on29/124 data sets,
+
658 C> the "expected" file header label is a y2k compliant 40-byte
+
659 C> pseudo-on85 version - if this is not encountered this code, as a
+
660 C> temporary measure during the y2k transition period, will look for
+
661 C> the original non-y2k compliant 32-byte on85 header label and use
+
662 C> the "windowing" technique to convert the 2-digit year to a 4-digit
+
663 C> year in preparation for returning a 40-byte pseudo-on85 label in
+
664 C> the first C call. (see iw3unp29 docblock for format of 40-byte
+
665 C> pseudo-on85 header label.)
+
666 C>
+
667 C> Program History Log:
+
668 C> -1991-07-23 Dennis Keyser w3fi64 (f77) internal read error
+
669 C> no longer causes calling program to fail but will move
+
670 C> to next record if can't recover to next report
+
671 C> -1993-10-07 Dennis Keyser -- adapted for use on cray (added save
+
672 C> statement, removed ibm-specific code, etc.)
+
673 C> -1993-10-15 R. E. Jones added code so if file is ebcdic it converts
+
674 C> it to ascii
+
675 C> -1996-10-04 Jack Woollen changed name to i03gad and incorporated
+
676 C> into new w3lib routine iw3gad
+
677 C> -2013-03-20 Dennis Keyser changes to run on wcoss
+
678 C>
+
679 C> @param[in] nunit fortran unit number for sequential data set containing
+
680 C> packed and blocked office note 29/124 reports
+
681 C> @param[out] obs array containing one report in unpacked office note
+
682 C> - 29/124 format is mixed, user must equivalence
+
683 C> - integer and character arrays to this array (see
+
684 C> - docblock for w3fi64 in /nwprod/lib/sorc/w3nco
+
685 C> - or writeups on w3fi64, on29, on124 for help)
+
686 C> - the length of the array should be at least 1608
+
687 C> @param[out] ier return flag (equal to function value) in iw3unp29 docblock
+
688 C> @return Y2K COMPLIANT
+
689 C>
+
690 C> @note aa unit number specified by input argument "nunit")
+
691 C> called by subprogram iw3unp29.
+
692 C>
+
693 C> @author keyser @date 2013-03-20
+
694 C>
+
695  FUNCTION i03o29(NUNIT, OBS, IER)
+
696 C ---> formerly FUNCTION KW3O29
+
697 
+
698  CHARACTER*1 cbuff(6432),con85l(32)
+
699  CHARACTER*2 cbf910
+
700  CHARACTER*4 cyr4d
+
701  CHARACTER*8 cbufr
+
702  INTEGER ibuff(5),obs(*)
+
703 
+
704  equivalence(ibuff,cbuff)
+
705 
+
706  SAVE
+
707 
+
708  DATA ioldun/0/
+
709 
+
710 C TEST FOR NEW (OR PREVIOUSLY USED) NUNIT AND ADJUST 'NEXT'
+
711 C (THIS ALLOWS USER TO SWITCH TO NEW NUNIT PRIOR TO READING TO
+
712 C THE 'END OF FILE' ON AN OLD UNIT. ANY SWITCH TO A NEW UNIT WILL
+
713 C START THE READ AT THE BEGINNING)
+
714 C ----------------------------------------------------------------
+
715 
+
716  if(nunit.eq.0) then
+
717  if(ioldun.gt.0) rewind ioldun
+
718  i03o29 = 0
+
719  ioldun = 0
+
720  return
+
721  end if
+
722 
+
723  IF(nunit.NE.ioldun) THEN
+
724 
+
725 C THIS IS A NEW UNIT NUMBER, SET 'NEXT' TO 0 AND REWIND THIS UNIT
+
726 C ---------------------------------------------------------------
+
727 
+
728 CDAKCDAK PRINT 87, NUNIT NOW REDUNDANT TO PRINT THIS
+
729  87 FORMAT(//' IW3UNP29/I03O29 - PREPARING TO READ ON29 DATA SET IN ',
+
730  $ 'UNIT ',i3/)
+
731  ioldun = nunit
+
732  next = 0
+
733  nfile = 0
+
734  rewind nunit
+
735  iswt = 0
+
736  END IF
+
737 
+
738  10 CONTINUE
+
739 
+
740  IF(next.NE.0) GO TO 70
+
741 
+
742 C COME HERE TO READ IN A NEW RECORD (EITHER REPORTS, Y2K COMPLIANT 40-
+
743 C BYTE PSEUDO-ON85 LBL, NON-Y2K 32-BYTE COMPLIANT ON85 LBL, OR E-O-F)
+
744 C --------------------------------------------------------------------
+
745 
+
746  READ(nunit,END=9997,ERR=9998,FMT='(A8)') cbufr
+
747  IF(cbufr(1:4).EQ.'BUFR' .OR. cbufr(5:8).EQ.'BUFR') THEN
+
748 
+
749 C INPUT DATASET IS BUFR - EXIT IMMEDIATELY
+
750 C ----------------------------------------
+
751 
+
752  ioldun = 0
+
753  next = 0
+
754  ier = 999
+
755  GO TO 90
+
756  END IF
+
757 
+
758  rewind nunit
+
759 
+
760  READ(nunit,err=9998,END=9997,FMT='(6432A1)') cbuff
+
761 
+
762 C IF ISWT=1, CHARACTER DATA IN RECORD ARE EBCDIC - CONVERT TO ASCII
+
763 C -----------------------------------------------------------------
+
764 
+
765  IF(iswt.EQ.1) CALL aea(cbuff,cbuff,6432)
+
766 
+
767  IF(nfile.EQ.0) THEN
+
768 
+
769 C TEST FOR EXPECTED HEADER LABEL
+
770 C ------------------------------
+
771 
+
772  nfile = 1
+
773 
+
774  IF(cbuff(25)//cbuff(26)//cbuff(27)//cbuff(28).EQ.'WASH') THEN
+
775  ELSEIF(cbuff(21)//cbuff(22)//cbuff(23)//cbuff(24).EQ.'WASH')THEN
+
776  ELSE
+
777 
+
778 C QUICK CHECK SHOWS SOMETHING OTHER THAN EITHER Y2K COMPLIANT PSEUDO-
+
779 C ON85 LBL OR NON-Y2K COMPLIANT ON85 LBL FOUND -- COULD MEAN CHARACTER
+
780 C DATA ARE IN EBCDIC, SO SEE IF CONVERSION TO ASCII RECTIFIES THIS
+
781 C ---------------------------------------------------------------------
+
782 
+
783  print 78
+
784  78 FORMAT(/' ##IW3UNP29 - NEITHER EXPECTED Y2K COMPLIANT PSEUDO-',
+
785  $ 'ON85 LABEL NOR SECOND CHOICE NON-Y2K COMPLIANT ON85 LABEL ',
+
786  $ 'FOUND IN'/14x,'FIRST RECORD OF FILE -- TRY EBCDIC TO ASCII ',
+
787  $ 'CONVERSION'/)
+
788  CALL aea(cbuff,cbuff,6432)
+
789  iswt = 1
+
790  END IF
+
791 
+
792  IF(cbuff(25)//cbuff(26)//cbuff(27)//cbuff(28).EQ.'WASH') THEN
+
793 
+
794 C THIS IS Y2K COMPLIANT 40-BYTE PSEUDO-ON85 LBL; RESET 'NEXT', SET
+
795 C 'IER', FILL 'OBS(1)-(4)', AND QUIT
+
796 C ---------------------------------------------------------------
+
797  next = 0
+
798  ier = 1
+
799  obs(1:5) = ibuff(1:5)
+
800  GO TO 90
+
801  ELSE IF(cbuff(21)//cbuff(22)//cbuff(23)//cbuff(24).EQ.'WASH')
+
802  $ THEN
+
803 
+
804 C THIS IS NON-Y2K COMPLIANT 32-BYTE ON85 LBL; RESET 'NEXT', SET
+
805 C 'IER', USE "WINDOWING" TECHNIQUE TO CONTRUCT 4-DIGIT YEAR,
+
806 C CONSTRUCT A 40-BYTE PSEUDO-ON85 LABE, FILL 'OBS(1)-(4)', AND QUIT
+
807 C ------------------------------------------------------------------
+
808  print'(" ==> THIS IS A TRUE OFFICE NOTE 29 FILE!! <==")'
+
809  print 88
+
810  88 FORMAT(/' ##IW3UNP29/I03O29 - WARNING: ORIGINAL NON-Y2K ',
+
811  $ 'COMPLIANT ON85 LABEL FOUND IN FIRST RECORD OF FILE INSTEAD OF ',
+
812  $ 'EXPECTED'/30x,'Y2K COMPLIANT PSEUDO-ON85 LABEL -- THIS ',
+
813  $ 'ROUTINE IS FORCED TO USE "WINDOWING" TECHNIQUE TO CONTRUCT'/30x,
+
814  $'A Y2K COMPLIANT PSEUDO-ON85 LABEL TO RETURN TO CALLING PROGRAM'/)
+
815 
+
816  next = 0
+
817  ier = 1
+
818 
+
819  cbf910 = cbuff(9)//cbuff(10)
+
820  READ(cbf910,'(I2)') iyr2d
+
821  print'(" ##IW3UNP29/I03O29 - 2-DIGIT YEAR FOUND IN ON85 ",
+
822  $ "LBL (",A,") IS: ",I0/19X," USE WINDOWING TECHNIQUE TO ",
+
823  $ "OBTAIN 4-DIGIT YEAR")', cbuff(1:32),iyr2d
+
824  IF(iyr2d.GT.20) THEN
+
825  iyr4d = 1900 + iyr2d
+
826  ELSE
+
827  iyr4d = 2000 + iyr2d
+
828  ENDIF
+
829  print'(" ##IW3UNP29/I03O29 - 4-DIGIT YEAR OBTAINED VIA ",
+
830  $ "WINDOWING TECHNIQUE IS: ",I0/)', iyr4d
+
831  con85l = cbuff(1:32)
+
832  cbuff(7:40) = ' '
+
833  cbuff(9:10) = con85l(7:8)
+
834  WRITE(cyr4d,'(I4.4)') iyr4d
+
835  DO i=1,4
+
836  cbuff(10+i) = cyr4d(i:i)
+
837  ENDDO
+
838  cbuff(15:36) = con85l(11:32)
+
839  obs(1:5) = ibuff(1:5)
+
840  GO TO 90
+
841  ELSE
+
842 
+
843 C SOMETHING OTHER THAN EITHER Y2K COMPLIANT PSEUDO-ON85 LBL OR
+
844 C NON-Y2K COMPLIANT ON85 LBL FOUND; RESET 'NEXT', SET 'IER' AND QUIT
+
845 C ------------------------------------------------------------------
+
846 CDAKCDAK PRINT 88 CAN'T PRINT THIS ANYMORE
+
847 CDA88 FORMAT(/' ##IW3UNP29/I03O29 - EXPECTED ON85 LABEL NOT FOUND IN ',
+
848 CDAK $ 'FIRST RECORD OF NEW LOGICAL FILE -- IER = 999'/)
+
849  ioldun = 0
+
850  next = 0
+
851  ier = 999
+
852  GO TO 90
+
853  END IF
+
854 
+
855  END IF
+
856 
+
857  IF(cbuff(1)//cbuff(2)//cbuff(3)//cbuff(4).EQ.'ENDO') THEN
+
858 
+
859 C LOGICAL "ENDOF FILE" READ; RESET NEXT, SET IER, AND QUIT
+
860 C --------------------------------------------------------
+
861 
+
862  next = 0
+
863  ier = 2
+
864  nfile = 0
+
865  GO TO 90
+
866  END IF
+
867  GO TO 70
+
868 
+
869  9997 CONTINUE
+
870 
+
871 C PHYSICAL END OF FILE; RESET 'NEXT', SET 'IER' AND QUIT
+
872 C ------------------------------------------------------
+
873 
+
874  next = 0
+
875  ier = 3
+
876  GO TO 90
+
877 
+
878  9998 CONTINUE
+
879 
+
880 C I/O ERROR; RESET 'NEXT', SET 'IER' AND QUIT
+
881 C -------------------------------------------
+
882 
+
883 cppppp
+
884  print'(" ##IW3UNP29/I03O29 - ERROR READING DATA RECORD")'
+
885 cppppp
+
886  next = 0
+
887  ier = 4
+
888  GO TO 90
+
889 
+
890  70 CONTINUE
+
891 
+
892 C WORKING WITHIN ACTUAL DATA REC. READ, CALL W3FI64 TO READ IN NEXT RPT
+
893 C ---------------------------------------------------------------------
+
894 
+
895  CALL w3fi64(cbuff,obs,next)
+
896 
+
897  IF(next.GE.0) THEN
+
898 
+
899 C REPORT SUCCESSFULLY RETURNED IN ARRAY 'OBS'
+
900 C -------------------------------------------
+
901 
+
902  ier = 0
+
903 
+
904  ELSE
+
905 
+
906 C HIT END-OF-RECORD, OR INTERNAL READ ERROR ENCOUNTERED & CAN'T RECOVER
+
907 C -- READ IN NEXT RECORD OF REPORTS
+
908 C ---------------------------------------------------------------------
+
909 
+
910  next = 0
+
911  GO TO 10
+
912  END IF
+
913 
+
914  90 CONTINUE
+
915 
+
916  i03o29 = ier
+
917 
+
918  RETURN
+
919 
+
920  END
+
921 C***********************************************************************
+
922 C> This function read subset and returns group name.
+
923 C> @param SUBSET subset
+
924 C> @return group name
+
925 C>
+
926 C> @author Dennis Keyser @date 2013-03-20
+
927 C>
+
928 C***********************************************************************
+
929  FUNCTION c01o29(SUBSET)
+
930 C ---> formerly FUNCTION ADP
+
931 
+
932  CHARACTER*(*) subset
+
933  CHARACTER*6 c01o29
+
934 
+
935  SAVE
+
936 
+
937  c01o29 = 'NONE'
+
938 
+
939  IF(subset(1:5).EQ.'NC000') c01o29 = 'ADPSFC'
+
940  IF(subset(1:5).EQ.'NC001') THEN
+
941  IF(subset(6:8).NE.'006') THEN
+
942  c01o29 = 'SFCSHP'
+
943  ELSE
+
944  c01o29 = 'SFCBOG'
+
945  END IF
+
946  END IF
+
947  IF(subset(1:5).EQ.'NC002') c01o29 = 'ADPUPA'
+
948  IF(subset(1:5).EQ.'NC004') c01o29 = 'AIRCFT'
+
949  IF(subset(1:5).EQ.'NC005') c01o29 = 'SATWND'
+
950  IF(subset(1:5).EQ.'NC012') c01o29 = 'SPSSMI'
+
951 
+
952  IF(subset .EQ. 'NC003101') c01o29 = 'SATEMP'
+
953  IF(subset .EQ. 'NC004004') c01o29 = 'AIRCAR'
+
954  IF(subset .EQ. 'NC004005') c01o29 = 'ADPUPA'
+
955 
+
956  IF(subset .EQ. 'ADPSFC') c01o29 = 'ADPSFC'
+
957  IF(subset .EQ. 'SFCSHP') c01o29 = 'SFCSHP'
+
958  IF(subset .EQ. 'SFCBOG') c01o29 = 'SFCBOG'
+
959  IF(subset .EQ. 'ADPUPA') c01o29 = 'ADPUPA'
+
960  IF(subset .EQ. 'AIRCFT') c01o29 = 'AIRCFT'
+
961  IF(subset .EQ. 'SATWND') c01o29 = 'SATWND'
+
962  IF(subset .EQ. 'SATEMP') c01o29 = 'SATEMP'
+
963  IF(subset .EQ. 'AIRCAR') c01o29 = 'AIRCAR'
+
964  IF(subset .EQ. 'SPSSMI') c01o29 = 'SPSSMI'
+
965 
+
966  IF(c01o29.EQ.'NONE') print'(" ##IW3UNP29/C01O29 - UNKNOWN SUBSET",
+
967  $ " (=",A,") -- CONTINUE~~")', subset
+
968 
+
969  RETURN
+
970  END
+
971 C***********************************************************************
+
972 C> This function read subset and returns corresponding file data.
+
973 C> @param SUBSET subset
+
974 C> @param LUNIT full path of file
+
975 C> @param OBS data output
+
976 C> @return file data
+
977 C>
+
978 C> @author Dennis Keyser @date 2013-03-20
+
979 C>
+
980 C***********************************************************************
+
981  FUNCTION r01o29(SUBSET,LUNIT,OBS)
+
982 C ---> formerly FUNCTION ADC
+
983 
+
984  CHARACTER*(*) subset
+
985  CHARACTER*6 c01o29,adpsub
+
986  dimension obs(*)
+
987 
+
988  SAVE
+
989 
+
990 C FIND AN ON29/124 DATA TYPE AND CALL A TRANSLATOR
+
991 C ------------------------------------------------
+
992 
+
993  r01o29 = 4
+
994  adpsub = c01o29(subset)
+
995  IF(adpsub .EQ. 'ADPSFC') r01o29 = r04o29(lunit,obs)
+
996  IF(adpsub .EQ. 'SFCSHP') r01o29 = r04o29(lunit,obs)
+
997  IF(adpsub .EQ. 'SFCBOG') r01o29 = r04o29(lunit,obs)
+
998  IF(adpsub .EQ. 'ADPUPA') r01o29 = r03o29(lunit,obs)
+
999  IF(adpsub .EQ. 'AIRCFT') r01o29 = r05o29(lunit,obs)
+
1000  IF(adpsub .EQ. 'AIRCAR') r01o29 = r05o29(lunit,obs)
+
1001  IF(adpsub .EQ. 'SATWND') r01o29 = r06o29(lunit,obs)
+
1002  IF(adpsub .EQ. 'SPSSMI') r01o29 = r07o29(lunit,obs)
+
1003  RETURN
+
1004  END
+
1005 C***********************************************************************
+
1006 C***********************************************************************
+
1007 C***********************************************************************
+
1008  SUBROUTINE s01o29(SID,XOB,YOB,RHR,RCH,RSV,RSV2,ELV,ITP,RTP)
+
1009 C ---> Formerly SUBROUTINE O29HDR
+
1010 
+
1011  common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
+
1012  common/io29ll/bmiss
+
1013 
+
1014  CHARACTER*(*) rsv,rsv2
+
1015  CHARACTER*8 cob,sid,rct
+
1016  dimension ihdr(12),rhdr(12),icats(50,150,11)
+
1017  REAL(8) bmiss
+
1018  equivalence(ihdr(1),rhdr(1)),(cob,iob),(icats,rcats)
+
1019 
+
1020  SAVE
+
1021 
+
1022  DATA omiss/99999/
+
1023 
+
1024 C INITIALIZE THE UNPACK ARRAY TO MISSINGS
+
1025 C ---------------------------------------
+
1026 
+
1027  ncat = 0
+
1028  rcats = omiss
+
1029  cob = ' '
+
1030  icats(6,1:149,1) = iob
+
1031  icats(4,1:149,2) = iob
+
1032  icats(4,1:149,3) = iob
+
1033  icats(4,1:149,4) = iob
+
1034  icats(6,1:149,5) = iob
+
1035  icats(6,1:149,6) = iob
+
1036  icats(3,1:149,7) = iob
+
1037  icats(3,1:149,8) = iob
+
1038 
+
1039 C WRITE THE RECEIPT TIME IN CHARACTERS
+
1040 C ------------------------------------
+
1041 
+
1042  rct = '9999 '
+
1043  IF(rch*100.LT.2401.AND.rch*100.GT.-1)
+
1044  $ WRITE(rct,'(I4.4)') nint(rch*100.)
+
1045 
+
1046 C STORE THE ON29 HEADER INFORMATION INTO UNP FORMAT
+
1047 C -------------------------------------------------
+
1048 
+
1049  rhdr( 1) = omiss
+
1050  IF(yob.LT.bmiss) rhdr( 1) = nint(100.*yob)
+
1051 cppppp
+
1052  IF(yob.GE.bmiss) print'(" ~~IW3UNP29/S01O29: ID ",A," has a ",
+
1053  $ "missing LATITUDE - on29 hdr, word 1 is set to ",G0)',
+
1054  $ sid,rhdr(1)
+
1055 cppppp
+
1056  rhdr( 2) = omiss
+
1057  IF(xob.LT.bmiss) rhdr( 2) = nint(100.*mod(720.-xob,360.))
+
1058 cppppp
+
1059  IF(xob.GE.bmiss) print'(" ~~IW3UNP29/S01O29: ID ",A," has a ",
+
1060  $ "missing LONGITUDE - on29 hdr, word 2 is set to ",G0)',
+
1061  $ sid,rhdr(2)
+
1062 cppppp
+
1063  rhdr( 3) = omiss
+
1064  rhdr( 4) = omiss
+
1065  IF(rhr.LT.bmiss) rhdr( 4) = nint((100.*rhr)+0.0001)
+
1066 cppppp
+
1067  IF(rhr.GE.bmiss) print'(" ~~IW3UNP29/S01O29: ID ",A," has a ",
+
1068  $ "missing OB TIME - on29 hdr, word 4 is set to ",G0)', sid,rhdr(4)
+
1069 cppppp
+
1070  IF(rsv2.EQ.' ') THEN
+
1071  cob = ' '
+
1072  cob(1:4) = rct(3:4)//rsv(1:2)
+
1073  ihdr(5) = iob
+
1074  cob = ' '
+
1075  cob(1:3) = rct(1:2)//rsv(3:3)
+
1076  ihdr(6) = iob
+
1077  ELSE
+
1078  cob = ' '
+
1079  cob(1:4) = rsv2(3:4)//rsv(1:2)
+
1080  ihdr(5) = iob
+
1081  cob = ' '
+
1082  cob(1:3) = rsv2(1:2)//rsv(3:3)
+
1083  ihdr(6) = iob
+
1084  END IF
+
1085  rhdr( 7) = nint(elv)
+
1086  ihdr( 8) = itp
+
1087  ihdr( 9) = rtp
+
1088  rhdr(10) = omiss
+
1089  cob = ' '
+
1090  cob(1:4) = sid(1:4)
+
1091  ihdr(11) = iob
+
1092  cob = ' '
+
1093  cob(1:4) = sid(5:6)//' '
+
1094  ihdr(12) = iob
+
1095 
+
1096 C STORE THE HEADER INTO A HOLDING ARRAY
+
1097 C -------------------------------------
+
1098 
+
1099  hdr = rhdr
+
1100 
+
1101  RETURN
+
1102  END
+
1103 C***********************************************************************
+
1104 C***********************************************************************
+
1105 C***********************************************************************
+
1106  SUBROUTINE s02o29(ICAT,N,*)
+
1107 C ---> Formerly SUBROUTINE O29CAT
+
1108 
+
1109  common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
+
1110  common/io29ee/pob(255),qob(255),tob(255),zob(255),dob(255),
+
1111  $ sob(255),vsg(255),clp(255),cla(255),ob8(255),
+
1112  $ cf8(255)
+
1113  common/io29ff/pqm(255),qqm(255),tqm(255),zqm(255),wqm(255),
+
1114  $ qcp(255),qca(255),q81(255),q82(255)
+
1115  common/io29gg/psl,stp,sdr,ssp,stm,dpd,tmx,tmi,hvz,prw,pw1,ccn,chn,
+
1116  $ ctl,ctm,cth,hcb,cpt,apt,pc6,snd,p24,dop,pow,how,swd,
+
1117  $ swp,swh,sst,spg,spd,shc,sas,wes
+
1118  common/io29hh/psq,spq,swq,stq,ddq
+
1119  common/io29ii/pwmin
+
1120  common/io29ll/bmiss
+
1121 
+
1122  CHARACTER*8 cob,c11,c12
+
1123  CHARACTER*1 pqm,qqm,tqm,zqm,wqm,qcp,qca,q81,q82,psq,spq,swq,stq,
+
1124  $ ddq
+
1125  dimension rcat(50),jcat(50)
+
1126  REAL(8) bmiss
+
1127  equivalence(rcat(1),jcat(1)),(c11,hdr(11)),(c12,hdr(12)),
+
1128  $ (cob,iob)
+
1129  LOGICAL surf
+
1130 
+
1131  SAVE
+
1132 
+
1133 cppppp-ID
+
1134  iprint = 0
+
1135 c if(C11(1:4)//C12(1:2).eq.'59758 ') iprint = 1
+
1136 c if(C11(1:4)//C12(1:2).eq.'59362 ') iprint = 1
+
1137 c if(C11(1:4)//C12(1:2).eq.'57957 ') iprint = 1
+
1138 c if(C11(1:4)//C12(1:2).eq.'74794 ') iprint = 1
+
1139 c if(C11(1:4)//C12(1:2).eq.'74389 ') iprint = 1
+
1140 c if(C11(1:4)//C12(1:2).eq.'96801A') iprint = 1
+
1141 cppppp-ID
+
1142 
+
1143  surf = .false.
+
1144  GOTO 1
+
1145 
+
1146 C ENTRY POINT SE01O29 FORCES DATA INTO THE SURFACE (FIRST) LEVEL
+
1147 C --------------------------------------------------------------
+
1148 
+
1149  entry se01o29(icat,n)
+
1150 C ---> formerly ENTRY O29SFC
+
1151  surf = .true.
+
1152 
+
1153 C CHECK THE PARAMETERS COMING IN
+
1154 C ------------------------------
+
1155 
+
1156 1 kcat = 0
+
1157  DO i = 1,11
+
1158  IF(icat.EQ.ikat(i)) THEN
+
1159  kcat = i
+
1160  GO TO 991
+
1161  END IF
+
1162  ENDDO
+
1163 
+
1164  991 CONTINUE
+
1165 
+
1166 C PARAMETER ICAT (ON29 CATEGORY) OUT OF BOUNDS RETURNS A 999
+
1167 C ----------------------------------------------------------
+
1168 
+
1169  IF(kcat.EQ.0) THEN
+
1170  print'(" ##IW3UNP29/S02O29 - ON29 CATEGORY ",I0," OUT OF ",
+
1171  $ "BOUNDS -- IER = 999")', icat
+
1172  RETURN 1
+
1173  END IF
+
1174 
+
1175 C PARAMETER N (LEVEL INDEX) OUT OF BOUNDS RETURNS A 999
+
1176 C -----------------------------------------------------
+
1177 
+
1178  IF(n.GT.255) THEN
+
1179  print'(" ##IW3UNP29/S02O29 - LEVEL INDEX ",I0," EXCEEDS 255 ",
+
1180  $ "-- IER = 999")', n
+
1181  RETURN 1
+
1182  END IF
+
1183 
+
1184 C MAKE A MISSING LEVEL AND RETURN WHEN N=0 (NOT ALLOWED FOR CAT 01)
+
1185 C -----------------------------------------------------------------
+
1186 
+
1187  IF(n.EQ.0) THEN
+
1188  IF(kcat.EQ.1) RETURN
+
1189  ncat(kcat) = min(149,ncat(kcat)+1)
+
1190 cppppp
+
1191  if(iprint.eq.1)
+
1192  $ print'(" To prepare for sfc. data, write all missings on ",
+
1193  $ "lvl ",I0," for cat ",I0)', ncat(kcat),kcat
+
1194 cppppp
+
1195  RETURN
+
1196  END IF
+
1197 
+
1198 C FIGURE OUT WHICH LEVEL TO UPDATE AND RESET THE LEVEL COUNTER
+
1199 C ------------------------------------------------------------
+
1200 
+
1201  IF(kcat.EQ.1) THEN
+
1202  l = i04o29(pob(n)*.1)
+
1203  IF(l.EQ.999999) GO TO 9999
+
1204 
+
1205 C BAD MANDATORY LEVEL RETURNS A 999
+
1206 C ---------------------------------
+
1207 
+
1208  IF(l.LE.0) THEN
+
1209  print'(" ##IW3UNP29/S02O29 - BAD MANDATORY LEVEL (P = ",
+
1210  $ G0,") -- IER = 999")', pob(n)
+
1211  RETURN 1
+
1212  END IF
+
1213  ncat(kcat) = max(ncat(kcat),l)
+
1214 cppppp
+
1215  if(iprint.eq.1)
+
1216  $ print'(" Will write cat. 1 data on lvl ",I0," for cat ",I0,
+
1217  $ ", - total no. cat. 1 lvls processed so far = ",I0)',
+
1218  $ l,kcat,ncat(kcat)
+
1219 cppppp
+
1220  ELSEIF(surf) THEN
+
1221  l = 1
+
1222  ncat(kcat) = max(ncat(kcat),1)
+
1223 cppppp
+
1224  if(iprint.eq.1)
+
1225  $ print'(" Will write cat. ",I0," SURFACE data on lvl ",I0,
+
1226  $ ", - total no. cat. ",I0," lvls processed so far = ",I0)',
+
1227  $ kcat,l,kcat,ncat(kcat)
+
1228 cppppp
+
1229  ELSE
+
1230  l = min(149,ncat(kcat)+1)
+
1231  IF(l.EQ.149) THEN
+
1232 cppppp
+
1233  print'(" ~~IW3UNP29/S02O29: ID ",A," - This cat. ",I0,
+
1234  $ " level cannot be processed because the limit has already",
+
1235  $ " been reached")', c11(1:4)//c12(1:2),kcat
+
1236 cppppp
+
1237  RETURN
+
1238  END IF
+
1239  ncat(kcat) = l
+
1240 cppppp
+
1241  if(iprint.eq.1)
+
1242  $ print'(" Will write cat. ",I0," NON-SFC data on lvl ",I0,
+
1243  $ ", - total no. cat. ",I0," lvls processed so far = ",I0)',
+
1244  $ kcat,l,kcat,ncat(kcat)
+
1245 cppppp
+
1246  END IF
+
1247 
+
1248 C EACH CATEGORY NEEDS A SPECIFIC DATA ARRANGEMENT
+
1249 C -----------------------------------------------
+
1250 
+
1251  cob = ' '
+
1252  IF(icat.EQ.1) THEN
+
1253  rcat(1) = min(nint(zob(n)),nint(rcats(1,l,kcat)))
+
1254  rcat(2) = min(nint(tob(n)),nint(rcats(2,l,kcat)))
+
1255  rcat(3) = min(nint(qob(n)),nint(rcats(3,l,kcat)))
+
1256  rcat(4) = min(nint(dob(n)),nint(rcats(4,l,kcat)))
+
1257  rcat(5) = min(nint(sob(n)),nint(rcats(5,l,kcat)))
+
1258  cob(1:4) = zqm(n)//tqm(n)//qqm(n)//wqm(n)
+
1259  jcat(6) = iob
+
1260  ELSEIF(icat.EQ.2) THEN
+
1261  rcat(1) = min(nint(pob(n)),99999)
+
1262  rcat(2) = min(nint(tob(n)),99999)
+
1263  rcat(3) = min(nint(qob(n)),99999)
+
1264  cob(1:3) = pqm(n)//tqm(n)//qqm(n)
+
1265  jcat(4) = iob
+
1266  ELSEIF(icat.EQ.3) THEN
+
1267  rcat(1) = min(nint(pob(n)),99999)
+
1268  rcat(2) = min(nint(dob(n)),99999)
+
1269  rcat(3) = min(nint(sob(n)),99999)
+
1270 
+
1271 C MARK THE TROPOPAUSE LEVEL IN CAT. 3
+
1272 
+
1273  IF(nint(vsg(n)).EQ.16) pqm(n) = 'T'
+
1274 
+
1275 C MARK THE MAXIMUM WIND LEVEL IN CAT. 3
+
1276 
+
1277  IF(nint(vsg(n)).EQ. 8) THEN
+
1278  pqm(n) = 'W'
+
1279  IF(pob(n).EQ.pwmin) pqm(n) = 'X'
+
1280  END IF
+
1281  cob(1:2) = pqm(n)//wqm(n)
+
1282  jcat(4) = iob
+
1283  ELSEIF(icat.EQ.4) THEN
+
1284  rcat(1) = min(nint(zob(n)),99999)
+
1285  rcat(2) = min(nint(dob(n)),99999)
+
1286  rcat(3) = min(nint(sob(n)),99999)
+
1287  cob(1:2) = zqm(n)//wqm(n)
+
1288  jcat(4) = iob
+
1289  ELSEIF(icat.EQ.5) THEN
+
1290  rcat(1) = min(nint(pob(n)),99999)
+
1291  rcat(2) = min(nint(tob(n)),99999)
+
1292  rcat(3) = min(nint(qob(n)),99999)
+
1293  rcat(4) = min(nint(dob(n)),99999)
+
1294  rcat(5) = min(nint(sob(n)),99999)
+
1295  cob(1:4) = pqm(n)//tqm(n)//qqm(n)//wqm(n)
+
1296  jcat(6) = iob
+
1297  ELSEIF(icat.EQ.6) THEN
+
1298  rcat(1) = min(nint(zob(n)),99999)
+
1299  rcat(2) = min(nint(tob(n)),99999)
+
1300  rcat(3) = min(nint(qob(n)),99999)
+
1301  rcat(4) = min(nint(dob(n)),99999)
+
1302  rcat(5) = min(nint(sob(n)),99999)
+
1303  cob(1:4) = zqm(n)//tqm(n)//qqm(n)//wqm(n)
+
1304  jcat(6) = iob
+
1305  ELSEIF(icat.EQ.7) THEN
+
1306  rcat(1) = min(nint(clp(n)),99999)
+
1307  rcat(2) = min(nint(cla(n)),99999)
+
1308  cob(1:2) = qcp(n)//qca(n)
+
1309  jcat(3) = iob
+
1310  ELSEIF(icat.EQ.8) THEN
+
1311  rcat(1) = min(nint(ob8(n)),99999)
+
1312  rcat(2) = min(nint(cf8(n)),99999)
+
1313  cob(1:2) = q81(n)//q82(n)
+
1314  jcat(3) = iob
+
1315  ELSEIF(icat.EQ.51) THEN
+
1316  rcat( 1) = min(nint(psl),99999)
+
1317  rcat( 2) = min(nint(stp),99999)
+
1318  rcat( 3) = min(nint(sdr),99999)
+
1319  rcat( 4) = min(nint(ssp),99999)
+
1320  rcat( 5) = min(nint(stm),99999)
+
1321  rcat( 6) = min(nint(dpd),99999)
+
1322  rcat( 7) = min(nint(tmx),99999)
+
1323  rcat( 8) = min(nint(tmi),99999)
+
1324  cob(1:4) = psq//spq//swq//stq
+
1325  jcat(9) = iob
+
1326  cob = ' '
+
1327  cob(1:1) = ddq
+
1328  jcat(10) = iob
+
1329  jcat(11) = min(nint(hvz),99999)
+
1330  jcat(12) = min(nint(prw),99999)
+
1331  jcat(13) = min(nint(pw1),99999)
+
1332  jcat(14) = min(nint(ccn),99999)
+
1333  jcat(15) = min(nint(chn),99999)
+
1334  jcat(16) = min(nint(ctl),99999)
+
1335  jcat(17) = min(nint(hcb),99999)
+
1336  jcat(18) = min(nint(ctm),99999)
+
1337  jcat(19) = min(nint(cth),99999)
+
1338  jcat(20) = min(nint(cpt),99999)
+
1339  rcat(21) = min(abs(nint(apt)),99999)
+
1340  IF(cpt.GE.bmiss.AND.apt.LT.0.)
+
1341  $ rcat(21) = min(abs(nint(apt))+500,99999)
+
1342  ELSEIF(icat.EQ.52) THEN
+
1343  jcat( 1) = min(nint(pc6),99999)
+
1344  jcat( 2) = min(nint(snd),99999)
+
1345  jcat( 3) = min(nint(p24),99999)
+
1346  jcat( 4) = min(nint(dop),99999)
+
1347  jcat( 5) = min(nint(pow),99999)
+
1348  jcat( 6) = min(nint(how),99999)
+
1349  jcat( 7) = min(nint(swd),99999)
+
1350  jcat( 8) = min(nint(swp),99999)
+
1351  jcat( 9) = min(nint(swh),99999)
+
1352  jcat(10) = min(nint(sst),99999)
+
1353  jcat(11) = min(nint(spg),99999)
+
1354  jcat(12) = min(nint(spd),99999)
+
1355  jcat(13) = min(nint(shc),99999)
+
1356  jcat(14) = min(nint(sas),99999)
+
1357  jcat(15) = min(nint(wes),99999)
+
1358  ELSE
+
1359 
+
1360 C UNSUPPORTED CATEGORY RETURNS A 999
+
1361 C ----------------------------------
+
1362 
+
1363  print'(" ##IW3UNP29/S02O29 - CATEGORY ",I0," NOT SUPPORTED ",
+
1364  $ "-- IER = 999")', icat
+
1365  RETURN 1
+
1366  END IF
+
1367 
+
1368 C TRANSFER THE LEVEL DATA INTO THE HOLDING ARRAY AND EXIT
+
1369 C -------------------------------------------------------
+
1370 
+
1371  DO i = 1,mcat(kcat)
+
1372  rcats(i,l,kcat) = rcat(i)
+
1373  ENDDO
+
1374 
+
1375  RETURN
+
1376  9999 CONTINUE
+
1377  RETURN 1
+
1378  END
+
1379 C***********************************************************************
+
1380 C***********************************************************************
+
1381 C***********************************************************************
+
1382  SUBROUTINE s03o29(UNP,SUBSET,*,*)
+
1383 C ---> Formerly SUBROUTINE O29UNP
+
1384 
+
1385  common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
+
1386 
+
1387  dimension rcat(50),jcat(50),unp(*)
+
1388  CHARACTER*8 subset
+
1389  equivalence(rcat(1),jcat(1))
+
1390 
+
1391  SAVE
+
1392 
+
1393 C CALL TO SORT CATEGORIES 02, 03, 04, AND 08 LEVELS
+
1394 C -------------------------------------------------
+
1395 
+
1396  CALL s04o29
+
1397 
+
1398 C TRANSFER DATA FROM ALL CATEGORIES INTO UNP ARRAY & SET POINTERS
+
1399 C ---------------------------------------------------------------
+
1400 
+
1401  indx = 43
+
1402  jcat = 0
+
1403  nlevto = 0
+
1404  nlevc8 = 0
+
1405 
+
1406  DO k = 1,11
+
1407  jcat(2*k+11) = ncat(k)
+
1408  IF(k.NE.7.AND.k.NE.8.AND.k.NE.11) THEN
+
1409  nlevto = nlevto + ncat(k)
+
1410  ELSE IF(k.EQ.8) THEN
+
1411  nlevc8 = nlevc8 + ncat(k)
+
1412  END IF
+
1413  IF(ncat(k).GT.0) jcat(2*k+12) = indx
+
1414  IF(ncat(k).EQ.0) jcat(2*k+12) = 0
+
1415  DO j = 1,ncat(k)
+
1416  DO i = 1,mcat(k)
+
1417 
+
1418 C UNPACKED ON29 REPORT CONTAINS MORE THAN 1608 WORDS - RETURNS A 999
+
1419 C ------------------------------------------------------------------
+
1420 
+
1421  IF(indx.GT.1608) THEN
+
1422  print'(" ##IW3UNP29/S03O29 - UNPKED ON29 RPT CONTAINS ",
+
1423  $ I0," WORDS, > LIMIT OF 1608 -- IER = 999")', indx
+
1424  RETURN 1
+
1425  END IF
+
1426  unp(indx) = rcats(i,j,k)
+
1427  indx = indx+1
+
1428  ENDDO
+
1429  ENDDO
+
1430  ENDDO
+
1431 
+
1432 C RETURN WITHOUT PROCESSING THIS REPORT IF NO DATA IN CAT. 1-6, 51, 52
+
1433 C (UNLESS SSM/I REPORT, THEN DO NOT RETURN UNLESS ALSO NO CAT. 8 DATA)
+
1434 C --------------------------------------------------------------------
+
1435 
+
1436  IF(nlevto.EQ.0) THEN
+
1437  IF(subset(1:5).NE.'NC012') THEN
+
1438  RETURN 2
+
1439  ELSE
+
1440  IF(nlevc8.EQ.0) RETURN 2
+
1441  END IF
+
1442  END IF
+
1443 
+
1444 C TRANSFER THE HEADER AND POINTER ARRAYS INTO UNP
+
1445 C -----------------------------------------------
+
1446 
+
1447  unp(1:12) = hdr
+
1448  unp(13:42) = rcat(13:42)
+
1449 
+
1450  RETURN
+
1451  END
+
1452 C***********************************************************************
+
1453 C***********************************************************************
+
1454 C***********************************************************************
+
1455  SUBROUTINE s04o29
+
1456 C ---> Formerly SUBROUTINE O29SRT
+
1457 
+
1458  common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
+
1459 cppppp
+
1460  character*8 c11,c12,sid
+
1461 cppppp
+
1462 
+
1463  dimension rcat(50,150),iord(150),iwork(65536),scat(50,150),rctl(3)
+
1464 cppppp
+
1465  equivalence(c11,hdr(11)),(c12,hdr(12))
+
1466 cppppp
+
1467 
+
1468  SAVE
+
1469 
+
1470 cppppp
+
1471  sid = c11(1:4)//c12(1:4)
+
1472 cppppp
+
1473 
+
1474 C SORT CATEGORIES 2, 3, AND 4 - LEAVE THE FIRST LEVEL IN EACH INTACT
+
1475 C ------------------------------------------------------------------
+
1476 
+
1477  DO k=2,4
+
1478  IF(ncat(k).GT.1) THEN
+
1479  DO j=1,ncat(k)-1
+
1480  DO i=1,mcat(k)
+
1481  scat(i,j) = rcats(i,j+1,k)
+
1482  ENDDO
+
1483  ENDDO
+
1484  CALL orders(2,iwork,scat(1,1),iord,ncat(k)-1,50,8,2)
+
1485  rctl = 10e9
+
1486  DO j=1,ncat(k)-1
+
1487  IF(k.LT.4) jj = iord((ncat(k)-1)-j+1)
+
1488  IF(k.EQ.4) jj = iord(j)
+
1489  DO i=1,mcat(k)
+
1490  rcat(i,j) = scat(i,jj)
+
1491  ENDDO
+
1492  idup = 0
+
1493  IF(nint(rcat(1,j)).EQ.nint(rctl(1))) THEN
+
1494  IF(nint(rcat(2,j)).EQ.nint(rctl(2)).AND.
+
1495  $ nint(rcat(3,j)).EQ.nint(rctl(3))) THEN
+
1496 cppppp
+
1497  if(k.ne.4) then
+
1498  print'(" ~~@@IW3UNP29/S04O29: ID ",A," has a ",
+
1499  $ "dupl. cat. ",I0," lvl (all data) at ",G0," mb -- lvl will be ",
+
1500  $ "excluded from processing")', sid,k,rcat(1,j)*.1
+
1501  else
+
1502  print'(" ~~@@IW3UNP29/S04O29: ID ",A," has a ",
+
1503  $ "dupl. cat. ",I0," lvl (all data) at ",G0," m -- lvl will be ",
+
1504  $ "excluded from processing")', sid,k,rcat(1,j)
+
1505  end if
+
1506 cppppp
+
1507  idup = 1
+
1508  ELSE
+
1509 cppppp
+
1510  if(k.ne.4) then
+
1511  print'(" ~~@@#IW3UNP29/S04O29: ID ",A," has a ",
+
1512  $ "dupl. cat. ",I0," press. lvl (data differ) at ",G0," mb -- lvl",
+
1513  $ " will NOT be excluded")', sid,k,rcat(1,j)*.1
+
1514  else
+
1515  print'(" ~~@@#IW3UNP29/S04O29: ID ",A," has a ",
+
1516  $ "dupl. cat. ",I0," height lvl (data differ) at ",G0," m -- lvl ",
+
1517  $ "will NOT be excluded")', sid,k,rcat(1,j)
+
1518  end if
+
1519 cppppp
+
1520  END IF
+
1521  END IF
+
1522  rctl = rcat(1:3,j)
+
1523  IF(idup.EQ.1) rcat(1,j) = 10e8
+
1524  ENDDO
+
1525  jjj = 1
+
1526  DO j=2,ncat(k)
+
1527  IF(rcat(1,j-1).GE.10e8) GO TO 887
+
1528  jjj = jjj + 1
+
1529  DO i=1,mcat(k)
+
1530  rcats(i,jjj,k) = rcat(i,j-1)
+
1531  ENDDO
+
1532  887 CONTINUE
+
1533  ENDDO
+
1534 cppppp
+
1535  if(jjj.ne.ncat(k))
+
1536  $ print'(" ~~@@IW3UNP29/S04O29: ID ",A," has had ",I0,
+
1537  $ " lvls removed due to their being duplicates")',
+
1538  $ sid,ncat(k)-jjj
+
1539 cppppp
+
1540  ncat(k) = jjj
+
1541  end if
+
1542  IF(ncat(k).EQ.1) THEN
+
1543  IF(min(rcats(1,1,k),rcats(2,1,k),rcats(3,1,k)).GT.99998.8)
+
1544  $ ncat(k) = 0
+
1545  END IF
+
1546  ENDDO
+
1547 
+
1548 C SORT CATEGORY 08 BY CODE FIGURE
+
1549 C -------------------------------
+
1550 
+
1551  DO k=8,8
+
1552  IF(ncat(k).GT.1) THEN
+
1553  CALL orders(2,iwork,rcats(2,1,k),iord,ncat(k),50,8,2)
+
1554  DO j=1,ncat(k)
+
1555  DO i=1,mcat(k)
+
1556  rcat(i,j) = rcats(i,iord(j),k)
+
1557  ENDDO
+
1558  ENDDO
+
1559  DO j=1,ncat(k)
+
1560  DO i=1,mcat(k)
+
1561  rcats(i,j,k) = rcat(i,j)
+
1562  ENDDO
+
1563  ENDDO
+
1564  END IF
+
1565  ENDDO
+
1566 
+
1567 C NORMAL EXIT
+
1568 C -----------
+
1569 
+
1570  RETURN
+
1571  END
+
1572 C***********************************************************************
+
1573 C***********************************************************************
+
1574 C***********************************************************************
+
1575  SUBROUTINE s05o29
+
1576 C ---> Formerly SUBROUTINE O29INX
+
1577 
+
1578  common/io29ee/obs(255,11)
+
1579  common/io29ff/qms(255,9)
+
1580  common/io29gg/sfo(34)
+
1581  common/io29hh/sfq(5)
+
1582  common/io29ll/bmiss
+
1583 
+
1584  CHARACTER*1 qms,sfq
+
1585 
+
1586  REAL(8) bmiss
+
1587 
+
1588  SAVE
+
1589 
+
1590 C SET THE INPUT DATA ARRAYS TO MISSING OR BLANK
+
1591 C ---------------------------------------------
+
1592 
+
1593  obs = bmiss
+
1594  qms = ' '
+
1595  sfo = bmiss
+
1596  sfq = ' '
+
1597 
+
1598  RETURN
+
1599  END
+
1600 C***********************************************************************
+
1601 C***********************************************************************
+
1602 C***********************************************************************
+
1603  FUNCTION i04o29(P)
+
1604 C ---> formerly FUNCTION MANO29
+
1605 
+
1606  common/io29jj/iset,manlin(1001)
+
1607 
+
1608  SAVE
+
1609 
+
1610  IF(iset.EQ.0) THEN
+
1611  manlin = 0
+
1612 
+
1613  manlin(1000) = 1
+
1614  manlin(850) = 2
+
1615  manlin(700) = 3
+
1616  manlin(500) = 4
+
1617  manlin(400) = 5
+
1618  manlin(300) = 6
+
1619  manlin(250) = 7
+
1620  manlin(200) = 8
+
1621  manlin(150) = 9
+
1622  manlin(100) = 10
+
1623  manlin(70) = 11
+
1624  manlin(50) = 12
+
1625  manlin(30) = 13
+
1626  manlin(20) = 14
+
1627  manlin(10) = 15
+
1628  manlin(7) = 16
+
1629  manlin(5) = 17
+
1630  manlin(3) = 18
+
1631  manlin(2) = 19
+
1632  manlin(1) = 20
+
1633 
+
1634  iset = 1
+
1635  END IF
+
1636 
+
1637  ip = nint(p*10.)
+
1638 
+
1639  IF(ip.GT.10000 .OR. ip.LT.10 .OR. mod(ip,10).NE.0) THEN
+
1640  i04o29 = 0
+
1641  ELSE
+
1642  i04o29 = manlin(ip/10)
+
1643  END IF
+
1644 
+
1645  RETURN
+
1646 
+
1647  END
+
1648 C***********************************************************************
+
1649 C***********************************************************************
+
1650 C***********************************************************************
+
1651  FUNCTION r02o29()
+
1652 C ---> formerly FUNCTION ONFUN
+
1653 
+
1654  common/io29ll/bmiss
+
1655 
+
1656  CHARACTER*8 subset,rpid
+
1657  LOGICAL l02o29,l03o29
+
1658  INTEGER kkk(0:99),kkkk(49)
+
1659  REAL(8) bmiss
+
1660 
+
1661  SAVE
+
1662 
+
1663  DATA grav/9.8/,cm2k/1.94/,tzro/273.15/
+
1664  DATA kkk /5*90,16*91,30*92,49*93/
+
1665  DATA kkkk/94,2*95,6*96,10*97,30*98/
+
1666 
+
1667  prs1(z) = 1013.25 * (((288.15 - (.0065 * z))/288.15)**5.256)
+
1668  prs2(z) = 226.3 * exp(1.576106e-4 * (11000. - z))
+
1669  prs3(pmnd,temp,z,zmnd)
+
1670  $ = pmnd * (((temp - (.0065 * (z - zmnd)))/temp)**5.256)
+
1671  es(t) = 6.1078 * exp((17.269 * (t-273.16))/((t-273.16)+237.3))
+
1672  qfrmtp(t,pppp) = (0.622 * es(t))/(pppp-(0.378 * es(t)))
+
1673  hgtf(p) = (1.-(p/1013.25)**(1./5.256))*(288.15/.0065)
+
1674 
+
1675  r02o29 = 0
+
1676 
+
1677  RETURN
+
1678 
+
1679  entry e01o29(prs)
+
1680 C ---> formerly ENTRY ONPRS
+
1681  IF(prs.LT.bmiss) e01o29 = nint(prs*.1)
+
1682  IF(prs.GE.bmiss) e01o29 = bmiss
+
1683  RETURN
+
1684  entry e37o29(pmnd,temp,hgt,zmnd,tqm)
+
1685 C ---> formerly ENTRY ONPFHT
+
1686  IF(hgt.GE.bmiss) THEN
+
1687  e37o29 = bmiss
+
1688  ELSE
+
1689  IF(hgt.LE.11000) THEN
+
1690  p = prs1(hgt)
+
1691  ELSE
+
1692  p = prs2(hgt)
+
1693  END IF
+
1694  IF(max(pmnd,zmnd).GE.bmiss) THEN
+
1695  e37o29 = p
+
1696  RETURN
+
1697  END IF
+
1698  IF(temp.GE.9999.) temp = bmiss
+
1699  IF(tqm.GE.bmiss) tqm = 2
+
1700  IF(temp.GE.bmiss.OR.tqm.GE.4) CALL w3fa03(p,d1,temp,d2)
+
1701  q = qfrmtp(temp,p)
+
1702  tvirt = temp * (1.0 + (0.61 * q))
+
1703  e37o29 = prs3(pmnd,tvirt,hgt,zmnd)
+
1704  END IF
+
1705  RETURN
+
1706  entry e03o29(prs)
+
1707 C ---> formerly ENTRY ONHFP
+
1708  IF(prs.LT.bmiss) e03o29 = hgtf(prs)
+
1709  IF(prs.GE.bmiss) e03o29 = bmiss
+
1710  RETURN
+
1711  entry e04o29(wdr,wsp)
+
1712 C ---> formerly ENTRY ONWDR
+
1713  e04o29 = wdr
+
1714  RETURN
+
1715  entry e05o29(wdr,wsp)
+
1716 C ---> formerly ENTRY ONWSP
+
1717  IF(wsp.LT.bmiss) THEN
+
1718  e05o29 = (wsp*cm2k)
+
1719  e05o29 = e05o29 + 0.0000001
+
1720  ELSE
+
1721  e05o29 = bmiss
+
1722  END IF
+
1723  RETURN
+
1724  entry e06o29(tmp)
+
1725 C ---> formerly ENTRY ONTMP
+
1726  itmp = nint(tmp*100.)
+
1727  itzro = nint(tzro*100.)
+
1728  IF(tmp.LT.bmiss) e06o29 = nint((itmp - itzro)*0.1)
+
1729  IF(tmp.GE.bmiss) e06o29 = bmiss
+
1730  RETURN
+
1731  entry e07o29(dpd,tmp)
+
1732 C ---> formerly ENTRY ONDPD
+
1733  IF(dpd.LT.bmiss .AND. tmp.LT.bmiss) e07o29 = (tmp-dpd)*10.
+
1734  IF(dpd.GE.bmiss .OR. tmp.GE.bmiss) e07o29 = bmiss
+
1735  RETURN
+
1736  entry e08o29(hgt)
+
1737 C ---> formerly ENTRY ONHGT
+
1738  e08o29 = hgt
+
1739  IF(hgt.LT.bmiss) e08o29 = (hgt/grav)
+
1740  RETURN
+
1741  entry e09o29(hvz)
+
1742 C ---> formerly ENTRY ONHVZ
+
1743  IF(hvz.GE.bmiss.OR.hvz.LT.0.) THEN
+
1744  e09o29 = bmiss
+
1745  ELSE IF(nint(hvz).LT.6000) THEN
+
1746  e09o29 = min(int(nint(hvz)/100),50)
+
1747  ELSE IF(nint(hvz).LT.30000) THEN
+
1748  e09o29 = int(nint(hvz)/1000) + 50
+
1749  ELSE IF(nint(hvz).LE.70000) THEN
+
1750  e09o29 = int(nint(hvz)/5000) + 74
+
1751  ELSE
+
1752  e09o29 = 89
+
1753  END IF
+
1754  RETURN
+
1755  entry e10o29(prw)
+
1756 C ---> formerly ENTRY ONPRW
+
1757  e10o29 = bmiss
+
1758  IF(prw.LT.bmiss) e10o29 = nint(mod(prw,100.))
+
1759  RETURN
+
1760  entry e11o29(paw)
+
1761 C ---> formerly ENTRY ONPAW
+
1762  e11o29 = bmiss
+
1763  IF(paw.LT.bmiss) e11o29 = nint(mod(paw,10.))
+
1764  RETURN
+
1765  entry e12o29(ccn)
+
1766 C ---> formerly ENTRY ONCCN
+
1767  IF(nint(ccn).EQ.0) THEN
+
1768  e12o29 = 0
+
1769  ELSE IF(ccn.LT. 15) THEN
+
1770  e12o29 = 1
+
1771  ELSE IF(ccn.LT. 35) THEN
+
1772  e12o29 = 2
+
1773  ELSE IF(ccn.LT. 45) THEN
+
1774  e12o29 = 3
+
1775  ELSE IF(ccn.LT. 55) THEN
+
1776  e12o29 = 4
+
1777  ELSE IF(ccn.LT. 65) THEN
+
1778  e12o29 = 5
+
1779  ELSE IF(ccn.LT. 85) THEN
+
1780  e12o29 = 6
+
1781  ELSE IF(ccn.LT.100) THEN
+
1782  e12o29 = 7
+
1783  ELSE IF(nint(ccn).EQ.100) THEN
+
1784  e12o29 = 8
+
1785  ELSE
+
1786  e12o29 = bmiss
+
1787  END IF
+
1788  RETURN
+
1789  entry e13o29(cla)
+
1790 C ---> formerly ENTRY ONCLA
+
1791  e13o29 = bmiss
+
1792  IF(cla.EQ.0) e13o29 = 0
+
1793  IF(cla.EQ.1) e13o29 = 5
+
1794  IF(cla.EQ.2) e13o29 = 25
+
1795  IF(cla.EQ.3) e13o29 = 40
+
1796  IF(cla.EQ.4) e13o29 = 50
+
1797  IF(cla.EQ.5) e13o29 = 60
+
1798  IF(cla.EQ.6) e13o29 = 75
+
1799  IF(cla.EQ.7) e13o29 = 95
+
1800  IF(cla.EQ.8) e13o29 = 100
+
1801  RETURN
+
1802  entry e14o29(ccl,ccm)
+
1803 C ---> formerly ENTRY ONCHN
+
1804  e14o29 = ccl
+
1805  IF(nint(e14o29).EQ.0) e14o29 = ccm
+
1806  IF(nint(e14o29).LT.10) RETURN
+
1807  IF(nint(e14o29).EQ.10) THEN
+
1808  e14o29 = 9.
+
1809  ELSE IF(nint(e14o29).EQ.15) THEN
+
1810  e14o29 = 10.
+
1811  ELSE
+
1812  e14o29 = bmiss
+
1813  END IF
+
1814  RETURN
+
1815  entry e15o29(ctlmh)
+
1816 C ---> formerly ENTRY ONCTL, ONCTM, ONCTH
+
1817  e15o29 = ctlmh
+
1818  RETURN
+
1819  entry e18o29(chl,chm,chh,ctl,ctm,cth)
+
1820 C ---> formerly ENTRY ONHCB
+
1821  IF(nint(max(ctl,ctm,cth)).EQ.0) THEN
+
1822  e18o29 = 9
+
1823  RETURN
+
1824  END IF
+
1825  e18o29 = bmiss
+
1826  IF(chh.LT.bmiss) e18o29 = chh
+
1827  IF(chm.LT.bmiss) e18o29 = chm
+
1828  IF(chl.LT.bmiss) e18o29 = chl
+
1829  IF(e18o29.GE.bmiss.OR.e18o29.LT.0) RETURN
+
1830  IF(e18o29.LT. 150) THEN
+
1831  e18o29 = 0
+
1832  ELSE IF(e18o29.LT. 350) THEN
+
1833  e18o29 = 1
+
1834  ELSE IF(e18o29.LT. 650) THEN
+
1835  e18o29 = 2
+
1836  ELSE IF(e18o29.LT. 950) THEN
+
1837  e18o29 = 3
+
1838  ELSE IF(e18o29.LT.1950) THEN
+
1839  e18o29 = 4
+
1840  ELSE IF(e18o29.LT.3250) THEN
+
1841  e18o29 = 5
+
1842  ELSE IF(e18o29.LT.4950) THEN
+
1843  e18o29 = 6
+
1844  ELSE IF(e18o29.LT.6750) THEN
+
1845  e18o29 = 7
+
1846  ELSE IF(e18o29.LT.8250) THEN
+
1847  e18o29 = 8
+
1848  ELSE
+
1849  e18o29 = 9
+
1850  END IF
+
1851  RETURN
+
1852  entry e19o29(cpt)
+
1853 C ---> formerly ENTRY ONCPT
+
1854  e19o29 = bmiss
+
1855  IF(nint(cpt).GT.-1.AND.nint(cpt).LT.9) e19o29 = cpt
+
1856  RETURN
+
1857  entry e20o29(prc)
+
1858 C ---> formerly ENTRY ONPRC
+
1859  e20o29 = prc
+
1860  IF(prc.LT.0.) THEN
+
1861  e20o29 = 9998
+
1862  ELSE IF(prc.LT.bmiss) THEN
+
1863  e20o29 = nint(prc*3.937)
+
1864  END IF
+
1865  RETURN
+
1866  entry e21o29(snd)
+
1867 C ---> formerly ENTRY ONSND
+
1868  e21o29 = snd
+
1869  IF(snd.LT.0.) THEN
+
1870  e21o29 = 998
+
1871  ELSE IF(snd.LT.bmiss) THEN
+
1872  e21o29 = nint(snd*39.37)
+
1873  END IF
+
1874  RETURN
+
1875  entry e22o29(pc6)
+
1876 C ---> formerly ENTRY ONDOP
+
1877  e22o29 = bmiss
+
1878  IF(pc6.LT.bmiss) e22o29 = 1
+
1879  RETURN
+
1880  entry e23o29(per)
+
1881 C ---> formerly ENTRY ONPOW, ONSWP
+
1882  e23o29 = nint(per)
+
1883  RETURN
+
1884  entry e24o29(hgt)
+
1885 C ---> formerly ENTRY ONHOW, ONSWH
+
1886  e24o29 = hgt
+
1887  IF(hgt.LT.bmiss) e24o29 = nint(2.*hgt)
+
1888  RETURN
+
1889  entry e25o29(swd)
+
1890 C ---> formerly ENTRY ONSWD
+
1891  e25o29 = swd
+
1892  IF(swd.EQ.0) THEN
+
1893  e25o29 = 0
+
1894  ELSE IF(swd.LT.5) THEN
+
1895  e25o29 = 36
+
1896  ELSE IF(swd.LT.bmiss) THEN
+
1897  e25o29 = nint((swd+.001)*.1)
+
1898  END IF
+
1899  RETURN
+
1900  entry e28o29(spg)
+
1901 C ---> formerly ENTRY ONSPG
+
1902  e28o29 = spg
+
1903  RETURN
+
1904  entry e29o29(spd)
+
1905 C ---> formerly ENTRY ONSPD
+
1906  e29o29 = spd
+
1907  RETURN
+
1908  entry e30o29(shc)
+
1909 C ---> formerly ENTRY ONSHC
+
1910  e30o29 = bmiss
+
1911  IF(nint(shc).GT.-1.AND.nint(shc).LT.9) e30o29 = nint(shc)
+
1912  RETURN
+
1913  entry e31o29(sas)
+
1914 C ---> formerly ENTRY ONSAS
+
1915  e31o29 = bmiss
+
1916  IF(nint(sas).GT.-1.AND.nint(sas).LT.10) e31o29 = nint(sas)
+
1917  RETURN
+
1918  entry e32o29(wes)
+
1919 C ---> formerly ENTRY ONWES
+
1920  e32o29 = wes
+
1921  RETURN
+
1922  entry e33o29(subset,rpid)
+
1923 C ---> formerly ENTRY ONRTP
+
1924  e33o29 = bmiss
+
1925  IF(subset(1:5).EQ.'NC000'.AND.l02o29(rpid) ) e33o29 = 511
+
1926  IF(subset(1:5).EQ.'NC000'.AND.l03o29(rpid) ) e33o29 = 512
+
1927  IF(subset.EQ.'NC001001'.AND.rpid.NE.'SHIP') e33o29 = 522
+
1928  IF(subset.EQ.'NC001001'.AND.rpid.EQ.'SHIP') e33o29 = 523
+
1929  IF(subset.EQ.'NC001002') e33o29 = 562
+
1930  IF(subset.EQ.'NC001003') e33o29 = 561
+
1931  IF(subset.EQ.'NC001004') e33o29 = 531
+
1932  IF(subset.EQ.'NC001006') e33o29 = 551
+
1933  IF(subset.EQ.'NC002001') THEN
+
1934 
+
1935 C LAND RADIOSONDE - FIXED
+
1936 C -----------------------
+
1937 
+
1938  e33o29 = 011
+
1939  IF(l03o29(rpid)) e33o29 = 012
+
1940  IF(rpid(1:4).EQ.'CLAS') e33o29 = 013
+
1941  END IF
+
1942  IF(subset.EQ.'NC002002') THEN
+
1943 
+
1944 C LAND RADIOSONDE - MOBILE
+
1945 C ------------------------
+
1946 
+
1947  e33o29 = 013
+
1948  END IF
+
1949  IF(subset.EQ.'NC002003') THEN
+
1950 
+
1951 C SHIP RADIOSONDE
+
1952 C ---------------
+
1953 
+
1954  e33o29 = 022
+
1955  IF(rpid(1:4).EQ.'SHIP') e33o29 = 023
+
1956  END IF
+
1957  IF(subset.EQ.'NC002004') THEN
+
1958 
+
1959 C DROPWINSONDE
+
1960 C -------------
+
1961 
+
1962  e33o29 = 031
+
1963  END IF
+
1964  IF(subset.EQ.'NC002005') THEN
+
1965 
+
1966 C PIBAL
+
1967 C -----
+
1968 
+
1969  e33o29 = 011
+
1970  IF(l03o29(rpid)) e33o29 = 012
+
1971  END IF
+
1972 
+
1973  IF(subset.EQ.'NC004001') e33o29 = 041
+
1974  IF(subset.EQ.'NC004002') e33o29 = 041
+
1975  IF(subset.EQ.'NC004003') e33o29 = 041
+
1976  IF(subset.EQ.'NC004004') e33o29 = 041
+
1977  IF(subset.EQ.'NC004005') e33o29 = 031
+
1978  IF(subset(1:5).EQ.'NC005') e33o29 = 063
+
1979  RETURN
+
1980  entry e34o29(hgt,z100)
+
1981 C ---> formerly ENTRY ONFIX
+
1982 C - With Jeff Ator's fix on 1/30/97, don't need this anymore
+
1983 cdak HGT0 = HGT
+
1984 cdak IF(MOD(NINT(HGT),300).EQ.0.OR.MOD(NINT(HGT),500).EQ.0)
+
1985 cdak $ HGT = HGT * 1.016
+
1986 
+
1987 C ALL WINDS-BY-HEIGHT HEIGHTS ARE TRUNCATED DOWN TO THE NEXT
+
1988 C 10 METER LEVEL IF PART DD (ABOVE 100 MB LEVEL) (ON29 CONVENTION)
+
1989 C -----------------------------------------------------------------
+
1990 
+
1991  IF(hgt.GT.z100) THEN
+
1992  IF(mod(nint(hgt),10).NE.0) hgt = int(hgt/10.) * 10
+
1993  e34o29 = nint(hgt)
+
1994  ELSE
+
1995 C - With Jeff Ator's fix on 1/30/97, don't need this anymore
+
1996 cdak IF(HGT.NE.HGT0) THEN
+
1997 cdak IF(MOD(NINT(HGT0),1500).EQ.0) HGT = HGT - 1.0
+
1998 cdak ELSE
+
1999  IF(mod(nint(hgt/1.016),1500).EQ.0) hgt = nint(hgt - 1.0)
+
2000 cdak END IF
+
2001  e34o29 = int(hgt)
+
2002  END IF
+
2003  RETURN
+
2004  entry e38o29(hvz)
+
2005  IF(hvz.GE.bmiss.OR.hvz.LT.0.) THEN
+
2006  e38o29 = bmiss
+
2007  ELSE IF(nint(hvz).LT.1000) THEN
+
2008  kk = min(int(nint(hvz)/10),99)
+
2009  e38o29 = kkk(kk)
+
2010  ELSE IF(nint(hvz).LT.50000) THEN
+
2011  kk = min(int(nint(hvz)/1000),49)
+
2012  e38o29 = kkkk(kk)
+
2013  ELSE
+
2014  e38o29 = 99
+
2015  END IF
+
2016  RETURN
+
2017  END
+
2018 C***********************************************************************
+
2019 C***********************************************************************
+
2020 C***********************************************************************
+
2021  FUNCTION c02o29()
+
2022 C ---> formerly FUNCTION ONCHR
+
2023  CHARACTER*8 c02o29,e35o29,e36o29
+
2024  CHARACTER*1 cprt(0:11),cmr29(0:15)
+
2025 
+
2026  SAVE
+
2027 
+
2028 C (NOTE: Prior to mid-March 1999, a purge or reject flag on pressure
+
2029 C was set to 6 (instead of 14 or 12, resp.) to get around the
+
2030 C 3-bit limit to ON29 pressure q.m. mnemonic "QMPR". The 3-bit
+
2031 C limit on "QMPR" was changed to 4-bits with a decoder change
+
2032 C in February 1999. However, the codes that write the q.m.'s
+
2033 C out (EDTBUFR and QUIPC) were not changed to write out 14 or
+
2034 C 12 for purge or reject until mid-March 1999. In order to
+
2035 C allow old runs to work properly, a q.m. of 6 will continue
+
2036 C to be interpreted as a "P". This would have to change if
+
2037 C q.m.=6 ever has a defined meaning.)
+
2038 
+
2039 C Code Table Value: 0 1 2 3 4 5 6 7
+
2040 
+
2041  DATA cmr29 /'H','A',' ','Q','C','F','P','F',
+
2042 
+
2043 C Code Table Value: 8 9 10 11 12 13 14 15
+
2044 
+
2045  . 'F','F','O','B','R','F','P','F'/
+
2046 
+
2047  DATA cprt /' ',' ',' ',' ','A','B','C','D','I','J','K','L'/
+
2048 
+
2049  c02o29 = ' '
+
2050  RETURN
+
2051  entry e35o29(qmk)
+
2052 C ---> formerly ENTRY ONQMK
+
2053  IF(qmk.GE.0 .AND. qmk.LE.15) e35o29 = cmr29(nint(qmk))
+
2054  IF(qmk.LT.0 .OR. qmk.GT.15) e35o29 = ' '
+
2055  RETURN
+
2056  entry e36o29(nprt)
+
2057 C ---> formerly ENTRY ONPRT
+
2058  e36o29 = ' '
+
2059  IF(nprt.LT.12) e36o29 = cprt(nprt)//' '
+
2060  RETURN
+
2061  END
+
2062 C***********************************************************************
+
2063 C***********************************************************************
+
2064 C***********************************************************************
+
2065  FUNCTION l01o29()
+
2066 C ---> formerly FUNCTION ONLOG
+
2067  CHARACTER*8 rpid
+
2068  LOGICAL l01o29,l02o29,l03o29
+
2069 
+
2070  SAVE
+
2071 
+
2072  l01o29 = .true.
+
2073 
+
2074  RETURN
+
2075 
+
2076  entry l02o29(rpid)
+
2077 C ---> formerly ENTRY ONBKS
+
2078  l02o29 = .false.
+
2079  READ(rpid,'(I5)',err=1) ibks
+
2080  l02o29 = .true.
+
2081 1 RETURN
+
2082  entry l03o29(rpid)
+
2083 C ---> formerly ENTRY ONCAL
+
2084  l03o29 = .true.
+
2085  READ(rpid,'(I5)',err=2) ibks
+
2086  l03o29 = .false.
+
2087 2 RETURN
+
2088  END
+
2089 C***********************************************************************
+
2090 C***********************************************************************
+
2091 C***********************************************************************
+
2092  FUNCTION r03o29(LUNIT,OBS)
+
2093 C ---> formerly FUNCTION ADPUPA
+
2094 
+
2095  common/io29dd/hdr(12),rcats(50,150,11),ikat(11),mcat(11),ncat(11)
+
2096  common/io29ee/pob(255),qob(255),tob(255),zob(255),dob(255),
+
2097  $ sob(255),vsg(255),clp(255),cla(255),ob8(255),
+
2098  $ cf8(255)
+
2099  common/io29ff/pqm(255),qqm(255),tqm(255),zqm(255),wqm(255),
+
2100  $ qcp(255),qca(255),q81(255),q82(255)
+
2101  common/io29cc/subset,idat10
+
2102  common/io29bb/kndx,kskacf(8),kskupa,ksksfc,ksksat,ksksmi
+
2103  common/io29ii/pwmin
+
2104  common/io29ll/bmiss
+
2105 
+
2106  CHARACTER*80 hdstr,lvstr,qmstr,rcstr
+
2107  CHARACTER*8 subset,sid,e35o29,e36o29,rsv,rsv2
+
2108  CHARACTER*1 pqm,qqm,tqm,zqm,wqm,qcp,qca,q81,q82,pqml
+
2109  REAL(8) rid_8,hdr_8(12),vsg_8(255)
+
2110  REAL(8) rct_8(5,255),arr_8(10,255)
+
2111  REAL(8) rat_8(255),rmore_8(4),rgp10_8(255),rpmsl_8,rpsal_8
+
2112  REAL(8) bmiss
+
2113  INTEGER ihblcs(0:9)
+
2114  dimension obs(*),rct(5,255),arr(10,255)
+
2115  dimension rat(255),rmore(4),rgp10(255)
+
2116  dimension p2(255),p8(255),p16(255)
+
2117 
+
2118  equivalence(rid_8,sid)
+
2119  LOGICAL l02o29
+
2120 
+
2121  SAVE
+
2122 
+
2123  DATA hdstr/'NULL CLON CLAT HOUR MINU SELV '/
+
2124  DATA lvstr/'PRLC TMDP TMDB GP07 GP10 WDIR WSPD '/
+
2125  DATA qmstr/'QMPR QMAT QMDD QMGP QMWN '/
+
2126  DATA rcstr/'RCHR RCMI RCTS '/
+
2127 
+
2128  DATA ihblcs/25,75,150,250,450,800,1250,1750,2250,2500/
+
2129 
+
2130  prs1(z) = 1013.25 * (((288.15 - (.0065 * z))/288.15)**5.256)
+
2131  prs2(z) = 226.3 * exp(1.576106e-4 * (11000. - z))
+
2132 
+
2133 C CHECK IF THIS IS A PREPBUFR FILE
+
2134 C --------------------------------
+
2135 
+
2136  r03o29 = 99
+
2137 c#V#V#dak - future
+
2138 cdak IF(SUBSET.EQ.'ADPUPA') R03O29 = PRPUPA(LUNIT,OBS)
+
2139 caaaaadak - future
+
2140  IF(r03o29.NE.99) RETURN
+
2141  r03o29 = 0
+
2142 
+
2143  CALL s05o29
+
2144 
+
2145 C VERTICAL SIGNIFICANCE DESCRIPTOR TO ASSIGN ON29 CATEGORY
+
2146 C --------------------------------------------------------
+
2147 
+
2148 C NOTE: MNEMONIC "VSIG" 008001 IS DEFINED AS VERTICAL SOUNDING
+
2149 C SIGNIFICANCE -- CODE TABLE FOLLOWS:
+
2150 C 64 Surface
+
2151 C processed as ON29 category 2 and/or 3 and/or 4
+
2152 C 32 Standard (mandatory) level
+
2153 C processed as ON29 category 1
+
2154 C 16 Tropopause level
+
2155 C processed as ON29 category 5
+
2156 C 8 Maximum wind level
+
2157 C processed as ON29 category 3 or 4
+
2158 C 4 Significant level, temperature
+
2159 C processed as ON29 category 2
+
2160 C 2 Significant level, wind
+
2161 C processed as ON29 category 3 or 4
+
2162 C 1 ???????????????????????
+
2163 C processed as ON29 category 6
+
2164 C
+
2165 C anything else - the level is not processed
+
2166 
+
2167  CALL ufbint(lunit,vsg_8,1,255,nlev,'VSIG');vsg=vsg_8
+
2168 
+
2169 C PUT THE HEADER INFORMATION INTO ON29 FORMAT
+
2170 C -------------------------------------------
+
2171 
+
2172  CALL ufbint(lunit,hdr_8,12, 1,iret,hdstr);hdr(2:)=hdr_8(2:)
+
2173  IF(hdr(5).GE.bmiss) hdr(5) = 0
+
2174  CALL ufbint(lunit,rid_8,1,1,iret,'RPID')
+
2175  IF(iret.NE.1) sid = 'MISSING '
+
2176 cppppp-ID
+
2177  iprint = 0
+
2178 c if(sid.eq.'59758 ') iprint = 1
+
2179 c if(sid.eq.'61094 ') iprint = 1
+
2180 c if(sid.eq.'62414 ') iprint = 1
+
2181 c if(sid.eq.'59362 ') iprint = 1
+
2182 c if(sid.eq.'57957 ') iprint = 1
+
2183 c if(sid.eq.'74794 ') iprint = 1
+
2184 c if(sid.eq.'74389 ') iprint = 1
+
2185 c if(sid.eq.'96801A ') iprint = 1
+
2186  if(iprint.eq.1)
+
2187  $ print'(" @@@ START DIAGNOSTIC PRINTOUT FOR ID ",A)', sid
+
2188 cppppp-ID
+
2189 
+
2190  irecco = 0
+
2191  CALL ufbint(lunit,rpmsl_8,1, 1,iret,'PMSL');rpmsl=rpmsl_8
+
2192  IF(subset.EQ.'NC004005') THEN
+
2193  CALL ufbint(lunit,rgp10_8,1,255,nlev,'GP10');rgp10=rgp10_8
+
2194  CALL ufbint(lunit,rpsal_8,1,1,iret,'PSAL');rpsal=rpsal_8
+
2195  IF(nint(vsg(1)).EQ.32.AND.rpmsl.GE.bmiss.AND.
+
2196  $ max(rgp10(1),rpsal).LT.bmiss) THEN
+
2197 cppppp
+
2198 cdak print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 1 type ",
+
2199 cdak $ "Flight-level RECCO")', sid
+
2200 cppppp
+
2201  irecco = 1
+
2202  ELSE IF(min(vsg(1),rpmsl,rgp10(1)).GE.bmiss.AND.rpsal.LT.
+
2203  $ bmiss)
+
2204  $ THEN
+
2205 cppppp
+
2206 cdak print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 6 type ",
+
2207 cdak $ "Flight-level RECCO (but reformatted into cat. 2/3)")', sid
+
2208 cppppp
+
2209  irecco = 6
+
2210  ELSE IF(min(vsg(1),rgp10(1)).GE.bmiss.AND.max(rpmsl,rpsal)
+
2211  $ .LT.bmiss) THEN
+
2212 cppppp
+
2213 cdak print'(" ~~IW3UNP29/R03O29: ID ",A," is a Cat. 2/3 type ",
+
2214 cdak $ "Flight-level RECCO with valid PMSL")', sid
+
2215 cppppp
+
2216  irecco = 23
+
2217  ELSE
+
2218 cppppp
+
2219  print'(" ~~IW3UNP29/R03O29: ID ",A," is currently an ",
+
2220  $ "unknown type of Flight-level RECCO - VSIG =",G0,
+
2221  $ "; PMSL =",G0,"; GP10 =",G0," -- SKIP IT for now")',
+
2222  $ sid,vsg(1),rpmsl,rgp10(1)
+
2223  r03o29 = -9999
+
2224  kskupa =kskupa + 1
+
2225  RETURN
+
2226 cppppp
+
2227  END IF
+
2228  END IF
+
2229 
+
2230  xob = hdr(2)
+
2231  yob = hdr(3)
+
2232  rhr = bmiss
+
2233  IF(hdr(4).LT.bmiss) rhr = nint(hdr(4))+nint(hdr(5))/60.
+
2234  rch = bmiss
+
2235  rsv = '999 '
+
2236  elv = hdr(6)
+
2237  IF(irecco.GT.0) THEN
+
2238  rpsal = rpsal + sign(0.0000001,rpsal)
+
2239  elv = rpsal
+
2240  END IF
+
2241 
+
2242  CALL ufbint(lunit,rat_8, 1,255,nlev,'RATP');rat=rat_8
+
2243  itp = min(99,nint(rat(1)))
+
2244  rtp = e33o29(subset,sid)
+
2245  IF(elv.GE.bmiss) THEN
+
2246 cppppp
+
2247  print'(" IW3UNP29/R03O29: ID ",A," has a missing elev, so ",
+
2248  $ "elevation set to ZERO")', sid
+
2249 cppppp
+
2250  IF((rtp.GT.20.AND.rtp.LT.24).OR.subset.EQ.'NC002004') elv = 0
+
2251  END IF
+
2252 cdak if(sid(5:5).eq.' ') print'(A)', sid
+
2253  IF(l02o29(sid).AND.sid(5:5).EQ.' ') sid = '0'//sid
+
2254  rsv2 = ' '
+
2255  CALL s01o29(sid,xob,yob,rhr,rch,rsv,rsv2,elv,itp,rtp)
+
2256 
+
2257 C PUT THE LEVEL DATA INTO ON29 UNITS
+
2258 C ----------------------------------
+
2259 
+
2260  CALL ufbint(lunit,arr_8,10,255,nlev,lvstr);arr=arr_8
+
2261 
+
2262  pwmin = 999999.
+
2263  jlv = 2
+
2264  IF(irecco.EQ.6) jlv = 1
+
2265  IF(irecco.GT.0.AND.nlev.EQ.1) THEN
+
2266  vsg(jlv) = 4
+
2267  vsg(jlv+1) = 2
+
2268  qob(jlv) = e07o29(arr(2,1),arr(3,1))
+
2269  tob(jlv) = e06o29(arr(3,1))
+
2270  arr(2,1) = bmiss
+
2271  arr(3,1) = bmiss
+
2272  dob(jlv+1) = e04o29(arr(6,1),arr(7,1))
+
2273  sob(jlv+1) = e05o29(arr(6,1),arr(7,1))
+
2274  IF(nint(dob(jlv+1)).EQ.0.AND.nint(sob(jlv+1)).GT.0)
+
2275  $ dob(jlv+1) = 360.
+
2276  IF(nint(dob(jlv+1)).EQ.360.AND.nint(sob(jlv+1)).EQ.0)
+
2277  $ dob(jlv+1) = 0.
+
2278  arr(6,1) = bmiss
+
2279  arr(7,1) = bmiss
+
2280  IF(irecco.EQ.23) THEN
+
2281  vsg(1) = 64
+
2282  arr(1,1) = rpmsl
+
2283  END IF
+
2284  END IF
+
2285 
+
2286  IF(irecco.EQ.6) GO TO 4523
+
2287 
+
2288  DO l=1,nlev
+
2289  pob(l) = e01o29(arr(1,l))
+
2290  IF(nint(arr(1,l)).LE.0) THEN
+
2291  pob(l) = bmiss
+
2292 cppppp
+
2293  print'(" ~~@@IW3UNP29/R03O29: ID ",A," has a ZERO or ",
+
2294  $ "negative reported pressure that is reset to missing")',
+
2295  $ sid
+
2296 cppppp
+
2297  END IF
+
2298  qob(l) = e07o29(arr(2,l),arr(3,l))
+
2299  tob(l) = e06o29(arr(3,l))
+
2300  zob(l) = min(e08o29(arr(4,l)),e08o29(arr(5,l)))
+
2301 cppppp
+
2302  if(iprint.eq.1) then
+
2303  if(irecco.gt.0) print'(" At lvl=",I0,"; orig. ZOB = ",G0)',
+
2304  $ l,zob(l)
+
2305  end if
+
2306 cppppp
+
2307  IF(irecco.EQ.1) THEN
+
2308  IF(mod(nint(zob(l)),10).NE.0) zob(l) = int(zob(l)/10.) * 10
+
2309  zob(l) = nint(zob(l))
+
2310  ELSEIF(irecco.EQ.23) THEN
+
2311  zob(l) = 0
+
2312  END IF
+
2313  dob(l) = e04o29(arr(6,l),arr(7,l))
+
2314  sob(l) = e05o29(arr(6,l),arr(7,l))
+
2315  IF(nint(dob(l)).EQ.0.AND.nint(sob(l)).GT.0) dob(l) = 360.
+
2316  IF(nint(dob(l)).EQ.360.AND.nint(sob(l)).EQ.0) dob(l) = 0.
+
2317 cppppp
+
2318  if(iprint.eq.1) then
+
2319  print'(" At lvl=",I0,"; VSG=",G0,"; POB = ",G0,"; QOB = ",G0,
+
2320  $ "; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,"; final SOB ",
+
2321  $ "(kts) = ",G0,"; origl SOB (mps) = ",G0)',
+
2322  $ l,vsg(l),pob(l),qob(l),tob(l),zob(l),dob(l),sob(l),arr(7,l)
+
2323  end if
+
2324 cppppp
+
2325  IF(irecco.EQ.0.AND.max(pob(l),dob(l),sob(l)).LT.bmiss)
+
2326  $ pwmin=min(pwmin,pob(l))
+
2327  ENDDO
+
2328 
+
2329  4523 CONTINUE
+
2330 
+
2331  mlev = nlev
+
2332 
+
2333  CALL ufbint(lunit,arr_8,10,255,nlev,qmstr);arr=arr_8
+
2334 
+
2335  IF(irecco.GT.0.AND.mlev.EQ.1) THEN
+
2336  pob1 = bmiss
+
2337  IF(pob(1).LT.bmiss) pob1 = pob(1) * 0.1
+
2338  tob1 = bmiss
+
2339  IF(tob(jlv).LT.bmiss) tob1 = (tob(jlv) * 0.1) + 273.15
+
2340  rps1 = rpsal
+
2341  zob1 = zob(1)
+
2342  tqm1 = arr(3,1)
+
2343  pob(jlv)=nint(e37o29(pob1,tob1,rps1,zob1,tqm1)) * 10
+
2344  pob(jlv+1) = pob(jlv)
+
2345 cppppp
+
2346  if(iprint.eq.1) then
+
2347  do l=jlv,jlv+1
+
2348  print'(" At lvl=",I0,"; VSG=",G0,"; POB = ",G0,"; QOB = ",
+
2349  $ G0,"; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,"; SOB = ",
+
2350  $ G0)', l,vsg(l),pob(l),qob(l),tob(l),zob(l),dob(l),sob(l)
+
2351  enddo
+
2352  end if
+
2353 cppppp
+
2354  END IF
+
2355 
+
2356  IF(irecco.GT.0.AND.nlev.EQ.1) THEN
+
2357  pqm(jlv) = 'E'
+
2358  pqm(jlv+1) = 'E'
+
2359  tqm(jlv) = e35o29(arr(2,1))
+
2360  arr(2,1) = bmiss
+
2361  qqm(jlv) = e35o29(arr(3,1))
+
2362  arr(3,1) = bmiss
+
2363  arr(4,1) = 3
+
2364  wqm(jlv+1) = e35o29(arr(5,1))
+
2365  arr(5,1) = bmiss
+
2366  END IF
+
2367 
+
2368  IF(irecco.EQ.6) GO TO 4524
+
2369 
+
2370  DO l=1,nlev
+
2371  pqm(l) = e35o29(arr(1,l))
+
2372  tqm(l) = e35o29(arr(2,l))
+
2373  qqm(l) = e35o29(arr(3,l))
+
2374  zqm(l) = e35o29(arr(4,l))
+
2375  wqm(l) = e35o29(arr(5,l))
+
2376  ENDDO
+
2377 
+
2378  4524 CONTINUE
+
2379 
+
2380  IF(irecco.GT.0.AND.nlev.EQ.1) nlev = jlv + 1
+
2381 
+
2382 C SURFACE DATA MUST GO FIRST
+
2383 C --------------------------
+
2384 
+
2385  CALL s02o29(2,0,*9999)
+
2386  CALL s02o29(3,0,*9999)
+
2387  CALL s02o29(4,0,*9999)
+
2388 
+
2389  indx2 = 0
+
2390  indx8 = 0
+
2391  indx16 = 0
+
2392  p2 = bmiss
+
2393  p8 = bmiss
+
2394  p16 = bmiss
+
2395 
+
2396  DO l=1,nlev
+
2397  IF(nint(vsg(l)).EQ.64) THEN
+
2398 cppppp
+
2399  if(iprint.eq.1) then
+
2400  print'(" Lvl=",L," is a surface level")'
+
2401  end if
+
2402  if(iprint.eq.1.and.pob(l).LT.bmiss.AND.(tob(l).LT.bmiss.OR.irecco
+
2403  $ .EQ.23)) then
+
2404  print'(" --> valid cat. 2 sfc. lvl ")'
+
2405  end if
+
2406 cppppp
+
2407  IF(pob(l).LT.bmiss.AND.(tob(l).LT.bmiss.OR.irecco.EQ.23))
+
2408  $ CALL se01o29(2,l)
+
2409 cppppp
+
2410  if(iprint.eq.1.and.pob(l).LT.bmiss.AND.(dob(l).LT.bmiss.OR.irecco
+
2411  $ .EQ.23)) then
+
2412  print'(" --> valid cat. 3 sfc. lvl ")'
+
2413  end if
+
2414 cppppp
+
2415  IF(pob(l).LT.bmiss.AND.(dob(l).LT.bmiss.OR.irecco.EQ.23))
+
2416  $ CALL se01o29(3,l)
+
2417  IF(zob(l).LT.bmiss.AND.dob(l).LT.bmiss) THEN
+
2418 cppppp
+
2419  if(iprint.eq.1) print'(" --> valid cat. 4 sfc. lvl ")'
+
2420 cppppp
+
2421 
+
2422 C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M.
+
2423 C -----------------------------------------------------------------
+
2424 
+
2425  zqm(l) = ' '
+
2426  CALL se01o29(4,l)
+
2427  END IF
+
2428  vsg(l) = 0
+
2429  ELSE IF(nint(vsg(l)).EQ.2) THEN
+
2430  p2(l) = pob(l)
+
2431  indx2 = l
+
2432  IF(indx8.GT.0) THEN
+
2433  DO ii = 1,indx8
+
2434  IF(pob(l).EQ.p8(ii).AND.pob(l).LT.bmiss) THEN
+
2435 cppppp
+
2436  if(iprint.eq.1) then
+
2437  print'(" ## This cat. 3 level, on lvl ",I0,
+
2438  $ " will have already been processed as a cat. 3 ",
+
2439  $ "MAX wind lvl (on lvl ",I0,") - skip this Cat. ",
+
2440  $ "3 lvl")', l,ii
+
2441  end if
+
2442 cppppp
+
2443  IF(max(sob(ii),dob(ii)).GE.bmiss) THEN
+
2444  sob(ii) = sob(l)
+
2445  dob(ii) = dob(l)
+
2446 cppppp
+
2447  if(iprint.eq.1) then
+
2448  print'(" ...... also on lvl ",I0," - transfer",
+
2449  $ " wind data to dupl. MAX wind lvl because its ",
+
2450  $ "missing there")', l
+
2451  end if
+
2452 cppppp
+
2453  END IF
+
2454  vsg(l) = 0
+
2455  GO TO 7732
+
2456  END IF
+
2457  ENDDO
+
2458  END IF
+
2459  ELSE IF(nint(vsg(l)).EQ.8) THEN
+
2460  p8(l) = pob(l)
+
2461  indx8 = l
+
2462  IF(indx2.GT.0) THEN
+
2463  DO ii = 1,indx2
+
2464  IF(pob(l).EQ.p2(ii).AND.pob(l).LT.bmiss) THEN
+
2465 cppppp
+
2466  if(iprint.eq.1) then
+
2467  print'(" ## This MAX wind level, on lvl ",I0,
+
2468  $ " will have already been processed as a cat. 3 ",
+
2469  $ "lvl (on lvl ",I0,") - skip this MAX wind lvl ",
+
2470  $ "but set"/6X,"cat. 3 lvl PQM to ""W""")', l,ii
+
2471  end if
+
2472 cppppp
+
2473  pqm(ii) = 'W'
+
2474  IF(pob(l).EQ.pwmin) pqm(ii) = 'X'
+
2475  IF(max(sob(ii),dob(ii)).GE.bmiss) THEN
+
2476  sob(ii) = sob(l)
+
2477  dob(ii) = dob(l)
+
2478 cppppp
+
2479  if(iprint.eq.1) then
+
2480  print'(" ...... also on lvl ",I0," - transfer",
+
2481  $ " wind data to dupl. cat. 3 lvl because its ",
+
2482  $ "missing there")', l
+
2483  end if
+
2484 cppppp
+
2485  END IF
+
2486  vsg(l) = 0
+
2487  GO TO 7732
+
2488  END IF
+
2489  ENDDO
+
2490  END IF
+
2491  IF(indx8-1.GT.0) THEN
+
2492  DO ii = 1,indx8-1
+
2493  IF(pob(l).EQ.p8(ii).AND.pob(l).LT.bmiss) THEN
+
2494 cppppp
+
2495  if(iprint.eq.1) then
+
2496  print'(" ## This cat. 3 MAX wind lvl, on lvl ",I0,
+
2497  $ " will have already been processed as a cat. 3 ",
+
2498  $ "MAX wind lvl (on lvl ",I0,") - skip this Cat. ",
+
2499  $ "3 MAX wind lvl")', l,ii
+
2500  end if
+
2501 cppppp
+
2502  IF(max(sob(ii),dob(ii)).GE.bmiss) THEN
+
2503  sob(ii) = sob(l)
+
2504  dob(ii) = dob(l)
+
2505 cppppp
+
2506  if(iprint.eq.1) then
+
2507  print'(" ...... also on lvl ",I0," - transfer",
+
2508  $ " wind data to dupl. MAX wind lvl because its ",
+
2509  $ "missing there")', l
+
2510  end if
+
2511 cppppp
+
2512  END IF
+
2513  vsg(l) = 0
+
2514  GO TO 7732
+
2515  END IF
+
2516  ENDDO
+
2517  END IF
+
2518  ELSE IF(nint(vsg(l)).EQ.16) THEN
+
2519  indx16 = indx16 + 1
+
2520  p16(indx16) = pob(l)
+
2521  END IF
+
2522  7732 CONTINUE
+
2523  ENDDO
+
2524 
+
2525 C TAKE CARE OF 925 MB NEXT
+
2526 C ------------------------
+
2527 
+
2528  DO l=1,nlev
+
2529  IF(nint(vsg(l)).EQ.32 .AND. nint(pob(l)).EQ.9250) THEN
+
2530  cf8(l) = 925
+
2531  ob8(l) = zob(l)
+
2532  q81(l) = ' '
+
2533  q82(l) = ' '
+
2534  IF(tob(l).LT.bmiss) CALL s02o29(2,l,*9999)
+
2535  IF(dob(l).LT.bmiss) CALL s02o29(3,l,*9999)
+
2536  IF(ob8(l).LT.bmiss) CALL s02o29(8,l,*9999)
+
2537  vsg(l) = 0
+
2538  END IF
+
2539  ENDDO
+
2540 
+
2541 C REST OF THE DATA
+
2542 C ----------------
+
2543 
+
2544  z100 = 16000
+
2545  DO l=1,nlev
+
2546  IF(nint(vsg(l)).EQ.32) THEN
+
2547  IF(min(dob(l),zob(l),tob(l)).GE.bmiss) THEN
+
2548 cppppp
+
2549  if(iprint.eq.1) then
+
2550  print'(" ==> For lvl ",I0,"; VSG=32 & DOB,ZOB,TOB all ",
+
2551  $ "missing --> this level not processed")', l
+
2552  end if
+
2553  vsg(l) = 0
+
2554  ELSE IF(min(zob(l),tob(l)).LT.bmiss) THEN
+
2555 cppppp
+
2556  if(iprint.eq.1) then
+
2557  print'(" ==> For lvl ",I0,"; VSG=32 & one or both of ",
+
2558  $ "ZOB,TOB non-missing --> valid cat. 1 lvl")', l
+
2559  end if
+
2560 cppppp
+
2561  CALL s02o29(1,l,*9999)
+
2562  IF(nint(pob(l)).EQ.1000.AND.zob(l).LT.bmiss) z100 = zob(l)
+
2563  vsg(l) = 0
+
2564  END IF
+
2565  END IF
+
2566  ENDDO
+
2567  DO l=1,nlev
+
2568  IF(nint(vsg(l)).EQ.32) THEN
+
2569  IF(dob(l).LT.bmiss.AND.min(zob(l),tob(l)).GE.bmiss) THEN
+
2570  ll = i04o29(pob(l)*.1)
+
2571  IF(ll.EQ.999999) THEN
+
2572 cppppp
+
2573  print'(" ~~IW3UNP29/R03O29: ID ",A," has VSG=32 for ",
+
2574  $ "lvl ",I0," but pressure not mand.!! --> this level ",
+
2575  $ "not processed")', sid,l
+
2576 cppppp
+
2577  ELSE IF(min(rcats(1,ll,1),rcats(2,ll,1)).LT.99999.) THEN
+
2578  IF(rcats(4,ll,1).GE.99998.) THEN
+
2579 cppppp
+
2580  if(iprint.eq.1) then
+
2581  print'(" ==> For lvl ",I0,"; VSG=32 & ZOB,TOB ",
+
2582  $ "both missing while DOB non-missing BUT one or ",
+
2583  $ "both of Z, T non-missing while wind missing ",
+
2584  $ "in"/7X,"earlier cat. 1 processing of this ",G0,
+
2585  $ "mb level --> valid cat. 1 lvl")', l,pob(l)*.1
+
2586  end if
+
2587 cppppp
+
2588  CALL s02o29(1,l,*9999)
+
2589  ELSE
+
2590 cppppp
+
2591  if(iprint.eq.1) then
+
2592  print'(" ==> For lvl ",I0,"; VSG=32 & ZOB,TOB ",
+
2593  $ "both missing while DOB non-missing BUT one or ",
+
2594  $ "both of Z, T non-missing while wind non-missing",
+
2595  $ " in"/6X,"earlier cat. 1 processing of this ",G0,
+
2596  $ "mb level --> valid cat. 3 lvl")', l,pob(l)*.1
+
2597  end if
+
2598 cppppp
+
2599  CALL s02o29(3,l,*9999)
+
2600  END IF
+
2601  ELSE
+
2602 cppppp
+
2603  if(iprint.eq.1) then
+
2604  print'(" ==> For lvl ",I0,"; VSG=32 & ZOB,TOB both ",
+
2605  $ "missing while DOB non-missing AND both Z, T ",
+
2606  $ "missing on"/7X,"this ",G0,"mb level in cat. 1 --> ",
+
2607  $ "valid cat. 3 lvl")', l,pob(l)*.1
+
2608  end if
+
2609 cppppp
+
2610  CALL s02o29(3,l,*9999)
+
2611  END IF
+
2612  ELSE
+
2613 cppppp
+
2614  print'(" ~~IW3UNP29/R03O29: ID ",A," has VSG=32 for lvl ",
+
2615  $ I0," & should never come here!! - by default output",
+
2616  $ " as cat. 1 lvl")', sid,l
+
2617 cppppp
+
2618  CALL s02o29(1,l,*9999)
+
2619  END IF
+
2620  vsg(l) = 0
+
2621  END IF
+
2622  ENDDO
+
2623 
+
2624  DO l=1,nlev
+
2625  IF(nint(vsg(l)).EQ. 4) THEN
+
2626 cppppp
+
2627  if(iprint.eq.1) then
+
2628  print'(" ==> For lvl ",I0,"; VSG= 4 --> valid cat. 2 ",
+
2629  $ "lvl")', l
+
2630  end if
+
2631 cppppp
+
2632  IF(indx16.GT.0) THEN
+
2633  DO ii = 1,indx16
+
2634  IF(pob(l).EQ.p16(ii).AND.pob(l).LT.bmiss) THEN
+
2635 cppppp
+
2636  if(iprint.eq.1) then
+
2637  print'(" ## This cat. 2 level, on lvl ",I0," is",
+
2638  $ " also the tropopause level, as its pressure ",
+
2639  $ "matches that of trop. lvl no. ",I0," - ",
+
2640  $ "set this cat. 2"/5X,"lvl PQM to ""T""")', l,ii
+
2641  end if
+
2642 cppppp
+
2643  pqm(l) = 'T'
+
2644  GO TO 7738
+
2645  END IF
+
2646  ENDDO
+
2647  END IF
+
2648  7738 CONTINUE
+
2649  CALL s02o29(2,l,*9999)
+
2650  vsg(l) = 0
+
2651  ELSEIF(nint(vsg(l)).EQ.16) THEN
+
2652 cppppp
+
2653  if(iprint.eq.1) then
+
2654  print'(" ==> For lvl ",I0,"; VSG=16 --> valid cat. 3/5 ",
+
2655  $ "lvl")', l
+
2656  end if
+
2657 cppppp
+
2658  pqml = pqm(l)
+
2659  IF(min(sob(l),dob(l)).LT.bmiss) CALL s02o29(3,l,*9999)
+
2660  pqm(l) = pqml
+
2661  CALL s02o29(5,l,*9999)
+
2662  vsg(l) = 0
+
2663  ELSEIF(nint(vsg(l)).EQ. 1) THEN
+
2664 cppppp
+
2665  print'(" ~~IW3UNP29/R03O29: HERE IS A VSG =1, SET TO CAT.6, ",
+
2666  $ "AT ID ",A,"; SHOULD NEVER HAPPEN!!")', sid
+
2667 cppppp
+
2668  CALL s02o29(6,l,*9999)
+
2669  vsg(l) = 0
+
2670  ELSEIF(nint(vsg(l)).EQ. 2 .AND. pob(l).LT.bmiss) THEN
+
2671  IF(max(sob(l),dob(l)).LT.bmiss) THEN
+
2672 cppppp
+
2673  if(iprint.eq.1) then
+
2674  print.ne.'(" ==> For lvl ",I0,"; VSG= 2 & POB missing ",
+
2675  $ "--> valid cat. 3 lvl (expect that ZOB is missing)")', l
+
2676  end if
+
2677 cppppp
+
2678  CALL s02o29(3,l,*9999)
+
2679  ELSE
+
2680 cppppp
+
2681  if(iprint.eq.1) then
+
2682  print.ne.'(" ==> For lvl ",I0,"; VSG= 2 & POB missing ",
+
2683  $ "--> Cat. 3 level not processed - wind is missing")', l
+
2684  end if
+
2685 cppppp
+
2686  END IF
+
2687  vsg(l) = 0
+
2688  ELSEIF(nint(vsg(l)).EQ. 2 .AND. zob(l).LT.bmiss) THEN
+
2689  IF(max(sob(l),dob(l)).LT.bmiss) THEN
+
2690 
+
2691 C CERTAIN U.S. WINDS-BY-HEIGHT ARE CORRECTED TO ON29 CONVENTION
+
2692 C -------------------------------------------------------------
+
2693 
+
2694  IF(sid(1:2).EQ.'70'.OR.sid(1:2).EQ.'71'.OR.sid(1:2).EQ.'72'
+
2695  $ .OR.sid(1:2).EQ.'74') zob(l) = e34o29(zob(l),z100)
+
2696 cppppp
+
2697  if(iprint.eq.1) then
+
2698  print.ne.'(" ==> For lvl ",I0,"; VSG= 2 & ZOB missing ",
+
2699  $ "--> valid cat. 4 lvl (POB must always be missing)")', l
+
2700  if(sid(1:2).eq.'70'.or.sid(1:2).eq.'71'.or.sid(1:2).eq.'72'
+
2701  $ .or.sid(1:2).eq.'74') print'(" .... ZOB at this ",
+
2702  $ "U.S. site adjusted to ",G0)', zob(l)
+
2703  end if
+
2704 cppppp
+
2705 
+
2706 C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M.
+
2707 C -----------------------------------------------------------------
+
2708 
+
2709  zqm(l) = ' '
+
2710 
+
2711  CALL s02o29(4,l,*9999)
+
2712  ELSE
+
2713 cppppp
+
2714  if(iprint.eq.1) then
+
2715  print.ne.'(" ==> For lvl ",I0,"; VSG= 2 & ZOB missing ",
+
2716  $ "--> Cat. 4 level not processed - wind is missing")', l
+
2717  end if
+
2718 cppppp
+
2719  END IF
+
2720  vsg(l) = 0
+
2721  ELSEIF(nint(vsg(l)).EQ. 8 .AND. pob(l).LT.bmiss) THEN
+
2722 cppppp
+
2723  if(iprint.eq.1) then
+
2724  print.ne.'(" ==> For lvl ",I0,"; VSG= 8 & POB missing ",
+
2725  $ "--> valid cat. 3 lvl (expect that ZOB is missing)")', l
+
2726  end if
+
2727 cppppp
+
2728  CALL s02o29(3,l,*9999)
+
2729  vsg(l) = 0
+
2730  ELSEIF(nint(vsg(l)).EQ. 8 .AND. zob(l).LT.bmiss) THEN
+
2731  IF(max(sob(l),dob(l)).LT.bmiss) THEN
+
2732 
+
2733 C CERTAIN U.S. WINDS-BY-HEIGHT ARE CORRECTED TO ON29 CONVENTION
+
2734 C -------------------------------------------------------------
+
2735 
+
2736  IF(sid(1:2).EQ.'70'.OR.sid(1:2).EQ.'71'.OR.sid(1:2).EQ.'72'
+
2737  $ .OR.sid(1:2).EQ.'74') zob(l) = e34o29(zob(l),z100)
+
2738 cppppp
+
2739  if(iprint.eq.1) then
+
2740  print.ne.'(" ==> For lvl ",I0,"; VSG= 8 & ZOB missing ",
+
2741  $ "--> valid cat. 4 lvl (POB must always be missing)")', l
+
2742  if(sid(1:2).eq.'70'.or.sid(1:2).eq.'71'.or.sid(1:2).eq.'72'
+
2743  $ .or.sid(1:2).eq.'74') print'(" .... ZOB at this ",
+
2744  $ "U.S. site adjusted to ",G0)', zob(l)
+
2745  end if
+
2746 cppppp
+
2747 
+
2748 C CAT. 4 HEIGHT DOES NOT PASS ON A KEEP, PURGE, OR REJECT LIST Q.M.
+
2749 C -----------------------------------------------------------------
+
2750 
+
2751  zqm(l) = ' '
+
2752 
+
2753  CALL s02o29(4,l,*9999)
+
2754  ELSE
+
2755 cppppp
+
2756  if(iprint.eq.1) then
+
2757  print.ne.'(" ==> For lvl ",I0,"; VSG= 8 & ZOB missing ",
+
2758  $ "--> Cat. 4 level not processed - wind is missing")', l
+
2759  end if
+
2760 cppppp
+
2761  END IF
+
2762  vsg(l) = 0
+
2763  END IF
+
2764  ENDDO
+
2765 
+
2766 C CHECK FOR LEVELS WHICH GOT LEFT OUT
+
2767 C -----------------------------------
+
2768 
+
2769  DO l=1,nlev
+
2770  IF(nint(vsg(l)).GT.0) THEN
+
2771  print 887, l,sid,nint(vsg(l))
+
2772  887 FORMAT(' ##IW3UNP29/R03O29 - ~~ON LVL',i4,' OF ID ',a8,', A ',
+
2773  $ 'VERTICAL SIGNIFICANCE OF',i3,' WAS NOT SUPPORTED - LEAVE ',
+
2774  $ 'THIS LEVEL OUT OF THE PROCESSING')
+
2775  print'(" ..... at lvl=",I0,"; POB = ",G0,"; QOB = ",G0,
+
2776  $ "; TOB = ",G0,"; ZOB = ",G0,"; DOB = ",G0,";"/19X,"SOB = ",
+
2777  $ G0)', pob(l),qob(l),tob(l),zob(l),dob(l),sob(l)
+
2778  END IF
+
2779  ENDDO
+
2780 
+
2781 C CLOUD DATA GOES INTO CATEGORY 07
+
2782 C --------------------------------
+
2783 
+
2784  CALL ufbint(lunit,arr_8,10,255,nlev,'HOCB CLAM QMCA HBLCS')
+
2785  arr=arr_8
+
2786  DO l=1,nlev
+
2787  IF(arr(1,l).LT.bmiss/2.) THEN
+
2788  ! Prior to 3/2002 HBLCS was not available, this will
+
2789  ! always be tested first because it is more precise
+
2790  ! in theory but will now be missing after 3/2002
+
2791  IF(elv+arr(1,l).GE.bmiss/2.) THEN
+
2792  clp(l) = bmiss
+
2793  ELSE IF(elv+arr(1,l).LE.11000) THEN
+
2794  clp(l) = (prs1(elv+arr(1,l))*10.) + 0.001
+
2795  ELSE
+
2796  clp(l) = (prs2(elv+arr(1,l))*10.) + 0.001
+
2797  END IF
+
2798  ELSE
+
2799  ! Effective 3/2002 only this will be available
+
2800  IF(nint(arr(4,l)).GE.10) THEN
+
2801  clp(l) = bmiss
+
2802  ELSE
+
2803  IF(elv+ihblcs(nint(arr(4,l))).GE.bmiss/2.) THEN
+
2804  clp(l) = bmiss
+
2805  ELSE IF(elv+ihblcs(nint(arr(4,l))).LE.11000) THEN
+
2806  clp(l) = (prs1(elv+ihblcs(nint(arr(4,l))))*10.) +0.001
+
2807  ELSE
+
2808  clp(l) = (prs2(elv+ihblcs(nint(arr(4,l))))*10.) +0.001
+
2809  END IF
+
2810  END IF
+
2811  END IF
+
2812  cla(l) = e13o29(arr(2,l))
+
2813  qcp(l) = ' '
+
2814  qca(l) = e35o29(arr(3,l))
+
2815  IF(clp(l).LT.bmiss .OR. cla(l).LT.bmiss) CALL s02o29(7,l,*9999)
+
2816  ENDDO
+
2817 
+
2818 C -----------------------------------------------------
+
2819 C MISC DATA GOES INTO CATEGORY 08
+
2820 C -----------------------------------------------------
+
2821 C CODE FIGURE 104 - RELEASE TIME IN .01*HR
+
2822 C CODE FIGURE 105 - RECEIPT TIME IN .01*HR
+
2823 C CODE FIGURE 106 - RADIOSONDE INSTR. TYPE,
+
2824 C SOLAR/IR CORRECTION INDICATOR,
+
2825 C TRACKING TECH/STATUS OF SYSTEM USED
+
2826 C CODE FIGURE 925 - HEIGHT OF 925 LEVEL
+
2827 C -----------------------------------------------------
+
2828 
+
2829  CALL ufbint(lunit,rct_8, 5,255,nrct,rcstr);rct=rct_8
+
2830 
+
2831 C NOTE: MNEMONIC "RCTS" 008202 IS A LOCAL DESCRIPTOR DEFINED AS
+
2832 C RECEIPT TIME SIGNIFICANCE -- CODE TABLE FOLLOWS:
+
2833 C 0 General decoder receipt time
+
2834 C 1 NCEP receipt time
+
2835 C 2 OSO receipt time
+
2836 C 3 ARINC ground station receipt time
+
2837 C 4 Radiosonde TEMP AA part receipt time
+
2838 C 5 Radiosonde TEMP BB part receipt time
+
2839 C 6 Radiosonde TEMP CC part receipt time
+
2840 C 7 Radiosonde TEMP DD part receipt time
+
2841 C 8 Radiosonde PILOT AA part receipt time
+
2842 C 9 Radiosonde PILOT BB part receipt time
+
2843 C 10 Radiosonde PILOT CC part receipt time
+
2844 C 11 Radiosonde PILOT DD part receipt time
+
2845 C 12-62 Reserved for future use
+
2846 C 63 Missing
+
2847 
+
2848  DO l=1,nrct
+
2849  cf8(l) = 105
+
2850  ob8(l) = nint((nint(rct(1,l))+nint(rct(2,l))/60.) * 100.)
+
2851  IF(irecco.GT.0.AND.nint(rct(3,l)).EQ.0) rct(3,l) = 9
+
2852  q81(l) = e36o29(nint(rct(3,l)))
+
2853  q82(l) = ' '
+
2854  CALL s02o29(8,l,*9999)
+
2855  ENDDO
+
2856 
+
2857  CALL ufbint(lunit,rmore_8,4,1,nrmore,'SIRC TTSS UALNHR UALNMN')
+
2858  rmore=rmore_8
+
2859  IF(max(rmore(3),rmore(4)).LT.bmiss) THEN
+
2860  cf8(1) = 104
+
2861  ob8(1) = nint((rmore(3)+rmore(4)/60.) * 100.)
+
2862  q81(1) = ' '
+
2863  q82(1) = ' '
+
2864  CALL s02o29(8,1,*9999)
+
2865  END IF
+
2866  IF(nint(rat(1)).LT.100) THEN
+
2867  cf8(1) = 106
+
2868  isir = 9
+
2869  IF(nint(rmore(1)).LT.9) isir = nint(rmore(1))
+
2870  itec = 99
+
2871  IF(nint(rmore(2)).LT.99) itec = nint(rmore(2))
+
2872  ob8(1) = (isir * 10000) + (nint(rat(1)) * 100) + itec
+
2873  q81(1) = ' '
+
2874  q82(1) = ' '
+
2875  CALL s02o29(8,1,*9999)
+
2876  END IF
+
2877 
+
2878 C PUT THE UNPACKED ON29 REPORT INTO OBS
+
2879 C -------------------------------------
+
2880 
+
2881  CALL s03o29(obs,subset,*9999,*9998)
+
2882 
+
2883  RETURN
+
2884  9999 CONTINUE
+
2885  r03o29 = 999
+
2886  RETURN
+
2887  9998 CONTINUE
+
2888  print'(" IW3UNP29/R03O29: RPT with ID= ",A," TOSSED - ZERO ",
+
2889  $ "CAT.1-6,51,52 LVLS")', sid
+
2890  r03o29 = -9999
+
2891  kskupa =kskupa + 1
+
2892  RETURN
+
2893  END
+
2894 C***********************************************************************
+
2895 C***********************************************************************
+
2896 C***********************************************************************
+
2897  FUNCTION r04o29(LUNIT,OBS)
+
2898 C ---> formerly FUNCTION SURFCE
+
2899 
+
2900  common/io29ee/pob(255),qob(255),tob(255),zob(255),dob(255),
+
2901  $ sob(255),vsg(255),clp(255),cla(255),ob8(255),
+
2902  $ cf8(255)
+
2903  common/io29ff/pqm(255),qqm(255),tqm(255),zqm(255),wqm(255),
+
2904  $ qcp(255),qca(255),q81(255),q82(255)
+
2905  common/io29gg/psl,stp,sdr,ssp,stm,dpd,tmx,tmi,hvz,prw,pw1,ccn,chn,
+
2906  $ ctl,ctm,cth,hcb,cpt,apt,pc6,snd,p24,dop,pow,how,swd,
+
2907  $ swp,swh,sst,spg,spd,shc,sas,wes
+
2908  common/io29hh/psq,spq,swq,stq,ddq
+
2909  common/io29cc/subset,idat10
+
2910  common/io29bb/kndx,kskacf(8),kskupa,ksksfc,ksksat,ksksmi
+
2911  common/io29ll/bmiss
+
2912 
+
2913  CHARACTER*80 hdstr,rcstr
+
2914  CHARACTER*8 subset,sid,e35o29,rsv,rsv2
+
2915  CHARACTER*1 pqm,qqm,tqm,zqm,wqm,qcp,qca,q81,q82,psq,spq,swq,stq,
+
2916  $ ddq
+
2917  REAL(8) rid_8,ufbint_8,bmiss
+
2918  REAL(8) hdr_8(20),rct_8(5,255),rrsv_8(3),clds_8(4,255),
+
2919  $ tmxmnm_8(4,255)
+
2920  INTEGER itiwm(0:15),ihblcs(0:9)
+
2921  dimension obs(*),hdr(20),rct(5,255),rrsv(3),clds(4,255),jth(0:9),
+
2922  $ jtl(0:9),ltl(0:9),tmxmnm(4,255)
+
2923  equivalence(rid_8,sid)
+
2924 
+
2925  SAVE
+
2926 
+
2927  DATA hdstr/'RPID CLON CLAT HOUR MINU SELV AUTO '/
+
2928  DATA rcstr/'RCHR RCMI RCTS '/
+
2929 
+
2930  DATA jth/0,1,2,3,4,5,6,8,7,9/,jtl/0,1,5,8,7,2,3,4,6,9/
+
2931  DATA ltl/0,1,5,6,7,2,8,4,3,9/
+
2932  DATA itiwm/0,3*7,3,3*7,1,3*7,4,3*7/
+
2933  DATA ihblcs/25,75,150,250,450,800,1250,1750,2250,2500/
+
2934 
+
2935 C CHECK IF THIS IS A PREPBUFR FILE
+
2936 C --------------------------------
+
2937 
+
2938  r04o29 = 99
+
2939 c#V#V#dak - future
+
2940 cdak IF(SUBSET.EQ.'ADPSFC') R04O29 = PRPSFC(LUNIT,OBS)
+
2941 cdak IF(SUBSET.EQ.'SFCSHP') R04O29 = PRPSFC(LUNIT,OBS)
+
2942 cdak IF(SUBSET.EQ.'SFCBOG') R04O29 = PRPSFC(LUNIT,OBS)
+
2943 caaaaadak - future
+
2944  IF(r04o29.NE.99) RETURN
+
2945  r04o29 = 0
+
2946 
+
2947  CALL s05o29
+
2948 
+
2949 C PUT THE HEADER INFORMATION INTO ON29 FORMAT
+
2950 C -------------------------------------------
+
2951 
+
2952  CALL ufbint(lunit,hdr_8,20, 1,iret,hdstr);hdr(2:)=hdr_8(2:)
+
2953  CALL ufbint(lunit,rct_8, 5,255,nrct,rcstr);rct=rct_8
+
2954  IF(hdr(5).GE.bmiss) hdr(5) = 0
+
2955  rctim = nint(rct(1,1))+nint(rct(2,1))/60.
+
2956  rid_8 = hdr_8(1)
+
2957  xob = hdr(2)
+
2958  yob = hdr(3)
+
2959  rhr = bmiss
+
2960  IF(hdr(4).LT.bmiss) rhr = nint(hdr(4))+nint(hdr(5))/60.
+
2961  rch = rctim
+
2962  elv = hdr(6)
+
2963 
+
2964 C I1 DEFINES SYNOPTIC FORMAT FLAG (SUBSET NC000001, NC000009)
+
2965 C I1 DEFINES AUTOMATED STATION TYPE (SUBSET NC000003-NC000008,NC000010)
+
2966 C I2 DEFINES CONVERTED HOURLY FLAG (SUBSET NC000xxx)
+
2967 C I2 DEFINES SHIP LOCATION FLAG (SUBSET NC001xxx) (WHERE xxx != 006)
+
2968 
+
2969  i1 = 9
+
2970  i2 = 9
+
2971  IF(subset(1:5).EQ.'NC000') THEN
+
2972  IF(subset(6:8).EQ.'001'.OR.subset(6:8).EQ.'009') THEN
+
2973  i1 = 1
+
2974  IF(subset(6:8).EQ.'009') i2 = 1
+
2975  ELSE IF(subset(6:8).NE.'002') THEN
+
2976  IF(hdr(7).LT.15) THEN
+
2977  IF(hdr(7).GT.0.AND.hdr(7).LT.5) THEN
+
2978  i1 = 2
+
2979  ELSE IF(hdr(7).EQ.8) THEN
+
2980  i1 = 3
+
2981  ELSE
+
2982  i1 = 4
+
2983  END IF
+
2984  END IF
+
2985  END IF
+
2986  END IF
+
2987  itp = (10 * i1) + i2
+
2988  rtp = e33o29(subset,sid)
+
2989 
+
2990 C THE 25'TH (RESERVE) CHARACTER IS INDICATOR FOR PRECIP. (INCL./EXCL.)
+
2991 C THE 26'TH (RESERVE) CHARACTER IS INDICATOR FOR W SPEED (SOURCE/UNITS)
+
2992 C '0' - Wind speed estimated in m/s (uncertified instrument)
+
2993 C '1' - Wind speed obtained from anemometer in m/s (certified
+
2994 C instrument)
+
2995 C '3' - Wind speed estimated in knots (uncertified instrument)
+
2996 C '4' - Wind speed obtained from anemometer in knots (certified
+
2997 C instrument)
+
2998 C '7' - Missing
+
2999 C THE 27'TH (RESERVE) CHARACTER IS INDICATOR FOR STN OPER./PAST WX DATA
+
3000 
+
3001  CALL ufbint(lunit,ufbint_8,1,1,nrsv,'INPC');rrsv(1)=ufbint_8
+
3002  CALL ufbint(lunit,ufbint_8,1,1,nrsv,'TIWM');tiwm=ufbint_8
+
3003  IF(tiwm.LT.bmiss) THEN ! Effective 3/2002
+
3004  rrsv(2) = 7
+
3005  IF(nint(tiwm).LE.15) rrsv(2) = itiwm(nint(tiwm))
+
3006  ELSE ! Prior to 3/2002
+
3007  CALL ufbint(lunit,ufbint_8,1,1,nrsv,'SUWS');rrsv(2)=ufbint_8
+
3008  END IF
+
3009  CALL ufbint(lunit,ufbint_8,1,1,nrsv,'ITSO');rrsv(3)=ufbint_8
+
3010  rsv = '999 '
+
3011  DO i=1,3
+
3012  IF(rrsv(i).LT.bmiss) WRITE(rsv(i:i),'(I1)') nint(rrsv(i))
+
3013  ENDDO
+
3014 
+
3015 C READ THE CATEGORY 51 SURFACE DATA FROM BUFR
+
3016 C -------------------------------------------
+
3017 
+
3018  CALL ufbint(lunit,ufbint_8,1,1,iret,'PMSL');psl=ufbint_8
+
3019  CALL ufbint(lunit,ufbint_8,1,1,iret,'PRES');stp=ufbint_8
+
3020  CALL ufbint(lunit,ufbint_8,1,1,iret,'WDIR');sdr=ufbint_8
+
3021  CALL ufbint(lunit,ufbint_8,1,1,iret,'WSPD');ssp=ufbint_8
+
3022  wspd1 = ssp
+
3023  CALL ufbint(lunit,ufbint_8,1,1,iret,'TMDB');stm=ufbint_8
+
3024  CALL ufbint(lunit,ufbint_8,1,1,iret,'TMDP');dpd=ufbint_8
+
3025  IF(subset.NE.'NC000007') THEN
+
3026  CALL ufbint(lunit,ufbint_8,1,1,iret,'MXTM');tmx=ufbint_8
+
3027  CALL ufbint(lunit,ufbint_8,1,1,iret,'MITM');tmi=ufbint_8
+
3028  ELSE
+
3029  tmx = bmiss
+
3030  tmi = bmiss
+
3031  END IF
+
3032  CALL ufbint(lunit,ufbint_8,1,1,iret,'QMPR');qsl=ufbint_8
+
3033  CALL ufbint(lunit,ufbint_8,1,1,iret,'QMPR');qsp=ufbint_8
+
3034  CALL ufbint(lunit,ufbint_8,1,1,iret,'QMWN');qmw=ufbint_8
+
3035  CALL ufbint(lunit,ufbint_8,1,1,iret,'QMAT');qmt=ufbint_8
+
3036  CALL ufbint(lunit,ufbint_8,1,1,iret,'QMDD');qmd=ufbint_8
+
3037  CALL ufbint(lunit,ufbint_8,1,1,iret,'HOVI');hvz=ufbint_8
+
3038  CALL ufbint(lunit,ufbint_8,1,1,iret,'PRWE');prw=ufbint_8
+
3039  CALL ufbint(lunit,ufbint_8,1,1,iret,'PSW1');pw1=ufbint_8
+
3040  CALL ufbint(lunit,ufbint_8,1,1,iret,'PSW2');pw2=ufbint_8
+
3041  CALL ufbint(lunit,ufbint_8,1,1,iret,'TOCC');ccn=ufbint_8
+
3042  CALL ufbint(lunit,ufbint_8,1,1,iret,'CHPT');cpt=ufbint_8
+
3043  CALL ufbint(lunit,ufbint_8,1,1,iret,'3HPC');apt=ufbint_8
+
3044  IF(max(apt,cpt).GE.bmiss) THEN
+
3045  apt = bmiss
+
3046  CALL ufbint(lunit,ufbint_8,1,1,iret,'24PC');apt24=ufbint_8
+
3047  IF(apt24.LT.bmiss) THEN
+
3048  apt = apt24
+
3049  cpt = bmiss
+
3050  END IF
+
3051  END IF
+
3052 
+
3053 
+
3054 C READ THE CATEGORY 52 SURFACE DATA FROM BUFR
+
3055 C -------------------------------------------
+
3056 
+
3057  CALL ufbint(lunit,ufbint_8,1,1,iret,'TP06');pc6=ufbint_8
+
3058  CALL ufbint(lunit,ufbint_8,1,1,iret,'TOSD');snd=ufbint_8
+
3059  CALL ufbint(lunit,ufbint_8,1,1,iret,'TP24');p24=ufbint_8
+
3060  CALL ufbint(lunit,ufbint_8,1,1,iret,'TOPC');pto=ufbint_8
+
3061  IF(pto.LT.bmiss) THEN
+
3062  IF(pc6.GE.bmiss.AND.nint(dop).EQ. 6) pc6 = pto
+
3063 cppppp
+
3064  IF(pc6.GE.bmiss.AND.nint(dop).EQ. 6)
+
3065  $ print'(" ~~IW3UNP29/R04O29: PTO used for PC6 since latter ",
+
3066  $ "missing & 6-hr DOP")'
+
3067 cppppp
+
3068  IF(p24.GE.bmiss.AND.nint(dop).EQ.24) p24 = pto
+
3069 cppppp
+
3070  IF(p24.GE.bmiss.AND.nint(dop).EQ.24)
+
3071  $ print'(" ~~IW3UNP29/R04O29: PTO used for P24 since latter ",
+
3072  $ "missing & 24-hr DOP")'
+
3073 cppppp
+
3074  END IF
+
3075  CALL ufbint(lunit,ufbint_8,1,1,iret,'POWW');pow=ufbint_8
+
3076  CALL ufbint(lunit,ufbint_8,1,1,iret,'HOWW');how=ufbint_8
+
3077  IF(subset(1:5).EQ.'NC001') THEN
+
3078  IF(subset(6:8).NE.'006') THEN
+
3079  IF(min(pow,how).GE.bmiss) THEN
+
3080  CALL ufbint(lunit,ufbint_8,1,1,iret,'POWV');pow=ufbint_8
+
3081  CALL ufbint(lunit,ufbint_8,1,1,iret,'HOWV');how=ufbint_8
+
3082  END IF
+
3083  ELSE
+
3084 C PAOBS always have a missing elev, but we know they are at sea level
+
3085  elv = 0
+
3086  END IF
+
3087  END IF
+
3088  CALL ufbint(lunit,ufbint_8,1,1,iret,'DOSW');swd=ufbint_8
+
3089  CALL ufbint(lunit,ufbint_8,1,1,iret,'POSW');swp=ufbint_8
+
3090  CALL ufbint(lunit,ufbint_8,1,1,iret,'HOSW');swh=ufbint_8
+
3091  CALL ufbint(lunit,ufbint_8,1,1,iret,'SST1');sst=ufbint_8
+
3092  IF(sst.GE.bmiss) THEN
+
3093  CALL ufbint(lunit,ufbint_8,1,1,iret,'STMP');sst=ufbint_8
+
3094  ENDIF
+
3095  CALL ufbint(lunit,ufbint_8,1,1,iret,'????');spg=ufbint_8
+
3096  CALL ufbint(lunit,ufbint_8,1,1,iret,'????');spd=ufbint_8
+
3097  CALL ufbint(lunit,ufbint_8,1,1,iret,'TDMP');shc=ufbint_8
+
3098  CALL ufbint(lunit,ufbint_8,1,1,iret,'ASMP');sas=ufbint_8
+
3099  CALL ufbint(lunit,ufbint_8,1,1,iret,'????');wes=ufbint_8
+
3100  i52flg = 0
+
3101  IF(min(snd,p24,pow,how,swd,swp,swh,sst,spg,spd,shc,sas,wes)
+
3102  $ .GE.bmiss.AND.(pc6.EQ.0..OR.pc6.GE.bmiss)) i52flg= 1
+
3103 
+
3104 C SOME CLOUD DATA IS NEEDED FOR LOW, MIDDLE, AND HIGH CLOUDS IN CAT. 51
+
3105 C ---------------------------------------------------------------------
+
3106 
+
3107  CALL ufbint(lunit,clds_8,4,255,ncld,'VSSO CLAM CLTP HOCB')
+
3108  clds=clds_8
+
3109  cth = -9999.
+
3110  ctm = -9999.
+
3111  ctl = -9999.
+
3112  chh = bmiss
+
3113  chm = bmiss
+
3114  chl = bmiss
+
3115  IF(ncld.EQ.0) THEN
+
3116  ccm = bmiss
+
3117  ccl = bmiss
+
3118  ELSE
+
3119  ccm = 0.
+
3120  ccl = 0.
+
3121  DO l=1,ncld
+
3122  vss = clds(1,l)
+
3123  cam = clds(2,l)
+
3124  ctp = clds(3,l)
+
3125  cht = bmiss
+
3126  IF(clds(4,l).LT.bmiss) THEN
+
3127  ! Prior to 3/2002 HBLCS was not available, this will
+
3128  ! always be tested first because it is more precise
+
3129  ! and may still be available for some types after
+
3130  ! 3/2002
+
3131  cht = clds(4,l)
+
3132  ELSE
+
3133  ! Effective 3/2002 this will be available and can be
+
3134  ! used for types where HOCB is not available - less
+
3135  ! precise and only available on 1 level
+
3136  CALL ufbint(lunit,ufbint_8,1,1,iret,'HBLCS')
+
3137  hblcs=ufbint_8
+
3138  IF(nint(hblcs).LT.10) cht = ihblcs(nint(hblcs))
+
3139  END IF
+
3140  IF(cht.LT.bmiss) cht = cht * 3.2808
+
3141  IF(nint(vss).EQ.0) THEN
+
3142  IF(nint(ctp).GT.9.AND.nint(ctp).LT.20) THEN
+
3143  ith = mod(nint(ctp),10)
+
3144  kth = jth(ith)
+
3145  cth = max(kth,nint(cth))
+
3146  chh = min(cht,chh)
+
3147  ELSE IF(nint(ctp).LT.30) THEN
+
3148  itm = mod(nint(ctp),10)
+
3149  ctm = max(itm,nint(ctm))
+
3150  IF(itm.EQ.0) cam = 0.
+
3151  ccm = max(cam,ccm)
+
3152  chm = min(cht,chm)
+
3153  ELSE IF(nint(ctp).LT.40) THEN
+
3154  itl = mod(nint(ctp),10)
+
3155  ktl = jtl(itl)
+
3156  ctl = max(ktl,nint(ctl))
+
3157  IF(itl.EQ.0) cam = 0.
+
3158  ccl = max(cam,ccl)
+
3159  chl = min(cht,chl)
+
3160  ELSE IF(nint(ctp).EQ.59) THEN
+
3161  cth = 10.
+
3162  ctm = 10.
+
3163  IF(ccm.EQ.0.) ccm = 15.
+
3164  ctl = 10.
+
3165  IF(ccl.EQ.0.) ccl = 15.
+
3166  ELSE IF(nint(ctp).EQ.60) THEN
+
3167  cth = 10.
+
3168  ELSE IF(nint(ctp).EQ.61) THEN
+
3169  ctm = 10.
+
3170  IF(ccm.EQ.0.) ccm = 15.
+
3171  ELSE IF(nint(ctp).EQ.62) THEN
+
3172  ctl = 10.
+
3173  IF(ccl.EQ.0.) ccl = 15.
+
3174  END IF
+
3175  END IF
+
3176  ENDDO
+
3177  END IF
+
3178  IF(nint(cth).GT.-1.AND.nint(cth).LT.10) THEN
+
3179  cth = jth(nint(cth))
+
3180  ELSE IF(nint(cth).NE.10) THEN
+
3181  cth = bmiss
+
3182  END IF
+
3183  IF(nint(ctm).LT.0.OR.nint(ctm).GT.10) THEN
+
3184  ctm = bmiss
+
3185  ccm = bmiss
+
3186  END IF
+
3187  IF(nint(ctl).GT.-1.AND.nint(ctl).LT.10) THEN
+
3188  ctl = ltl(nint(ctl))
+
3189  ELSE IF(nint(ctl).NE.10) THEN
+
3190  ctl = bmiss
+
3191  ccl = bmiss
+
3192  END IF
+
3193 
+
3194 C CALL FUNCTIONS TO TRANSFORM TO ON29/124 UNITS
+
3195 C ---------------------------------------------
+
3196 
+
3197  psl = e01o29(psl)
+
3198  stp = e01o29(stp)
+
3199  sdr = e04o29(sdr,ssp)
+
3200  ssp = e05o29(sdr,ssp)
+
3201  IF(nint(sdr).EQ.0) sdr = 360.
+
3202  IF(sdr.GE.bmiss.AND.nint(ssp).EQ.0) sdr = 360.
+
3203  dpd = e07o29(dpd,stm)
+
3204  stm = e06o29(stm)
+
3205  tmx = e06o29(tmx)
+
3206  tmi = e06o29(tmi)
+
3207 
+
3208  psq = e35o29(qsl)
+
3209  spq = e35o29(qsp)
+
3210  swq = e35o29(qmw)
+
3211  stq = e35o29(qmt)
+
3212  ddq = e35o29(qmd)
+
3213 
+
3214 C ADJUST QUIPS QUALITY MARKERS TO REFLECT UNPACKED ON29 CONVENTION
+
3215 
+
3216  IF(subset(1:5).EQ.'NC001'.AND.psq.EQ.'C') stp = bmiss
+
3217  IF(psl.GE.bmiss) psq = ' '
+
3218  IF(stp.GE.bmiss) spq = ' '
+
3219  IF(max(sdr,ssp).GE.bmiss) swq = ' '
+
3220  IF(stm.GE.bmiss) stq = ' '
+
3221 
+
3222  IF(subset(1:5).EQ.'NC000'.OR.subset.EQ.'NC001004') THEN
+
3223  hvz = e09o29(hvz)
+
3224  ELSE
+
3225  hvz = e38o29(hvz)
+
3226  END IF
+
3227  prw = e10o29(prw)
+
3228  pw1 = e11o29(pw1)
+
3229  pw2 = e11o29(pw2)
+
3230  IF(ddq.NE.'P'.AND.ddq.NE.'H'.AND.ddq.NE.'C') THEN
+
3231  ddq = ' '
+
3232  ipw2 = nint(pw2)
+
3233  IF(ipw2.GT.-1.AND.ipw2.LT.10) WRITE(ddq,'(I1)') ipw2
+
3234  END IF
+
3235  ccn = e12o29(ccn)
+
3236  chn = e14o29(ccl,ccm)
+
3237  ctl = e15o29(ctl)
+
3238  ctm = e15o29(ctm)
+
3239  cth = e15o29(cth)
+
3240  hcb = e18o29(chl,chm,chh,ctl,ctm,cth)
+
3241  cpt = e19o29(cpt)
+
3242  apt = e01o29(apt)
+
3243 
+
3244  pc6 = e20o29(pc6)
+
3245  snd = e21o29(snd)
+
3246  p24 = e20o29(p24)
+
3247  dop = e22o29(pc6)
+
3248  pow = e23o29(pow)
+
3249  how = e24o29(how)
+
3250  swd = e25o29(swd)
+
3251  swp = e23o29(swp)
+
3252  swh = e24o29(swh)
+
3253  sst = e06o29(sst)
+
3254  spg = e28o29(spg)
+
3255  spd = e29o29(spd)
+
3256  shc = e30o29(shc)
+
3257  sas = e31o29(sas)
+
3258  wes = e32o29(wes)
+
3259 
+
3260 C MAKE THE UNPACKED ON29/124 REPORT INTO OBS
+
3261 C ------------------------------------------
+
3262 
+
3263  rsv2 = ' '
+
3264  CALL s01o29(sid,xob,yob,rhr,rch,rsv,rsv2,elv,itp,rtp)
+
3265  CALL s02o29(51,1,*9999)
+
3266  IF(i52flg.EQ.0) CALL s02o29(52,1,*9999)
+
3267 
+
3268 C ------------------------------------------------------------------
+
3269 C MISC DATA GOES INTO CATEGORY 08
+
3270 C ------------------------------------------------------------------
+
3271 C CODE FIGURE 020 - ALTIMETER SETTING IN 0.1*MB
+
3272 C CODE FIGURE 081 - CALENDAR DAY MAXIMUM TEMPERATURE
+
3273 C CODE FIGURE 082 - CALENDAR DAY MINIMUM TEMPERATURE
+
3274 C CODE FIGURE 083 - SIX HOUR MAXIMUM TEMPERATURE
+
3275 C CODE FIGURE 084 - SIX HOUR MINIMUM TEMPERATURE
+
3276 C CODE FIGURE 085 - PRECIPITATION OVER PAST HOUR IN 0.01*INCHES
+
3277 C CODE FIGURE 098 - DURATION OF SUNSHINE FOR CALENDAR DAY IN MINUTES
+
3278 C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S
+
3279 C ------------------------------------------------------------------
+
3280 
+
3281  CALL ufbint(lunit,ufbint_8,1,1,iret,'ALSE');als=ufbint_8
+
3282  IF(als.LT.bmiss) THEN
+
3283  ob8(1) = e01o29(als)
+
3284  cf8(1) = 20
+
3285  q81(1) = ' '
+
3286  q82(1) = ' '
+
3287  CALL s02o29(8,1,*9999)
+
3288  END IF
+
3289  IF(subset.EQ.'NC000007') THEN
+
3290  CALL ufbint(lunit,tmxmnm_8,4,255,ntxm,
+
3291  $ '.DTHMXTM MXTM .DTHMITM MITM');tmxmnm=tmxmnm_8
+
3292  IF(ntxm.GT.0) THEN
+
3293  DO i = 1,ntxm
+
3294  DO j = 1,3,2
+
3295  IF(nint(tmxmnm(j,i)).EQ.24) THEN
+
3296  IF(tmxmnm(j+1,i).LT.bmiss) THEN
+
3297  tmx = e06o29(tmxmnm(j+1,i))
+
3298  IF(tmx.LT.0) THEN
+
3299  ob8(1) = 1000 + abs(nint(tmx))
+
3300  ELSE
+
3301  ob8(1) = nint(tmx)
+
3302  END IF
+
3303  cf8(1) = 81 + int(j/2)
+
3304  q81(1) = ' '
+
3305  q82(1) = ' '
+
3306  CALL s02o29(8,1,*9999)
+
3307  END IF
+
3308  ELSE IF(nint(tmxmnm(j,i)).EQ.6) THEN
+
3309  IF(tmxmnm(j+1,i).LT.bmiss) THEN
+
3310  tmx = e06o29(tmxmnm(j+1,i))
+
3311  IF(tmx.LT.0) THEN
+
3312  ob8(1) = 1000 + abs(nint(tmx))
+
3313  ELSE
+
3314  ob8(1) = nint(tmx)
+
3315  END IF
+
3316  cf8(1) = 83 + int(j/2)
+
3317  q81(1) = ' '
+
3318  q82(1) = ' '
+
3319  CALL s02o29(8,1,*9999)
+
3320  END IF
+
3321  END IF
+
3322  ENDDO
+
3323  ENDDO
+
3324  END IF
+
3325  END IF
+
3326  CALL ufbint(lunit,ufbint_8,1,1,iret,'TP01');pc1=ufbint_8
+
3327  IF(pc1.LT.10000) THEN
+
3328  ob8(1) = e20o29(pc1)
+
3329  cf8(1) = 85
+
3330  q81(1) = ' '
+
3331  q82(1) = ' '
+
3332  CALL s02o29(8,1,*9999)
+
3333  END IF
+
3334  CALL ufbint(lunit,ufbint_8,1,1,iret,'TOSS');dus=ufbint_8
+
3335  IF(nint(dus).LT.1000) THEN
+
3336  ob8(1) = nint(98000. + dus)
+
3337  cf8(1) = 98
+
3338  q81(1) = ' '
+
3339  q82(1) = ' '
+
3340  CALL s02o29(8,1,*9999)
+
3341  END IF
+
3342  IF(wspd1.LT.bmiss) THEN
+
3343  ob8(1) = nint(wspd1*10.)
+
3344  cf8(1) = 924
+
3345  q81(1) = ' '
+
3346  q82(1) = ' '
+
3347  CALL s02o29(8,1,*9999)
+
3348  END IF
+
3349 
+
3350  CALL s03o29(obs,subset,*9999,*9998)
+
3351 
+
3352  RETURN
+
3353 
+
3354  9999 CONTINUE
+
3355  r04o29 = 999
+
3356  RETURN
+
3357 
+
3358  9998 CONTINUE
+
3359  print'(" IW3UNP29/R04O29: RPT with ID= ",A," TOSSED - ZERO ",
+
3360  $ "CAT.1-6,51,52 LVLS")', sid
+
3361  r04o29 = -9999
+
3362  ksksfc =ksksfc + 1
+
3363  RETURN
+
3364 
+
3365  END
+
3366 C***********************************************************************
+
3367 C***********************************************************************
+
3368 C***********************************************************************
+
3369  FUNCTION r05o29(LUNIT,OBS)
+
3370 C ---> formerly FUNCTION AIRCFT
+
3371 
+
3372  common/io29ee/pob(255),qob(255),tob(255),zob(255),dob(255),
+
3373  $ sob(255),vsg(255),clp(255),cla(255),ob8(255),
+
3374  $ cf8(255)
+
3375  common/io29ff/pqm(255),qqm(255),tqm(255),zqm(255),wqm(255),
+
3376  $ qcp(255),qca(255),q81(255),q82(255)
+
3377  common/io29cc/subset,idat10
+
3378  common/io29bb/kndx,kskacf(8),kskupa,ksksfc,ksksat,ksksmi
+
3379  common/io29ll/bmiss
+
3380 
+
3381  CHARACTER*80 hdstr,lvstr,qmstr,rcstr,crawr
+
3382  CHARACTER*8 subset,sid,sido,sidmod,e35o29,rsv,rsv2,ccl,craw(1,255)
+
3383  CHARACTER*1 pqm,qqm,tqm,zqm,wqm,qcp,qca,q81,q82,cturb(0:14)
+
3384  REAL(8) rid_8,rcl_8,ufbint_8,rns_8,bmiss
+
3385  REAL(8) hdr_8(20),rct_8(5,255),arr_8(10,255),raw_8(1,255)
+
3386  dimension obs(*),hdr(20),rct(5,255),arr(10,255),raw(1,255)
+
3387  equivalence(rid_8,sid),(rcl_8,ccl),(raw_8,craw)
+
3388 
+
3389  SAVE
+
3390 
+
3391  DATA hdstr/'RPID CLON CLAT HOUR MINU SECO '/
+
3392  DATA lvstr/'PRLC TMDP TMDB WDIR WSPD '/
+
3393  DATA qmstr/'QMPR QMAT QMDD QMGP QMWN '/
+
3394  DATA rcstr/'RCHR RCMI RCTS '/
+
3395 
+
3396  DATA cturb/'0','1','2','3','0','1','2','3','0','1','2',4*'3'/
+
3397 
+
3398 C CHECK IF THIS IS A PREPBUFR FILE
+
3399 C --------------------------------
+
3400 
+
3401  r05o29 = 99
+
3402 c#V#V#dak - future
+
3403 cdak IF(SUBSET.EQ.'AIRCFT') R05O29 = PRPCFT(LUNIT,OBS)
+
3404 cdak IF(SUBSET.EQ.'AIRCAR') R05O29 = PRPCFT(LUNIT,OBS)
+
3405 caaaaadak - future
+
3406  IF(r05o29.NE.99) RETURN
+
3407  r05o29 = 0
+
3408 
+
3409  CALL s05o29
+
3410 
+
3411 C PUT THE HEADER INFORMATION INTO ON29 FORMAT
+
3412 C -------------------------------------------
+
3413 
+
3414  CALL ufbint(lunit,hdr_8,20, 1,iret,hdstr);hdr(2:)=hdr_8(2:)
+
3415  IF(iret.EQ.0) sid = ' '
+
3416  CALL ufbint(lunit,rct_8, 5,255,nrct,rcstr);rct=rct_8
+
3417  IF(hdr(5).GE.bmiss) hdr(5) = 0
+
3418  IF(hdr(6).GE.bmiss) hdr(6) = 0
+
3419  rctim = nint(rct(1,1))+nint(rct(2,1))/60.
+
3420  rid_8 = hdr_8(1)
+
3421  xob = hdr(2)
+
3422  yob = hdr(3)
+
3423  rhr = bmiss
+
3424  IF(hdr(4).LT.bmiss) rhr = nint(hdr(4)) + ((nint(hdr(5)) * 60.) +
+
3425  $ nint(hdr(6)))/3600.
+
3426  rch = rctim
+
3427 
+
3428 C TRY TO FIND FIND THE FLIGHT LEVEL HEIGHT
+
3429 C ----------------------------------------
+
3430 
+
3431  CALL ufbint(lunit,hdr_8,20,1,iret,'PSAL FLVL IALT HMSL PRLC')
+
3432  hdr=hdr_8
+
3433  elev = bmiss
+
3434  IF(hdr(5).LT.bmiss) elev = e03o29(hdr(5)*.01)
+
3435  IF(hdr(4).LT.bmiss) elev = hdr(4)
+
3436 C FOR MDCARS ACARS DATA ONLY:
+
3437 C UNCOMMENTING NEXT LINE WILL SET P-ALT TO REPORTED "IALT" VALUE --
+
3438 C IN THIS CASE, PREPDATA WILL LATER GET PRESS. VIA STD. ATMOS. FCN.
+
3439 C COMMENTING NEXT LINE WILL USE REPORTED PRESSURE "PRLC" TO GET
+
3440 C P-ALT VIA INVERSE STD. ATMOS. FCN. -- IN THIS CASE, PREPDATA WILL
+
3441 C LATER RETURN THIS SAME PRESS. VIA STD. ATMOS. FCN.
+
3442 cdak IF(HDR(3).LT.BMISS) ELEV = HDR(3)
+
3443  IF(hdr(2).LT.bmiss) elev = hdr(2) + sign(0.0000001,hdr(2))
+
3444  IF(hdr(1).LT.bmiss) elev = hdr(1) + sign(0.0000001,hdr(1))
+
3445  elv = elev
+
3446 
+
3447 C ACFT NAVIGATION SYSTEM STORED IN INSTR. TYPE LOCATION (AS WITH ON29)
+
3448 C --------------------------------------------------------------------
+
3449 
+
3450  itp = 99
+
3451  CALL ufbint(lunit,rns_8,1,1,iret,'ACNS');rns=rns_8
+
3452  IF(rns.LT.bmiss) THEN
+
3453  IF(nint(rns).EQ.0) THEN
+
3454  itp = 97
+
3455  ELSE IF(nint(rns).EQ.1) THEN
+
3456  itp = 98
+
3457  END IF
+
3458  END IF
+
3459 
+
3460  rtp = e33o29(subset,sid)
+
3461 
+
3462  CALL ufbint(lunit,rcl_8,1,1,iret,'BORG') ! Effective 3/2002
+
3463  IF(iret.EQ.0) THEN
+
3464  ccl = ' '
+
3465  CALL ufbint(lunit,rcl_8,1,1,iret,'ICLI') ! Prior to 3/2002
+
3466  IF(iret.EQ.0) ccl = ' '
+
3467  END IF
+
3468 cvvvvv temporary?
+
3469  IF(ccl(1:4).EQ.'KAWN') THEN
+
3470 
+
3471 C This will toss all Carswell/Tinker Aircraft reports - until Jack
+
3472 C fixes the dup-check to properly remove the duplicate Carswell
+
3473 C reports, we are better off removing them all since they are
+
3474 C often of less quality than the non-Carswell AIREP reports
+
3475 C RIGHT NOW WE ARE HAPPY WITH DUP-CHECKER'S HANDLING OF THESE,
+
3476 C SO COMMENT THIS OUT
+
3477 
+
3478 cdak R05O29 = -9999
+
3479 cdak KSKACF(?) = KSKACF(?) + 1
+
3480 cdak RETURN
+
3481  END IF
+
3482 caaaaa temporary?
+
3483  IF(subset.EQ.'NC004003') THEN
+
3484 
+
3485 C ------------------------------------
+
3486 C ASDAR/AMDAR AIRCRAFT TYPE COME HERE
+
3487 C ------------------------------------
+
3488 
+
3489 cvvvvv temporary?
+
3490 C Currently, we throw out any ASDAR/AMDAR reports with header "LFPW" -
+
3491 C simply because they never appeared in NAS9000 ON29 AIRCFT data set
+
3492 C (NOTE: These should all have ACID's that begin with "IT")
+
3493 C (NOTE: These will not be removed from the new decoders, because
+
3494 C they are apparently unique reports of reasonable
+
3495 C quality. EMC just needs to test them in a parallel run
+
3496 C to make sure prepacqc and the analysis handle them okay.)
+
3497 
+
3498 C NOTE: NO, NO DON'T THROW THEM OUT ANY MORE !!!!!!
+
3499 C Keyser -- 6/13/97
+
3500 
+
3501 CDAKCDAK if(ccl(1:4).eq.'LFPW') then
+
3502 cppppp
+
3503 cdak print'(" IW3UNP29/R05O29: TOSS ""LFPW"" AMDAR with ID = ",A,
+
3504 cdak $ "; CCL = ",A)', SID,CCL(1:4)
+
3505 cppppp
+
3506 CDAKCDAK R05O29 = -9999
+
3507 CDAKCDAK kskacf(2) = kskacf(2) + 1
+
3508 CDAKCDAK return
+
3509 CDAKCDAK end if
+
3510 caaaaa temporary?
+
3511 
+
3512 C MODIFY REPORT ID AS WAS DONE IN OLD ON29 AIRCRAFT PACKER
+
3513 C --------------------------------------------------------
+
3514 
+
3515  CALL s06o29(sid,sidmod)
+
3516  sido = sid
+
3517  sid = sidmod
+
3518 
+
3519 C THE 25'TH (RESERVE) CHARACTER INDICATES PHASE OF FLIGHT
+
3520 C THE 26'TH (RESERVE) CHARACTER INDICATES TEMPERATURE PRECISION
+
3521 C THE 27'TH (RESERVE) CHARACTER INDICATES CARSWELL (NEVER HAPPENS)
+
3522 C (NOTE: NAS9000 ONLY ASSIGNED HEADER "KAWN" AS CARSWELL, ALTHOUGH
+
3523 C "PHWR" AND "EGWR" ARE ALSO APPARENTLY ALSO CARSWELL)
+
3524 
+
3525  rsv = '71 '
+
3526  CALL ufbint(lunit,ufbint_8,1,1,iret,'POAF');pof=ufbint_8
+
3527  IF(pof.LT.bmiss) WRITE(rsv(1:1),'(I1)') nint(pof)
+
3528  CALL ufbint(lunit,ufbint_8,1,1,iret,'PCAT');pct=ufbint_8
+
3529  IF(nint(pct).GT.1) rsv(2:2) = '0'
+
3530  IF(ccl(1:4).EQ.'KAWN') rsv(3:3) = 'C'
+
3531 
+
3532  ELSE IF(subset.EQ.'NC004004') THEN
+
3533 
+
3534 C ------------------------------
+
3535 C ACARS AIRCRAFT TYPE COME HERE
+
3536 C ------------------------------
+
3537 
+
3538  CALL ufbint(lunit,rid_8,1,1,iret,'ACRN')
+
3539  IF(iret.EQ.0) sid = 'ACARS '
+
3540  kndx = kndx + 1
+
3541  rsv = '999 '
+
3542 
+
3543  ELSE IF(subset.EQ.'NC004001'.OR.subset.EQ.'NC004002') THEN
+
3544 
+
3545 C -----------------------------------------
+
3546 C AIREP AND PIREP AIRCRAFT TYPES COME HERE
+
3547 C -----------------------------------------
+
3548 
+
3549 C MAY POSSIBLY NEED TO MODIFY THE RPID HERE
+
3550 C -----------------------------------------
+
3551 
+
3552  IF(sid(6:6).EQ.'Z') sid(6:6) = 'X'
+
3553  IF(sid.EQ.'A '.OR.sid.EQ.' '.OR.sid(1:3).EQ.'ARP'
+
3554  $ .OR.sid(1:3).EQ.'ARS') sid = 'AIRCFT '
+
3555 
+
3556 cvvvvv temporary?
+
3557 C Determined that Hickum AFB reports are much like Carswell - they have
+
3558 C problems! They also are usually duplicates of either Carswell or
+
3559 C non-Carswell reports. Apparently the front-end processing filters
+
3560 C them out (according to B. Ballish). So, to make things match,
+
3561 C we will do the same here.
+
3562 C ACTUALLY, JEFF ATOR HAS REMOVED THESE FROM THE DECODER, SO WE
+
3563 C SHOULD NEVER EVEN SEE THEM IN THE DATABASE, but it won't hurt
+
3564 C anything to keep this in here.
+
3565 C (NOTE: These all have headers of "PHWR")
+
3566 
+
3567  if(ccl(1:4).eq.'PHWR') then
+
3568 cppppp
+
3569 cdak print'(" IW3UNP29/R05O29: TOSS ""PHWR"" AIREP with ID = ",A,
+
3570 cdak $ "; CCL = ",A)', SID,CCL(1:4)
+
3571 cppppp
+
3572  r05o29 = -9999
+
3573  kskacf(8) = kskacf(8) + 1
+
3574  return
+
3575  end if
+
3576 caaaaa temporary?
+
3577 
+
3578 cvvvvv temporary?
+
3579 C 1) Carswell/Tinker AMDARS are processed as AIREP subtypes.
+
3580 C Nearly all of them are duplicated as true non-Carswell AMDARS in
+
3581 C the AMDAR subtype. The earlier version of the aircraft dup-
+
3582 C checker could not remove such duplicates; the new verison now
+
3583 C in operations can remove these. SO, WE HAVE COMMENTED THIS OUT.
+
3584 C
+
3585 C The Carswell AMDARS can be identified by the string " Sxyz" in
+
3586 C the raw report (beyond byte 40), where y is 0,1, or 2.
+
3587 C (NOTE: Apparently Carswell here applies to more headers than
+
3588 C just "KAWN", so report header is not even checked.)
+
3589 
+
3590 C 2) Carswell/Tinker ACARS are processed as AIREP subtypes.
+
3591 C These MAY duplicate true non-Carswell ACARS in the ACARS
+
3592 C subtype. The NAS9000 decoder always excluded this type (no
+
3593 C dup-checking was done). All of these will be removed here.
+
3594 C The Carswell ACARS can be identified by the string " Sxyz" in
+
3595 C the raw report (beyond byte 40), where y is 3 or greater.
+
3596 C (NOTE: Apparently Carswell here applies to more headers than
+
3597 C just "KAWN", so report header is not even checked.)
+
3598 
+
3599  call ufbint(lunit,raw_8,1,255,nlev,'RRSTG');raw=raw_8
+
3600  if(nlev.gt.5) then
+
3601  ni = -7
+
3602  do mm = 6,nlev
+
3603  ni = ni + 8
+
3604  crawr(ni:ni+7) = craw(1,mm)
+
3605  if(ni+8.gt.80) go to 556
+
3606  enddo
+
3607  556 continue
+
3608  do mm = 1,ni+7
+
3609  if(crawr(mm:mm+1).eq.' S') then
+
3610  if((crawr(mm+2:mm+2).ge.'0'.and.crawr(mm+2:mm+2).le.
+
3611  $ '9').or.crawr(mm+2:mm+2).eq.'/') then
+
3612  if((crawr(mm+3:mm+3).ge.'0'.and.crawr(mm+3:mm+3)
+
3613  $ .le.'9').or.crawr(mm+3:mm+3).eq.'/') then
+
3614  if((crawr(mm+4:mm+4).ge.'0'.and.
+
3615  $ crawr(mm+4:mm+4).le.'9').or.crawr(mm+4:mm+4)
+
3616  $ .eq.'/') then
+
3617 cppppp
+
3618 cdak print'(" IW3UNP29/R05O29: For ",A,", raw_8(",I0,") = ",A)',
+
3619 cdak $ SID,ni+7,crawr(1:ni+7)
+
3620 cppppp
+
3621  if(crawr(mm+3:mm+3).lt.'3') then
+
3622 
+
3623 C THIS IS A CARSWELL/TINKER AMDAR REPORT --> THROW OUT
+
3624 C (NOT ANYMORE, DUP-CHECKER IS HANDLING THESE OKAY NOW)
+
3625 C ----------------------------------------------------
+
3626 
+
3627 cppppp
+
3628 cdak print'(" IW3UNP29/R05O29: Found a Carswell AMDAR for ",A,
+
3629 cdak $ "; CCL = ",A)', SID,CCL(1:4)
+
3630 cppppp
+
3631 cdak R05O29 = -9999
+
3632 cdak KSKACF(3) = KSKACF(3) + 1
+
3633 cdak RETURN
+
3634  else
+
3635 
+
3636 C THIS IS A CARSWELL/TINKER ACARS REPORT --> THROW OUT
+
3637 C ----------------------------------------------------
+
3638 
+
3639 cppppp
+
3640 cdak print'(" IW3UNP29/R05O29: Found a Carswell ACARS for ",A,
+
3641 cdak $ "; CCL = ",A)', SID,CCL(1:4)
+
3642 cppppp
+
3643  r05o29 = -9999
+
3644  kskacf(4) = kskacf(4) + 1
+
3645  RETURN
+
3646 
+
3647  end if
+
3648  end if
+
3649  end if
+
3650  end iF
+
3651  end if
+
3652  if(mm+5.gt.ni+7) go to 557
+
3653  enddo
+
3654  557 continue
+
3655  END IF
+
3656 caaaaa temporary?
+
3657 
+
3658 C THE 25'TH (RESERVE) CHARACTER INDICATES 8'TH CHARACTER OF STATION ID
+
3659 C THE 26'TH (RESERVE) CHARACTER INDICATES 7'TH CHARACTER OF STATION ID
+
3660 C THE 27'TH (RESERVE) CHARACTER INDICATES CARSWELL
+
3661 C (NOTE: NAS9000 ONLY ASSIGNED HEADER "KAWN" AS CARSWELL, ALTHOUGH
+
3662 C "PHWR" AND "EGWR" ARE ALSO APPARENTLY ALSO CARSWELL)
+
3663 
+
3664  rsv = sid(8:8)//sid(7:7)//' '
+
3665  IF(ccl(1:4).EQ.'KAWN') rsv(3:3) = 'C'
+
3666 
+
3667  END IF
+
3668 
+
3669 C -----------------------------
+
3670 C ALL AIRCRAFT TYPES COME HERE
+
3671 C -----------------------------
+
3672 
+
3673  CALL ufbint(lunit,ufbint_8,1,1,iret,'DGOT');dgt=ufbint_8
+
3674 
+
3675 C PUT THE LEVEL DATA INTO ON29 UNITS
+
3676 C ----------------------------------
+
3677 
+
3678  CALL ufbint(lunit,arr_8,10,255,nlev,lvstr);arr=arr_8
+
3679  DO l=1,nlev
+
3680 
+
3681 Cvvvvv temporary?
+
3682 C Even though PREPDATA filters out any aircraft reports with a missing
+
3683 C wind, or AIREP/PIREP and AMDAR reports below 100 and 2286 meters,
+
3684 C respectively, it will be done here for now in order to help in
+
3685 C the comparison between counts coming from the Cray dumps and the
+
3686 C NAS9000 ON29 dumps (the NAS9000 ON29 maker filters these out).
+
3687 
+
3688 C NO, NO LET'S NOT FILTER HERE ANY MORE - LEAVE IT UP TO PREPDATA
+
3689 C SINCE WE AREN'T COMPARING NAS9000 AND CRAY COUNTS ANY MORE
+
3690 C Keyser -- 6/13/97
+
3691 
+
3692 CDAKCDAK if(arr(4,1).ge.bmiss.or.arr(5,1).ge.bmiss) then
+
3693 CDAKCDAK R05O29 = -9999
+
3694 CDAKCDAK kskacf(5) = kskacf(5) + 1
+
3695 CDAKCDAK return
+
3696 CDAKCDAK end if
+
3697 CDAKCDAK if(subset.eq.'NC004003'.and.elev.lt.2286.) then
+
3698 CDAKCDAK R05O29 = -9999
+
3699 CDAKCDAK kskacf(6) = kskacf(6) + 1
+
3700 CDAKCDAK return
+
3701 CDAKCDAK else if(subset.ne.'NC004004'.and.elev.lt.100.) then
+
3702 CDAKCDAK R05O29 = -9999
+
3703 CDAKCDAK kskacf(7) = kskacf(7) + 1
+
3704 CDAKCDAK return
+
3705 CDAKCDAK end if
+
3706 caaaaa temporary?
+
3707 
+
3708  pob(l) = e01o29(arr(1,l))
+
3709  qob(l) = e07o29(arr(2,l),arr(3,l))
+
3710  tob(l) = e06o29(arr(3,l))
+
3711  zob(l) = elev
+
3712  dob(l) = e04o29(arr(4,l),arr(5,l))
+
3713  sob(l) = e05o29(arr(4,l),arr(5,l))
+
3714  ENDDO
+
3715  wspd1 = arr(5,1)
+
3716 
+
3717  CALL ufbint(lunit,arr_8,10,255,nlev,qmstr);arr=arr_8
+
3718 
+
3719  IF(subset.EQ.'NC004004') THEN
+
3720 
+
3721 C ---------------------------------------------------------
+
3722 C ACARS AIRCRAFT TYPE COME HERE FOR QUALITY MARK ASSIGNMENT
+
3723 C ---------------------------------------------------------
+
3724 
+
3725  DO l=1,nlev
+
3726  pqm(l) = e35o29(arr(1,l))
+
3727  tqm(l) = e35o29(arr(2,l))
+
3728  qqm(l) = e35o29(arr(3,l))
+
3729  zqm(l) = e35o29(arr(4,l))
+
3730  wqm(l) = e35o29(arr(5,l))
+
3731  ENDDO
+
3732 
+
3733 C DEFAULT Q.MARK FOR WIND: "A"
+
3734 C ----------------------------
+
3735 
+
3736  IF(nlev.EQ.0.OR.arr(5,1).GE.bmiss) wqm(1) = 'A'
+
3737 
+
3738  ELSE
+
3739 
+
3740 C --------------------------------------------------------------
+
3741 C ALL OTHER AIRCRAFT TYPES COME HERE FOR QUALITY MARK ASSIGNMENT
+
3742 C --------------------------------------------------------------
+
3743 
+
3744  DO l=1,nlev
+
3745  arr(4,l) = 2
+
3746 
+
3747 C IF KEEP FLAG ON WIND, ENTIRE REPORT GETS KEEP FLAG ('H' IN ZQM)
+
3748 C -- unless....
+
3749 C IF PURGE FLAG ON WIND, ENTIRE REPORT GETS PURGE FLAG ('P' IN ZQM)
+
3750 C IF PURGE FLAG ON TEMP, ENTIRE REPORT GETS PURGE FLAG ('P' IN ZQM)
+
3751 C IF FAIL FLAG ON WIND, ENTIRE REPORT GETS FAIL FLAG ('F' IN ZQM)
+
3752 C IF FAIL FLAG ON TEMP, ENTIRE REPORT GETS FAIL FLAG ('F' IN ZQM)
+
3753 C -----------------------------------------------------------------
+
3754 
+
3755  IF(arr(5,l).EQ.0.AND.(arr(2,l).LT.10.OR.arr(2,l).GT.15))THEN
+
3756  arr(4,l) = 0
+
3757  ELSE IF(arr(5,l).EQ.14.OR.arr(2,l).EQ.14) THEN
+
3758  arr(4,l) = 14
+
3759  ELSE IF(arr(5,l).EQ.13.OR.arr(2,l).EQ.13) THEN
+
3760  arr(4,l) = 13
+
3761  END IF
+
3762  pqm(l) = ' '
+
3763  tqm(l) = ' '
+
3764  qqm(l) = ' '
+
3765  zqm(l) = e35o29(arr(4,l))
+
3766 
+
3767 C DEGREE OF TURBULENCE IS STORED IN MOISTURE Q.M. SLOT
+
3768 C ----------------------------------------------------
+
3769 
+
3770  IF(nint(dgt).LT.15) qqm(l) = cturb(nint(dgt))
+
3771  ENDDO
+
3772 
+
3773 C DEFAULT Q.MARK FOR WIND: "C"
+
3774 C ----------------------------
+
3775 
+
3776  wqm(1) = 'C'
+
3777  END IF
+
3778 
+
3779 C PUT THE UNPACKED ON29 REPORT INTO OBS
+
3780 C -------------------------------------
+
3781 
+
3782  rsv2 = ' '
+
3783  CALL s01o29(sid,xob,yob,rhr,rch,rsv,rsv2,elv,itp,rtp)
+
3784  CALL s02o29(6,1,*9999)
+
3785 
+
3786 C ------------------------------------------------------------------
+
3787 C MISC DATA GOES INTO CATEGORY 08
+
3788 C ------------------------------------------------------------------
+
3789 C CODE FIGURE 021 - REPORT SEQUENCE NUMBER
+
3790 C CODE FIGURE 917 - CHARACTERS 1 AND 2 OF ACTUAL STATION IDENTIFICATION
+
3791 C (CURRENTLY ONLY FOR ASDAR/AMDAR)
+
3792 C CODE FIGURE 918 - CHARACTERS 3 AND 4 OF ACTUAL STATION IDENTIFICATION
+
3793 C (CURRENTLY ONLY FOR ASDAR/AMDAR)
+
3794 C CODE FIGURE 919 - CHARACTERS 5 AND 6 OF ACTUAL STATION IDENTIFICATION
+
3795 C (CURRENTLY ONLY FOR ASDAR/AMDAR)
+
3796 C CODE FIGURE 920 - CHARACTERS 7 AND 8 OF ACTUAL STATION IDENTIFICATION
+
3797 C (CURRENTLY ONLY FOR ASDAR/AMDAR AND ACARS)
+
3798 C CODE FIGURE 921 - OBSERVATION TIME TO NEAREST 1000'TH OF AN HOUR
+
3799 C (CURRENTLY ONLY FOR ACARS)
+
3800 C CODE FIGURE 922 - FIRST TWO CHARACTERS OF BULLETIN BEING MONITORED
+
3801 C CODE FIGURE 923 - LAST TWO CHARACTERS OF BULLETIN BEING MONITORED
+
3802 C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S
+
3803 C ------------------------------------------------------------------
+
3804 
+
3805  IF(subset.EQ.'NC004004') THEN
+
3806  ob8(1) = kndx
+
3807  cf8(1) = 21
+
3808  q81(1) = ' '
+
3809  q82(1) = ' '
+
3810  CALL s02o29(8,1,*9999)
+
3811  ob8(1) = 99999.
+
3812  q81(1) = sid(7:7)
+
3813  q82(1) = sid(8:8)
+
3814  cf8(1) = 920
+
3815  CALL s02o29(8,1,*9999)
+
3816  IF(rhr.LT.bmiss) THEN
+
3817  ob8(1) = nint((rhr*1000.)+0.0000001)
+
3818  cf8(1) = 921
+
3819  q81(1) = ' '
+
3820  q82(1) = ' '
+
3821  CALL s02o29(8,1,*9999)
+
3822  END IF
+
3823  ELSE IF(subset.EQ.'NC004003') THEN
+
3824  DO kkk = 1,4
+
3825  ob8(kkk) = 99999.
+
3826  q81(kkk) = sido(2*kkk-1:2*kkk-1)
+
3827  q82(kkk) = sido(2*kkk:2*kkk)
+
3828  cf8(kkk) = 916 + kkk
+
3829  CALL s02o29(8,kkk,*9999)
+
3830  ENDDO
+
3831  END IF
+
3832  IF(ccl.NE.' ') THEN
+
3833  ob8(2) = 99999.
+
3834  q81(2) = ccl(1:1)
+
3835  q82(2) = ccl(2:2)
+
3836  cf8(2) = 922
+
3837  CALL s02o29(8,2,*9999)
+
3838  ob8(3) = 99999.
+
3839  q81(3) = ccl(3:3)
+
3840  q82(3) = ccl(4:4)
+
3841  cf8(3) = 923
+
3842  CALL s02o29(8,3,*9999)
+
3843  END IF
+
3844  IF(wspd1.LT.bmiss) THEN
+
3845  ob8(4) = nint(wspd1*10.)
+
3846  cf8(4) = 924
+
3847  q81(4) = ' '
+
3848  q82(4) = ' '
+
3849  CALL s02o29(8,4,*9999)
+
3850  END IF
+
3851 
+
3852  CALL s03o29(obs,subset,*9999,*9998)
+
3853 
+
3854  RETURN
+
3855 
+
3856  9999 CONTINUE
+
3857  r05o29 = 999
+
3858  RETURN
+
3859 
+
3860  9998 CONTINUE
+
3861  print'(" IW3UNP29/R05O29: RPT with ID= ",A," TOSSED - ZERO ",
+
3862  $ "CAT.1-6,51,52 LVLS")', sid
+
3863  r05o29 = -9999
+
3864  kskacf(1) = kskacf(1) + 1
+
3865  RETURN
+
3866 
+
3867  END
+
3868 C***********************************************************************
+
3869 C***********************************************************************
+
3870 C***********************************************************************
+
3871  FUNCTION r06o29(LUNIT,OBS)
+
3872 C ---> formerly FUNCTION SATWND
+
3873 
+
3874  common/io29ee/pob(255),qob(255),tob(255),zob(255),dob(255),
+
3875  $ sob(255),vsg(255),clp(255),cla(255),ob8(255),
+
3876  $ cf8(255)
+
3877  common/io29ff/pqm(255),qqm(255),tqm(255),zqm(255),wqm(255),
+
3878  $ qcp(255),qca(255),q81(255),q82(255)
+
3879  common/io29cc/subset,idat10
+
3880  common/io29bb/kndx,kskacf(8),kskupa,ksksfc,ksksat,ksksmi
+
3881  common/io29kk/kount(499,18)
+
3882  common/io29ll/bmiss
+
3883 
+
3884  CHARACTER*80 hdstr,lvstr,qmstr,rcstr
+
3885  CHARACTER*8 subset,sid,e35o29,rsv,rsv2
+
3886  CHARACTER*3 cindx3
+
3887  CHARACTER*1 pqm,qqm,tqm,zqm,wqm,qcp,qca,q81,q82,csat(499),
+
3888  $ cprd(9),cindx7,c7(26),cprod(0:4),cprdf(3)
+
3889  INTEGER iprdf(3)
+
3890  REAL(8) rid_8,ufbint_8,bmiss
+
3891  REAL(8) hdr_8(20),rct_8(5,255),arr_8(10,255)
+
3892  dimension obs(*),hdr(20),rct(5,255),arr(10,255)
+
3893  equivalence(rid_8,sid)
+
3894 
+
3895  SAVE
+
3896 
+
3897  DATA hdstr/'RPID CLON CLAT HOUR MINU SAID '/
+
3898  DATA lvstr/'PRLC TMDP TMDB WDIR WSPD '/
+
3899  DATA qmstr/'QMPR QMAT QMDD QMGP SWQM '/
+
3900  DATA rcstr/'RCHR RCMI RCTS '/
+
3901 
+
3902  DATA csat /'A','B','C','D',45*'?','Z','W','X','Y','Z','W','X',
+
3903  $ 'Y','Z','W',90*'?','R','O','P','Q','R','O','P','Q','R','O',
+
3904  $ 339*'?','V'/
+
3905  DATA cprod /'C','D','?','?','E'/
+
3906  DATA cprdf /'C','B','V'/
+
3907  DATA iprdf / 1 , 6 , 4 /
+
3908  DATA cprd /'C','V','I','W','P','T','L','Z','G'/
+
3909  DATA c7 /'A','B','C','D','E','F','G','H','I','J','K','L','M',
+
3910  $ 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/
+
3911 
+
3912 C CHECK IF THIS IS A PREPBUFR FILE
+
3913 C --------------------------------
+
3914 
+
3915  r06o29 = 99
+
3916 c#V#V#dak - future
+
3917 cdak IF(SUBSET.EQ.'SATWND') R06O29 = PRPWND(LUNIT,OBS)
+
3918 caaaaadak - future
+
3919  IF(r06o29.NE.99) RETURN
+
3920  r06o29 = 0
+
3921 
+
3922  CALL s05o29
+
3923 
+
3924 C TRY TO FIND FIND THE HEIGHT ASSIGNMENT
+
3925 C --------------------------------------
+
3926 
+
3927  CALL ufbint(lunit,hdr_8,20,1,iret,'HGHT PRLC');hdr=hdr_8
+
3928  elev = bmiss
+
3929  IF(hdr(2).LT.bmiss) elev = e03o29(hdr(2)*.01)
+
3930  IF(hdr(1).LT.bmiss) elev = hdr(1)
+
3931 
+
3932 C PUT THE HEADER INFORMATION INTO ON29 FORMAT
+
3933 C -------------------------------------------
+
3934 
+
3935  CALL ufbint(lunit,hdr_8,20, 1,iret,hdstr);hdr(2:)=hdr_8(2:)
+
3936  CALL ufbint(lunit,rct_8, 5,255,nrct,rcstr);rct=rct_8
+
3937  IF(hdr(5).GE.bmiss) hdr(5) = 0
+
3938  rctim = nint(rct(1,1))+nint(rct(2,1))/60.
+
3939  rid_8 = hdr_8(1)
+
3940  xob = hdr(2)
+
3941  yob = hdr(3)
+
3942  rhr = bmiss
+
3943  IF(hdr(4).LT.bmiss) rhr = nint(hdr(4))+nint(hdr(5))/60.
+
3944  rch = rctim
+
3945  rsv = '990 '
+
3946 
+
3947 C THE 25'TH (RESERVE) CHARACTER IS THE CLOUD MASK/DEEP LAYER INDICATOR
+
3948 C {=2 - CLOUD TOP (NORMAL CLOUD DRIFT), =1 - DEEP LAYER,
+
3949 C =9 - INDICATOR MISSING, THUS REVERTS TO DEFAULT CLOUD TOP}
+
3950 C (=9 FOR ALL BUT U.S. HIGH-DENSITY SATWND TYPES)
+
3951 C --------------------------------------------------------------------
+
3952 
+
3953 C THE 27'TH (RESERVE) CHARACTER INDICATES THE PRODUCER OF THE SATWND
+
3954 C ------------------------------------------------------------------
+
3955 
+
3956 C THE INSTRUMENT TYPE INDICATES THE PRODUCT TYPE
+
3957 C ----------------------------------------------
+
3958 
+
3959  itp = 99
+
3960 
+
3961 C REPROCESS THE STN. ID
+
3962 C ---------------------
+
3963 
+
3964 C REPROCESSED CHAR 1 -----> GOES: BUFR CHAR 1
+
3965 C -----> METEOSAT: SAT. NO. 52, 56 GET 'X'
+
3966 C SAT. NO. 53, 57 GET 'Y'
+
3967 C SAT. NO. 50, 54, 58 GET 'Z'
+
3968 C SAT. NO. 51, 55, 59 GET 'W'
+
3969 C -----> GMS(JA): SAT. NO. 152,156 GET 'P'
+
3970 C SAT. NO. 153,157 GET 'Q'
+
3971 C SAT. NO. 150,154,158 GET 'R'
+
3972 C SAT. NO. 151,155,159 GET 'O'
+
3973 C -----> INSAT: SAT. NO. 499 GET 'V'
+
3974 C REPROCESSED CHAR 2 -----> GOES: RETURNED VALUE IN BUFR FOR 'SWPR'
+
3975 C (PRODUCER)
+
3976 C -----> OTHERS: SAT. PRODUCER -- ESA GET 'C'
+
3977 C -- GMS GET 'D'
+
3978 C -- INSAT GET 'E'
+
3979 C REPROCESSED CHAR 6 -----> GOES: BUFR CHAR 6
+
3980 C -----> OTHERS -- INFRA-RED CLOUD DRIFT GET 'C'
+
3981 C -- VISIBLE CLOUD DRIFT GET 'B'
+
3982 C -- WATER VAPOR GET 'V'
+
3983 C REPROCESSED CHAR 3-5 ---> SEQUENTIAL SERIAL INDEX (001 - 999)
+
3984 C (UNIQUE FOR EACH BUFR CHAR 1/6 COMB.)
+
3985 C REPROCESSED CHAR 7 -----> GROUP NUMBER FOR SERIAL INDEX IN
+
3986 C REPROCESSED CHAR 3-5 (0 - 9, A - Z)
+
3987 C REPROCESSED CHAR 8 -----> ALWAYS BLANK (' ') FOR NOW
+
3988 
+
3989  READ(subset(8:8),'(I1)') inum
+
3990  IF(sid(1:1).GE.'A'.AND.sid(1:1).LE.'D') THEN
+
3991  CALL ufbint(lunit,ufbint_8,1,1,iret,'SWPR');swpr=ufbint_8
+
3992  IF(nint(swpr).GT.0.AND.nint(swpr).LT.10)
+
3993  $ WRITE(rsv(3:3),'(I1)') nint(swpr)
+
3994  sid(2:2) = rsv(3:3)
+
3995  CALL ufbint(lunit,ufbint_8,1,1,iret,'SWTP');swtp=ufbint_8
+
3996  IF(swtp.LT.bmiss) itp = nint(swtp)
+
3997  CALL ufbint(lunit,ufbint_8,1,1,iret,'SWDL');swdl=ufbint_8
+
3998  IF(nint(swdl).GT.-1.AND.nint(swdl).LT.10)
+
3999  $ WRITE(rsv(1:1),'(I1)') nint(swdl)
+
4000  ELSE
+
4001  sid = '????????'
+
4002  IF(nint(hdr(6)).LT.500) THEN
+
4003  sid(1:1) = csat(nint(hdr(6)))
+
4004  sid(2:2) = cprod(nint(hdr(6))/100)
+
4005  rsv(3:3) = sid(2:2)
+
4006  END IF
+
4007  IF(inum.LT.4) THEN
+
4008  sid(6:6) = cprdf(inum)
+
4009  itp = iprdf(inum)
+
4010  END IF
+
4011  END IF
+
4012  cindx3 = '???'
+
4013  cindx7 = '?'
+
4014  IF(nint(hdr(6)).LT.500.AND.itp.LT.19) THEN
+
4015  kount(nint(hdr(6)),itp) = min(kount(nint(hdr(6)),itp)+1,35999)
+
4016  kount3 = mod(kount(nint(hdr(6)),itp),1000)
+
4017  kount7 = int(kount(nint(hdr(6)),itp)/1000)
+
4018  WRITE(cindx3,'(I3.3)') kount3
+
4019  IF(kount7.LT.10) THEN
+
4020  WRITE(cindx7,'(I1.1)') kount7
+
4021  ELSE
+
4022  cindx7 = c7(kount7-9)
+
4023  END IF
+
4024  END IF
+
4025  sid = sid(1:2)//cindx3//sid(6:6)//cindx7//' '
+
4026 
+
4027  elv = elev
+
4028  rtp = e33o29(subset,sid)
+
4029 
+
4030 C PUT THE LEVEL DATA INTO ON29 UNITS
+
4031 C ----------------------------------
+
4032 
+
4033  CALL ufbint(lunit,arr_8,10,255,nlev,lvstr);arr=arr_8
+
4034  DO l=1,nlev
+
4035  pob(l) = e01o29(arr(1,l))
+
4036 
+
4037 C GROSS CHECK ON PRESSURE
+
4038 C -----------------------
+
4039 
+
4040  IF(nint(pob(l)).EQ.0) THEN
+
4041  print'(" ~~IW3UNP29/R06O29: RPT with ID= ",A," TOSSED - ",
+
4042  $ "PRES. IS ZERO MB")', sid
+
4043  r06o29 = -9999
+
4044  ksksat = ksksat + 1
+
4045  RETURN
+
4046  END IF
+
4047 
+
4048  qob(l) = e07o29(arr(2,l),arr(3,l))
+
4049  tob(l) = e06o29(arr(3,l))
+
4050  zob(l) = elev
+
4051  dob(l) = e04o29(arr(4,l),arr(5,l))
+
4052  sob(l) = e05o29(arr(4,l),arr(5,l))
+
4053  ENDDO
+
4054  wspd1 = arr(5,1)
+
4055 
+
4056 C DETERMINE QUALITY MARKERS
+
4057 C -------------------------
+
4058 
+
4059  CALL ufbint(lunit,arr_8,10,255,nlev,qmstr);arr=arr_8
+
4060  CALL ufbint(lunit,ufbint_8,1,1,iret,'RFFL');rffl=ufbint_8
+
4061  IF(rffl.LT.bmiss.AND.(nint(arr(5,1)).EQ.2.OR.nint(arr(5,1)).GE.
+
4062  $ bmiss)) THEN
+
4063  IF(nint(rffl).GT.84) THEN
+
4064  arr(5,1) = 1
+
4065  ELSE IF(nint(rffl).GT.55) THEN
+
4066  arr(5,1) = 2
+
4067  ELSE IF(nint(rffl).GT.49) THEN
+
4068  arr(5,1) = 3
+
4069  ELSE
+
4070  arr(5,1) = 13
+
4071  END IF
+
4072  END IF
+
4073 
+
4074  DO l=1,nlev
+
4075  wqm(l) = e35o29(arr(5,l))
+
4076 
+
4077  IF(wqm(l).EQ.'R'.OR.wqm(l).EQ.'P'.OR.wqm(l).EQ.'F') THEN
+
4078 
+
4079 C A REJECT, PURGE, OR FAIL FLAG ON WIND IS TRANSFERRED TO ALL VARIABLES
+
4080 C ---------------------------------------------------------------------
+
4081 
+
4082  pqm(l) = wqm(l)
+
4083  tqm(l) = wqm(l)
+
4084  qqm(l) = wqm(l)
+
4085  zqm(l) = wqm(l)
+
4086 
+
4087  ELSE
+
4088 
+
4089  pqm(l) = e35o29(arr(1,l))
+
4090  tqm(l) = e35o29(arr(2,l))
+
4091  qqm(l) = e35o29(arr(3,l))
+
4092  zqm(l) = e35o29(arr(4,l))
+
4093 
+
4094  END IF
+
4095 
+
4096  ENDDO
+
4097 
+
4098 C PUT THE UNPACKED ON29 REPORT INTO OBS
+
4099 C -------------------------------------
+
4100 
+
4101  rsv2 = ' '
+
4102  CALL s01o29(sid,xob,yob,rhr,rch,rsv,rsv2,elv,itp,rtp)
+
4103  CALL s02o29(6,1,*9999)
+
4104 
+
4105 C ---------------------------------------------------------------------
+
4106 C MISC DATA GOES INTO CATEGORY 08
+
4107 C ---------------------------------------------------------------------
+
4108 C CODE FIGURE 013 - PRESSURE
+
4109 C CODE FIGURE 920 - CHARACTERS 7 AND 8 OF ACTUAL STATION IDENTIFICATION
+
4110 C (CURRENTLY ONLY APPLIES TO U.S. SATWND TYPES)
+
4111 C CODE FIGURE 924 - WIND SPEED IN 0.01*M/S
+
4112 C ---------------------------------------------------------------------
+
4113 C ---------------------------------------------------------------------
+
4114 
+
4115  IF(pob(1).LT.bmiss) THEN
+
4116  ob8(1) = nint(pob(1)*0.1)
+
4117  cf8(1) = 13
+
4118  q81(1) = ' '
+
4119  q82(1) = ' '
+
4120  CALL s02o29(8,1,*9999)
+
4121  END IF
+
4122  IF(sid(1:1).GE.'A'.AND.sid(1:1).LE.'D') THEN
+
4123  ob8(1) = 99999.
+
4124  q81(1) = sid(7:7)
+
4125  q82(1) = sid(8:8)
+
4126  cf8(1) = 920
+
4127  CALL s02o29(8,1,*9999)
+
4128  END IF
+
4129  IF(wspd1.LT.bmiss) THEN
+
4130  ob8(2) = nint(wspd1*10.)
+
4131  cf8(2) = 924
+
4132  q81(2) = ' '
+
4133  q82(2) = ' '
+
4134  CALL s02o29(8,2,*9999)
+
4135  END IF
+
4136 
+
4137  CALL s03o29(obs,subset,*9999,*9998)
+
4138 
+
4139  RETURN
+
4140 
+
4141  9999 CONTINUE
+
4142  r06o29 = 999
+
4143  RETURN
+
4144 
+
4145  9998 CONTINUE
+
4146  print'(" IW3UNP29/R06O29: RPT with ID= ",A," TOSSED - ZERO ",
+
4147  $ "CAT.1-6,51,52 LVLS")', sid
+
4148  r06o29 = -9999
+
4149  ksksat =ksksat + 1
+
4150  RETURN
+
4151 
+
4152  END
+
4153 C***********************************************************************
+
4154 C***********************************************************************
+
4155 C***********************************************************************
+
4156  FUNCTION r07o29(LUNIT,OBS)
+
4157 C ---> formerly FUNCTION SPSSMI
+
4158 
+
4159  common/io29ee/pob(255),qob(255),tob(255),zob(255),dob(255),
+
4160  $ sob(255),vsg(255),clp(255),cla(255),ob8(255),
+
4161  $ cf8(255)
+
4162  common/io29ff/pqm(255),qqm(255),tqm(255),zqm(255),wqm(255),
+
4163  $ qcp(255),qca(255),q81(255),q82(255)
+
4164  common/io29cc/subset,idat10
+
4165  common/io29bb/kndx,kskacf(8),kskupa,ksksfc,ksksat,ksksmi
+
4166  common/io29ll/bmiss
+
4167 
+
4168  CHARACTER*80 hdstr
+
4169  CHARACTER*8 subset,sid,rsv,rsv2
+
4170  CHARACTER*4 cstdv
+
4171  CHARACTER*1 pqm,qqm,tqm,zqm,wqm,qcp,qca,q81,q82,crf
+
4172  REAL(8) rid_8,ufbint_8,hdr_8(20),tmbr_8(7),addp_8(5),prod_8(2,2)
+
4173  REAL(8) bmiss
+
4174  dimension obs(*),hdr(20),addp(5),prod(2,2),tmbr(7)
+
4175 
+
4176  equivalence(rid_8,sid)
+
4177 
+
4178  SAVE
+
4179 
+
4180  DATA hdstr/'RPID CLON CLAT HOUR MINU SECO NMCT SAID '/
+
4181 
+
4182 C CHECK IF THIS IS A PREPBUFR FILE
+
4183 C --------------------------------
+
4184 
+
4185  r07o29 = 99
+
4186 c#V#V#dak - future
+
4187 cdak IF(SUBSET.EQ.'SPSSMI') R07O29 = PRPSMI(LUNIT,OBS)
+
4188 caaaaadak - future
+
4189  IF(r07o29.NE.99) RETURN
+
4190  r07o29 = 0
+
4191 
+
4192  CALL s05o29
+
4193 
+
4194 C PUT THE HEADER INFORMATION INTO ON29 FORMAT
+
4195 C -------------------------------------------
+
4196 
+
4197  CALL ufbint(lunit,hdr_8,20, 1,iret,hdstr);hdr(2:)=hdr_8(2:)
+
4198  IF(hdr(5).GE.bmiss) hdr(5) = 0
+
4199  IF(hdr(6).GE.bmiss) hdr(6) = 0
+
4200  rid_8 = hdr_8(1)
+
4201  xob = hdr(2)
+
4202  yob = hdr(3)
+
4203  rhr = bmiss
+
4204  IF(hdr(4).LT.bmiss) rhr = nint(hdr(4)) + ((nint(hdr(5)) * 60.) +
+
4205  $ nint(hdr(6)))/3600.
+
4206  rch = 99999.
+
4207  elv = 99999.
+
4208  itp = 99
+
4209  rtp = hdr(7)
+
4210 
+
4211 C CHECK ON VALUE FOR SATELLITE ID TO DETERMINE IF THIS IS A SUPEROB
+
4212 C (SATELLITE ID IS MISSING FOR SUPEROBS)
+
4213 C -----------------------------------------------------------------
+
4214 
+
4215  isupob = 1
+
4216  IF(hdr(8).LT.bmiss) isupob = 0
+
4217 
+
4218 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
4219 
+
4220  stdv = bmiss
+
4221 
+
4222 C PUT THE SSM/I DATA INTO ON29 UNITS (WILL RETURN TO HEADER DATA LATER)
+
4223 C ALL PROCESSING GOES INTO CATEGORY 08
+
4224 C ---------------------------------------------------------------------
+
4225 
+
4226  IF(rtp.EQ.68) THEN
+
4227 C ---------------------------------------------------------------------
+
4228 C ** 7-CHANNEL BRIGHTNESS TEMPERATURES -- REPORT TYPE 68 **
+
4229 C ---------------------------------------------------------------------
+
4230 C CODE FIGURE 189 - 19 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4231 C CODE FIGURE 190 - 19 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4232 C CODE FIGURE 191 - 22 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4233 C CODE FIGURE 192 - 37 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4234 C CODE FIGURE 193 - 37 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4235 C CODE FIGURE 194 - 85 GHZ V BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4236 C CODE FIGURE 195 - 85 GHZ H BRIGHTNESS TEMPERATURE (DEG. K X 100)
+
4237 C ---------------------------------------------------------------------
+
4238  nlcat8 = 7
+
4239  CALL ufbint(lunit,tmbr_8,1,7,nlev,'TMBR');tmbr=tmbr_8
+
4240  DO nchn = 1,7
+
4241  ob8(nchn) = min(nint(tmbr(nchn)*100.),99999)
+
4242  cf8(nchn) = 188 + nchn
+
4243  ENDDO
+
4244  ELSE IF(rtp.EQ.575) THEN
+
4245 C ---------------------------------------------------------------------
+
4246 C ** ADDITIONAL PRODUCTS -- REPORT TYPE 575 **
+
4247 C ---------------------------------------------------------------------
+
4248 C CODE FIGURE 210 - SURFACE TAG (RANGE: 0,1,3-6)
+
4249 C CODE FIGURE 211 - ICE CONCENTRATION (PERCENT)
+
4250 C CODE FIGURE 212 - ICE AGE (RANGE: 0,1)
+
4251 C CODE FIGURE 213 - ICE EDGE (RANGE: 0,1)
+
4252 C CODE FIGURE 214 - CALCULATED SURFACE TYPE (RANGE: 1-20)
+
4253 C ---------------------------------------------------------------------
+
4254  nlcat8 = 5
+
4255  CALL ufbint(lunit,addp_8,5,1,iret,'SFTG ICON ICAG ICED SFTP')
+
4256  addp=addp_8
+
4257  DO nadd = 1,5
+
4258  IF(addp(nadd).LT.bmiss) THEN
+
4259  ob8(nadd) = nint(addp(nadd))
+
4260  cf8(nadd) = 209 + nadd
+
4261  END IF
+
4262  ENDDO
+
4263  ELSE IF(rtp.EQ.571) THEN
+
4264 C ---------------------------------------------------------------------
+
4265 C ** OCEAN SURFACE WIND SPEED PRODUCT -- REPORT TYPE 571 **
+
4266 C ---------------------------------------------------------------------
+
4267 C CODE FIGURE 196 - OCEANIC WIND SPEED (M/S * 10)
+
4268 C (RAIN FLAG IN Q.M. BYTE 2)
+
4269 C ---------------------------------------------------------------------
+
4270  cf8(1) = 196
+
4271  elv = 0
+
4272  nlcat8 = 1
+
4273  IF(isupob.EQ.1) THEN
+
4274  CALL ufbrep(lunit,prod_8,2,2,iret,'FOST WSOS');prod=prod_8
+
4275  DO jj = 1,2
+
4276  IF(prod(1,jj).EQ.4) THEN
+
4277  ob8(1) = nint(prod(2,jj)*10.)
+
4278  ELSE IF(prod(1,jj).EQ.10) THEN
+
4279  stdv = nint(prod(2,jj)*100.)
+
4280  END IF
+
4281  ENDDO
+
4282  ELSE
+
4283  CALL ufbint(lunit,ufbint_8,1,1,iret,'WSOS');prodn=ufbint_8
+
4284  ob8(1) = nint(prodn*10.)
+
4285  CALL ufbint(lunit,ufbint_8,1,1,iret,'RFLG');rflg=ufbint_8
+
4286  IF(rflg.LT.bmiss) THEN
+
4287  WRITE(crf,'(I1.1)') nint(rflg)
+
4288  q82(1) = crf
+
4289  END IF
+
4290  END IF
+
4291  ELSE IF(rtp.EQ.65) THEN
+
4292 C ---------------------------------------------------------------------
+
4293 C ** OCEAN TOTAL PRECIPITABLE WATER PRODUCT -- REPORT TYPE 65 **
+
4294 C ---------------------------------------------------------------------
+
4295 C CODE FIGURE 197 - TOTAL PRECIPITABLE WATER (MM * 10)
+
4296 C (RAIN FLAG IN Q.M. BYTE 2)
+
4297 C ---------------------------------------------------------------------
+
4298  cf8(1) = 197
+
4299  elv = 0
+
4300  nlcat8 = 1
+
4301  IF(isupob.EQ.1) THEN
+
4302  CALL ufbrep(lunit,prod_8,2,2,iret,'FOST PH2O');prod=prod_8
+
4303  DO jj = 1,2
+
4304  IF(prod(1,jj).EQ.4) THEN
+
4305  ob8(1) = nint(prod(2,jj)*10.)
+
4306  ELSE IF(prod(1,jj).EQ.10) THEN
+
4307  stdv = nint(prod(2,jj)*100.)
+
4308  END IF
+
4309  ENDDO
+
4310  ELSE
+
4311  CALL ufbint(lunit,ufbint_8,1,1,iret,'PH2O');prodn=ufbint_8
+
4312  ob8(1) = nint(prodn*10.)
+
4313  CALL ufbint(lunit,ufbint_8,1,1,iret,'RFLG');rflg=ufbint_8
+
4314  IF(rflg.LT.bmiss) THEN
+
4315  WRITE(crf,'(I1)') nint(rflg)
+
4316  q82(1) = crf
+
4317  END IF
+
4318  END IF
+
4319  ELSE IF(rtp.EQ.66) THEN
+
4320 C ---------------------------------------------------------------------
+
4321 C ** LAND/OCEAN RAINFALL RATE -- REPORT TYPE 66 **
+
4322 C ---------------------------------------------------------------------
+
4323 C CODE FIGURE 198 - RAINFALL RATE (MM/HR)
+
4324 C ---------------------------------------------------------------------
+
4325  cf8(1) = 198
+
4326  nlcat8 = 1
+
4327  IF(isupob.EQ.1) THEN
+
4328  CALL ufbrep(lunit,prod_8,2,2,iret,'FOST REQV');prod=prod_8
+
4329  DO jj = 1,2
+
4330  IF(prod(1,jj).EQ.4) THEN
+
4331  ob8(1) = nint(prod(2,jj)*3600.)
+
4332  ELSE IF(prod(1,jj).EQ.10) THEN
+
4333  stdv = nint(prod(2,jj)*36000.)
+
4334  END IF
+
4335  ENDDO
+
4336  ELSE
+
4337  CALL ufbint(lunit,ufbint_8,1,1,iret,'REQV');prodn=ufbint_8
+
4338  ob8(1) = nint(prodn*3600.)
+
4339  END IF
+
4340  ELSE IF(rtp.EQ.576) THEN
+
4341 C ---------------------------------------------------------------------
+
4342 C ** SURFACE TEMPERATURE -- REPORT TYPE 576 **
+
4343 C ---------------------------------------------------------------------
+
4344 C CODE FIGURE 199 - SURFACE TEMPERATURE (DEGREES KELVIN)
+
4345 C ---------------------------------------------------------------------
+
4346  cf8(1) = 199
+
4347  nlcat8 = 1
+
4348  IF(isupob.EQ.1) THEN
+
4349  CALL ufbrep(lunit,prod_8,2,2,iret,'FOST TMSK');prod=prod_8
+
4350  DO jj = 1,2
+
4351  IF(prod(1,jj).EQ.4) THEN
+
4352  ob8(1) = nint(prod(2,jj))
+
4353  ELSE IF(prod(1,jj).EQ.10) THEN
+
4354  stdv = nint(prod(2,jj)*10.)
+
4355  END IF
+
4356  ENDDO
+
4357  ELSE
+
4358  CALL ufbint(lunit,ufbint_8,1,1,iret,'TMSK');prodn=ufbint_8
+
4359  ob8(1) = nint(prodn)
+
4360  END IF
+
4361  ELSE IF(rtp.EQ.69) THEN
+
4362 C ---------------------------------------------------------------------
+
4363 C ** OCEAN CLOUD WATER -- REPORT TYPE 69 **
+
4364 C ---------------------------------------------------------------------
+
4365 C CODE FIGURE 200 - CLOUD WATER (MM * 100)
+
4366 C ---------------------------------------------------------------------
+
4367  cf8(1) = 200
+
4368  elv = 0
+
4369  nlcat8 = 1
+
4370  IF(isupob.EQ.1) THEN
+
4371  CALL ufbrep(lunit,prod_8,2,2,iret,'FOST CH2O');prod=prod_8
+
4372  DO jj = 1,2
+
4373  IF(prod(1,jj).EQ.4) THEN
+
4374  ob8(1) = nint(prod(2,jj)*100.)
+
4375  ELSE IF(prod(1,jj).EQ.10) THEN
+
4376  stdv = nint(prod(2,jj)*1000.)
+
4377  END IF
+
4378  ENDDO
+
4379  ELSE
+
4380  CALL ufbint(lunit,ufbint_8,1,1,iret,'CH2O');prodn=ufbint_8
+
4381  ob8(1) = nint(prodn*100.)
+
4382  END IF
+
4383  ELSE IF(rtp.EQ.573) THEN
+
4384 C ---------------------------------------------------------------------
+
4385 C ** SOIL MOISTURE -- REPORT TYPE 573 **
+
4386 C ---------------------------------------------------------------------
+
4387 C CODE FIGURE 201 - SOIL MOISTURE (MM)
+
4388 C ---------------------------------------------------------------------
+
4389  cf8(1) = 201
+
4390  nlcat8 = 1
+
4391  IF(isupob.EQ.1) THEN
+
4392  CALL ufbrep(lunit,prod_8,2,2,iret,'FOST SMOI');prod=prod_8
+
4393  DO jj = 1,2
+
4394  IF(prod(1,jj).EQ.4) THEN
+
4395  ob8(1) = nint(prod(2,jj)*1000.)
+
4396  ELSE IF(prod(1,jj).EQ.10) THEN
+
4397  stdv = nint(prod(2,jj)*10000.)
+
4398  END IF
+
4399  ENDDO
+
4400  ELSE
+
4401  CALL ufbint(lunit,ufbint_8,1,1,iret,'SMOI');prodn=ufbint_8
+
4402  ob8(1) = nint(prodn*1000.)
+
4403  END IF
+
4404  ELSE IF(rtp.EQ.574) THEN
+
4405 C ---------------------------------------------------------------------
+
4406 C ** SNOW DEPTH -- REPORT TYPE 574 **
+
4407 C ---------------------------------------------------------------------
+
4408 C CODE FIGURE 202 - SNOW DEPTH (MM)
+
4409 C ---------------------------------------------------------------------
+
4410  cf8(1) = 202
+
4411  nlcat8 = 1
+
4412  IF(isupob.EQ.1) THEN
+
4413  CALL ufbrep(lunit,prod_8,2,2,iret,'FOST SNDP');prod=prod_8
+
4414  DO jj = 1,2
+
4415  IF(prod(1,jj).EQ.4) THEN
+
4416  ob8(1) = nint(prod(2,jj)*1000.)
+
4417  ELSE IF(prod(1,jj).EQ.10) THEN
+
4418  stdv = nint(prod(2,jj)*10000.)
+
4419  END IF
+
4420  ENDDO
+
4421  ELSE
+
4422  CALL ufbint(lunit,ufbint_8,1,1,iret,'SNDP');prodn=ufbint_8
+
4423  ob8(1) = nint(prodn*1000.)
+
4424  END IF
+
4425  END IF
+
4426 
+
4427 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
4428 
+
4429 C FINISH PUTTING THE HEADER INFORMATION INTO ON29 FORMAT
+
4430 C ------------------------------------------------------
+
4431 
+
4432  rsv = '999 '
+
4433  rsv2 = ' '
+
4434 
+
4435  IF(stdv.LT.bmiss) THEN
+
4436  WRITE(cstdv,'(I4.4)') nint(stdv)
+
4437  ELSE
+
4438  cstdv = '9999'
+
4439  END IF
+
4440  rsv2(3:4) = cstdv(1:2)
+
4441  rsv(1:2) = cstdv(3:4)
+
4442 
+
4443  CALL ufbint(lunit,ufbint_8,1,1,iret,'ACAV');acav=ufbint_8
+
4444  IF(acav.LT.bmiss) THEN
+
4445  WRITE(cstdv(1:2),'(I2.2)') nint(acav)
+
4446  ELSE
+
4447  cstdv = '9999'
+
4448  END IF
+
4449  rsv2(1:2) = cstdv(1:2)
+
4450 
+
4451  CALL s01o29(sid,xob,yob,rhr,rch,rsv,rsv2,elv,itp,rtp)
+
4452 
+
4453  DO ii = 1,nlcat8
+
4454  IF(cf8(ii).LT.bmiss) CALL s02o29(8,ii,*9999)
+
4455  ENDDO
+
4456 
+
4457 C PUT THE UNPACKED ON29 REPORT INTO OBS
+
4458 C -------------------------------------
+
4459 
+
4460  CALL s03o29(obs,subset,*9999,*9998)
+
4461 
+
4462  RETURN
+
4463  9999 CONTINUE
+
4464  r07o29 = 999
+
4465  RETURN
+
4466  9998 CONTINUE
+
4467  print'(" IW3UNP29/R07O29: RPT with ID= ",A," TOSSED - ZERO ",
+
4468  $ "CAT.1-6,8,51,52 LVLS")', sid
+
4469  r07o29 = -9999
+
4470  ksksmi = ksksmi + 1
+
4471  RETURN
+
4472  END
+
4473 
+
4474 C> This subrountine modifies amdar reports so that last character ends
+
4475 C> with 'Z'.
+
4476 C> @param[in] IDEN Acft id
+
4477 C> @param[out] ID Modified aircraft id.
+
4478 C>
+
4479 C> @author RAY CRAYTON @date 1992-02-16
+
4480 
+
4481  SUBROUTINE s06o29(IDEN,ID)
+
4482 C ---> formerly SUBROUTINE IDP
+
4483 
+
4484  CHARACTER*8 IDEN,ID
+
4485  CHARACTER*6 ZEROES
+
4486  CHARACTER*1 JCHAR
+
4487 
+
4488  SAVE
+
4489 
+
4490  DATA zeroes/'000000'/
+
4491 
+
4492  id = ' '
+
4493 
+
4494  l = index(iden(1:8),' ')
+
4495  IF(l.EQ.0) THEN
+
4496  n = 8
+
4497  ELSE
+
4498  n = l - 1
+
4499  IF(n.LT.1) THEN
+
4500  id = 'AMDARZ'
+
4501  END IF
+
4502  END IF
+
4503 
+
4504  IF(n.EQ.8) THEN
+
4505  IF(iden(8:8).EQ.'Z') THEN
+
4506 
+
4507 C THE ID INDICATES IT IS AN 8-CHARACTER ASDAR REPORT. COMPRESS IT BY
+
4508 C DELETING THE 6TH AND 7TH CHARACTER
+
4509 C ------------------------------------------------------------------
+
4510 
+
4511  id = iden(1:5)//'Z'
+
4512  GO TO 500
+
4513  END IF
+
4514  END IF
+
4515 
+
4516  l = i05o29(iden(1:1),7,jchar)
+
4517 
+
4518  IF(l.EQ.0.OR.l.GT.6.OR.n.GT.6) THEN
+
4519 
+
4520 C UP THROUGH 6 CHARACTERS ARE LETTERS. CHANGE 6TH CHARACTER TO 'Z'
+
4521 C ---------------------------------------------------------------
+
4522 
+
4523  IF(n.GE.5) THEN
+
4524  id = iden
+
4525  id(6:6) = 'Z'
+
4526  ELSE
+
4527 
+
4528 C ZERO FILL AND ADD 'Z' TO MAKE 6 CHARAACTERS
+
4529 C -------------------------------------------
+
4530 
+
4531  id = iden(1:n)//zeroes(n+1:5)//'Z'
+
4532  END IF
+
4533 
+
4534  ELSE IF(n.EQ.6) THEN
+
4535 
+
4536 C THE IDEN HAS 6 NUMERIC OR ALPHANUMERIC CHARACTERS
+
4537 C -------------------------------------------------
+
4538 
+
4539  IF(iden(6:6).EQ.'Z') THEN
+
4540  id = iden(1:6)
+
4541  ELSE IF(l.GT.3) THEN
+
4542  id = iden(1:3)//iden(5:6)//'Z'
+
4543  ELSE IF(l.EQ.1) THEN
+
4544  id = iden(2:6)//'Z'
+
4545  ELSE
+
4546  id = iden(1:l-1)//iden(l+1:6)//'Z'
+
4547  END IF
+
4548 
+
4549  ELSE IF(n.EQ.5) THEN
+
4550 
+
4551 C THE IDEN HAS 5 NUMERIC OR ALPHANUMERIC CHARACTERS
+
4552 C -------------------------------------------------
+
4553 
+
4554  id = iden(1:5)//'Z'
+
4555  ELSE
+
4556 
+
4557 C THE IDEN HAS 1-4 NUMERIC OR ALPHANUMERIC CHARACTERS
+
4558 C ---------------------------------------------------
+
4559 
+
4560  IF(l.EQ.1) THEN
+
4561  id = zeroes(1:5-n)//iden(1:n)//'Z'
+
4562  ELSE
+
4563  IF(n.LT.l) THEN
+
4564  iden(1:6) = 'AMDARZ'
+
4565  ELSE
+
4566  id = iden(1:l-1)// zeroes(1:5-n)//iden(l:n)//'Z'
+
4567  END IF
+
4568  END IF
+
4569  END IF
+
4570 
+
4571  500 CONTINUE
+
4572  RETURN
+
4573  END
+
4574 
+
4575 C> This function finds the location of the next numeric character
+
4576 C> in a string of characters.
+
4577 C>
+
4578 C> @param[in] STRING Character array.
+
4579 C> @param[in] NUM Number of characters to search in string.
+
4580 C> @param[out] CHAR Character found.
+
4581 C> @return I05O29 Integer*4 location of alphanumeric character, = 0 if not found.
+
4582 C> @author Ray Crayton @date 1989-07-07
+
4583 C>
+
4584  FUNCTION i05o29(STRING,NUM,CHAR)
+
4585 C ---> formerly FUNCTION IFIG
+
4586  CHARACTER*1 string(1),char
+
4587 
+
4588  SAVE
+
4589 
+
4590  DO i = 1,num
+
4591  IF(string(i).GE.'0'.AND.string(i).LE.'9') THEN
+
4592  i05o29 = i
+
4593  char = string(i)
+
4594  GO TO 200
+
4595  END IF
+
4596  ENDDO
+
4597  i05o29 = 0
+
4598  char = '?'
+
4599  200 CONTINUE
+
4600  RETURN
+
4601  END
+
+
+
aea
subroutine aea(IA, IE, NC)
Program history log:
Definition: aea.f:41
+
r01o29
function r01o29(SUBSET, LUNIT, OBS)
This function read subset and returns corresponding file data.
Definition: iw3unp29.f:982
+
iw3unp29
function iw3unp29(LUNIT, OBS, IER)
This routine has not been tested reading input data from any dump type in ON29/124 format on WCOSS.
Definition: iw3unp29.f:271
+
i03o29
function i03o29(NUNIT, OBS, IER)
This function reads a true (see *) on29/124 data set and unpacks one report into the unpacked office ...
Definition: iw3unp29.f:696
+
w3fa03
subroutine w3fa03(PRESS, HEIGHT, TEMP, THETA)
Computes the standard height, temperature, and potential temperature given the pressure in millibars ...
Definition: w3fa03.f:28
+
s06o29
subroutine s06o29(IDEN, ID)
This subrountine modifies amdar reports so that last character ends with 'Z'.
Definition: iw3unp29.f:4482
+
c01o29
character *6 function c01o29(SUBSET)
This function read subset and returns group name.
Definition: iw3unp29.f:930
+
orders
subroutine orders(IN, ISORT, IDATA, INDEX, N, M, I1, I2)
Orders is a fast and stable sort routine suitable for efficient, multiple-pass sorting on variable le...
Definition: orders.f:86
+
i01o29
function i01o29(LUNIT, HDR, IER)
This function read obs files and returns error message.
Definition: iw3unp29.f:477
+
i05o29
function i05o29(STRING, NUM, CHAR)
This function finds the location of the next numeric character in a string of characters.
Definition: iw3unp29.f:4585
+
i02o29
function i02o29(LUNIT, OBS, IER)
This function read obs files and returns error message.
Definition: iw3unp29.f:546
+
w3fi64
subroutine w3fi64(COCBUF, LOCRPT, NEXT)
Unpacks an array of upper-air reports that are packed in the format described by NMC office note 29,...
Definition: w3fi64.f:393
+ + + + diff --git a/ver-2.10.0/ixgb_8f.html b/ver-2.10.0/ixgb_8f.html new file mode 100644 index 00000000..b3a8ea53 --- /dev/null +++ b/ver-2.10.0/ixgb_8f.html @@ -0,0 +1,204 @@ + + + + + + + +NCEPLIBS-w3emc: ixgb.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
ixgb.f File Reference
+
+
+ +

This subprogram makes one index record. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine ixgb (LUGB, LSKIP, LGRIB, NLEN, NNUM, MLEN, CBUF)
 Byte 001-004: Bytes to skip in data file before grib message. More...
 
+

Detailed Description

+

This subprogram makes one index record.

+
Author
Mark iredell
+
Date
1995-10-31
+ +

Definition in file ixgb.f.

+

Function/Subroutine Documentation

+ +

◆ ixgb()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine ixgb ( LUGB,
 LSKIP,
 LGRIB,
 NLEN,
 NNUM,
 MLEN,
character, dimension(*) CBUF 
)
+
+ +

Byte 001-004: Bytes to skip in data file before grib message.

+

Byte 005-008: Bytes to skip in message before pds. Byte 009-012: Bytes to skip in message before gds (0 if no gds). Byte 013-016: Bytes to skip in message before bms (0 if no bms). Byte 017-020: Bytes to skip in message before bds. Byte 021-024: Bytes total in the message. Byte 025-025: Grib version number. Byte 026-053: Product definition section (pds). Byte 054-095: Grid definition section (gds) (or nulls). Byte 096-101: First part of the bit map section (bms) (or nulls). Byte 102-112: First part of the binary data section (bds). Byte 113-172: (optional) bytes 41-100 of the pds. Byte 173-184: (optional) bytes 29-40 of the pds. Byte 185-320: (optional) bytes 43-178 of the gds.

+

Program history log:

    +
  • Mark iredell 1995-10-31
    • +
  • Mark iredell 1996-10-31 Augmented optional definitions to byte 320.
    • +
  • Mark iredell 2001-06-05 Apply linux port by ebisuzaki.
    • +
+
Parameters
+ + + + + + + + +
[in]LUGBInteger logical unit of input grib file.
[in]LSKIPInteger number of bytes to skip before grib message.
[in]LGRIBInteger number of bytes in grib message.
[in]NLENInteger length of each index record in bytes.
[in]NNUMInteger index record number to make.
[out]MLENInteger actual valid length of index record.
[out]CBUFCharacter*1 (mbuf) buffer to receive index data.
+
+
+
Author
Mark iredell
+
Date
1995-10-31
+ +

Definition at line 36 of file ixgb.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/ixgb_8f.js b/ver-2.10.0/ixgb_8f.js new file mode 100644 index 00000000..324f83a3 --- /dev/null +++ b/ver-2.10.0/ixgb_8f.js @@ -0,0 +1,4 @@ +var ixgb_8f = +[ + [ "ixgb", "ixgb_8f.html#a21b5f70c2205bfb68df79fbb83928066", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/ixgb_8f_source.html b/ver-2.10.0/ixgb_8f_source.html new file mode 100644 index 00000000..4b5ac612 --- /dev/null +++ b/ver-2.10.0/ixgb_8f_source.html @@ -0,0 +1,247 @@ + + + + + + + +NCEPLIBS-w3emc: ixgb.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
ixgb.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief This subprogram makes one index record.
+
3 C> @author Mark iredell @date 1995-10-31
+
4 
+
5 C> Byte 001-004: Bytes to skip in data file before grib message.
+
6 C> Byte 005-008: Bytes to skip in message before pds.
+
7 C> Byte 009-012: Bytes to skip in message before gds (0 if no gds).
+
8 C> Byte 013-016: Bytes to skip in message before bms (0 if no bms).
+
9 C> Byte 017-020: Bytes to skip in message before bds.
+
10 C> Byte 021-024: Bytes total in the message.
+
11 C> Byte 025-025: Grib version number.
+
12 C> Byte 026-053: Product definition section (pds).
+
13 C> Byte 054-095: Grid definition section (gds) (or nulls).
+
14 C> Byte 096-101: First part of the bit map section (bms) (or nulls).
+
15 C> Byte 102-112: First part of the binary data section (bds).
+
16 C> Byte 113-172: (optional) bytes 41-100 of the pds.
+
17 C> Byte 173-184: (optional) bytes 29-40 of the pds.
+
18 C> Byte 185-320: (optional) bytes 43-178 of the gds.
+
19 C>
+
20 C> Program history log:
+
21 C> - Mark iredell 1995-10-31
+
22 C> - Mark iredell 1996-10-31 Augmented optional definitions to byte 320.
+
23 C> - Mark iredell 2001-06-05 Apply linux port by ebisuzaki.
+
24 C>
+
25 C> @param[in] LUGB Integer logical unit of input grib file.
+
26 C> @param[in] LSKIP Integer number of bytes to skip before grib message.
+
27 C> @param[in] LGRIB Integer number of bytes in grib message.
+
28 C> @param[in] NLEN Integer length of each index record in bytes.
+
29 C> @param[in] NNUM Integer index record number to make.
+
30 C> @param[out] MLEN Integer actual valid length of index record.
+
31 C> @param[out] CBUF Character*1 (mbuf) buffer to receive index data.
+
32 C>
+
33 C> @author Mark iredell @date 1995-10-31
+
34 C-----------------------------------------------------------------------
+
35  SUBROUTINE ixgb(LUGB,LSKIP,LGRIB,NLEN,NNUM,MLEN,CBUF)
+
36  CHARACTER CBUF(*)
+
37  parameter(lindex=112,mindex=320)
+
38  parameter(ixskp=0,ixspd=4,ixsgd=8,ixsbm=12,ixsbd=16,ixlen=20,
+
39  & ixver=24,ixpds=25,ixgds=53,ixbms=95,ixbds=101,
+
40  & ixpdx=112,ixpdw=172,ixgdx=184)
+
41  parameter(mxskp=4,mxspd=4,mxsgd=4,mxsbm=4,mxsbd=4,mxlen=4,
+
42  & mxver=1,mxpds=28,mxgds=42,mxbms=6,mxbds=11,
+
43  & mxpdx=60,mxpdw=12,mxgdx=136)
+
44  CHARACTER CBREAD(MINDEX),CINDEX(MINDEX)
+
45 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
46 C INITIALIZE INDEX RECORD AND READ GRIB MESSAGE
+
47  mlen=lindex
+
48  cindex=char(0)
+
49  CALL sbytec(cindex,lskip,8*ixskp,8*mxskp)
+
50  CALL sbytec(cindex,lgrib,8*ixlen,8*mxlen)
+
51 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
52 C PUT PDS IN INDEX RECORD
+
53  iskpds=8
+
54  ibskip=lskip
+
55  ibread=iskpds+mxpds
+
56  CALL baread(lugb,ibskip,ibread,lbread,cbread)
+
57  IF(lbread.NE.ibread) RETURN
+
58  cindex(ixver+1)=cbread(8)
+
59  CALL sbytec(cindex,iskpds,8*ixspd,8*mxspd)
+
60  CALL gbytec(cbread,lenpds,8*iskpds,8*3)
+
61  CALL gbytec(cbread,incgds,8*iskpds+8*7+0,1)
+
62  CALL gbytec(cbread,incbms,8*iskpds+8*7+1,1)
+
63  ilnpds=min(lenpds,mxpds)
+
64  cindex(ixpds+1:ixpds+ilnpds)=cbread(iskpds+1:iskpds+ilnpds)
+
65  isktot=iskpds+lenpds
+
66 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
67 C PUT PDS EXTENSION IN INDEX RECORD
+
68  IF(lenpds.GT.mxpds) THEN
+
69  iskpdw=iskpds+mxpds
+
70  ilnpdw=min(lenpds-mxpds,mxpdw)
+
71  ibskip=lskip+iskpdw
+
72  ibread=ilnpdw
+
73  CALL baread(lugb,ibskip,ibread,lbread,cbread)
+
74  IF(lbread.NE.ibread) RETURN
+
75  cindex(ixpdw+1:ixpdw+ilnpdw)=cbread(1:ilnpdw)
+
76  iskpdx=iskpds+(mxpds+mxpdw)
+
77  ilnpdx=min(lenpds-(mxpds+mxpdw),mxpdx)
+
78  ibskip=lskip+iskpdx
+
79  ibread=ilnpdx
+
80  CALL baread(lugb,ibskip,ibread,lbread,cbread)
+
81  IF(lbread.NE.ibread) RETURN
+
82  cindex(ixpdx+1:ixpdx+ilnpdx)=cbread(1:ilnpdx)
+
83  mlen=max(mlen,ixpdw+ilnpdw,ixpdx+ilnpdx)
+
84  ENDIF
+
85 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
86 C PUT GDS IN INDEX RECORD
+
87  IF(incgds.NE.0) THEN
+
88  iskgds=isktot
+
89  ibskip=lskip+iskgds
+
90  ibread=mxgds
+
91  CALL baread(lugb,ibskip,ibread,lbread,cbread)
+
92  IF(lbread.NE.ibread) RETURN
+
93  CALL sbytec(cindex,iskgds,8*ixsgd,8*mxsgd)
+
94  CALL gbytec(cbread,lengds,0,8*3)
+
95  ilngds=min(lengds,mxgds)
+
96  cindex(ixgds+1:ixgds+ilngds)=cbread(1:ilngds)
+
97  isktot=iskgds+lengds
+
98  IF(lengds.GT.mxgds) THEN
+
99  iskgdx=iskgds+mxgds
+
100  ilngdx=min(lengds-mxgds,mxgdx)
+
101  ibskip=lskip+iskgdx
+
102  ibread=ilngdx
+
103  CALL baread(lugb,ibskip,ibread,lbread,cbread)
+
104  IF(lbread.NE.ibread) RETURN
+
105  cindex(ixgdx+1:ixgdx+ilngdx)=cbread(1:ilngdx)
+
106  mlen=max(mlen,ixgdx+ilngdx)
+
107  ENDIF
+
108  ENDIF
+
109 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
110 C PUT BMS IN INDEX RECORD
+
111  IF(incbms.NE.0) THEN
+
112  iskbms=isktot
+
113  ibskip=lskip+iskbms
+
114  ibread=mxbms
+
115  CALL baread(lugb,ibskip,ibread,lbread,cbread)
+
116  IF(lbread.NE.ibread) RETURN
+
117  CALL sbytec(cindex,iskbms,8*ixsbm,8*mxsbm)
+
118  CALL gbytec(cbread,lenbms,0,8*3)
+
119  ilnbms=min(lenbms,mxbms)
+
120  cindex(ixbms+1:ixbms+ilnbms)=cbread(1:ilnbms)
+
121  isktot=iskbms+lenbms
+
122  ENDIF
+
123 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
124 C PUT BDS IN INDEX RECORD
+
125  iskbds=isktot
+
126  ibskip=lskip+iskbds
+
127  ibread=mxbds
+
128  CALL baread(lugb,ibskip,ibread,lbread,cbread)
+
129  IF(lbread.NE.ibread) RETURN
+
130  CALL sbytec(cindex,iskbds,8*ixsbd,8*mxsbd)
+
131  CALL gbytec(cbread,lenbds,0,8*3)
+
132  ilnbds=min(lenbds,mxbds)
+
133  cindex(ixbds+1:ixbds+ilnbds)=cbread(1:ilnbds)
+
134 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
135 C STORE INDEX RECORD
+
136  mlen=min(mlen,nlen)
+
137  nskip=nlen*(nnum-1)
+
138  cbuf(nskip+1:nskip+mlen)=cindex(1:mlen)
+
139  cbuf(nskip+mlen+1:nskip+nlen)=char(0)
+
140 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
141  RETURN
+
142  END
+
+
+
ixgb
subroutine ixgb(LUGB, LSKIP, LGRIB, NLEN, NNUM, MLEN, CBUF)
Byte 001-004: Bytes to skip in data file before grib message.
Definition: ixgb.f:36
+
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+
gbytec
subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
Definition: gbytec.f:14
+
sbytec
subroutine sbytec(OUT, IN, ISKIP, NBYTE)
This is a wrapper for sbytesc()
Definition: sbytec.f:14
+ + + + diff --git a/ver-2.10.0/jquery.js b/ver-2.10.0/jquery.js new file mode 100644 index 00000000..103c32d7 --- /dev/null +++ b/ver-2.10.0/jquery.js @@ -0,0 +1,35 @@ +/*! jQuery v3.4.1 | (c) JS Foundation and other contributors | jquery.org/license */ +!function(e,t){"use strict";"object"==typeof module&&"object"==typeof module.exports?module.exports=e.document?t(e,!0):function(e){if(!e.document)throw new Error("jQuery requires a window with a document");return t(e)}:t(e)}("undefined"!=typeof window?window:this,function(C,e){"use strict";var t=[],E=C.document,r=Object.getPrototypeOf,s=t.slice,g=t.concat,u=t.push,i=t.indexOf,n={},o=n.toString,v=n.hasOwnProperty,a=v.toString,l=a.call(Object),y={},m=function(e){return"function"==typeof e&&"number"!=typeof e.nodeType},x=function(e){return null!=e&&e===e.window},c={type:!0,src:!0,nonce:!0,noModule:!0};function b(e,t,n){var r,i,o=(n=n||E).createElement("script");if(o.text=e,t)for(r in c)(i=t[r]||t.getAttribute&&t.getAttribute(r))&&o.setAttribute(r,i);n.head.appendChild(o).parentNode.removeChild(o)}function w(e){return null==e?e+"":"object"==typeof e||"function"==typeof e?n[o.call(e)]||"object":typeof e}var f="3.4.1",k=function(e,t){return new k.fn.init(e,t)},p=/^[\s\uFEFF\xA0]+|[\s\uFEFF\xA0]+$/g;function d(e){var t=!!e&&"length"in e&&e.length,n=w(e);return!m(e)&&!x(e)&&("array"===n||0===t||"number"==typeof t&&0+~]|"+M+")"+M+"*"),U=new RegExp(M+"|>"),X=new RegExp($),V=new RegExp("^"+I+"$"),G={ID:new RegExp("^#("+I+")"),CLASS:new RegExp("^\\.("+I+")"),TAG:new RegExp("^("+I+"|[*])"),ATTR:new RegExp("^"+W),PSEUDO:new RegExp("^"+$),CHILD:new RegExp("^:(only|first|last|nth|nth-last)-(child|of-type)(?:\\("+M+"*(even|odd|(([+-]|)(\\d*)n|)"+M+"*(?:([+-]|)"+M+"*(\\d+)|))"+M+"*\\)|)","i"),bool:new RegExp("^(?:"+R+")$","i"),needsContext:new RegExp("^"+M+"*[>+~]|:(even|odd|eq|gt|lt|nth|first|last)(?:\\("+M+"*((?:-\\d)?\\d*)"+M+"*\\)|)(?=[^-]|$)","i")},Y=/HTML$/i,Q=/^(?:input|select|textarea|button)$/i,J=/^h\d$/i,K=/^[^{]+\{\s*\[native \w/,Z=/^(?:#([\w-]+)|(\w+)|\.([\w-]+))$/,ee=/[+~]/,te=new RegExp("\\\\([\\da-f]{1,6}"+M+"?|("+M+")|.)","ig"),ne=function(e,t,n){var r="0x"+t-65536;return r!=r||n?t:r<0?String.fromCharCode(r+65536):String.fromCharCode(r>>10|55296,1023&r|56320)},re=/([\0-\x1f\x7f]|^-?\d)|^-$|[^\0-\x1f\x7f-\uFFFF\w-]/g,ie=function(e,t){return t?"\0"===e?"\ufffd":e.slice(0,-1)+"\\"+e.charCodeAt(e.length-1).toString(16)+" ":"\\"+e},oe=function(){T()},ae=be(function(e){return!0===e.disabled&&"fieldset"===e.nodeName.toLowerCase()},{dir:"parentNode",next:"legend"});try{H.apply(t=O.call(m.childNodes),m.childNodes),t[m.childNodes.length].nodeType}catch(e){H={apply:t.length?function(e,t){L.apply(e,O.call(t))}:function(e,t){var n=e.length,r=0;while(e[n++]=t[r++]);e.length=n-1}}}function se(t,e,n,r){var i,o,a,s,u,l,c,f=e&&e.ownerDocument,p=e?e.nodeType:9;if(n=n||[],"string"!=typeof t||!t||1!==p&&9!==p&&11!==p)return n;if(!r&&((e?e.ownerDocument||e:m)!==C&&T(e),e=e||C,E)){if(11!==p&&(u=Z.exec(t)))if(i=u[1]){if(9===p){if(!(a=e.getElementById(i)))return n;if(a.id===i)return n.push(a),n}else if(f&&(a=f.getElementById(i))&&y(e,a)&&a.id===i)return n.push(a),n}else{if(u[2])return H.apply(n,e.getElementsByTagName(t)),n;if((i=u[3])&&d.getElementsByClassName&&e.getElementsByClassName)return H.apply(n,e.getElementsByClassName(i)),n}if(d.qsa&&!A[t+" "]&&(!v||!v.test(t))&&(1!==p||"object"!==e.nodeName.toLowerCase())){if(c=t,f=e,1===p&&U.test(t)){(s=e.getAttribute("id"))?s=s.replace(re,ie):e.setAttribute("id",s=k),o=(l=h(t)).length;while(o--)l[o]="#"+s+" "+xe(l[o]);c=l.join(","),f=ee.test(t)&&ye(e.parentNode)||e}try{return H.apply(n,f.querySelectorAll(c)),n}catch(e){A(t,!0)}finally{s===k&&e.removeAttribute("id")}}}return g(t.replace(B,"$1"),e,n,r)}function ue(){var r=[];return function e(t,n){return r.push(t+" ")>b.cacheLength&&delete e[r.shift()],e[t+" "]=n}}function le(e){return e[k]=!0,e}function ce(e){var t=C.createElement("fieldset");try{return!!e(t)}catch(e){return!1}finally{t.parentNode&&t.parentNode.removeChild(t),t=null}}function fe(e,t){var n=e.split("|"),r=n.length;while(r--)b.attrHandle[n[r]]=t}function pe(e,t){var n=t&&e,r=n&&1===e.nodeType&&1===t.nodeType&&e.sourceIndex-t.sourceIndex;if(r)return r;if(n)while(n=n.nextSibling)if(n===t)return-1;return e?1:-1}function de(t){return function(e){return"input"===e.nodeName.toLowerCase()&&e.type===t}}function he(n){return function(e){var t=e.nodeName.toLowerCase();return("input"===t||"button"===t)&&e.type===n}}function ge(t){return function(e){return"form"in e?e.parentNode&&!1===e.disabled?"label"in e?"label"in e.parentNode?e.parentNode.disabled===t:e.disabled===t:e.isDisabled===t||e.isDisabled!==!t&&ae(e)===t:e.disabled===t:"label"in e&&e.disabled===t}}function ve(a){return le(function(o){return o=+o,le(function(e,t){var n,r=a([],e.length,o),i=r.length;while(i--)e[n=r[i]]&&(e[n]=!(t[n]=e[n]))})})}function ye(e){return e&&"undefined"!=typeof e.getElementsByTagName&&e}for(e in d=se.support={},i=se.isXML=function(e){var t=e.namespaceURI,n=(e.ownerDocument||e).documentElement;return!Y.test(t||n&&n.nodeName||"HTML")},T=se.setDocument=function(e){var t,n,r=e?e.ownerDocument||e:m;return r!==C&&9===r.nodeType&&r.documentElement&&(a=(C=r).documentElement,E=!i(C),m!==C&&(n=C.defaultView)&&n.top!==n&&(n.addEventListener?n.addEventListener("unload",oe,!1):n.attachEvent&&n.attachEvent("onunload",oe)),d.attributes=ce(function(e){return e.className="i",!e.getAttribute("className")}),d.getElementsByTagName=ce(function(e){return e.appendChild(C.createComment("")),!e.getElementsByTagName("*").length}),d.getElementsByClassName=K.test(C.getElementsByClassName),d.getById=ce(function(e){return a.appendChild(e).id=k,!C.getElementsByName||!C.getElementsByName(k).length}),d.getById?(b.filter.ID=function(e){var t=e.replace(te,ne);return function(e){return e.getAttribute("id")===t}},b.find.ID=function(e,t){if("undefined"!=typeof t.getElementById&&E){var n=t.getElementById(e);return n?[n]:[]}}):(b.filter.ID=function(e){var n=e.replace(te,ne);return function(e){var t="undefined"!=typeof e.getAttributeNode&&e.getAttributeNode("id");return t&&t.value===n}},b.find.ID=function(e,t){if("undefined"!=typeof t.getElementById&&E){var n,r,i,o=t.getElementById(e);if(o){if((n=o.getAttributeNode("id"))&&n.value===e)return[o];i=t.getElementsByName(e),r=0;while(o=i[r++])if((n=o.getAttributeNode("id"))&&n.value===e)return[o]}return[]}}),b.find.TAG=d.getElementsByTagName?function(e,t){return"undefined"!=typeof t.getElementsByTagName?t.getElementsByTagName(e):d.qsa?t.querySelectorAll(e):void 0}:function(e,t){var n,r=[],i=0,o=t.getElementsByTagName(e);if("*"===e){while(n=o[i++])1===n.nodeType&&r.push(n);return r}return o},b.find.CLASS=d.getElementsByClassName&&function(e,t){if("undefined"!=typeof t.getElementsByClassName&&E)return t.getElementsByClassName(e)},s=[],v=[],(d.qsa=K.test(C.querySelectorAll))&&(ce(function(e){a.appendChild(e).innerHTML="",e.querySelectorAll("[msallowcapture^='']").length&&v.push("[*^$]="+M+"*(?:''|\"\")"),e.querySelectorAll("[selected]").length||v.push("\\["+M+"*(?:value|"+R+")"),e.querySelectorAll("[id~="+k+"-]").length||v.push("~="),e.querySelectorAll(":checked").length||v.push(":checked"),e.querySelectorAll("a#"+k+"+*").length||v.push(".#.+[+~]")}),ce(function(e){e.innerHTML="";var t=C.createElement("input");t.setAttribute("type","hidden"),e.appendChild(t).setAttribute("name","D"),e.querySelectorAll("[name=d]").length&&v.push("name"+M+"*[*^$|!~]?="),2!==e.querySelectorAll(":enabled").length&&v.push(":enabled",":disabled"),a.appendChild(e).disabled=!0,2!==e.querySelectorAll(":disabled").length&&v.push(":enabled",":disabled"),e.querySelectorAll("*,:x"),v.push(",.*:")})),(d.matchesSelector=K.test(c=a.matches||a.webkitMatchesSelector||a.mozMatchesSelector||a.oMatchesSelector||a.msMatchesSelector))&&ce(function(e){d.disconnectedMatch=c.call(e,"*"),c.call(e,"[s!='']:x"),s.push("!=",$)}),v=v.length&&new RegExp(v.join("|")),s=s.length&&new RegExp(s.join("|")),t=K.test(a.compareDocumentPosition),y=t||K.test(a.contains)?function(e,t){var n=9===e.nodeType?e.documentElement:e,r=t&&t.parentNode;return e===r||!(!r||1!==r.nodeType||!(n.contains?n.contains(r):e.compareDocumentPosition&&16&e.compareDocumentPosition(r)))}:function(e,t){if(t)while(t=t.parentNode)if(t===e)return!0;return!1},D=t?function(e,t){if(e===t)return l=!0,0;var n=!e.compareDocumentPosition-!t.compareDocumentPosition;return n||(1&(n=(e.ownerDocument||e)===(t.ownerDocument||t)?e.compareDocumentPosition(t):1)||!d.sortDetached&&t.compareDocumentPosition(e)===n?e===C||e.ownerDocument===m&&y(m,e)?-1:t===C||t.ownerDocument===m&&y(m,t)?1:u?P(u,e)-P(u,t):0:4&n?-1:1)}:function(e,t){if(e===t)return l=!0,0;var n,r=0,i=e.parentNode,o=t.parentNode,a=[e],s=[t];if(!i||!o)return e===C?-1:t===C?1:i?-1:o?1:u?P(u,e)-P(u,t):0;if(i===o)return pe(e,t);n=e;while(n=n.parentNode)a.unshift(n);n=t;while(n=n.parentNode)s.unshift(n);while(a[r]===s[r])r++;return r?pe(a[r],s[r]):a[r]===m?-1:s[r]===m?1:0}),C},se.matches=function(e,t){return se(e,null,null,t)},se.matchesSelector=function(e,t){if((e.ownerDocument||e)!==C&&T(e),d.matchesSelector&&E&&!A[t+" "]&&(!s||!s.test(t))&&(!v||!v.test(t)))try{var n=c.call(e,t);if(n||d.disconnectedMatch||e.document&&11!==e.document.nodeType)return n}catch(e){A(t,!0)}return 0":{dir:"parentNode",first:!0}," ":{dir:"parentNode"},"+":{dir:"previousSibling",first:!0},"~":{dir:"previousSibling"}},preFilter:{ATTR:function(e){return e[1]=e[1].replace(te,ne),e[3]=(e[3]||e[4]||e[5]||"").replace(te,ne),"~="===e[2]&&(e[3]=" "+e[3]+" "),e.slice(0,4)},CHILD:function(e){return e[1]=e[1].toLowerCase(),"nth"===e[1].slice(0,3)?(e[3]||se.error(e[0]),e[4]=+(e[4]?e[5]+(e[6]||1):2*("even"===e[3]||"odd"===e[3])),e[5]=+(e[7]+e[8]||"odd"===e[3])):e[3]&&se.error(e[0]),e},PSEUDO:function(e){var t,n=!e[6]&&e[2];return G.CHILD.test(e[0])?null:(e[3]?e[2]=e[4]||e[5]||"":n&&X.test(n)&&(t=h(n,!0))&&(t=n.indexOf(")",n.length-t)-n.length)&&(e[0]=e[0].slice(0,t),e[2]=n.slice(0,t)),e.slice(0,3))}},filter:{TAG:function(e){var t=e.replace(te,ne).toLowerCase();return"*"===e?function(){return!0}:function(e){return e.nodeName&&e.nodeName.toLowerCase()===t}},CLASS:function(e){var t=p[e+" "];return t||(t=new RegExp("(^|"+M+")"+e+"("+M+"|$)"))&&p(e,function(e){return t.test("string"==typeof e.className&&e.className||"undefined"!=typeof e.getAttribute&&e.getAttribute("class")||"")})},ATTR:function(n,r,i){return function(e){var t=se.attr(e,n);return null==t?"!="===r:!r||(t+="","="===r?t===i:"!="===r?t!==i:"^="===r?i&&0===t.indexOf(i):"*="===r?i&&-1:\x20\t\r\n\f]*)[\x20\t\r\n\f]*\/?>(?:<\/\1>|)$/i;function j(e,n,r){return m(n)?k.grep(e,function(e,t){return!!n.call(e,t,e)!==r}):n.nodeType?k.grep(e,function(e){return e===n!==r}):"string"!=typeof n?k.grep(e,function(e){return-1)[^>]*|#([\w-]+))$/;(k.fn.init=function(e,t,n){var r,i;if(!e)return this;if(n=n||q,"string"==typeof e){if(!(r="<"===e[0]&&">"===e[e.length-1]&&3<=e.length?[null,e,null]:L.exec(e))||!r[1]&&t)return!t||t.jquery?(t||n).find(e):this.constructor(t).find(e);if(r[1]){if(t=t instanceof k?t[0]:t,k.merge(this,k.parseHTML(r[1],t&&t.nodeType?t.ownerDocument||t:E,!0)),D.test(r[1])&&k.isPlainObject(t))for(r in t)m(this[r])?this[r](t[r]):this.attr(r,t[r]);return this}return(i=E.getElementById(r[2]))&&(this[0]=i,this.length=1),this}return e.nodeType?(this[0]=e,this.length=1,this):m(e)?void 0!==n.ready?n.ready(e):e(k):k.makeArray(e,this)}).prototype=k.fn,q=k(E);var H=/^(?:parents|prev(?:Until|All))/,O={children:!0,contents:!0,next:!0,prev:!0};function P(e,t){while((e=e[t])&&1!==e.nodeType);return e}k.fn.extend({has:function(e){var t=k(e,this),n=t.length;return this.filter(function(){for(var e=0;e\x20\t\r\n\f]*)/i,he=/^$|^module$|\/(?:java|ecma)script/i,ge={option:[1,""],thead:[1,"","
"],col:[2,"","
"],tr:[2,"","
"],td:[3,"","
"],_default:[0,"",""]};function ve(e,t){var n;return n="undefined"!=typeof e.getElementsByTagName?e.getElementsByTagName(t||"*"):"undefined"!=typeof e.querySelectorAll?e.querySelectorAll(t||"*"):[],void 0===t||t&&A(e,t)?k.merge([e],n):n}function ye(e,t){for(var n=0,r=e.length;nx",y.noCloneChecked=!!me.cloneNode(!0).lastChild.defaultValue;var Te=/^key/,Ce=/^(?:mouse|pointer|contextmenu|drag|drop)|click/,Ee=/^([^.]*)(?:\.(.+)|)/;function ke(){return!0}function Se(){return!1}function Ne(e,t){return e===function(){try{return E.activeElement}catch(e){}}()==("focus"===t)}function Ae(e,t,n,r,i,o){var a,s;if("object"==typeof t){for(s in"string"!=typeof n&&(r=r||n,n=void 0),t)Ae(e,s,n,r,t[s],o);return e}if(null==r&&null==i?(i=n,r=n=void 0):null==i&&("string"==typeof n?(i=r,r=void 0):(i=r,r=n,n=void 0)),!1===i)i=Se;else if(!i)return e;return 1===o&&(a=i,(i=function(e){return k().off(e),a.apply(this,arguments)}).guid=a.guid||(a.guid=k.guid++)),e.each(function(){k.event.add(this,t,i,r,n)})}function De(e,i,o){o?(Q.set(e,i,!1),k.event.add(e,i,{namespace:!1,handler:function(e){var t,n,r=Q.get(this,i);if(1&e.isTrigger&&this[i]){if(r.length)(k.event.special[i]||{}).delegateType&&e.stopPropagation();else if(r=s.call(arguments),Q.set(this,i,r),t=o(this,i),this[i](),r!==(n=Q.get(this,i))||t?Q.set(this,i,!1):n={},r!==n)return e.stopImmediatePropagation(),e.preventDefault(),n.value}else r.length&&(Q.set(this,i,{value:k.event.trigger(k.extend(r[0],k.Event.prototype),r.slice(1),this)}),e.stopImmediatePropagation())}})):void 0===Q.get(e,i)&&k.event.add(e,i,ke)}k.event={global:{},add:function(t,e,n,r,i){var o,a,s,u,l,c,f,p,d,h,g,v=Q.get(t);if(v){n.handler&&(n=(o=n).handler,i=o.selector),i&&k.find.matchesSelector(ie,i),n.guid||(n.guid=k.guid++),(u=v.events)||(u=v.events={}),(a=v.handle)||(a=v.handle=function(e){return"undefined"!=typeof k&&k.event.triggered!==e.type?k.event.dispatch.apply(t,arguments):void 0}),l=(e=(e||"").match(R)||[""]).length;while(l--)d=g=(s=Ee.exec(e[l])||[])[1],h=(s[2]||"").split(".").sort(),d&&(f=k.event.special[d]||{},d=(i?f.delegateType:f.bindType)||d,f=k.event.special[d]||{},c=k.extend({type:d,origType:g,data:r,handler:n,guid:n.guid,selector:i,needsContext:i&&k.expr.match.needsContext.test(i),namespace:h.join(".")},o),(p=u[d])||((p=u[d]=[]).delegateCount=0,f.setup&&!1!==f.setup.call(t,r,h,a)||t.addEventListener&&t.addEventListener(d,a)),f.add&&(f.add.call(t,c),c.handler.guid||(c.handler.guid=n.guid)),i?p.splice(p.delegateCount++,0,c):p.push(c),k.event.global[d]=!0)}},remove:function(e,t,n,r,i){var o,a,s,u,l,c,f,p,d,h,g,v=Q.hasData(e)&&Q.get(e);if(v&&(u=v.events)){l=(t=(t||"").match(R)||[""]).length;while(l--)if(d=g=(s=Ee.exec(t[l])||[])[1],h=(s[2]||"").split(".").sort(),d){f=k.event.special[d]||{},p=u[d=(r?f.delegateType:f.bindType)||d]||[],s=s[2]&&new RegExp("(^|\\.)"+h.join("\\.(?:.*\\.|)")+"(\\.|$)"),a=o=p.length;while(o--)c=p[o],!i&&g!==c.origType||n&&n.guid!==c.guid||s&&!s.test(c.namespace)||r&&r!==c.selector&&("**"!==r||!c.selector)||(p.splice(o,1),c.selector&&p.delegateCount--,f.remove&&f.remove.call(e,c));a&&!p.length&&(f.teardown&&!1!==f.teardown.call(e,h,v.handle)||k.removeEvent(e,d,v.handle),delete u[d])}else for(d in u)k.event.remove(e,d+t[l],n,r,!0);k.isEmptyObject(u)&&Q.remove(e,"handle events")}},dispatch:function(e){var t,n,r,i,o,a,s=k.event.fix(e),u=new Array(arguments.length),l=(Q.get(this,"events")||{})[s.type]||[],c=k.event.special[s.type]||{};for(u[0]=s,t=1;t\x20\t\r\n\f]*)[^>]*)\/>/gi,qe=/\s*$/g;function Oe(e,t){return A(e,"table")&&A(11!==t.nodeType?t:t.firstChild,"tr")&&k(e).children("tbody")[0]||e}function Pe(e){return e.type=(null!==e.getAttribute("type"))+"/"+e.type,e}function Re(e){return"true/"===(e.type||"").slice(0,5)?e.type=e.type.slice(5):e.removeAttribute("type"),e}function Me(e,t){var n,r,i,o,a,s,u,l;if(1===t.nodeType){if(Q.hasData(e)&&(o=Q.access(e),a=Q.set(t,o),l=o.events))for(i in delete a.handle,a.events={},l)for(n=0,r=l[i].length;n")},clone:function(e,t,n){var r,i,o,a,s,u,l,c=e.cloneNode(!0),f=oe(e);if(!(y.noCloneChecked||1!==e.nodeType&&11!==e.nodeType||k.isXMLDoc(e)))for(a=ve(c),r=0,i=(o=ve(e)).length;r").attr(n.scriptAttrs||{}).prop({charset:n.scriptCharset,src:n.url}).on("load error",i=function(e){r.remove(),i=null,e&&t("error"===e.type?404:200,e.type)}),E.head.appendChild(r[0])},abort:function(){i&&i()}}});var Vt,Gt=[],Yt=/(=)\?(?=&|$)|\?\?/;k.ajaxSetup({jsonp:"callback",jsonpCallback:function(){var e=Gt.pop()||k.expando+"_"+kt++;return this[e]=!0,e}}),k.ajaxPrefilter("json jsonp",function(e,t,n){var r,i,o,a=!1!==e.jsonp&&(Yt.test(e.url)?"url":"string"==typeof e.data&&0===(e.contentType||"").indexOf("application/x-www-form-urlencoded")&&Yt.test(e.data)&&"data");if(a||"jsonp"===e.dataTypes[0])return r=e.jsonpCallback=m(e.jsonpCallback)?e.jsonpCallback():e.jsonpCallback,a?e[a]=e[a].replace(Yt,"$1"+r):!1!==e.jsonp&&(e.url+=(St.test(e.url)?"&":"?")+e.jsonp+"="+r),e.converters["script json"]=function(){return o||k.error(r+" was not called"),o[0]},e.dataTypes[0]="json",i=C[r],C[r]=function(){o=arguments},n.always(function(){void 0===i?k(C).removeProp(r):C[r]=i,e[r]&&(e.jsonpCallback=t.jsonpCallback,Gt.push(r)),o&&m(i)&&i(o[0]),o=i=void 0}),"script"}),y.createHTMLDocument=((Vt=E.implementation.createHTMLDocument("").body).innerHTML="
",2===Vt.childNodes.length),k.parseHTML=function(e,t,n){return"string"!=typeof e?[]:("boolean"==typeof t&&(n=t,t=!1),t||(y.createHTMLDocument?((r=(t=E.implementation.createHTMLDocument("")).createElement("base")).href=E.location.href,t.head.appendChild(r)):t=E),o=!n&&[],(i=D.exec(e))?[t.createElement(i[1])]:(i=we([e],t,o),o&&o.length&&k(o).remove(),k.merge([],i.childNodes)));var r,i,o},k.fn.load=function(e,t,n){var r,i,o,a=this,s=e.indexOf(" ");return-1").append(k.parseHTML(e)).find(r):e)}).always(n&&function(e,t){a.each(function(){n.apply(this,o||[e.responseText,t,e])})}),this},k.each(["ajaxStart","ajaxStop","ajaxComplete","ajaxError","ajaxSuccess","ajaxSend"],function(e,t){k.fn[t]=function(e){return this.on(t,e)}}),k.expr.pseudos.animated=function(t){return k.grep(k.timers,function(e){return t===e.elem}).length},k.offset={setOffset:function(e,t,n){var r,i,o,a,s,u,l=k.css(e,"position"),c=k(e),f={};"static"===l&&(e.style.position="relative"),s=c.offset(),o=k.css(e,"top"),u=k.css(e,"left"),("absolute"===l||"fixed"===l)&&-1<(o+u).indexOf("auto")?(a=(r=c.position()).top,i=r.left):(a=parseFloat(o)||0,i=parseFloat(u)||0),m(t)&&(t=t.call(e,n,k.extend({},s))),null!=t.top&&(f.top=t.top-s.top+a),null!=t.left&&(f.left=t.left-s.left+i),"using"in t?t.using.call(e,f):c.css(f)}},k.fn.extend({offset:function(t){if(arguments.length)return void 0===t?this:this.each(function(e){k.offset.setOffset(this,t,e)});var e,n,r=this[0];return r?r.getClientRects().length?(e=r.getBoundingClientRect(),n=r.ownerDocument.defaultView,{top:e.top+n.pageYOffset,left:e.left+n.pageXOffset}):{top:0,left:0}:void 0},position:function(){if(this[0]){var e,t,n,r=this[0],i={top:0,left:0};if("fixed"===k.css(r,"position"))t=r.getBoundingClientRect();else{t=this.offset(),n=r.ownerDocument,e=r.offsetParent||n.documentElement;while(e&&(e===n.body||e===n.documentElement)&&"static"===k.css(e,"position"))e=e.parentNode;e&&e!==r&&1===e.nodeType&&((i=k(e).offset()).top+=k.css(e,"borderTopWidth",!0),i.left+=k.css(e,"borderLeftWidth",!0))}return{top:t.top-i.top-k.css(r,"marginTop",!0),left:t.left-i.left-k.css(r,"marginLeft",!0)}}},offsetParent:function(){return this.map(function(){var e=this.offsetParent;while(e&&"static"===k.css(e,"position"))e=e.offsetParent;return e||ie})}}),k.each({scrollLeft:"pageXOffset",scrollTop:"pageYOffset"},function(t,i){var o="pageYOffset"===i;k.fn[t]=function(e){return _(this,function(e,t,n){var r;if(x(e)?r=e:9===e.nodeType&&(r=e.defaultView),void 0===n)return r?r[i]:e[t];r?r.scrollTo(o?r.pageXOffset:n,o?n:r.pageYOffset):e[t]=n},t,e,arguments.length)}}),k.each(["top","left"],function(e,n){k.cssHooks[n]=ze(y.pixelPosition,function(e,t){if(t)return t=_e(e,n),$e.test(t)?k(e).position()[n]+"px":t})}),k.each({Height:"height",Width:"width"},function(a,s){k.each({padding:"inner"+a,content:s,"":"outer"+a},function(r,o){k.fn[o]=function(e,t){var n=arguments.length&&(r||"boolean"!=typeof e),i=r||(!0===e||!0===t?"margin":"border");return _(this,function(e,t,n){var r;return x(e)?0===o.indexOf("outer")?e["inner"+a]:e.document.documentElement["client"+a]:9===e.nodeType?(r=e.documentElement,Math.max(e.body["scroll"+a],r["scroll"+a],e.body["offset"+a],r["offset"+a],r["client"+a])):void 0===n?k.css(e,t,i):k.style(e,t,n,i)},s,n?e:void 0,n)}})}),k.each("blur focus focusin focusout resize scroll click dblclick mousedown mouseup mousemove mouseover mouseout mouseenter mouseleave change select submit keydown keypress keyup contextmenu".split(" "),function(e,n){k.fn[n]=function(e,t){return 0a;a++)for(i in o[a])n=o[a][i],o[a].hasOwnProperty(i)&&void 0!==n&&(e[i]=t.isPlainObject(n)?t.isPlainObject(e[i])?t.widget.extend({},e[i],n):t.widget.extend({},n):n);return e},t.widget.bridge=function(e,i){var n=i.prototype.widgetFullName||e;t.fn[e]=function(o){var a="string"==typeof o,r=s.call(arguments,1),h=this;return a?this.length||"instance"!==o?this.each(function(){var i,s=t.data(this,n);return"instance"===o?(h=s,!1):s?t.isFunction(s[o])&&"_"!==o.charAt(0)?(i=s[o].apply(s,r),i!==s&&void 0!==i?(h=i&&i.jquery?h.pushStack(i.get()):i,!1):void 0):t.error("no such method '"+o+"' for "+e+" widget instance"):t.error("cannot call methods on "+e+" prior to initialization; "+"attempted to call method '"+o+"'")}):h=void 0:(r.length&&(o=t.widget.extend.apply(null,[o].concat(r))),this.each(function(){var e=t.data(this,n);e?(e.option(o||{}),e._init&&e._init()):t.data(this,n,new i(o,this))})),h}},t.Widget=function(){},t.Widget._childConstructors=[],t.Widget.prototype={widgetName:"widget",widgetEventPrefix:"",defaultElement:"
",options:{classes:{},disabled:!1,create:null},_createWidget:function(e,s){s=t(s||this.defaultElement||this)[0],this.element=t(s),this.uuid=i++,this.eventNamespace="."+this.widgetName+this.uuid,this.bindings=t(),this.hoverable=t(),this.focusable=t(),this.classesElementLookup={},s!==this&&(t.data(s,this.widgetFullName,this),this._on(!0,this.element,{remove:function(t){t.target===s&&this.destroy()}}),this.document=t(s.style?s.ownerDocument:s.document||s),this.window=t(this.document[0].defaultView||this.document[0].parentWindow)),this.options=t.widget.extend({},this.options,this._getCreateOptions(),e),this._create(),this.options.disabled&&this._setOptionDisabled(this.options.disabled),this._trigger("create",null,this._getCreateEventData()),this._init()},_getCreateOptions:function(){return{}},_getCreateEventData:t.noop,_create:t.noop,_init:t.noop,destroy:function(){var e=this;this._destroy(),t.each(this.classesElementLookup,function(t,i){e._removeClass(i,t)}),this.element.off(this.eventNamespace).removeData(this.widgetFullName),this.widget().off(this.eventNamespace).removeAttr("aria-disabled"),this.bindings.off(this.eventNamespace)},_destroy:t.noop,widget:function(){return this.element},option:function(e,i){var s,n,o,a=e;if(0===arguments.length)return t.widget.extend({},this.options);if("string"==typeof e)if(a={},s=e.split("."),e=s.shift(),s.length){for(n=a[e]=t.widget.extend({},this.options[e]),o=0;s.length-1>o;o++)n[s[o]]=n[s[o]]||{},n=n[s[o]];if(e=s.pop(),1===arguments.length)return void 0===n[e]?null:n[e];n[e]=i}else{if(1===arguments.length)return void 0===this.options[e]?null:this.options[e];a[e]=i}return this._setOptions(a),this},_setOptions:function(t){var e;for(e in t)this._setOption(e,t[e]);return this},_setOption:function(t,e){return"classes"===t&&this._setOptionClasses(e),this.options[t]=e,"disabled"===t&&this._setOptionDisabled(e),this},_setOptionClasses:function(e){var i,s,n;for(i in e)n=this.classesElementLookup[i],e[i]!==this.options.classes[i]&&n&&n.length&&(s=t(n.get()),this._removeClass(n,i),s.addClass(this._classes({element:s,keys:i,classes:e,add:!0})))},_setOptionDisabled:function(t){this._toggleClass(this.widget(),this.widgetFullName+"-disabled",null,!!t),t&&(this._removeClass(this.hoverable,null,"ui-state-hover"),this._removeClass(this.focusable,null,"ui-state-focus"))},enable:function(){return this._setOptions({disabled:!1})},disable:function(){return this._setOptions({disabled:!0})},_classes:function(e){function i(i,o){var a,r;for(r=0;i.length>r;r++)a=n.classesElementLookup[i[r]]||t(),a=e.add?t(t.unique(a.get().concat(e.element.get()))):t(a.not(e.element).get()),n.classesElementLookup[i[r]]=a,s.push(i[r]),o&&e.classes[i[r]]&&s.push(e.classes[i[r]])}var s=[],n=this;return e=t.extend({element:this.element,classes:this.options.classes||{}},e),this._on(e.element,{remove:"_untrackClassesElement"}),e.keys&&i(e.keys.match(/\S+/g)||[],!0),e.extra&&i(e.extra.match(/\S+/g)||[]),s.join(" ")},_untrackClassesElement:function(e){var i=this;t.each(i.classesElementLookup,function(s,n){-1!==t.inArray(e.target,n)&&(i.classesElementLookup[s]=t(n.not(e.target).get()))})},_removeClass:function(t,e,i){return this._toggleClass(t,e,i,!1)},_addClass:function(t,e,i){return this._toggleClass(t,e,i,!0)},_toggleClass:function(t,e,i,s){s="boolean"==typeof s?s:i;var n="string"==typeof t||null===t,o={extra:n?e:i,keys:n?t:e,element:n?this.element:t,add:s};return o.element.toggleClass(this._classes(o),s),this},_on:function(e,i,s){var n,o=this;"boolean"!=typeof e&&(s=i,i=e,e=!1),s?(i=n=t(i),this.bindings=this.bindings.add(i)):(s=i,i=this.element,n=this.widget()),t.each(s,function(s,a){function r(){return e||o.options.disabled!==!0&&!t(this).hasClass("ui-state-disabled")?("string"==typeof a?o[a]:a).apply(o,arguments):void 0}"string"!=typeof a&&(r.guid=a.guid=a.guid||r.guid||t.guid++);var h=s.match(/^([\w:-]*)\s*(.*)$/),l=h[1]+o.eventNamespace,c=h[2];c?n.on(l,c,r):i.on(l,r)})},_off:function(e,i){i=(i||"").split(" ").join(this.eventNamespace+" ")+this.eventNamespace,e.off(i).off(i),this.bindings=t(this.bindings.not(e).get()),this.focusable=t(this.focusable.not(e).get()),this.hoverable=t(this.hoverable.not(e).get())},_delay:function(t,e){function i(){return("string"==typeof t?s[t]:t).apply(s,arguments)}var s=this;return setTimeout(i,e||0)},_hoverable:function(e){this.hoverable=this.hoverable.add(e),this._on(e,{mouseenter:function(e){this._addClass(t(e.currentTarget),null,"ui-state-hover")},mouseleave:function(e){this._removeClass(t(e.currentTarget),null,"ui-state-hover")}})},_focusable:function(e){this.focusable=this.focusable.add(e),this._on(e,{focusin:function(e){this._addClass(t(e.currentTarget),null,"ui-state-focus")},focusout:function(e){this._removeClass(t(e.currentTarget),null,"ui-state-focus")}})},_trigger:function(e,i,s){var n,o,a=this.options[e];if(s=s||{},i=t.Event(i),i.type=(e===this.widgetEventPrefix?e:this.widgetEventPrefix+e).toLowerCase(),i.target=this.element[0],o=i.originalEvent)for(n in o)n in i||(i[n]=o[n]);return this.element.trigger(i,s),!(t.isFunction(a)&&a.apply(this.element[0],[i].concat(s))===!1||i.isDefaultPrevented())}},t.each({show:"fadeIn",hide:"fadeOut"},function(e,i){t.Widget.prototype["_"+e]=function(s,n,o){"string"==typeof n&&(n={effect:n});var a,r=n?n===!0||"number"==typeof n?i:n.effect||i:e;n=n||{},"number"==typeof n&&(n={duration:n}),a=!t.isEmptyObject(n),n.complete=o,n.delay&&s.delay(n.delay),a&&t.effects&&t.effects.effect[r]?s[e](n):r!==e&&s[r]?s[r](n.duration,n.easing,o):s.queue(function(i){t(this)[e](),o&&o.call(s[0]),i()})}}),t.widget,function(){function e(t,e,i){return[parseFloat(t[0])*(u.test(t[0])?e/100:1),parseFloat(t[1])*(u.test(t[1])?i/100:1)]}function i(e,i){return parseInt(t.css(e,i),10)||0}function s(e){var i=e[0];return 9===i.nodeType?{width:e.width(),height:e.height(),offset:{top:0,left:0}}:t.isWindow(i)?{width:e.width(),height:e.height(),offset:{top:e.scrollTop(),left:e.scrollLeft()}}:i.preventDefault?{width:0,height:0,offset:{top:i.pageY,left:i.pageX}}:{width:e.outerWidth(),height:e.outerHeight(),offset:e.offset()}}var n,o=Math.max,a=Math.abs,r=/left|center|right/,h=/top|center|bottom/,l=/[\+\-]\d+(\.[\d]+)?%?/,c=/^\w+/,u=/%$/,d=t.fn.position;t.position={scrollbarWidth:function(){if(void 0!==n)return n;var e,i,s=t("
"),o=s.children()[0];return t("body").append(s),e=o.offsetWidth,s.css("overflow","scroll"),i=o.offsetWidth,e===i&&(i=s[0].clientWidth),s.remove(),n=e-i},getScrollInfo:function(e){var i=e.isWindow||e.isDocument?"":e.element.css("overflow-x"),s=e.isWindow||e.isDocument?"":e.element.css("overflow-y"),n="scroll"===i||"auto"===i&&e.widthi?"left":e>0?"right":"center",vertical:0>r?"top":s>0?"bottom":"middle"};l>p&&p>a(e+i)&&(u.horizontal="center"),c>f&&f>a(s+r)&&(u.vertical="middle"),u.important=o(a(e),a(i))>o(a(s),a(r))?"horizontal":"vertical",n.using.call(this,t,u)}),h.offset(t.extend(D,{using:r}))})},t.ui.position={fit:{left:function(t,e){var i,s=e.within,n=s.isWindow?s.scrollLeft:s.offset.left,a=s.width,r=t.left-e.collisionPosition.marginLeft,h=n-r,l=r+e.collisionWidth-a-n;e.collisionWidth>a?h>0&&0>=l?(i=t.left+h+e.collisionWidth-a-n,t.left+=h-i):t.left=l>0&&0>=h?n:h>l?n+a-e.collisionWidth:n:h>0?t.left+=h:l>0?t.left-=l:t.left=o(t.left-r,t.left)},top:function(t,e){var i,s=e.within,n=s.isWindow?s.scrollTop:s.offset.top,a=e.within.height,r=t.top-e.collisionPosition.marginTop,h=n-r,l=r+e.collisionHeight-a-n;e.collisionHeight>a?h>0&&0>=l?(i=t.top+h+e.collisionHeight-a-n,t.top+=h-i):t.top=l>0&&0>=h?n:h>l?n+a-e.collisionHeight:n:h>0?t.top+=h:l>0?t.top-=l:t.top=o(t.top-r,t.top)}},flip:{left:function(t,e){var i,s,n=e.within,o=n.offset.left+n.scrollLeft,r=n.width,h=n.isWindow?n.scrollLeft:n.offset.left,l=t.left-e.collisionPosition.marginLeft,c=l-h,u=l+e.collisionWidth-r-h,d="left"===e.my[0]?-e.elemWidth:"right"===e.my[0]?e.elemWidth:0,p="left"===e.at[0]?e.targetWidth:"right"===e.at[0]?-e.targetWidth:0,f=-2*e.offset[0];0>c?(i=t.left+d+p+f+e.collisionWidth-r-o,(0>i||a(c)>i)&&(t.left+=d+p+f)):u>0&&(s=t.left-e.collisionPosition.marginLeft+d+p+f-h,(s>0||u>a(s))&&(t.left+=d+p+f))},top:function(t,e){var i,s,n=e.within,o=n.offset.top+n.scrollTop,r=n.height,h=n.isWindow?n.scrollTop:n.offset.top,l=t.top-e.collisionPosition.marginTop,c=l-h,u=l+e.collisionHeight-r-h,d="top"===e.my[1],p=d?-e.elemHeight:"bottom"===e.my[1]?e.elemHeight:0,f="top"===e.at[1]?e.targetHeight:"bottom"===e.at[1]?-e.targetHeight:0,m=-2*e.offset[1];0>c?(s=t.top+p+f+m+e.collisionHeight-r-o,(0>s||a(c)>s)&&(t.top+=p+f+m)):u>0&&(i=t.top-e.collisionPosition.marginTop+p+f+m-h,(i>0||u>a(i))&&(t.top+=p+f+m))}},flipfit:{left:function(){t.ui.position.flip.left.apply(this,arguments),t.ui.position.fit.left.apply(this,arguments)},top:function(){t.ui.position.flip.top.apply(this,arguments),t.ui.position.fit.top.apply(this,arguments)}}}}(),t.ui.position,t.extend(t.expr[":"],{data:t.expr.createPseudo?t.expr.createPseudo(function(e){return function(i){return!!t.data(i,e)}}):function(e,i,s){return!!t.data(e,s[3])}}),t.fn.extend({disableSelection:function(){var t="onselectstart"in document.createElement("div")?"selectstart":"mousedown";return function(){return this.on(t+".ui-disableSelection",function(t){t.preventDefault()})}}(),enableSelection:function(){return this.off(".ui-disableSelection")}}),t.ui.focusable=function(i,s){var n,o,a,r,h,l=i.nodeName.toLowerCase();return"area"===l?(n=i.parentNode,o=n.name,i.href&&o&&"map"===n.nodeName.toLowerCase()?(a=t("img[usemap='#"+o+"']"),a.length>0&&a.is(":visible")):!1):(/^(input|select|textarea|button|object)$/.test(l)?(r=!i.disabled,r&&(h=t(i).closest("fieldset")[0],h&&(r=!h.disabled))):r="a"===l?i.href||s:s,r&&t(i).is(":visible")&&e(t(i)))},t.extend(t.expr[":"],{focusable:function(e){return t.ui.focusable(e,null!=t.attr(e,"tabindex"))}}),t.ui.focusable,t.fn.form=function(){return"string"==typeof this[0].form?this.closest("form"):t(this[0].form)},t.ui.formResetMixin={_formResetHandler:function(){var e=t(this);setTimeout(function(){var i=e.data("ui-form-reset-instances");t.each(i,function(){this.refresh()})})},_bindFormResetHandler:function(){if(this.form=this.element.form(),this.form.length){var t=this.form.data("ui-form-reset-instances")||[];t.length||this.form.on("reset.ui-form-reset",this._formResetHandler),t.push(this),this.form.data("ui-form-reset-instances",t)}},_unbindFormResetHandler:function(){if(this.form.length){var e=this.form.data("ui-form-reset-instances");e.splice(t.inArray(this,e),1),e.length?this.form.data("ui-form-reset-instances",e):this.form.removeData("ui-form-reset-instances").off("reset.ui-form-reset")}}},"1.7"===t.fn.jquery.substring(0,3)&&(t.each(["Width","Height"],function(e,i){function s(e,i,s,o){return t.each(n,function(){i-=parseFloat(t.css(e,"padding"+this))||0,s&&(i-=parseFloat(t.css(e,"border"+this+"Width"))||0),o&&(i-=parseFloat(t.css(e,"margin"+this))||0)}),i}var n="Width"===i?["Left","Right"]:["Top","Bottom"],o=i.toLowerCase(),a={innerWidth:t.fn.innerWidth,innerHeight:t.fn.innerHeight,outerWidth:t.fn.outerWidth,outerHeight:t.fn.outerHeight};t.fn["inner"+i]=function(e){return void 0===e?a["inner"+i].call(this):this.each(function(){t(this).css(o,s(this,e)+"px")})},t.fn["outer"+i]=function(e,n){return"number"!=typeof e?a["outer"+i].call(this,e):this.each(function(){t(this).css(o,s(this,e,!0,n)+"px")})}}),t.fn.addBack=function(t){return this.add(null==t?this.prevObject:this.prevObject.filter(t))}),t.ui.keyCode={BACKSPACE:8,COMMA:188,DELETE:46,DOWN:40,END:35,ENTER:13,ESCAPE:27,HOME:36,LEFT:37,PAGE_DOWN:34,PAGE_UP:33,PERIOD:190,RIGHT:39,SPACE:32,TAB:9,UP:38},t.ui.escapeSelector=function(){var t=/([!"#$%&'()*+,./:;<=>?@[\]^`{|}~])/g;return function(e){return e.replace(t,"\\$1")}}(),t.fn.labels=function(){var e,i,s,n,o;return this[0].labels&&this[0].labels.length?this.pushStack(this[0].labels):(n=this.eq(0).parents("label"),s=this.attr("id"),s&&(e=this.eq(0).parents().last(),o=e.add(e.length?e.siblings():this.siblings()),i="label[for='"+t.ui.escapeSelector(s)+"']",n=n.add(o.find(i).addBack(i))),this.pushStack(n))},t.fn.scrollParent=function(e){var i=this.css("position"),s="absolute"===i,n=e?/(auto|scroll|hidden)/:/(auto|scroll)/,o=this.parents().filter(function(){var e=t(this);return s&&"static"===e.css("position")?!1:n.test(e.css("overflow")+e.css("overflow-y")+e.css("overflow-x"))}).eq(0);return"fixed"!==i&&o.length?o:t(this[0].ownerDocument||document)},t.extend(t.expr[":"],{tabbable:function(e){var i=t.attr(e,"tabindex"),s=null!=i;return(!s||i>=0)&&t.ui.focusable(e,s)}}),t.fn.extend({uniqueId:function(){var t=0;return function(){return this.each(function(){this.id||(this.id="ui-id-"+ ++t)})}}(),removeUniqueId:function(){return this.each(function(){/^ui-id-\d+$/.test(this.id)&&t(this).removeAttr("id")})}}),t.ui.ie=!!/msie [\w.]+/.exec(navigator.userAgent.toLowerCase());var n=!1;t(document).on("mouseup",function(){n=!1}),t.widget("ui.mouse",{version:"1.12.1",options:{cancel:"input, textarea, button, select, option",distance:1,delay:0},_mouseInit:function(){var e=this;this.element.on("mousedown."+this.widgetName,function(t){return e._mouseDown(t)}).on("click."+this.widgetName,function(i){return!0===t.data(i.target,e.widgetName+".preventClickEvent")?(t.removeData(i.target,e.widgetName+".preventClickEvent"),i.stopImmediatePropagation(),!1):void 0}),this.started=!1},_mouseDestroy:function(){this.element.off("."+this.widgetName),this._mouseMoveDelegate&&this.document.off("mousemove."+this.widgetName,this._mouseMoveDelegate).off("mouseup."+this.widgetName,this._mouseUpDelegate)},_mouseDown:function(e){if(!n){this._mouseMoved=!1,this._mouseStarted&&this._mouseUp(e),this._mouseDownEvent=e;var i=this,s=1===e.which,o="string"==typeof this.options.cancel&&e.target.nodeName?t(e.target).closest(this.options.cancel).length:!1;return s&&!o&&this._mouseCapture(e)?(this.mouseDelayMet=!this.options.delay,this.mouseDelayMet||(this._mouseDelayTimer=setTimeout(function(){i.mouseDelayMet=!0},this.options.delay)),this._mouseDistanceMet(e)&&this._mouseDelayMet(e)&&(this._mouseStarted=this._mouseStart(e)!==!1,!this._mouseStarted)?(e.preventDefault(),!0):(!0===t.data(e.target,this.widgetName+".preventClickEvent")&&t.removeData(e.target,this.widgetName+".preventClickEvent"),this._mouseMoveDelegate=function(t){return i._mouseMove(t)},this._mouseUpDelegate=function(t){return i._mouseUp(t)},this.document.on("mousemove."+this.widgetName,this._mouseMoveDelegate).on("mouseup."+this.widgetName,this._mouseUpDelegate),e.preventDefault(),n=!0,!0)):!0}},_mouseMove:function(e){if(this._mouseMoved){if(t.ui.ie&&(!document.documentMode||9>document.documentMode)&&!e.button)return this._mouseUp(e);if(!e.which)if(e.originalEvent.altKey||e.originalEvent.ctrlKey||e.originalEvent.metaKey||e.originalEvent.shiftKey)this.ignoreMissingWhich=!0;else if(!this.ignoreMissingWhich)return this._mouseUp(e)}return(e.which||e.button)&&(this._mouseMoved=!0),this._mouseStarted?(this._mouseDrag(e),e.preventDefault()):(this._mouseDistanceMet(e)&&this._mouseDelayMet(e)&&(this._mouseStarted=this._mouseStart(this._mouseDownEvent,e)!==!1,this._mouseStarted?this._mouseDrag(e):this._mouseUp(e)),!this._mouseStarted)},_mouseUp:function(e){this.document.off("mousemove."+this.widgetName,this._mouseMoveDelegate).off("mouseup."+this.widgetName,this._mouseUpDelegate),this._mouseStarted&&(this._mouseStarted=!1,e.target===this._mouseDownEvent.target&&t.data(e.target,this.widgetName+".preventClickEvent",!0),this._mouseStop(e)),this._mouseDelayTimer&&(clearTimeout(this._mouseDelayTimer),delete this._mouseDelayTimer),this.ignoreMissingWhich=!1,n=!1,e.preventDefault()},_mouseDistanceMet:function(t){return Math.max(Math.abs(this._mouseDownEvent.pageX-t.pageX),Math.abs(this._mouseDownEvent.pageY-t.pageY))>=this.options.distance},_mouseDelayMet:function(){return this.mouseDelayMet},_mouseStart:function(){},_mouseDrag:function(){},_mouseStop:function(){},_mouseCapture:function(){return!0}}),t.ui.plugin={add:function(e,i,s){var n,o=t.ui[e].prototype;for(n in s)o.plugins[n]=o.plugins[n]||[],o.plugins[n].push([i,s[n]])},call:function(t,e,i,s){var n,o=t.plugins[e];if(o&&(s||t.element[0].parentNode&&11!==t.element[0].parentNode.nodeType))for(n=0;o.length>n;n++)t.options[o[n][0]]&&o[n][1].apply(t.element,i)}},t.widget("ui.resizable",t.ui.mouse,{version:"1.12.1",widgetEventPrefix:"resize",options:{alsoResize:!1,animate:!1,animateDuration:"slow",animateEasing:"swing",aspectRatio:!1,autoHide:!1,classes:{"ui-resizable-se":"ui-icon ui-icon-gripsmall-diagonal-se"},containment:!1,ghost:!1,grid:!1,handles:"e,s,se",helper:!1,maxHeight:null,maxWidth:null,minHeight:10,minWidth:10,zIndex:90,resize:null,start:null,stop:null},_num:function(t){return parseFloat(t)||0},_isNumber:function(t){return!isNaN(parseFloat(t))},_hasScroll:function(e,i){if("hidden"===t(e).css("overflow"))return!1;var s=i&&"left"===i?"scrollLeft":"scrollTop",n=!1;return e[s]>0?!0:(e[s]=1,n=e[s]>0,e[s]=0,n)},_create:function(){var e,i=this.options,s=this;this._addClass("ui-resizable"),t.extend(this,{_aspectRatio:!!i.aspectRatio,aspectRatio:i.aspectRatio,originalElement:this.element,_proportionallyResizeElements:[],_helper:i.helper||i.ghost||i.animate?i.helper||"ui-resizable-helper":null}),this.element[0].nodeName.match(/^(canvas|textarea|input|select|button|img)$/i)&&(this.element.wrap(t("
").css({position:this.element.css("position"),width:this.element.outerWidth(),height:this.element.outerHeight(),top:this.element.css("top"),left:this.element.css("left")})),this.element=this.element.parent().data("ui-resizable",this.element.resizable("instance")),this.elementIsWrapper=!0,e={marginTop:this.originalElement.css("marginTop"),marginRight:this.originalElement.css("marginRight"),marginBottom:this.originalElement.css("marginBottom"),marginLeft:this.originalElement.css("marginLeft")},this.element.css(e),this.originalElement.css("margin",0),this.originalResizeStyle=this.originalElement.css("resize"),this.originalElement.css("resize","none"),this._proportionallyResizeElements.push(this.originalElement.css({position:"static",zoom:1,display:"block"})),this.originalElement.css(e),this._proportionallyResize()),this._setupHandles(),i.autoHide&&t(this.element).on("mouseenter",function(){i.disabled||(s._removeClass("ui-resizable-autohide"),s._handles.show())}).on("mouseleave",function(){i.disabled||s.resizing||(s._addClass("ui-resizable-autohide"),s._handles.hide())}),this._mouseInit()},_destroy:function(){this._mouseDestroy();var e,i=function(e){t(e).removeData("resizable").removeData("ui-resizable").off(".resizable").find(".ui-resizable-handle").remove()};return this.elementIsWrapper&&(i(this.element),e=this.element,this.originalElement.css({position:e.css("position"),width:e.outerWidth(),height:e.outerHeight(),top:e.css("top"),left:e.css("left")}).insertAfter(e),e.remove()),this.originalElement.css("resize",this.originalResizeStyle),i(this.originalElement),this},_setOption:function(t,e){switch(this._super(t,e),t){case"handles":this._removeHandles(),this._setupHandles();break;default:}},_setupHandles:function(){var e,i,s,n,o,a=this.options,r=this;if(this.handles=a.handles||(t(".ui-resizable-handle",this.element).length?{n:".ui-resizable-n",e:".ui-resizable-e",s:".ui-resizable-s",w:".ui-resizable-w",se:".ui-resizable-se",sw:".ui-resizable-sw",ne:".ui-resizable-ne",nw:".ui-resizable-nw"}:"e,s,se"),this._handles=t(),this.handles.constructor===String)for("all"===this.handles&&(this.handles="n,e,s,w,se,sw,ne,nw"),s=this.handles.split(","),this.handles={},i=0;s.length>i;i++)e=t.trim(s[i]),n="ui-resizable-"+e,o=t("
"),this._addClass(o,"ui-resizable-handle "+n),o.css({zIndex:a.zIndex}),this.handles[e]=".ui-resizable-"+e,this.element.append(o);this._renderAxis=function(e){var i,s,n,o;e=e||this.element;for(i in this.handles)this.handles[i].constructor===String?this.handles[i]=this.element.children(this.handles[i]).first().show():(this.handles[i].jquery||this.handles[i].nodeType)&&(this.handles[i]=t(this.handles[i]),this._on(this.handles[i],{mousedown:r._mouseDown})),this.elementIsWrapper&&this.originalElement[0].nodeName.match(/^(textarea|input|select|button)$/i)&&(s=t(this.handles[i],this.element),o=/sw|ne|nw|se|n|s/.test(i)?s.outerHeight():s.outerWidth(),n=["padding",/ne|nw|n/.test(i)?"Top":/se|sw|s/.test(i)?"Bottom":/^e$/.test(i)?"Right":"Left"].join(""),e.css(n,o),this._proportionallyResize()),this._handles=this._handles.add(this.handles[i])},this._renderAxis(this.element),this._handles=this._handles.add(this.element.find(".ui-resizable-handle")),this._handles.disableSelection(),this._handles.on("mouseover",function(){r.resizing||(this.className&&(o=this.className.match(/ui-resizable-(se|sw|ne|nw|n|e|s|w)/i)),r.axis=o&&o[1]?o[1]:"se")}),a.autoHide&&(this._handles.hide(),this._addClass("ui-resizable-autohide"))},_removeHandles:function(){this._handles.remove()},_mouseCapture:function(e){var i,s,n=!1;for(i in this.handles)s=t(this.handles[i])[0],(s===e.target||t.contains(s,e.target))&&(n=!0);return!this.options.disabled&&n},_mouseStart:function(e){var i,s,n,o=this.options,a=this.element;return this.resizing=!0,this._renderProxy(),i=this._num(this.helper.css("left")),s=this._num(this.helper.css("top")),o.containment&&(i+=t(o.containment).scrollLeft()||0,s+=t(o.containment).scrollTop()||0),this.offset=this.helper.offset(),this.position={left:i,top:s},this.size=this._helper?{width:this.helper.width(),height:this.helper.height()}:{width:a.width(),height:a.height()},this.originalSize=this._helper?{width:a.outerWidth(),height:a.outerHeight()}:{width:a.width(),height:a.height()},this.sizeDiff={width:a.outerWidth()-a.width(),height:a.outerHeight()-a.height()},this.originalPosition={left:i,top:s},this.originalMousePosition={left:e.pageX,top:e.pageY},this.aspectRatio="number"==typeof o.aspectRatio?o.aspectRatio:this.originalSize.width/this.originalSize.height||1,n=t(".ui-resizable-"+this.axis).css("cursor"),t("body").css("cursor","auto"===n?this.axis+"-resize":n),this._addClass("ui-resizable-resizing"),this._propagate("start",e),!0},_mouseDrag:function(e){var i,s,n=this.originalMousePosition,o=this.axis,a=e.pageX-n.left||0,r=e.pageY-n.top||0,h=this._change[o];return this._updatePrevProperties(),h?(i=h.apply(this,[e,a,r]),this._updateVirtualBoundaries(e.shiftKey),(this._aspectRatio||e.shiftKey)&&(i=this._updateRatio(i,e)),i=this._respectSize(i,e),this._updateCache(i),this._propagate("resize",e),s=this._applyChanges(),!this._helper&&this._proportionallyResizeElements.length&&this._proportionallyResize(),t.isEmptyObject(s)||(this._updatePrevProperties(),this._trigger("resize",e,this.ui()),this._applyChanges()),!1):!1},_mouseStop:function(e){this.resizing=!1;var i,s,n,o,a,r,h,l=this.options,c=this;return this._helper&&(i=this._proportionallyResizeElements,s=i.length&&/textarea/i.test(i[0].nodeName),n=s&&this._hasScroll(i[0],"left")?0:c.sizeDiff.height,o=s?0:c.sizeDiff.width,a={width:c.helper.width()-o,height:c.helper.height()-n},r=parseFloat(c.element.css("left"))+(c.position.left-c.originalPosition.left)||null,h=parseFloat(c.element.css("top"))+(c.position.top-c.originalPosition.top)||null,l.animate||this.element.css(t.extend(a,{top:h,left:r})),c.helper.height(c.size.height),c.helper.width(c.size.width),this._helper&&!l.animate&&this._proportionallyResize()),t("body").css("cursor","auto"),this._removeClass("ui-resizable-resizing"),this._propagate("stop",e),this._helper&&this.helper.remove(),!1},_updatePrevProperties:function(){this.prevPosition={top:this.position.top,left:this.position.left},this.prevSize={width:this.size.width,height:this.size.height}},_applyChanges:function(){var t={};return this.position.top!==this.prevPosition.top&&(t.top=this.position.top+"px"),this.position.left!==this.prevPosition.left&&(t.left=this.position.left+"px"),this.size.width!==this.prevSize.width&&(t.width=this.size.width+"px"),this.size.height!==this.prevSize.height&&(t.height=this.size.height+"px"),this.helper.css(t),t},_updateVirtualBoundaries:function(t){var e,i,s,n,o,a=this.options;o={minWidth:this._isNumber(a.minWidth)?a.minWidth:0,maxWidth:this._isNumber(a.maxWidth)?a.maxWidth:1/0,minHeight:this._isNumber(a.minHeight)?a.minHeight:0,maxHeight:this._isNumber(a.maxHeight)?a.maxHeight:1/0},(this._aspectRatio||t)&&(e=o.minHeight*this.aspectRatio,s=o.minWidth/this.aspectRatio,i=o.maxHeight*this.aspectRatio,n=o.maxWidth/this.aspectRatio,e>o.minWidth&&(o.minWidth=e),s>o.minHeight&&(o.minHeight=s),o.maxWidth>i&&(o.maxWidth=i),o.maxHeight>n&&(o.maxHeight=n)),this._vBoundaries=o},_updateCache:function(t){this.offset=this.helper.offset(),this._isNumber(t.left)&&(this.position.left=t.left),this._isNumber(t.top)&&(this.position.top=t.top),this._isNumber(t.height)&&(this.size.height=t.height),this._isNumber(t.width)&&(this.size.width=t.width)},_updateRatio:function(t){var e=this.position,i=this.size,s=this.axis;return this._isNumber(t.height)?t.width=t.height*this.aspectRatio:this._isNumber(t.width)&&(t.height=t.width/this.aspectRatio),"sw"===s&&(t.left=e.left+(i.width-t.width),t.top=null),"nw"===s&&(t.top=e.top+(i.height-t.height),t.left=e.left+(i.width-t.width)),t},_respectSize:function(t){var e=this._vBoundaries,i=this.axis,s=this._isNumber(t.width)&&e.maxWidth&&e.maxWidtht.width,a=this._isNumber(t.height)&&e.minHeight&&e.minHeight>t.height,r=this.originalPosition.left+this.originalSize.width,h=this.originalPosition.top+this.originalSize.height,l=/sw|nw|w/.test(i),c=/nw|ne|n/.test(i);return o&&(t.width=e.minWidth),a&&(t.height=e.minHeight),s&&(t.width=e.maxWidth),n&&(t.height=e.maxHeight),o&&l&&(t.left=r-e.minWidth),s&&l&&(t.left=r-e.maxWidth),a&&c&&(t.top=h-e.minHeight),n&&c&&(t.top=h-e.maxHeight),t.width||t.height||t.left||!t.top?t.width||t.height||t.top||!t.left||(t.left=null):t.top=null,t},_getPaddingPlusBorderDimensions:function(t){for(var e=0,i=[],s=[t.css("borderTopWidth"),t.css("borderRightWidth"),t.css("borderBottomWidth"),t.css("borderLeftWidth")],n=[t.css("paddingTop"),t.css("paddingRight"),t.css("paddingBottom"),t.css("paddingLeft")];4>e;e++)i[e]=parseFloat(s[e])||0,i[e]+=parseFloat(n[e])||0;return{height:i[0]+i[2],width:i[1]+i[3]}},_proportionallyResize:function(){if(this._proportionallyResizeElements.length)for(var t,e=0,i=this.helper||this.element;this._proportionallyResizeElements.length>e;e++)t=this._proportionallyResizeElements[e],this.outerDimensions||(this.outerDimensions=this._getPaddingPlusBorderDimensions(t)),t.css({height:i.height()-this.outerDimensions.height||0,width:i.width()-this.outerDimensions.width||0})},_renderProxy:function(){var e=this.element,i=this.options;this.elementOffset=e.offset(),this._helper?(this.helper=this.helper||t("
"),this._addClass(this.helper,this._helper),this.helper.css({width:this.element.outerWidth(),height:this.element.outerHeight(),position:"absolute",left:this.elementOffset.left+"px",top:this.elementOffset.top+"px",zIndex:++i.zIndex}),this.helper.appendTo("body").disableSelection()):this.helper=this.element +},_change:{e:function(t,e){return{width:this.originalSize.width+e}},w:function(t,e){var i=this.originalSize,s=this.originalPosition;return{left:s.left+e,width:i.width-e}},n:function(t,e,i){var s=this.originalSize,n=this.originalPosition;return{top:n.top+i,height:s.height-i}},s:function(t,e,i){return{height:this.originalSize.height+i}},se:function(e,i,s){return t.extend(this._change.s.apply(this,arguments),this._change.e.apply(this,[e,i,s]))},sw:function(e,i,s){return t.extend(this._change.s.apply(this,arguments),this._change.w.apply(this,[e,i,s]))},ne:function(e,i,s){return t.extend(this._change.n.apply(this,arguments),this._change.e.apply(this,[e,i,s]))},nw:function(e,i,s){return t.extend(this._change.n.apply(this,arguments),this._change.w.apply(this,[e,i,s]))}},_propagate:function(e,i){t.ui.plugin.call(this,e,[i,this.ui()]),"resize"!==e&&this._trigger(e,i,this.ui())},plugins:{},ui:function(){return{originalElement:this.originalElement,element:this.element,helper:this.helper,position:this.position,size:this.size,originalSize:this.originalSize,originalPosition:this.originalPosition}}}),t.ui.plugin.add("resizable","animate",{stop:function(e){var i=t(this).resizable("instance"),s=i.options,n=i._proportionallyResizeElements,o=n.length&&/textarea/i.test(n[0].nodeName),a=o&&i._hasScroll(n[0],"left")?0:i.sizeDiff.height,r=o?0:i.sizeDiff.width,h={width:i.size.width-r,height:i.size.height-a},l=parseFloat(i.element.css("left"))+(i.position.left-i.originalPosition.left)||null,c=parseFloat(i.element.css("top"))+(i.position.top-i.originalPosition.top)||null;i.element.animate(t.extend(h,c&&l?{top:c,left:l}:{}),{duration:s.animateDuration,easing:s.animateEasing,step:function(){var s={width:parseFloat(i.element.css("width")),height:parseFloat(i.element.css("height")),top:parseFloat(i.element.css("top")),left:parseFloat(i.element.css("left"))};n&&n.length&&t(n[0]).css({width:s.width,height:s.height}),i._updateCache(s),i._propagate("resize",e)}})}}),t.ui.plugin.add("resizable","containment",{start:function(){var e,i,s,n,o,a,r,h=t(this).resizable("instance"),l=h.options,c=h.element,u=l.containment,d=u instanceof t?u.get(0):/parent/.test(u)?c.parent().get(0):u;d&&(h.containerElement=t(d),/document/.test(u)||u===document?(h.containerOffset={left:0,top:0},h.containerPosition={left:0,top:0},h.parentData={element:t(document),left:0,top:0,width:t(document).width(),height:t(document).height()||document.body.parentNode.scrollHeight}):(e=t(d),i=[],t(["Top","Right","Left","Bottom"]).each(function(t,s){i[t]=h._num(e.css("padding"+s))}),h.containerOffset=e.offset(),h.containerPosition=e.position(),h.containerSize={height:e.innerHeight()-i[3],width:e.innerWidth()-i[1]},s=h.containerOffset,n=h.containerSize.height,o=h.containerSize.width,a=h._hasScroll(d,"left")?d.scrollWidth:o,r=h._hasScroll(d)?d.scrollHeight:n,h.parentData={element:d,left:s.left,top:s.top,width:a,height:r}))},resize:function(e){var i,s,n,o,a=t(this).resizable("instance"),r=a.options,h=a.containerOffset,l=a.position,c=a._aspectRatio||e.shiftKey,u={top:0,left:0},d=a.containerElement,p=!0;d[0]!==document&&/static/.test(d.css("position"))&&(u=h),l.left<(a._helper?h.left:0)&&(a.size.width=a.size.width+(a._helper?a.position.left-h.left:a.position.left-u.left),c&&(a.size.height=a.size.width/a.aspectRatio,p=!1),a.position.left=r.helper?h.left:0),l.top<(a._helper?h.top:0)&&(a.size.height=a.size.height+(a._helper?a.position.top-h.top:a.position.top),c&&(a.size.width=a.size.height*a.aspectRatio,p=!1),a.position.top=a._helper?h.top:0),n=a.containerElement.get(0)===a.element.parent().get(0),o=/relative|absolute/.test(a.containerElement.css("position")),n&&o?(a.offset.left=a.parentData.left+a.position.left,a.offset.top=a.parentData.top+a.position.top):(a.offset.left=a.element.offset().left,a.offset.top=a.element.offset().top),i=Math.abs(a.sizeDiff.width+(a._helper?a.offset.left-u.left:a.offset.left-h.left)),s=Math.abs(a.sizeDiff.height+(a._helper?a.offset.top-u.top:a.offset.top-h.top)),i+a.size.width>=a.parentData.width&&(a.size.width=a.parentData.width-i,c&&(a.size.height=a.size.width/a.aspectRatio,p=!1)),s+a.size.height>=a.parentData.height&&(a.size.height=a.parentData.height-s,c&&(a.size.width=a.size.height*a.aspectRatio,p=!1)),p||(a.position.left=a.prevPosition.left,a.position.top=a.prevPosition.top,a.size.width=a.prevSize.width,a.size.height=a.prevSize.height)},stop:function(){var e=t(this).resizable("instance"),i=e.options,s=e.containerOffset,n=e.containerPosition,o=e.containerElement,a=t(e.helper),r=a.offset(),h=a.outerWidth()-e.sizeDiff.width,l=a.outerHeight()-e.sizeDiff.height;e._helper&&!i.animate&&/relative/.test(o.css("position"))&&t(this).css({left:r.left-n.left-s.left,width:h,height:l}),e._helper&&!i.animate&&/static/.test(o.css("position"))&&t(this).css({left:r.left-n.left-s.left,width:h,height:l})}}),t.ui.plugin.add("resizable","alsoResize",{start:function(){var e=t(this).resizable("instance"),i=e.options;t(i.alsoResize).each(function(){var e=t(this);e.data("ui-resizable-alsoresize",{width:parseFloat(e.width()),height:parseFloat(e.height()),left:parseFloat(e.css("left")),top:parseFloat(e.css("top"))})})},resize:function(e,i){var s=t(this).resizable("instance"),n=s.options,o=s.originalSize,a=s.originalPosition,r={height:s.size.height-o.height||0,width:s.size.width-o.width||0,top:s.position.top-a.top||0,left:s.position.left-a.left||0};t(n.alsoResize).each(function(){var e=t(this),s=t(this).data("ui-resizable-alsoresize"),n={},o=e.parents(i.originalElement[0]).length?["width","height"]:["width","height","top","left"];t.each(o,function(t,e){var i=(s[e]||0)+(r[e]||0);i&&i>=0&&(n[e]=i||null)}),e.css(n)})},stop:function(){t(this).removeData("ui-resizable-alsoresize")}}),t.ui.plugin.add("resizable","ghost",{start:function(){var e=t(this).resizable("instance"),i=e.size;e.ghost=e.originalElement.clone(),e.ghost.css({opacity:.25,display:"block",position:"relative",height:i.height,width:i.width,margin:0,left:0,top:0}),e._addClass(e.ghost,"ui-resizable-ghost"),t.uiBackCompat!==!1&&"string"==typeof e.options.ghost&&e.ghost.addClass(this.options.ghost),e.ghost.appendTo(e.helper)},resize:function(){var e=t(this).resizable("instance");e.ghost&&e.ghost.css({position:"relative",height:e.size.height,width:e.size.width})},stop:function(){var e=t(this).resizable("instance");e.ghost&&e.helper&&e.helper.get(0).removeChild(e.ghost.get(0))}}),t.ui.plugin.add("resizable","grid",{resize:function(){var e,i=t(this).resizable("instance"),s=i.options,n=i.size,o=i.originalSize,a=i.originalPosition,r=i.axis,h="number"==typeof s.grid?[s.grid,s.grid]:s.grid,l=h[0]||1,c=h[1]||1,u=Math.round((n.width-o.width)/l)*l,d=Math.round((n.height-o.height)/c)*c,p=o.width+u,f=o.height+d,m=s.maxWidth&&p>s.maxWidth,g=s.maxHeight&&f>s.maxHeight,_=s.minWidth&&s.minWidth>p,v=s.minHeight&&s.minHeight>f;s.grid=h,_&&(p+=l),v&&(f+=c),m&&(p-=l),g&&(f-=c),/^(se|s|e)$/.test(r)?(i.size.width=p,i.size.height=f):/^(ne)$/.test(r)?(i.size.width=p,i.size.height=f,i.position.top=a.top-d):/^(sw)$/.test(r)?(i.size.width=p,i.size.height=f,i.position.left=a.left-u):((0>=f-c||0>=p-l)&&(e=i._getPaddingPlusBorderDimensions(this)),f-c>0?(i.size.height=f,i.position.top=a.top-d):(f=c-e.height,i.size.height=f,i.position.top=a.top+o.height-f),p-l>0?(i.size.width=p,i.position.left=a.left-u):(p=l-e.width,i.size.width=p,i.position.left=a.left+o.width-p))}}),t.ui.resizable});/** + * Copyright (c) 2007 Ariel Flesler - aflesler ○ gmail • com | https://github.com/flesler + * Licensed under MIT + * @author Ariel Flesler + * @version 2.1.2 + */ +;(function(f){"use strict";"function"===typeof define&&define.amd?define(["jquery"],f):"undefined"!==typeof module&&module.exports?module.exports=f(require("jquery")):f(jQuery)})(function($){"use strict";function n(a){return!a.nodeName||-1!==$.inArray(a.nodeName.toLowerCase(),["iframe","#document","html","body"])}function h(a){return $.isFunction(a)||$.isPlainObject(a)?a:{top:a,left:a}}var p=$.scrollTo=function(a,d,b){return $(window).scrollTo(a,d,b)};p.defaults={axis:"xy",duration:0,limit:!0};$.fn.scrollTo=function(a,d,b){"object"=== typeof d&&(b=d,d=0);"function"===typeof b&&(b={onAfter:b});"max"===a&&(a=9E9);b=$.extend({},p.defaults,b);d=d||b.duration;var u=b.queue&&1=f[g]?0:Math.min(f[g],n));!a&&1-1){targetElements.on(evt+EVENT_NAMESPACE,function elementToggle(event){$.powerTip.toggle(this,event)})}else{targetElements.on(evt+EVENT_NAMESPACE,function elementOpen(event){$.powerTip.show(this,event)})}});$.each(options.closeEvents,function(idx,evt){if($.inArray(evt,options.openEvents)<0){targetElements.on(evt+EVENT_NAMESPACE,function elementClose(event){$.powerTip.hide(this,!isMouseEvent(event))})}});targetElements.on("keydown"+EVENT_NAMESPACE,function elementKeyDown(event){if(event.keyCode===27){$.powerTip.hide(this,true)}})}return targetElements};$.fn.powerTip.defaults={fadeInTime:200,fadeOutTime:100,followMouse:false,popupId:"powerTip",popupClass:null,intentSensitivity:7,intentPollInterval:100,closeDelay:100,placement:"n",smartPlacement:false,offset:10,mouseOnToPopup:false,manual:false,openEvents:["mouseenter","focus"],closeEvents:["mouseleave","blur"]};$.fn.powerTip.smartPlacementLists={n:["n","ne","nw","s"],e:["e","ne","se","w","nw","sw","n","s","e"],s:["s","se","sw","n"],w:["w","nw","sw","e","ne","se","n","s","w"],nw:["nw","w","sw","n","s","se","nw"],ne:["ne","e","se","n","s","sw","ne"],sw:["sw","w","nw","s","n","ne","sw"],se:["se","e","ne","s","n","nw","se"],"nw-alt":["nw-alt","n","ne-alt","sw-alt","s","se-alt","w","e"],"ne-alt":["ne-alt","n","nw-alt","se-alt","s","sw-alt","e","w"],"sw-alt":["sw-alt","s","se-alt","nw-alt","n","ne-alt","w","e"],"se-alt":["se-alt","s","sw-alt","ne-alt","n","nw-alt","e","w"]};$.powerTip={show:function apiShowTip(element,event){if(isMouseEvent(event)){trackMouse(event);session.previousX=event.pageX;session.previousY=event.pageY;$(element).data(DATA_DISPLAYCONTROLLER).show()}else{$(element).first().data(DATA_DISPLAYCONTROLLER).show(true,true)}return element},reposition:function apiResetPosition(element){$(element).first().data(DATA_DISPLAYCONTROLLER).resetPosition();return element},hide:function apiCloseTip(element,immediate){var displayController;immediate=element?immediate:true;if(element){displayController=$(element).first().data(DATA_DISPLAYCONTROLLER)}else if(session.activeHover){displayController=session.activeHover.data(DATA_DISPLAYCONTROLLER)}if(displayController){displayController.hide(immediate)}return element},toggle:function apiToggle(element,event){if(session.activeHover&&session.activeHover.is(element)){$.powerTip.hide(element,!isMouseEvent(event))}else{$.powerTip.show(element,event)}return element}};$.powerTip.showTip=$.powerTip.show;$.powerTip.closeTip=$.powerTip.hide;function CSSCoordinates(){var me=this;me.top="auto";me.left="auto";me.right="auto";me.bottom="auto";me.set=function(property,value){if($.isNumeric(value)){me[property]=Math.round(value)}}}function DisplayController(element,options,tipController){var hoverTimer=null,myCloseDelay=null;function openTooltip(immediate,forceOpen){cancelTimer();if(!element.data(DATA_HASACTIVEHOVER)){if(!immediate){session.tipOpenImminent=true;hoverTimer=setTimeout(function intentDelay(){hoverTimer=null;checkForIntent()},options.intentPollInterval)}else{if(forceOpen){element.data(DATA_FORCEDOPEN,true)}closeAnyDelayed();tipController.showTip(element)}}else{cancelClose()}}function closeTooltip(disableDelay){if(myCloseDelay){myCloseDelay=session.closeDelayTimeout=clearTimeout(myCloseDelay);session.delayInProgress=false}cancelTimer();session.tipOpenImminent=false;if(element.data(DATA_HASACTIVEHOVER)){element.data(DATA_FORCEDOPEN,false);if(!disableDelay){session.delayInProgress=true;session.closeDelayTimeout=setTimeout(function closeDelay(){session.closeDelayTimeout=null;tipController.hideTip(element);session.delayInProgress=false;myCloseDelay=null},options.closeDelay);myCloseDelay=session.closeDelayTimeout}else{tipController.hideTip(element)}}}function checkForIntent(){var xDifference=Math.abs(session.previousX-session.currentX),yDifference=Math.abs(session.previousY-session.currentY),totalDifference=xDifference+yDifference;if(totalDifference",{id:options.popupId});if($body.length===0){$body=$("body")}$body.append(tipElement);session.tooltips=session.tooltips?session.tooltips.add(tipElement):tipElement}if(options.followMouse){if(!tipElement.data(DATA_HASMOUSEMOVE)){$document.on("mousemove"+EVENT_NAMESPACE,positionTipOnCursor);$window.on("scroll"+EVENT_NAMESPACE,positionTipOnCursor);tipElement.data(DATA_HASMOUSEMOVE,true)}}function beginShowTip(element){element.data(DATA_HASACTIVEHOVER,true);tipElement.queue(function queueTipInit(next){showTip(element);next()})}function showTip(element){var tipContent;if(!element.data(DATA_HASACTIVEHOVER)){return}if(session.isTipOpen){if(!session.isClosing){hideTip(session.activeHover)}tipElement.delay(100).queue(function queueTipAgain(next){showTip(element);next()});return}element.trigger("powerTipPreRender");tipContent=getTooltipContent(element);if(tipContent){tipElement.empty().append(tipContent)}else{return}element.trigger("powerTipRender");session.activeHover=element;session.isTipOpen=true;tipElement.data(DATA_MOUSEONTOTIP,options.mouseOnToPopup);tipElement.addClass(options.popupClass);if(!options.followMouse||element.data(DATA_FORCEDOPEN)){positionTipOnElement(element);session.isFixedTipOpen=true}else{positionTipOnCursor()}if(!element.data(DATA_FORCEDOPEN)&&!options.followMouse){$document.on("click"+EVENT_NAMESPACE,function documentClick(event){var target=event.target;if(target!==element[0]){if(options.mouseOnToPopup){if(target!==tipElement[0]&&!$.contains(tipElement[0],target)){$.powerTip.hide()}}else{$.powerTip.hide()}}})}if(options.mouseOnToPopup&&!options.manual){tipElement.on("mouseenter"+EVENT_NAMESPACE,function tipMouseEnter(){if(session.activeHover){session.activeHover.data(DATA_DISPLAYCONTROLLER).cancel()}});tipElement.on("mouseleave"+EVENT_NAMESPACE,function tipMouseLeave(){if(session.activeHover){session.activeHover.data(DATA_DISPLAYCONTROLLER).hide()}})}tipElement.fadeIn(options.fadeInTime,function fadeInCallback(){if(!session.desyncTimeout){session.desyncTimeout=setInterval(closeDesyncedTip,500)}element.trigger("powerTipOpen")})}function hideTip(element){session.isClosing=true;session.isTipOpen=false;session.desyncTimeout=clearInterval(session.desyncTimeout);element.data(DATA_HASACTIVEHOVER,false);element.data(DATA_FORCEDOPEN,false);$document.off("click"+EVENT_NAMESPACE);tipElement.off(EVENT_NAMESPACE);tipElement.fadeOut(options.fadeOutTime,function fadeOutCallback(){var coords=new CSSCoordinates;session.activeHover=null;session.isClosing=false;session.isFixedTipOpen=false;tipElement.removeClass();coords.set("top",session.currentY+options.offset);coords.set("left",session.currentX+options.offset);tipElement.css(coords);element.trigger("powerTipClose")})}function positionTipOnCursor(){var tipWidth,tipHeight,coords,collisions,collisionCount;if(!session.isFixedTipOpen&&(session.isTipOpen||session.tipOpenImminent&&tipElement.data(DATA_HASMOUSEMOVE))){tipWidth=tipElement.outerWidth();tipHeight=tipElement.outerHeight();coords=new CSSCoordinates;coords.set("top",session.currentY+options.offset);coords.set("left",session.currentX+options.offset);collisions=getViewportCollisions(coords,tipWidth,tipHeight);if(collisions!==Collision.none){collisionCount=countFlags(collisions);if(collisionCount===1){if(collisions===Collision.right){coords.set("left",session.scrollLeft+session.windowWidth-tipWidth)}else if(collisions===Collision.bottom){coords.set("top",session.scrollTop+session.windowHeight-tipHeight)}}else{coords.set("left",session.currentX-tipWidth-options.offset);coords.set("top",session.currentY-tipHeight-options.offset)}}tipElement.css(coords)}}function positionTipOnElement(element){var priorityList,finalPlacement;if(options.smartPlacement||options.followMouse&&element.data(DATA_FORCEDOPEN)){priorityList=$.fn.powerTip.smartPlacementLists[options.placement];$.each(priorityList,function(idx,pos){var collisions=getViewportCollisions(placeTooltip(element,pos),tipElement.outerWidth(),tipElement.outerHeight());finalPlacement=pos;return collisions!==Collision.none})}else{placeTooltip(element,options.placement);finalPlacement=options.placement}tipElement.removeClass("w nw sw e ne se n s w se-alt sw-alt ne-alt nw-alt");tipElement.addClass(finalPlacement)}function placeTooltip(element,placement){var iterationCount=0,tipWidth,tipHeight,coords=new CSSCoordinates;coords.set("top",0);coords.set("left",0);tipElement.css(coords);do{tipWidth=tipElement.outerWidth();tipHeight=tipElement.outerHeight();coords=placementCalculator.compute(element,placement,tipWidth,tipHeight,options.offset);tipElement.css(coords)}while(++iterationCount<=5&&(tipWidth!==tipElement.outerWidth()||tipHeight!==tipElement.outerHeight()));return coords}function closeDesyncedTip(){var isDesynced=false,hasDesyncableCloseEvent=$.grep(["mouseleave","mouseout","blur","focusout"],function(eventType){return $.inArray(eventType,options.closeEvents)!==-1}).length>0;if(session.isTipOpen&&!session.isClosing&&!session.delayInProgress&&hasDesyncableCloseEvent){if(session.activeHover.data(DATA_HASACTIVEHOVER)===false||session.activeHover.is(":disabled")){isDesynced=true}else if(!isMouseOver(session.activeHover)&&!session.activeHover.is(":focus")&&!session.activeHover.data(DATA_FORCEDOPEN)){if(tipElement.data(DATA_MOUSEONTOTIP)){if(!isMouseOver(tipElement)){isDesynced=true}}else{isDesynced=true}}if(isDesynced){hideTip(session.activeHover)}}}this.showTip=beginShowTip;this.hideTip=hideTip;this.resetPosition=positionTipOnElement}function isSvgElement(element){return Boolean(window.SVGElement&&element[0]instanceof SVGElement)}function isMouseEvent(event){return Boolean(event&&$.inArray(event.type,MOUSE_EVENTS)>-1&&typeof event.pageX==="number")}function initTracking(){if(!session.mouseTrackingActive){session.mouseTrackingActive=true;getViewportDimensions();$(getViewportDimensions);$document.on("mousemove"+EVENT_NAMESPACE,trackMouse);$window.on("resize"+EVENT_NAMESPACE,trackResize);$window.on("scroll"+EVENT_NAMESPACE,trackScroll)}}function getViewportDimensions(){session.scrollLeft=$window.scrollLeft();session.scrollTop=$window.scrollTop();session.windowWidth=$window.width();session.windowHeight=$window.height()}function trackResize(){session.windowWidth=$window.width();session.windowHeight=$window.height()}function trackScroll(){var x=$window.scrollLeft(),y=$window.scrollTop();if(x!==session.scrollLeft){session.currentX+=x-session.scrollLeft;session.scrollLeft=x}if(y!==session.scrollTop){session.currentY+=y-session.scrollTop;session.scrollTop=y}}function trackMouse(event){session.currentX=event.pageX;session.currentY=event.pageY}function isMouseOver(element){var elementPosition=element.offset(),elementBox=element[0].getBoundingClientRect(),elementWidth=elementBox.right-elementBox.left,elementHeight=elementBox.bottom-elementBox.top;return session.currentX>=elementPosition.left&&session.currentX<=elementPosition.left+elementWidth&&session.currentY>=elementPosition.top&&session.currentY<=elementPosition.top+elementHeight}function getTooltipContent(element){var tipText=element.data(DATA_POWERTIP),tipObject=element.data(DATA_POWERTIPJQ),tipTarget=element.data(DATA_POWERTIPTARGET),targetElement,content;if(tipText){if($.isFunction(tipText)){tipText=tipText.call(element[0])}content=tipText}else if(tipObject){if($.isFunction(tipObject)){tipObject=tipObject.call(element[0])}if(tipObject.length>0){content=tipObject.clone(true,true)}}else if(tipTarget){targetElement=$("#"+tipTarget);if(targetElement.length>0){content=targetElement.html()}}return content}function getViewportCollisions(coords,elementWidth,elementHeight){var viewportTop=session.scrollTop,viewportLeft=session.scrollLeft,viewportBottom=viewportTop+session.windowHeight,viewportRight=viewportLeft+session.windowWidth,collisions=Collision.none;if(coords.topviewportBottom||Math.abs(coords.bottom-session.windowHeight)>viewportBottom){collisions|=Collision.bottom}if(coords.leftviewportRight){collisions|=Collision.left}if(coords.left+elementWidth>viewportRight||coords.right1)){a.preventDefault();var c=a.originalEvent.changedTouches[0],d=document.createEvent("MouseEvents");d.initMouseEvent(b,!0,!0,window,1,c.screenX,c.screenY,c.clientX,c.clientY,!1,!1,!1,!1,0,null),a.target.dispatchEvent(d)}}if(a.support.touch="ontouchend"in document,a.support.touch){var e,b=a.ui.mouse.prototype,c=b._mouseInit,d=b._mouseDestroy;b._touchStart=function(a){var b=this;!e&&b._mouseCapture(a.originalEvent.changedTouches[0])&&(e=!0,b._touchMoved=!1,f(a,"mouseover"),f(a,"mousemove"),f(a,"mousedown"))},b._touchMove=function(a){e&&(this._touchMoved=!0,f(a,"mousemove"))},b._touchEnd=function(a){e&&(f(a,"mouseup"),f(a,"mouseout"),this._touchMoved||f(a,"click"),e=!1)},b._mouseInit=function(){var b=this;b.element.bind({touchstart:a.proxy(b,"_touchStart"),touchmove:a.proxy(b,"_touchMove"),touchend:a.proxy(b,"_touchEnd")}),c.call(b)},b._mouseDestroy=function(){var b=this;b.element.unbind({touchstart:a.proxy(b,"_touchStart"),touchmove:a.proxy(b,"_touchMove"),touchend:a.proxy(b,"_touchEnd")}),d.call(b)}}}(jQuery);/*! SmartMenus jQuery Plugin - v1.1.0 - September 17, 2017 + * http://www.smartmenus.org/ + * Copyright Vasil Dinkov, Vadikom Web Ltd. http://vadikom.com; Licensed MIT */(function(t){"function"==typeof define&&define.amd?define(["jquery"],t):"object"==typeof module&&"object"==typeof module.exports?module.exports=t(require("jquery")):t(jQuery)})(function($){function initMouseDetection(t){var e=".smartmenus_mouse";if(mouseDetectionEnabled||t)mouseDetectionEnabled&&t&&($(document).off(e),mouseDetectionEnabled=!1);else{var i=!0,s=null,o={mousemove:function(t){var e={x:t.pageX,y:t.pageY,timeStamp:(new Date).getTime()};if(s){var o=Math.abs(s.x-e.x),a=Math.abs(s.y-e.y);if((o>0||a>0)&&2>=o&&2>=a&&300>=e.timeStamp-s.timeStamp&&(mouse=!0,i)){var n=$(t.target).closest("a");n.is("a")&&$.each(menuTrees,function(){return $.contains(this.$root[0],n[0])?(this.itemEnter({currentTarget:n[0]}),!1):void 0}),i=!1}}s=e}};o[touchEvents?"touchstart":"pointerover pointermove pointerout MSPointerOver MSPointerMove MSPointerOut"]=function(t){isTouchEvent(t.originalEvent)&&(mouse=!1)},$(document).on(getEventsNS(o,e)),mouseDetectionEnabled=!0}}function isTouchEvent(t){return!/^(4|mouse)$/.test(t.pointerType)}function getEventsNS(t,e){e||(e="");var i={};for(var s in t)i[s.split(" ").join(e+" ")+e]=t[s];return i}var menuTrees=[],mouse=!1,touchEvents="ontouchstart"in window,mouseDetectionEnabled=!1,requestAnimationFrame=window.requestAnimationFrame||function(t){return setTimeout(t,1e3/60)},cancelAnimationFrame=window.cancelAnimationFrame||function(t){clearTimeout(t)},canAnimate=!!$.fn.animate;return $.SmartMenus=function(t,e){this.$root=$(t),this.opts=e,this.rootId="",this.accessIdPrefix="",this.$subArrow=null,this.activatedItems=[],this.visibleSubMenus=[],this.showTimeout=0,this.hideTimeout=0,this.scrollTimeout=0,this.clickActivated=!1,this.focusActivated=!1,this.zIndexInc=0,this.idInc=0,this.$firstLink=null,this.$firstSub=null,this.disabled=!1,this.$disableOverlay=null,this.$touchScrollingSub=null,this.cssTransforms3d="perspective"in t.style||"webkitPerspective"in t.style,this.wasCollapsible=!1,this.init()},$.extend($.SmartMenus,{hideAll:function(){$.each(menuTrees,function(){this.menuHideAll()})},destroy:function(){for(;menuTrees.length;)menuTrees[0].destroy();initMouseDetection(!0)},prototype:{init:function(t){var e=this;if(!t){menuTrees.push(this),this.rootId=((new Date).getTime()+Math.random()+"").replace(/\D/g,""),this.accessIdPrefix="sm-"+this.rootId+"-",this.$root.hasClass("sm-rtl")&&(this.opts.rightToLeftSubMenus=!0);var i=".smartmenus";this.$root.data("smartmenus",this).attr("data-smartmenus-id",this.rootId).dataSM("level",1).on(getEventsNS({"mouseover focusin":$.proxy(this.rootOver,this),"mouseout focusout":$.proxy(this.rootOut,this),keydown:$.proxy(this.rootKeyDown,this)},i)).on(getEventsNS({mouseenter:$.proxy(this.itemEnter,this),mouseleave:$.proxy(this.itemLeave,this),mousedown:$.proxy(this.itemDown,this),focus:$.proxy(this.itemFocus,this),blur:$.proxy(this.itemBlur,this),click:$.proxy(this.itemClick,this)},i),"a"),i+=this.rootId,this.opts.hideOnClick&&$(document).on(getEventsNS({touchstart:$.proxy(this.docTouchStart,this),touchmove:$.proxy(this.docTouchMove,this),touchend:$.proxy(this.docTouchEnd,this),click:$.proxy(this.docClick,this)},i)),$(window).on(getEventsNS({"resize orientationchange":$.proxy(this.winResize,this)},i)),this.opts.subIndicators&&(this.$subArrow=$("").addClass("sub-arrow"),this.opts.subIndicatorsText&&this.$subArrow.html(this.opts.subIndicatorsText)),initMouseDetection()}if(this.$firstSub=this.$root.find("ul").each(function(){e.menuInit($(this))}).eq(0),this.$firstLink=this.$root.find("a").eq(0),this.opts.markCurrentItem){var s=/(index|default)\.[^#\?\/]*/i,o=/#.*/,a=window.location.href.replace(s,""),n=a.replace(o,"");this.$root.find("a").each(function(){var t=this.href.replace(s,""),i=$(this);(t==a||t==n)&&(i.addClass("current"),e.opts.markCurrentTree&&i.parentsUntil("[data-smartmenus-id]","ul").each(function(){$(this).dataSM("parent-a").addClass("current")}))})}this.wasCollapsible=this.isCollapsible()},destroy:function(t){if(!t){var e=".smartmenus";this.$root.removeData("smartmenus").removeAttr("data-smartmenus-id").removeDataSM("level").off(e),e+=this.rootId,$(document).off(e),$(window).off(e),this.opts.subIndicators&&(this.$subArrow=null)}this.menuHideAll();var i=this;this.$root.find("ul").each(function(){var t=$(this);t.dataSM("scroll-arrows")&&t.dataSM("scroll-arrows").remove(),t.dataSM("shown-before")&&((i.opts.subMenusMinWidth||i.opts.subMenusMaxWidth)&&t.css({width:"",minWidth:"",maxWidth:""}).removeClass("sm-nowrap"),t.dataSM("scroll-arrows")&&t.dataSM("scroll-arrows").remove(),t.css({zIndex:"",top:"",left:"",marginLeft:"",marginTop:"",display:""})),0==(t.attr("id")||"").indexOf(i.accessIdPrefix)&&t.removeAttr("id")}).removeDataSM("in-mega").removeDataSM("shown-before").removeDataSM("scroll-arrows").removeDataSM("parent-a").removeDataSM("level").removeDataSM("beforefirstshowfired").removeAttr("role").removeAttr("aria-hidden").removeAttr("aria-labelledby").removeAttr("aria-expanded"),this.$root.find("a.has-submenu").each(function(){var t=$(this);0==t.attr("id").indexOf(i.accessIdPrefix)&&t.removeAttr("id")}).removeClass("has-submenu").removeDataSM("sub").removeAttr("aria-haspopup").removeAttr("aria-controls").removeAttr("aria-expanded").closest("li").removeDataSM("sub"),this.opts.subIndicators&&this.$root.find("span.sub-arrow").remove(),this.opts.markCurrentItem&&this.$root.find("a.current").removeClass("current"),t||(this.$root=null,this.$firstLink=null,this.$firstSub=null,this.$disableOverlay&&(this.$disableOverlay.remove(),this.$disableOverlay=null),menuTrees.splice($.inArray(this,menuTrees),1))},disable:function(t){if(!this.disabled){if(this.menuHideAll(),!t&&!this.opts.isPopup&&this.$root.is(":visible")){var e=this.$root.offset();this.$disableOverlay=$('
').css({position:"absolute",top:e.top,left:e.left,width:this.$root.outerWidth(),height:this.$root.outerHeight(),zIndex:this.getStartZIndex(!0),opacity:0}).appendTo(document.body)}this.disabled=!0}},docClick:function(t){return this.$touchScrollingSub?(this.$touchScrollingSub=null,void 0):((this.visibleSubMenus.length&&!$.contains(this.$root[0],t.target)||$(t.target).closest("a").length)&&this.menuHideAll(),void 0)},docTouchEnd:function(){if(this.lastTouch){if(!(!this.visibleSubMenus.length||void 0!==this.lastTouch.x2&&this.lastTouch.x1!=this.lastTouch.x2||void 0!==this.lastTouch.y2&&this.lastTouch.y1!=this.lastTouch.y2||this.lastTouch.target&&$.contains(this.$root[0],this.lastTouch.target))){this.hideTimeout&&(clearTimeout(this.hideTimeout),this.hideTimeout=0);var t=this;this.hideTimeout=setTimeout(function(){t.menuHideAll()},350)}this.lastTouch=null}},docTouchMove:function(t){if(this.lastTouch){var e=t.originalEvent.touches[0];this.lastTouch.x2=e.pageX,this.lastTouch.y2=e.pageY}},docTouchStart:function(t){var e=t.originalEvent.touches[0];this.lastTouch={x1:e.pageX,y1:e.pageY,target:e.target}},enable:function(){this.disabled&&(this.$disableOverlay&&(this.$disableOverlay.remove(),this.$disableOverlay=null),this.disabled=!1)},getClosestMenu:function(t){for(var e=$(t).closest("ul");e.dataSM("in-mega");)e=e.parent().closest("ul");return e[0]||null},getHeight:function(t){return this.getOffset(t,!0)},getOffset:function(t,e){var i;"none"==t.css("display")&&(i={position:t[0].style.position,visibility:t[0].style.visibility},t.css({position:"absolute",visibility:"hidden"}).show());var s=t[0].getBoundingClientRect&&t[0].getBoundingClientRect(),o=s&&(e?s.height||s.bottom-s.top:s.width||s.right-s.left);return o||0===o||(o=e?t[0].offsetHeight:t[0].offsetWidth),i&&t.hide().css(i),o},getStartZIndex:function(t){var e=parseInt(this[t?"$root":"$firstSub"].css("z-index"));return!t&&isNaN(e)&&(e=parseInt(this.$root.css("z-index"))),isNaN(e)?1:e},getTouchPoint:function(t){return t.touches&&t.touches[0]||t.changedTouches&&t.changedTouches[0]||t},getViewport:function(t){var e=t?"Height":"Width",i=document.documentElement["client"+e],s=window["inner"+e];return s&&(i=Math.min(i,s)),i},getViewportHeight:function(){return this.getViewport(!0)},getViewportWidth:function(){return this.getViewport()},getWidth:function(t){return this.getOffset(t)},handleEvents:function(){return!this.disabled&&this.isCSSOn()},handleItemEvents:function(t){return this.handleEvents()&&!this.isLinkInMegaMenu(t)},isCollapsible:function(){return"static"==this.$firstSub.css("position")},isCSSOn:function(){return"inline"!=this.$firstLink.css("display")},isFixed:function(){var t="fixed"==this.$root.css("position");return t||this.$root.parentsUntil("body").each(function(){return"fixed"==$(this).css("position")?(t=!0,!1):void 0}),t},isLinkInMegaMenu:function(t){return $(this.getClosestMenu(t[0])).hasClass("mega-menu")},isTouchMode:function(){return!mouse||this.opts.noMouseOver||this.isCollapsible()},itemActivate:function(t,e){var i=t.closest("ul"),s=i.dataSM("level");if(s>1&&(!this.activatedItems[s-2]||this.activatedItems[s-2][0]!=i.dataSM("parent-a")[0])){var o=this;$(i.parentsUntil("[data-smartmenus-id]","ul").get().reverse()).add(i).each(function(){o.itemActivate($(this).dataSM("parent-a"))})}if((!this.isCollapsible()||e)&&this.menuHideSubMenus(this.activatedItems[s-1]&&this.activatedItems[s-1][0]==t[0]?s:s-1),this.activatedItems[s-1]=t,this.$root.triggerHandler("activate.smapi",t[0])!==!1){var a=t.dataSM("sub");a&&(this.isTouchMode()||!this.opts.showOnClick||this.clickActivated)&&this.menuShow(a)}},itemBlur:function(t){var e=$(t.currentTarget);this.handleItemEvents(e)&&this.$root.triggerHandler("blur.smapi",e[0])},itemClick:function(t){var e=$(t.currentTarget);if(this.handleItemEvents(e)){if(this.$touchScrollingSub&&this.$touchScrollingSub[0]==e.closest("ul")[0])return this.$touchScrollingSub=null,t.stopPropagation(),!1;if(this.$root.triggerHandler("click.smapi",e[0])===!1)return!1;var i=$(t.target).is(".sub-arrow"),s=e.dataSM("sub"),o=s?2==s.dataSM("level"):!1,a=this.isCollapsible(),n=/toggle$/.test(this.opts.collapsibleBehavior),r=/link$/.test(this.opts.collapsibleBehavior),h=/^accordion/.test(this.opts.collapsibleBehavior);if(s&&!s.is(":visible")){if((!r||!a||i)&&(this.opts.showOnClick&&o&&(this.clickActivated=!0),this.itemActivate(e,h),s.is(":visible")))return this.focusActivated=!0,!1}else if(a&&(n||i))return this.itemActivate(e,h),this.menuHide(s),n&&(this.focusActivated=!1),!1;return this.opts.showOnClick&&o||e.hasClass("disabled")||this.$root.triggerHandler("select.smapi",e[0])===!1?!1:void 0}},itemDown:function(t){var e=$(t.currentTarget);this.handleItemEvents(e)&&e.dataSM("mousedown",!0)},itemEnter:function(t){var e=$(t.currentTarget);if(this.handleItemEvents(e)){if(!this.isTouchMode()){this.showTimeout&&(clearTimeout(this.showTimeout),this.showTimeout=0);var i=this;this.showTimeout=setTimeout(function(){i.itemActivate(e)},this.opts.showOnClick&&1==e.closest("ul").dataSM("level")?1:this.opts.showTimeout)}this.$root.triggerHandler("mouseenter.smapi",e[0])}},itemFocus:function(t){var e=$(t.currentTarget);this.handleItemEvents(e)&&(!this.focusActivated||this.isTouchMode()&&e.dataSM("mousedown")||this.activatedItems.length&&this.activatedItems[this.activatedItems.length-1][0]==e[0]||this.itemActivate(e,!0),this.$root.triggerHandler("focus.smapi",e[0]))},itemLeave:function(t){var e=$(t.currentTarget);this.handleItemEvents(e)&&(this.isTouchMode()||(e[0].blur(),this.showTimeout&&(clearTimeout(this.showTimeout),this.showTimeout=0)),e.removeDataSM("mousedown"),this.$root.triggerHandler("mouseleave.smapi",e[0]))},menuHide:function(t){if(this.$root.triggerHandler("beforehide.smapi",t[0])!==!1&&(canAnimate&&t.stop(!0,!0),"none"!=t.css("display"))){var e=function(){t.css("z-index","")};this.isCollapsible()?canAnimate&&this.opts.collapsibleHideFunction?this.opts.collapsibleHideFunction.call(this,t,e):t.hide(this.opts.collapsibleHideDuration,e):canAnimate&&this.opts.hideFunction?this.opts.hideFunction.call(this,t,e):t.hide(this.opts.hideDuration,e),t.dataSM("scroll")&&(this.menuScrollStop(t),t.css({"touch-action":"","-ms-touch-action":"","-webkit-transform":"",transform:""}).off(".smartmenus_scroll").removeDataSM("scroll").dataSM("scroll-arrows").hide()),t.dataSM("parent-a").removeClass("highlighted").attr("aria-expanded","false"),t.attr({"aria-expanded":"false","aria-hidden":"true"});var i=t.dataSM("level");this.activatedItems.splice(i-1,1),this.visibleSubMenus.splice($.inArray(t,this.visibleSubMenus),1),this.$root.triggerHandler("hide.smapi",t[0])}},menuHideAll:function(){this.showTimeout&&(clearTimeout(this.showTimeout),this.showTimeout=0);for(var t=this.opts.isPopup?1:0,e=this.visibleSubMenus.length-1;e>=t;e--)this.menuHide(this.visibleSubMenus[e]);this.opts.isPopup&&(canAnimate&&this.$root.stop(!0,!0),this.$root.is(":visible")&&(canAnimate&&this.opts.hideFunction?this.opts.hideFunction.call(this,this.$root):this.$root.hide(this.opts.hideDuration))),this.activatedItems=[],this.visibleSubMenus=[],this.clickActivated=!1,this.focusActivated=!1,this.zIndexInc=0,this.$root.triggerHandler("hideAll.smapi")},menuHideSubMenus:function(t){for(var e=this.activatedItems.length-1;e>=t;e--){var i=this.activatedItems[e].dataSM("sub");i&&this.menuHide(i)}},menuInit:function(t){if(!t.dataSM("in-mega")){t.hasClass("mega-menu")&&t.find("ul").dataSM("in-mega",!0);for(var e=2,i=t[0];(i=i.parentNode.parentNode)!=this.$root[0];)e++;var s=t.prevAll("a").eq(-1);s.length||(s=t.prevAll().find("a").eq(-1)),s.addClass("has-submenu").dataSM("sub",t),t.dataSM("parent-a",s).dataSM("level",e).parent().dataSM("sub",t);var o=s.attr("id")||this.accessIdPrefix+ ++this.idInc,a=t.attr("id")||this.accessIdPrefix+ ++this.idInc;s.attr({id:o,"aria-haspopup":"true","aria-controls":a,"aria-expanded":"false"}),t.attr({id:a,role:"group","aria-hidden":"true","aria-labelledby":o,"aria-expanded":"false"}),this.opts.subIndicators&&s[this.opts.subIndicatorsPos](this.$subArrow.clone())}},menuPosition:function(t){var e,i,s=t.dataSM("parent-a"),o=s.closest("li"),a=o.parent(),n=t.dataSM("level"),r=this.getWidth(t),h=this.getHeight(t),u=s.offset(),l=u.left,c=u.top,d=this.getWidth(s),m=this.getHeight(s),p=$(window),f=p.scrollLeft(),v=p.scrollTop(),b=this.getViewportWidth(),S=this.getViewportHeight(),g=a.parent().is("[data-sm-horizontal-sub]")||2==n&&!a.hasClass("sm-vertical"),M=this.opts.rightToLeftSubMenus&&!o.is("[data-sm-reverse]")||!this.opts.rightToLeftSubMenus&&o.is("[data-sm-reverse]"),w=2==n?this.opts.mainMenuSubOffsetX:this.opts.subMenusSubOffsetX,T=2==n?this.opts.mainMenuSubOffsetY:this.opts.subMenusSubOffsetY;if(g?(e=M?d-r-w:w,i=this.opts.bottomToTopSubMenus?-h-T:m+T):(e=M?w-r:d-w,i=this.opts.bottomToTopSubMenus?m-T-h:T),this.opts.keepInViewport){var y=l+e,I=c+i;if(M&&f>y?e=g?f-y+e:d-w:!M&&y+r>f+b&&(e=g?f+b-r-y+e:w-r),g||(S>h&&I+h>v+S?i+=v+S-h-I:(h>=S||v>I)&&(i+=v-I)),g&&(I+h>v+S+.49||v>I)||!g&&h>S+.49){var x=this;t.dataSM("scroll-arrows")||t.dataSM("scroll-arrows",$([$('')[0],$('')[0]]).on({mouseenter:function(){t.dataSM("scroll").up=$(this).hasClass("scroll-up"),x.menuScroll(t)},mouseleave:function(e){x.menuScrollStop(t),x.menuScrollOut(t,e)},"mousewheel DOMMouseScroll":function(t){t.preventDefault()}}).insertAfter(t));var A=".smartmenus_scroll";if(t.dataSM("scroll",{y:this.cssTransforms3d?0:i-m,step:1,itemH:m,subH:h,arrowDownH:this.getHeight(t.dataSM("scroll-arrows").eq(1))}).on(getEventsNS({mouseover:function(e){x.menuScrollOver(t,e)},mouseout:function(e){x.menuScrollOut(t,e)},"mousewheel DOMMouseScroll":function(e){x.menuScrollMousewheel(t,e)}},A)).dataSM("scroll-arrows").css({top:"auto",left:"0",marginLeft:e+(parseInt(t.css("border-left-width"))||0),width:r-(parseInt(t.css("border-left-width"))||0)-(parseInt(t.css("border-right-width"))||0),zIndex:t.css("z-index")}).eq(g&&this.opts.bottomToTopSubMenus?0:1).show(),this.isFixed()){var C={};C[touchEvents?"touchstart touchmove touchend":"pointerdown pointermove pointerup MSPointerDown MSPointerMove MSPointerUp"]=function(e){x.menuScrollTouch(t,e)},t.css({"touch-action":"none","-ms-touch-action":"none"}).on(getEventsNS(C,A))}}}t.css({top:"auto",left:"0",marginLeft:e,marginTop:i-m})},menuScroll:function(t,e,i){var s,o=t.dataSM("scroll"),a=t.dataSM("scroll-arrows"),n=o.up?o.upEnd:o.downEnd;if(!e&&o.momentum){if(o.momentum*=.92,s=o.momentum,.5>s)return this.menuScrollStop(t),void 0}else s=i||(e||!this.opts.scrollAccelerate?this.opts.scrollStep:Math.floor(o.step));var r=t.dataSM("level");if(this.activatedItems[r-1]&&this.activatedItems[r-1].dataSM("sub")&&this.activatedItems[r-1].dataSM("sub").is(":visible")&&this.menuHideSubMenus(r-1),o.y=o.up&&o.y>=n||!o.up&&n>=o.y?o.y:Math.abs(n-o.y)>s?o.y+(o.up?s:-s):n,t.css(this.cssTransforms3d?{"-webkit-transform":"translate3d(0, "+o.y+"px, 0)",transform:"translate3d(0, "+o.y+"px, 0)"}:{marginTop:o.y}),mouse&&(o.up&&o.y>o.downEnd||!o.up&&o.y0;t.dataSM("scroll-arrows").eq(i?0:1).is(":visible")&&(t.dataSM("scroll").up=i,this.menuScroll(t,!0))}e.preventDefault()},menuScrollOut:function(t,e){mouse&&(/^scroll-(up|down)/.test((e.relatedTarget||"").className)||(t[0]==e.relatedTarget||$.contains(t[0],e.relatedTarget))&&this.getClosestMenu(e.relatedTarget)==t[0]||t.dataSM("scroll-arrows").css("visibility","hidden"))},menuScrollOver:function(t,e){if(mouse&&!/^scroll-(up|down)/.test(e.target.className)&&this.getClosestMenu(e.target)==t[0]){this.menuScrollRefreshData(t);var i=t.dataSM("scroll"),s=$(window).scrollTop()-t.dataSM("parent-a").offset().top-i.itemH;t.dataSM("scroll-arrows").eq(0).css("margin-top",s).end().eq(1).css("margin-top",s+this.getViewportHeight()-i.arrowDownH).end().css("visibility","visible")}},menuScrollRefreshData:function(t){var e=t.dataSM("scroll"),i=$(window).scrollTop()-t.dataSM("parent-a").offset().top-e.itemH;this.cssTransforms3d&&(i=-(parseFloat(t.css("margin-top"))-i)),$.extend(e,{upEnd:i,downEnd:i+this.getViewportHeight()-e.subH})},menuScrollStop:function(t){return this.scrollTimeout?(cancelAnimationFrame(this.scrollTimeout),this.scrollTimeout=0,t.dataSM("scroll").step=1,!0):void 0},menuScrollTouch:function(t,e){if(e=e.originalEvent,isTouchEvent(e)){var i=this.getTouchPoint(e);if(this.getClosestMenu(i.target)==t[0]){var s=t.dataSM("scroll");if(/(start|down)$/i.test(e.type))this.menuScrollStop(t)?(e.preventDefault(),this.$touchScrollingSub=t):this.$touchScrollingSub=null,this.menuScrollRefreshData(t),$.extend(s,{touchStartY:i.pageY,touchStartTime:e.timeStamp});else if(/move$/i.test(e.type)){var o=void 0!==s.touchY?s.touchY:s.touchStartY;if(void 0!==o&&o!=i.pageY){this.$touchScrollingSub=t;var a=i.pageY>o;void 0!==s.up&&s.up!=a&&$.extend(s,{touchStartY:i.pageY,touchStartTime:e.timeStamp}),$.extend(s,{up:a,touchY:i.pageY}),this.menuScroll(t,!0,Math.abs(i.pageY-o))}e.preventDefault()}else void 0!==s.touchY&&((s.momentum=15*Math.pow(Math.abs(i.pageY-s.touchStartY)/(e.timeStamp-s.touchStartTime),2))&&(this.menuScrollStop(t),this.menuScroll(t),e.preventDefault()),delete s.touchY)}}},menuShow:function(t){if((t.dataSM("beforefirstshowfired")||(t.dataSM("beforefirstshowfired",!0),this.$root.triggerHandler("beforefirstshow.smapi",t[0])!==!1))&&this.$root.triggerHandler("beforeshow.smapi",t[0])!==!1&&(t.dataSM("shown-before",!0),canAnimate&&t.stop(!0,!0),!t.is(":visible"))){var e=t.dataSM("parent-a"),i=this.isCollapsible();if((this.opts.keepHighlighted||i)&&e.addClass("highlighted"),i)t.removeClass("sm-nowrap").css({zIndex:"",width:"auto",minWidth:"",maxWidth:"",top:"",left:"",marginLeft:"",marginTop:""});else{if(t.css("z-index",this.zIndexInc=(this.zIndexInc||this.getStartZIndex())+1),(this.opts.subMenusMinWidth||this.opts.subMenusMaxWidth)&&(t.css({width:"auto",minWidth:"",maxWidth:""}).addClass("sm-nowrap"),this.opts.subMenusMinWidth&&t.css("min-width",this.opts.subMenusMinWidth),this.opts.subMenusMaxWidth)){var s=this.getWidth(t);t.css("max-width",this.opts.subMenusMaxWidth),s>this.getWidth(t)&&t.removeClass("sm-nowrap").css("width",this.opts.subMenusMaxWidth)}this.menuPosition(t)}var o=function(){t.css("overflow","")};i?canAnimate&&this.opts.collapsibleShowFunction?this.opts.collapsibleShowFunction.call(this,t,o):t.show(this.opts.collapsibleShowDuration,o):canAnimate&&this.opts.showFunction?this.opts.showFunction.call(this,t,o):t.show(this.opts.showDuration,o),e.attr("aria-expanded","true"),t.attr({"aria-expanded":"true","aria-hidden":"false"}),this.visibleSubMenus.push(t),this.$root.triggerHandler("show.smapi",t[0])}},popupHide:function(t){this.hideTimeout&&(clearTimeout(this.hideTimeout),this.hideTimeout=0);var e=this;this.hideTimeout=setTimeout(function(){e.menuHideAll()},t?1:this.opts.hideTimeout)},popupShow:function(t,e){if(!this.opts.isPopup)return alert('SmartMenus jQuery Error:\n\nIf you want to show this menu via the "popupShow" method, set the isPopup:true option.'),void 0;if(this.hideTimeout&&(clearTimeout(this.hideTimeout),this.hideTimeout=0),this.$root.dataSM("shown-before",!0),canAnimate&&this.$root.stop(!0,!0),!this.$root.is(":visible")){this.$root.css({left:t,top:e});var i=this,s=function(){i.$root.css("overflow","")};canAnimate&&this.opts.showFunction?this.opts.showFunction.call(this,this.$root,s):this.$root.show(this.opts.showDuration,s),this.visibleSubMenus[0]=this.$root}},refresh:function(){this.destroy(!0),this.init(!0)},rootKeyDown:function(t){if(this.handleEvents())switch(t.keyCode){case 27:var e=this.activatedItems[0];if(e){this.menuHideAll(),e[0].focus();var i=e.dataSM("sub");i&&this.menuHide(i)}break;case 32:var s=$(t.target);if(s.is("a")&&this.handleItemEvents(s)){var i=s.dataSM("sub");i&&!i.is(":visible")&&(this.itemClick({currentTarget:t.target}),t.preventDefault())}}},rootOut:function(t){if(this.handleEvents()&&!this.isTouchMode()&&t.target!=this.$root[0]&&(this.hideTimeout&&(clearTimeout(this.hideTimeout),this.hideTimeout=0),!this.opts.showOnClick||!this.opts.hideOnClick)){var e=this;this.hideTimeout=setTimeout(function(){e.menuHideAll()},this.opts.hideTimeout)}},rootOver:function(t){this.handleEvents()&&!this.isTouchMode()&&t.target!=this.$root[0]&&this.hideTimeout&&(clearTimeout(this.hideTimeout),this.hideTimeout=0)},winResize:function(t){if(this.handleEvents()){if(!("onorientationchange"in window)||"orientationchange"==t.type){var e=this.isCollapsible();this.wasCollapsible&&e||(this.activatedItems.length&&this.activatedItems[this.activatedItems.length-1][0].blur(),this.menuHideAll()),this.wasCollapsible=e}}else if(this.$disableOverlay){var i=this.$root.offset();this.$disableOverlay.css({top:i.top,left:i.left,width:this.$root.outerWidth(),height:this.$root.outerHeight()})}}}}),$.fn.dataSM=function(t,e){return e?this.data(t+"_smartmenus",e):this.data(t+"_smartmenus")},$.fn.removeDataSM=function(t){return this.removeData(t+"_smartmenus")},$.fn.smartmenus=function(options){if("string"==typeof options){var args=arguments,method=options;return Array.prototype.shift.call(args),this.each(function(){var t=$(this).data("smartmenus");t&&t[method]&&t[method].apply(t,args)})}return this.each(function(){var dataOpts=$(this).data("sm-options")||null;if(dataOpts)try{dataOpts=eval("("+dataOpts+")")}catch(e){dataOpts=null,alert('ERROR\n\nSmartMenus jQuery init:\nInvalid "data-sm-options" attribute value syntax.')}new $.SmartMenus(this,$.extend({},$.fn.smartmenus.defaults,options,dataOpts))})},$.fn.smartmenus.defaults={isPopup:!1,mainMenuSubOffsetX:0,mainMenuSubOffsetY:0,subMenusSubOffsetX:0,subMenusSubOffsetY:0,subMenusMinWidth:"10em",subMenusMaxWidth:"20em",subIndicators:!0,subIndicatorsPos:"append",subIndicatorsText:"",scrollStep:30,scrollAccelerate:!0,showTimeout:250,hideTimeout:500,showDuration:0,showFunction:null,hideDuration:0,hideFunction:function(t,e){t.fadeOut(200,e)},collapsibleShowDuration:0,collapsibleShowFunction:function(t,e){t.slideDown(200,e)},collapsibleHideDuration:0,collapsibleHideFunction:function(t,e){t.slideUp(200,e)},showOnClick:!1,hideOnClick:!0,noMouseOver:!1,keepInViewport:!0,keepHighlighted:!0,markCurrentItem:!1,markCurrentTree:!0,rightToLeftSubMenus:!1,bottomToTopSubMenus:!1,collapsibleBehavior:"default"},$}); \ No newline at end of file diff --git a/ver-2.10.0/lengds_8f.html b/ver-2.10.0/lengds_8f.html new file mode 100644 index 00000000..6231aeb3 --- /dev/null +++ b/ver-2.10.0/lengds_8f.html @@ -0,0 +1,156 @@ + + + + + + + +NCEPLIBS-w3emc: lengds.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
lengds.f File Reference
+
+
+ +

GIven a grid description section (in w3fi63 format), return its size in terms of number of data points. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

function lengds (KGDS)
 Program history log: More...
 
+

Detailed Description

+

GIven a grid description section (in w3fi63 format), return its size in terms of number of data points.

+
Author
Mark Iredell
+
Date
1996-07-19
+ +

Definition in file lengds.f.

+

Function/Subroutine Documentation

+ +

◆ lengds()

+ +
+
+ + + + + + + + +
function lengds (integer, dimension(200) KGDS)
+
+ +

Program history log:

+
    +
  • Mark Iredell 1996-07-19
    • +
+
Parameters
+ + +
[in]KGDSInteger (200) gds parameters in w3fi63 format.
+
+
+
Returns
LENGDS Integer size of grid.
+
Author
Mark Iredell
+
Date
1996-07-19
+ +

Definition at line 15 of file lengds.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/lengds_8f.js b/ver-2.10.0/lengds_8f.js new file mode 100644 index 00000000..19857862 --- /dev/null +++ b/ver-2.10.0/lengds_8f.js @@ -0,0 +1,4 @@ +var lengds_8f = +[ + [ "lengds", "lengds_8f.html#a53ab57aefe7c9277606708b4c8af7b00", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/lengds_8f_source.html b/ver-2.10.0/lengds_8f_source.html new file mode 100644 index 00000000..34336d9e --- /dev/null +++ b/ver-2.10.0/lengds_8f_source.html @@ -0,0 +1,133 @@ + + + + + + + +NCEPLIBS-w3emc: lengds.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
lengds.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief GIven a grid description section (in w3fi63 format),
+
3 C> return its size in terms of number of data points.
+
4 C> @author Mark Iredell @date 1996-07-19
+
5 
+
6 C> Program history log:
+
7 C> - Mark Iredell 1996-07-19
+
8 C>
+
9 C> @param[in] KGDS Integer (200) gds parameters in w3fi63 format.
+
10 C> @return LENGDS Integer size of grid.
+
11 C>
+
12 C> @author Mark Iredell @date 1996-07-19
+
13 C-----------------------------------------------------------------------
+
14  FUNCTION lengds(KGDS)
+
15  INTEGER kgds(200)
+
16 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
17 C SPECIAL CASE OF STAGGERED ETA
+
18  IF(kgds(1).EQ.201) THEN
+
19  lengds=kgds(7)*kgds(8)-kgds(8)/2
+
20 C SPECIAL CASE OF FILLED ETA
+
21  ELSEIF(kgds(1).EQ.202) THEN
+
22  lengds=kgds(7)*kgds(8)
+
23 C SPECIAL CASE OF THINNED WAFS
+
24  ELSEIF(kgds(19).EQ.0.AND.kgds(20).NE.255) THEN
+
25  lengds=kgds(21)
+
26 C GENERAL CASE
+
27  ELSE
+
28  lengds=kgds(2)*kgds(3)
+
29  ENDIF
+
30 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
31  END
+
+
+
lengds
function lengds(KGDS)
Program history log:
Definition: lengds.f:15
+ + + + diff --git a/ver-2.10.0/makgds_8f90_source.html b/ver-2.10.0/makgds_8f90_source.html new file mode 100644 index 00000000..73352a7d --- /dev/null +++ b/ver-2.10.0/makgds_8f90_source.html @@ -0,0 +1,141 @@ + + + + + + + +NCEPLIBS-w3emc: makgds.f90 Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
makgds.f90
+
+
+
1 
+
107 SUBROUTINE makgds(IOPT,KGDS,GDS,LENGDS,IRET)
+
108  IMPLICIT NONE
+
109  !
+
110  CHARACTER, INTENT(INOUT) :: GDS(400)
+
111  !
+
112  INTEGER, INTENT(IN ) :: IOPT
+
113  INTEGER, INTENT(INOUT) :: KGDS(200)
+
114  INTEGER, INTENT( OUT) :: IRET, LENGDS
+
115  !
+
116  INTEGER :: ICOMP, IPDS(200), IGDS(200)
+
117  INTEGER :: KPTR(200), KPDS(200), NPTS
+
118  !
+
119  DATA kptr/200*0/, kpds/200*0/
+
120  ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
121  ! UNPACK GDS INTO KGDS
+
122  IF(iopt.EQ.-1) THEN
+
123  CALL fi633(gds,kptr,kgds,iret)
+
124  ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
125  ! USE KGDS TO PACK GDS
+
126  ELSEIF(iopt.EQ.255) THEN
+
127  CALL r63w72(kpds,kgds,ipds,igds)
+
128  icomp=mod(igds(8)/8,2)
+
129  CALL w3fi74(igds,icomp,gds,lengds,npts,iret)
+
130  ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
131  ! USE NCEP GRID ID TO MAKE GDS AND KGDS
+
132  ELSEIF(iopt.GT.0.AND.iopt.LT.255) THEN
+
133  CALL w3fi71(iopt,igds,iret)
+
134  IF(iret.EQ.0) THEN
+
135  icomp=mod(igds(8)/8,2)
+
136  CALL w3fi74(igds,icomp,gds,lengds,npts,iret)
+
137  IF(iret.EQ.0) CALL fi633(gds,kptr,kgds,iret)
+
138  ENDIF
+
139  ENDIF
+
140  ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
141 END SUBROUTINE makgds
+
+
+
r63w72
subroutine r63w72(KPDS, KGDS, IPDS, IGDS)
Determines the integer PDS and GDS parameters for the GRIB1 packing routine w3fi72() given the parame...
Definition: r63w72.f:27
+
w3fi74
subroutine w3fi74(IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR)
This subroutine constructs a GRIB grid definition section.
Definition: w3fi74.f:19
+
w3fi71
subroutine w3fi71(IGRID, IGDS, IERR)
Makes a 18, 37, 55, 64, or 91 word integer array used by w3fi72() GRIB packer to make the grid descri...
Definition: w3fi71.f:187
+
fi633
subroutine fi633(MSGA, KPTR, KGDS, KRET)
Extract info from grib-gds.
Definition: w3fi63.f:981
+ + + + diff --git a/ver-2.10.0/makwmo_8f.html b/ver-2.10.0/makwmo_8f.html new file mode 100644 index 00000000..667f29b7 --- /dev/null +++ b/ver-2.10.0/makwmo_8f.html @@ -0,0 +1,191 @@ + + + + + + + +NCEPLIBS-w3emc: makwmo.f File Reference + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+Functions/Subroutines
+
+
makwmo.f File Reference
+
+
+ +

FORMS THE WMO HEADER FOR A GIVEN BULLETIN. +More...

+ +

Go to the source code of this file.

+ + + + + +

+Functions/Subroutines

subroutine makwmo (BULHED, IDAY, IHOUR, KWBX, HEADER)
 Program history log: More...
 
+

Detailed Description

+

FORMS THE WMO HEADER FOR A GIVEN BULLETIN.

+
Author
Farley
+
Date
1984-07-06
+ +

Definition in file makwmo.f.

+

Function/Subroutine Documentation

+ +

◆ makwmo()

+ +
+
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
subroutine makwmo (character * 6 BULHED,
 IDAY,
 IHOUR,
character * 4 KWBX,
character * 1, dimension (*) HEADER 
)
+
+ +

Program history log:

+
    +
  • Farley 1984-07-06
    • +
  • Ralph Jones 1994-10-10 Changes for cray.
    • +
  • Ralph Jones 1995-10-18 Add parameter KWBX to call.
    • +
  • Stephen Gilbert 1998-06-16 Changed argument list to pass in day and hour instead of the old O.N. 84 date word.
    • +
  • Stephen Gilbert 2003-03-28 Removed equivalences.
    • +
+
Parameters
+ + + + + + +
[in]BULHEDTTAAII bulletin header. FT10
[in]IDAYDay of Month.
[in]IHOURHour of Day.
[in]KWBX4 characters (KWBC to KWBQ)
[out]HEADERComplete WMO header in ASCII.
+
+
+
Author
Farley
+
Date
1984-07-06
+ +

Definition at line 21 of file makwmo.f.

+ +
+
+
+
+ + + + diff --git a/ver-2.10.0/makwmo_8f.js b/ver-2.10.0/makwmo_8f.js new file mode 100644 index 00000000..5c3d88f5 --- /dev/null +++ b/ver-2.10.0/makwmo_8f.js @@ -0,0 +1,4 @@ +var makwmo_8f = +[ + [ "makwmo", "makwmo_8f.html#a8fd8c7e636856ca63ccdd4a0d786636d", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/makwmo_8f_source.html b/ver-2.10.0/makwmo_8f_source.html new file mode 100644 index 00000000..4c492878 --- /dev/null +++ b/ver-2.10.0/makwmo_8f_source.html @@ -0,0 +1,180 @@ + + + + + + + +NCEPLIBS-w3emc: makwmo.f Source File + + + + + + + + + + + + + +
+
+ + + + + + +
+
NCEPLIBS-w3emc +  2.10.0 +
+
+
+ + + + + + + +
+
+ +
+
+
+ +
+ +
+
+ + +
+ +
+ +
+
+
makwmo.f
+
+
+Go to the documentation of this file.
1 C> @file
+
2 C> @brief FORMS THE WMO HEADER FOR A GIVEN BULLETIN.
+
3 C> @author Farley @date 1984-07-06
+
4 
+
5 C> Program history log:
+
6 C> - Farley 1984-07-06
+
7 C> - Ralph Jones 1994-10-10 Changes for cray.
+
8 C> - Ralph Jones 1995-10-18 Add parameter KWBX to call.
+
9 C> - Stephen Gilbert 1998-06-16 Changed argument list to pass in day and hour
+
10 C> instead of the old O.N. 84 date word.
+
11 C> - Stephen Gilbert 2003-03-28 Removed equivalences.
+
12 C>
+
13 C> @param[in] BULHED TTAAII bulletin header. FT10
+
14 C> @param[in] IDAY Day of Month.
+
15 C> @param[in] IHOUR Hour of Day.
+
16 C> @param[in] KWBX 4 characters (KWBC to KWBQ)
+
17 C> @param[out] HEADER Complete WMO header in ASCII.
+
18 C>
+
19 C> @author Farley @date 1984-07-06
+
20  SUBROUTINE makwmo (BULHED,IDAY,IHOUR,KWBX,HEADER)
+
21 C
+
22  CHARACTER * 6 BULHED
+
23  CHARACTER * 1 HEADER (*)
+
24  CHARACTER * 1 WMOHDR (21)
+
25  CHARACTER * 4 KWBX
+
26  CHARACTER * 2 CTEMP
+
27 C
+
28 C--------------------------------------------------------------------
+
29 C
+
30 C$ 1. CREATE WMO HEADER.
+
31 C
+
32 C$ 1.1 CONVERT BULHED FROM EBCDIC TO ASCII.
+
33 C
+
34 C WRITE (6,FMT='('' MADE IT TO MAKWMO'')')
+
35 C
+
36  DO i = 1,6
+
37  wmohdr(i) = bulhed(i:i)
+
38  END DO
+
39  wmohdr(7)=char(32) ! ASCII BLANK
+
40 C
+
41 C MOVE KWBX INTO WMO HEADER
+
42 C
+
43  DO i = 1,4
+
44  wmohdr(i+7) = kwbx(i:i)
+
45  END DO
+
46  wmohdr(12)=char(32) ! ASCII BLANK
+
47 C
+
48 C$ 1.2 PICK OFF THE DAY OF MONTH (YY)
+
49 C$ AND CONVERT TO ASCII.
+
50 C
+
51  write(ctemp,fmt='(I2.2)') iday
+
52  wmohdr(13)=ctemp(1:1)
+
53  wmohdr(14)=ctemp(2:2)
+
54 C
+
55 C$ 1.3 PICK OFF THE HOUR(GG) AND CONVERT TO ASCII.
+
56 C
+
57  write(ctemp,fmt='(I2.2)') ihour
+
58  wmohdr(15)=ctemp(1:1)
+
59  wmohdr(16)=ctemp(2:2)
+
60 C
+
61 C 1.4 FIL IN REST OF HEADER
+
62 C
+
63  wmohdr(17)=char(48) ! ASCII "0"
+
64  wmohdr(18)=char(48) ! ASCII "0"
+
65  wmohdr(19)=char(13) ! ASCII CR = '\r'
+
66  wmohdr(20)=char(13) ! ASCII CR = '\r'
+
67  wmohdr(21)=char(10) ! ASCII LF = '\n'
+
68 C
+
69 C--------------------------------------------------------------------
+
70 C
+
71 C$ 2. MOVE WMOHDR TO OUTPUT FIELD.
+
72 C
+
73  DO 200 i = 1,21
+
74  header(i) = wmohdr(i)
+
75  200 CONTINUE
+
76 C
+
77  RETURN
+
78  END
+
+
+
makwmo
subroutine makwmo(BULHED, IDAY, IHOUR, KWBX, HEADER)
Program history log:
Definition: makwmo.f:21
+ + + + diff --git a/ver-2.10.0/menu.js b/ver-2.10.0/menu.js new file mode 100644 index 00000000..433c15b8 --- /dev/null +++ b/ver-2.10.0/menu.js @@ -0,0 +1,50 @@ +/* + @licstart The following is the entire license notice for the + JavaScript code in this file. + + Copyright (C) 1997-2017 by Dimitri van Heesch + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + + @licend The above is the entire license notice + for the JavaScript code in this file + */ +function initMenu(relPath,searchEnabled,serverSide,searchPage,search) { + function makeTree(data,relPath) { + var result=''; + if ('children' in data) { + result+=''; + } + return result; + } + + $('#main-nav').append(makeTree(menudata,relPath)); + $('#main-nav').children(':first').addClass('sm sm-dox').attr('id','main-menu'); + if (searchEnabled) { + if (serverSide) { + $('#main-menu').append('
    • '); + } else { + $('#main-menu').append('
    • '); + } + } + $('#main-menu').smartmenus(); +} +/* @license-end */ diff --git a/ver-2.10.0/menudata.js b/ver-2.10.0/menudata.js new file mode 100644 index 00000000..ed31782c --- /dev/null +++ b/ver-2.10.0/menudata.js @@ -0,0 +1,72 @@ +/* +@licstart The following is the entire license notice for the +JavaScript code in this file. + +Copyright (C) 1997-2019 by Dimitri van Heesch + +This program is free software; you can redistribute it and/or modify +it under the terms of version 2 of the GNU General Public License as published by +the Free Software Foundation + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License along +with this program; if not, write to the Free Software Foundation, Inc., +51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +@licend The above is the entire license notice +for the JavaScript code in this file +*/ +var menudata={children:[ +{text:"Main Page",url:"index.html"}, +{text:"Modules",url:"namespaces.html",children:[ +{text:"Modules List",url:"namespaces.html"}, +{text:"Module Members",url:"namespacemembers.html",children:[ +{text:"All",url:"namespacemembers.html"}, +{text:"Functions/Subroutines",url:"namespacemembers_func.html"}]}]}, +{text:"Data Types List",url:"annotated.html",children:[ +{text:"Data Types List",url:"annotated.html"}]}, +{text:"Files",url:"files.html",children:[ +{text:"File List",url:"files.html"}, +{text:"Globals",url:"globals.html",children:[ +{text:"All",url:"globals.html",children:[ +{text:"a",url:"globals.html#index_a"}, +{text:"b",url:"globals_b.html#index_b"}, +{text:"c",url:"globals_c.html#index_c"}, +{text:"e",url:"globals_e.html#index_e"}, +{text:"f",url:"globals_f.html#index_f"}, +{text:"g",url:"globals_g.html#index_g"}, +{text:"i",url:"globals_i.html#index_i"}, +{text:"l",url:"globals_l.html#index_l"}, +{text:"m",url:"globals_m.html#index_m"}, +{text:"o",url:"globals_o.html#index_o"}, +{text:"p",url:"globals_p.html#index_p"}, +{text:"q",url:"globals_q.html#index_q"}, +{text:"r",url:"globals_r.html#index_r"}, +{text:"s",url:"globals_s.html#index_s"}, +{text:"u",url:"globals_u.html#index_u"}, +{text:"v",url:"globals_v.html#index_v"}, +{text:"w",url:"globals_w.html#index_w"}, +{text:"x",url:"globals_x.html#index_x"}]}, +{text:"Functions/Subroutines",url:"globals_func.html",children:[ +{text:"a",url:"globals_func.html#index_a"}, +{text:"b",url:"globals_func_b.html#index_b"}, +{text:"c",url:"globals_func_c.html#index_c"}, +{text:"e",url:"globals_func_e.html#index_e"}, +{text:"f",url:"globals_func_f.html#index_f"}, +{text:"g",url:"globals_func_g.html#index_g"}, +{text:"i",url:"globals_func_i.html#index_i"}, +{text:"l",url:"globals_func_l.html#index_l"}, +{text:"m",url:"globals_func_m.html#index_m"}, +{text:"o",url:"globals_func_o.html#index_o"}, +{text:"p",url:"globals_func_p.html#index_p"}, +{text:"q",url:"globals_func_q.html#index_q"}, +{text:"r",url:"globals_func_r.html#index_r"}, +{text:"s",url:"globals_func_s.html#index_s"}, +{text:"u",url:"globals_func_u.html#index_u"}, +{text:"v",url:"globals_func_v.html#index_v"}, +{text:"w",url:"globals_func_w.html#index_w"}, +{text:"x",url:"globals_func_x.html#index_x"}]}]}]}]} diff --git a/ver-2.10.0/mersenne__twister_8f.html b/ver-2.10.0/mersenne__twister_8f.html new file mode 100644 index 00000000..bcee11cd --- /dev/null +++ b/ver-2.10.0/mersenne__twister_8f.html @@ -0,0 +1,138 @@ + + + + + + + +NCEPLIBS-w3emc: mersenne_twister.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Data Types | +Modules | +Functions/Subroutines
    +
    +
    mersenne_twister.f File Reference
    +
    +
    + +

    Modern random number generator. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Modules

    module  mersenne_twister
     This module calculates random numbers using the Mersenne twister.
     
    + + + + + + + + + + + + + +

    +Functions/Subroutines

    real function, public mersenne_twister::random_gauss_f ()
     Generates Gaussian random numbers in functional mode. More...
     
    integer function, public mersenne_twister::random_index_f (imax)
     Generates random indices in functional mode. More...
     
    real function, public mersenne_twister::random_number_f ()
     Generates random numbers in functional mode. More...
     
    subroutine, public mersenne_twister::random_seed (size, put, get, stat)
     Sets and gets state; overloads Fortran 90 standard. More...
     
    +

    Detailed Description

    +

    Modern random number generator.

    +
    Author
    Mark Iredell
    +
    Date
    2005-06-14
    + +

    Definition in file mersenne_twister.f.

    +
    +
    + + + + diff --git a/ver-2.10.0/mersenne__twister_8f.js b/ver-2.10.0/mersenne__twister_8f.js new file mode 100644 index 00000000..397ebbb4 --- /dev/null +++ b/ver-2.10.0/mersenne__twister_8f.js @@ -0,0 +1,30 @@ +var mersenne__twister_8f = +[ + [ "random_gauss_f", "mersenne__twister_8f.html#acd01aa05ecfbe1c3283dc3552fc9a437", null ], + [ "random_gauss_i", "mersenne__twister_8f.html#ab7560f4ac03fad6c0c5b1a393ab7af80", null ], + [ "random_gauss_s", "mersenne__twister_8f.html#ad3e61a71aa72a0b9654626b15296dbec", null ], + [ "random_gauss_t", "mersenne__twister_8f.html#a4e3b13adf5b25114f982e3e977bef004", null ], + [ "random_index_f", "mersenne__twister_8f.html#acc59b5b06bcd98e292ffeaeae88c9c5e", null ], + [ "random_index_i", "mersenne__twister_8f.html#a9c1b3fcd1cb4e6b20a46607a0991e75c", null ], + [ "random_index_s", "mersenne__twister_8f.html#a9b5f511523152deb897819b9f5b35dba", null ], + [ "random_index_t", "mersenne__twister_8f.html#a9c03281caf481123f41fac129244685c", null ], + [ "random_number_f", "mersenne__twister_8f.html#a72d5b1cd21e6af407325bb8b0e18481a", null ], + [ "random_number_i", "mersenne__twister_8f.html#a715dd6280653ef8f2b0a6cd7076d870d", null ], + [ "random_number_s", "mersenne__twister_8f.html#a52fb0e5bfcfd792c8060b8fa96f20610", null ], + [ "random_number_t", "mersenne__twister_8f.html#a3652cf0177c16351a259362f05c52be6", null ], + [ "random_seed", "mersenne__twister_8f.html#ab5807578f927f719be280774b17803ad", null ], + [ "random_setseed_s", "mersenne__twister_8f.html#a017f5f4708314e41f34e087c48a44daf", null ], + [ "random_setseed_t", "mersenne__twister_8f.html#ae7c1227f3e7c3774b3731a3ee2f4e519", null ], + [ "rgauss", "mersenne__twister_8f.html#a70e1a1b6a0642c45700bcb0e01a16b6b", null ], + [ "iseed", "mersenne__twister_8f.html#a58ab3b5d65dcd05266b45662309f5f55", null ], + [ "lmask", "mersenne__twister_8f.html#a6385e50a4db3a7ca25b92d761374957b", null ], + [ "m", "mersenne__twister_8f.html#a6a4ca59c1e8484f3d42a3e9dc7a693b0", null ], + [ "mag01", "mersenne__twister_8f.html#adf6d74a10cc19bef891508c741282476", null ], + [ "mata", "mersenne__twister_8f.html#acf08832d5cbe3032b51a9f67a1b89c05", null ], + [ "n", "mersenne__twister_8f.html#a6ab34baf3b5aece50818d2c7cc4357b7", null ], + [ "nrest", "mersenne__twister_8f.html#a18afbd0bb0326af3129bc4bec59aee46", null ], + [ "sstat", "mersenne__twister_8f.html#a2373934764432b7b64b31c4e82340a34", null ], + [ "tmaskb", "mersenne__twister_8f.html#ab0fb126acb98e7500c8fda1aa4508ddb", null ], + [ "tmaskc", "mersenne__twister_8f.html#ae97528980ebbb1a68b7b0787721cb543", null ], + [ "umask", "mersenne__twister_8f.html#a722ec0932b5a922b6c91aec4b658adef", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/mersenne__twister_8f_source.html b/ver-2.10.0/mersenne__twister_8f_source.html new file mode 100644 index 00000000..f084510e --- /dev/null +++ b/ver-2.10.0/mersenne__twister_8f_source.html @@ -0,0 +1,416 @@ + + + + + + + +NCEPLIBS-w3emc: mersenne_twister.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    mersenne_twister.f
    +
    +
    +Go to the documentation of this file.
    1 
    +
    4 
    +
    90  module mersenne_twister
    +
    91  private
    +
    92 ! Public declarations
    +
    93  public random_stat
    +
    94  public random_seed
    +
    95  public random_setseed
    +
    96  public random_number
    +
    97  public random_number_f
    +
    98  public random_gauss
    +
    99  public random_gauss_f
    +
    100  public random_index
    +
    101  public random_index_f
    +
    102 ! Parameters
    +
    103  integer,parameter:: n=624
    +
    104  integer,parameter:: m=397
    +
    105  integer,parameter:: mata=-1727483681 ! constant vector a
    +
    106  integer,parameter:: umask=-2147483648 ! most significant w-r bits
    +
    107  integer,parameter:: lmask =2147483647 ! least significant r bits
    +
    108  integer,parameter:: tmaskb=-1658038656 ! tempering parameter
    +
    109  integer,parameter:: tmaskc=-272236544 ! tempering parameter
    +
    110  integer,parameter:: mag01(0:1)=(/0,mata/)
    +
    111  integer,parameter:: iseed=4357
    +
    112  integer,parameter:: nrest=n+6
    +
    113 ! Defined types
    +
    114  type random_stat
    +
    115  private
    +
    116  integer:: mti=n+1
    +
    117  integer:: mt(0:n-1)
    +
    118  integer:: iset
    +
    119  real:: gset
    +
    120  end type
    +
    121 ! Saved data
    +
    122  type(random_stat),save:: sstat
    +
    123 ! Overloaded interfaces
    +
    124  interface random_setseed
    +
    125  module procedure random_setseed_s
    +
    126  module procedure random_setseed_t
    +
    127  end interface
    +
    128  interface random_number
    +
    129  module procedure random_number_i
    +
    130  module procedure random_number_s
    +
    131  module procedure random_number_t
    +
    132  end interface
    +
    133  interface random_gauss
    +
    134  module procedure random_gauss_i
    +
    135  module procedure random_gauss_s
    +
    136  module procedure random_gauss_t
    +
    137  end interface
    +
    138  interface random_index
    +
    139  module procedure random_index_i
    +
    140  module procedure random_index_s
    +
    141  module procedure random_index_t
    +
    142  end interface
    +
    143 ! All the subprograms
    +
    144  contains
    +
    150  subroutine random_seed(size,put,get,stat)
    +
    151  implicit none
    +
    152  integer,intent(out),optional:: size
    +
    153  integer,intent(in),optional:: put(nrest)
    +
    154  integer,intent(out),optional:: get(nrest)
    +
    155  type(random_stat),intent(inout),optional:: stat
    +
    156  if(present(size)) then ! return size of seed array
    +
    157 ! if(present(put).or.present(get))&
    +
    158 ! call errmsg('RANDOM_SEED: more than one option set - some ignored')
    +
    159  size=nrest
    +
    160  elseif(present(put)) then ! restore from seed array
    +
    161 ! if(present(get))&
    +
    162 ! call errmsg('RANDOM_SEED: more than one option set - some ignored')
    +
    163  if(present(stat)) then
    +
    164  stat%mti=put(1)
    +
    165  stat%mt=put(2:n+1)
    +
    166  stat%iset=put(n+2)
    +
    167  stat%gset=transfer(put(n+3:nrest),stat%gset)
    +
    168  if(stat%mti.lt.0.or.stat%mti.gt.n.or.any(stat%mt.eq.0).or.
    +
    169  & stat%iset.lt.0.or.stat%iset.gt.1) then
    +
    170  call random_setseed_t(iseed,stat)
    +
    171 ! call errmsg('RANDOM_SEED: invalid seeds put - default seeds used')
    +
    172  endif
    +
    173  else
    +
    174  sstat%mti=put(1)
    +
    175  sstat%mt=put(2:n+1)
    +
    176  sstat%iset=put(n+2)
    +
    177  sstat%gset=transfer(put(n+3:nrest),sstat%gset)
    +
    178  if(sstat%mti.lt.0.or.sstat%mti.gt.n.or.any(sstat%mt.eq.0)
    +
    179  & .or.sstat%iset.lt.0.or.sstat%iset.gt.1) then
    +
    180  call random_setseed_t(iseed,sstat)
    +
    181 ! call errmsg('RANDOM_SEED: invalid seeds put - default seeds used')
    +
    182  endif
    +
    183  endif
    +
    184  elseif(present(get)) then ! save to seed array
    +
    185  if(present(stat)) then
    +
    186  if(stat%mti.eq.n+1) call random_setseed_t(iseed,stat)
    +
    187  get(1)=stat%mti
    +
    188  get(2:n+1)=stat%mt
    +
    189  get(n+2)=stat%iset
    +
    190  get(n+3:nrest)=transfer(stat%gset,get,nrest-(n+3)+1)
    +
    191  else
    +
    192  if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
    +
    193  get(1)=sstat%mti
    +
    194  get(2:n+1)=sstat%mt
    +
    195  get(n+2)=sstat%iset
    +
    196  get(n+3:nrest)=transfer(sstat%gset,get,nrest-(n+3)+1)
    +
    197  endif
    +
    198  else ! reset default seed
    +
    199  if(present(stat)) then
    +
    200  call random_setseed_t(iseed,stat)
    +
    201  else
    +
    202  call random_setseed_t(iseed,sstat)
    +
    203  endif
    +
    204  endif
    +
    205  end subroutine
    +
    208  subroutine random_setseed_s(inseed)
    +
    209  implicit none
    +
    210  integer,intent(in):: inseed
    +
    211  call random_setseed_t(inseed,sstat)
    +
    212  end subroutine
    +
    216  subroutine random_setseed_t(inseed,stat)
    +
    217  implicit none
    +
    218  integer,intent(in):: inseed
    +
    219  type(random_stat),intent(out):: stat
    +
    220  integer ii,mti
    +
    221  ii=inseed
    +
    222  if(ii.eq.0) ii=iseed
    +
    223  stat%mti=n
    +
    224  stat%mt(0)=iand(ii,-1)
    +
    225  do mti=1,n-1
    +
    226  stat%mt(mti)=iand(69069*stat%mt(mti-1),-1)
    +
    227  enddo
    +
    228  stat%iset=0
    +
    229  stat%gset=0.
    +
    230  end subroutine
    +
    233  function random_number_f() result(harvest)
    +
    234  implicit none
    +
    235  real:: harvest
    +
    236  real h(1)
    +
    237  if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
    +
    238  call random_number_t(h,sstat)
    +
    239  harvest=h(1)
    +
    240  end function
    +
    244  subroutine random_number_i(harvest,inseed)
    +
    245  implicit none
    +
    246  real,intent(out):: harvest(:)
    +
    247  integer,intent(in):: inseed
    +
    248  type(random_stat) stat
    +
    249  call random_setseed_t(inseed,stat)
    +
    250  call random_number_t(harvest,stat)
    +
    251  end subroutine
    +
    254  subroutine random_number_s(harvest)
    +
    255  implicit none
    +
    256  real,intent(out):: harvest(:)
    +
    257  if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
    +
    258  call random_number_t(harvest,sstat)
    +
    259  end subroutine
    +
    263  subroutine random_number_t(harvest,stat)
    +
    264  implicit none
    +
    265  real,intent(out):: harvest(:)
    +
    266  type(random_stat),intent(inout):: stat
    +
    267  integer j,kk,y
    +
    268  integer tshftu,tshfts,tshftt,tshftl
    +
    269  tshftu(y)=ishft(y,-11)
    +
    270  tshfts(y)=ishft(y,7)
    +
    271  tshftt(y)=ishft(y,15)
    +
    272  tshftl(y)=ishft(y,-18)
    +
    273  do j=1,size(harvest)
    +
    274  if(stat%mti.ge.n) then
    +
    275  do kk=0,n-m-1
    +
    276  y=ior(iand(stat%mt(kk),umask),iand(stat%mt(kk+1),lmask))
    +
    277  stat%mt(kk)=ieor(ieor(stat%mt(kk+m),ishft(y,-1)),
    +
    278  & mag01(iand(y,1)))
    +
    279  enddo
    +
    280  do kk=n-m,n-2
    +
    281  y=ior(iand(stat%mt(kk),umask),iand(stat%mt(kk+1),lmask))
    +
    282  stat%mt(kk)=ieor(ieor(stat%mt(kk+(m-n)),ishft(y,-1)),
    +
    283  & mag01(iand(y,1)))
    +
    284  enddo
    +
    285  y=ior(iand(stat%mt(n-1),umask),iand(stat%mt(0),lmask))
    +
    286  stat%mt(n-1)=ieor(ieor(stat%mt(m-1),ishft(y,-1)),
    +
    287  & mag01(iand(y,1)))
    +
    288  stat%mti=0
    +
    289  endif
    +
    290  y=stat%mt(stat%mti)
    +
    291  y=ieor(y,tshftu(y))
    +
    292  y=ieor(y,iand(tshfts(y),tmaskb))
    +
    293  y=ieor(y,iand(tshftt(y),tmaskc))
    +
    294  y=ieor(y,tshftl(y))
    +
    295  if(y.lt.0) then
    +
    296  harvest(j)=(real(y)+2.0**32)/(2.0**32-1.0)
    +
    297  else
    +
    298  harvest(j)=real(y)/(2.0**32-1.0)
    +
    299  endif
    +
    300  stat%mti=stat%mti+1
    +
    301  enddo
    +
    302  end subroutine
    +
    305  function random_gauss_f() result(harvest)
    +
    306  implicit none
    +
    307  real:: harvest
    +
    308  real h(1)
    +
    309  if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
    +
    310  call random_gauss_t(h,sstat)
    +
    311  harvest=h(1)
    +
    312  end function
    +
    316  subroutine random_gauss_i(harvest,inseed)
    +
    317  implicit none
    +
    318  real,intent(out):: harvest(:)
    +
    319  integer,intent(in):: inseed
    +
    320  type(random_stat) stat
    +
    321  call random_setseed_t(inseed,stat)
    +
    322  call random_gauss_t(harvest,stat)
    +
    323  end subroutine
    +
    326  subroutine random_gauss_s(harvest)
    +
    327  implicit none
    +
    328  real,intent(out):: harvest(:)
    +
    329  if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
    +
    330  call random_gauss_t(harvest,sstat)
    +
    331  end subroutine
    +
    335  subroutine random_gauss_t(harvest,stat)
    +
    336  implicit none
    +
    337  real,intent(out):: harvest(:)
    +
    338  type(random_stat),intent(inout):: stat
    +
    339  integer mx,my,mz,j
    +
    340  real r2(2),r,g1,g2
    +
    341  mz=size(harvest)
    +
    342  if(mz.le.0) return
    +
    343  mx=0
    +
    344  if(stat%iset.eq.1) then
    +
    345  mx=1
    +
    346  harvest(1)=stat%gset
    +
    347  stat%iset=0
    +
    348  endif
    +
    349  my=(mz-mx)/2*2+mx
    +
    350  do
    +
    351  call random_number_t(harvest(mx+1:my),stat)
    +
    352  do j=mx,my-2,2
    +
    353  call rgauss(harvest(j+1),harvest(j+2),r,g1,g2)
    +
    354  if(r.lt.1.) then
    +
    355  harvest(mx+1)=g1
    +
    356  harvest(mx+2)=g2
    +
    357  mx=mx+2
    +
    358  endif
    +
    359  enddo
    +
    360  if(mx.eq.my) exit
    +
    361  enddo
    +
    362  if(my.lt.mz) then
    +
    363  do
    +
    364  call random_number_t(r2,stat)
    +
    365  call rgauss(r2(1),r2(2),r,g1,g2)
    +
    366  if(r.lt.1.) exit
    +
    367  enddo
    +
    368  harvest(mz)=g1
    +
    369  stat%gset=g2
    +
    370  stat%iset=1
    +
    371  endif
    +
    372  contains
    +
    379  subroutine rgauss(r1,r2,r,g1,g2)
    +
    380  real,intent(in):: r1,r2
    +
    381  real,intent(out):: r,g1,g2
    +
    382  real v1,v2,fac
    +
    383  v1=2.*r1-1.
    +
    384  v2=2.*r2-1.
    +
    385  r=v1**2+v2**2
    +
    386  if(r.lt.1.) then
    +
    387  fac=sqrt(-2.*log(r)/r)
    +
    388  g1=v1*fac
    +
    389  g2=v2*fac
    +
    390  endif
    +
    391  end subroutine
    +
    392  end subroutine
    +
    396  function random_index_f(imax) result(iharvest)
    +
    397  implicit none
    +
    398  integer,intent(in):: imax
    +
    399  integer:: iharvest
    +
    400  integer ih(1)
    +
    401  if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
    +
    402  call random_index_t(imax,ih,sstat)
    +
    403  iharvest=ih(1)
    +
    404  end function
    +
    409  subroutine random_index_i(imax,iharvest,inseed)
    +
    410  implicit none
    +
    411  integer,intent(in):: imax
    +
    412  integer,intent(out):: iharvest(:)
    +
    413  integer,intent(in):: inseed
    +
    414  type(random_stat) stat
    +
    415  call random_setseed_t(inseed,stat)
    +
    416  call random_index_t(imax,iharvest,stat)
    +
    417  end subroutine
    +
    421  subroutine random_index_s(imax,iharvest)
    +
    422  implicit none
    +
    423  integer,intent(in):: imax
    +
    424  integer,intent(out):: iharvest(:)
    +
    425  if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat)
    +
    426  call random_index_t(imax,iharvest,sstat)
    +
    427  end subroutine
    +
    432  subroutine random_index_t(imax,iharvest,stat)
    +
    433  implicit none
    +
    434  integer,intent(in):: imax
    +
    435  integer,intent(out):: iharvest(:)
    +
    436  type(random_stat),intent(inout):: stat
    +
    437  integer,parameter:: mh=n
    +
    438  integer i1,i2,mz
    +
    439  real h(mh)
    +
    440  mz=size(iharvest)
    +
    441  do i1=1,mz,mh
    +
    442  i2=min((i1-1)+mh,mz)
    +
    443  call random_number_t(h(:i2-(i1-1)),stat)
    +
    444  iharvest(i1:i2)=max(ceiling(h(:i2-(i1-1))*imax),1)
    +
    445  enddo
    +
    446  end subroutine
    +
    447  end module
    +
    +
    +
    mersenne_twister::random_seed
    subroutine, public random_seed(size, put, get, stat)
    Sets and gets state; overloads Fortran 90 standard.
    Definition: mersenne_twister.f:151
    +
    mersenne_twister::random_number_f
    real function, public random_number_f()
    Generates random numbers in functional mode.
    Definition: mersenne_twister.f:234
    +
    mersenne_twister::random_gauss_f
    real function, public random_gauss_f()
    Generates Gaussian random numbers in functional mode.
    Definition: mersenne_twister.f:306
    +
    mersenne_twister
    This module calculates random numbers using the Mersenne twister.
    Definition: mersenne_twister.f:90
    +
    mersenne_twister::random_index_f
    integer function, public random_index_f(imax)
    Generates random indices in functional mode.
    Definition: mersenne_twister.f:397
    + + + + diff --git a/ver-2.10.0/mkfldsep_8f.html b/ver-2.10.0/mkfldsep_8f.html new file mode 100644 index 00000000..5a947a9f --- /dev/null +++ b/ver-2.10.0/mkfldsep_8f.html @@ -0,0 +1,219 @@ + + + + + + + +NCEPLIBS-w3emc: mkfldsep.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    mkfldsep.f File Reference
    +
    +
    + +

    Makes TOC Flag Field Separator Block. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine mkfldsep (csep, iopt, lenin, lenbull, lenout)
     Generates a TOC Flag Field Separator Block used to separate WMO Bulletins within a transmission file to be ingested in TOC's FTP Input Service, which can be used to disseminate WMO buletins. More...
     
    +

    Detailed Description

    +

    Makes TOC Flag Field Separator Block.

    +
    Author
    Stephen Gilbert
    +
    Date
    2002-09-16
    + +

    Definition in file mkfldsep.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ mkfldsep()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine mkfldsep (character*(*), intent(out) csep,
    integer, intent(in) iopt,
    integer, intent(in) lenin,
    integer, intent(in) lenbull,
    integer, intent(out) lenout 
    )
    +
    + +

    Generates a TOC Flag Field Separator Block used to separate WMO Bulletins within a transmission file to be ingested in TOC's FTP Input Service, which can be used to disseminate WMO buletins.

    +

    (see http://weather.gov/tg/ftpingest.html)

    +

    This routine can generate different flag field separator blocks depending on the value of variable iopt.

    +

    Bulletin "Flag Field Separator" block - OPTION 1 (old)

      +
    • bytes:
        +
      • 1 - 4 Marker string (####).
        • +
      • 5 - 7 Block length [018 fixed value].
        • +
      • 8 - 13 Total length of bulletin in bytes [octets] (not including the flag field block).
        • +
      • 14 - 17 Marker string (####).
        • +
      • 18 Line Feed (ASCII "0A").
        • +
      +
      • +
    +

    Bulletin "Flag Field Separator" block - OPTION 1a (new)

      +
    • bytes:
        +
      • 1 - 4 Marker string (####).
        • +
      • 5 - 7 Block length (nnn) - value always greater than 018.
        • +
      • 8 - 18 Total length of bulletin in bytes [octets] (not including the flag field block).
        • +
      • 19 - nnn-5 Reserved for future use.
        • +
      • nnn-4 - nnn-1 Marker string (####).
        • +
      • nnn Line Feed (ASCII "0A").
        • +
      +
      • +
    +

    Bulletin "Flag Field Separator" block - OPTION 2 (limited)

      +
    • bytes:
        +
      • 1 - 4 Marker string (****).
        • +
      • 5 - 14 Total length of bulletin in bytes [octets] (not including the flag field block).
        • +
      • 15 - 18 Marker string (****).
        • +
      • 19 Line Feed (ASCII "0A").
        • +
      +
      • +
    +

    Program history log:

      +
    • Stephen Gilbert 2002-09-16
      • +
    +
    Parameters
    + + + + + + +
    [in]ioptFlag Field Separator block option: = 1: Separator block for use with alphanumeric bulletins. if lenin <= 18 and lenbull <= 999999, OPTION 1 block will be generated. if lenin > 18 or lenbull > 999999, OPTION 1a block will be generated. = 2: Separator block for use with GRIB/BUFR bulletins.
    [in]leninDesired length of the flag field separator block. ignored, if iopt=2.
    [in]lenbullInteger length of the bulletin (in bytes) that will follow this separator block.
    [out]csep*(*)Character array containing the flag field separator.
    [out]lenoutInteger length of the flag field separator block.
    +
    +
    +
    Author
    Stephen Gilbert
    +
    Date
    2002-09-16
    + +

    Definition at line 58 of file mkfldsep.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/mkfldsep_8f.js b/ver-2.10.0/mkfldsep_8f.js new file mode 100644 index 00000000..46ea8cd3 --- /dev/null +++ b/ver-2.10.0/mkfldsep_8f.js @@ -0,0 +1,4 @@ +var mkfldsep_8f = +[ + [ "mkfldsep", "mkfldsep_8f.html#ac36c3aa46eee1a7f5ce77daa4c3fc045", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/mkfldsep_8f_source.html b/ver-2.10.0/mkfldsep_8f_source.html new file mode 100644 index 00000000..cb3b490f --- /dev/null +++ b/ver-2.10.0/mkfldsep_8f_source.html @@ -0,0 +1,199 @@ + + + + + + + +NCEPLIBS-w3emc: mkfldsep.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    mkfldsep.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Makes TOC Flag Field Separator Block
    +
    3 C> @author Stephen Gilbert @date 2002-09-16
    +
    4 
    +
    5 C> Generates a TOC Flag Field Separator Block used to separate
    +
    6 C> WMO Bulletins within a transmission file to be ingested in TOC's
    +
    7 C> FTP Input Service, which can be used to disseminate WMO buletins.
    +
    8 C> (see http://weather.gov/tg/ftpingest.html)
    +
    9 C>
    +
    10 C> This routine can generate different flag field separator blocks
    +
    11 C> depending on the value of variable iopt.
    +
    12 C>
    +
    13 C> Bulletin "Flag Field Separator" block - OPTION 1 (old)
    +
    14 C> - bytes:
    +
    15 C> - 1 - 4 Marker string (####).
    +
    16 C> - 5 - 7 Block length [018 fixed value].
    +
    17 C> - 8 - 13 Total length of bulletin in bytes [octets]
    +
    18 C> (not including the flag field block).
    +
    19 C> - 14 - 17 Marker string (####).
    +
    20 C> - 18 Line Feed (ASCII "0A").
    +
    21 C>
    +
    22 C> Bulletin "Flag Field Separator" block - OPTION 1a (new)
    +
    23 C> - bytes:
    +
    24 C> - 1 - 4 Marker string (####).
    +
    25 C> - 5 - 7 Block length (nnn) - value always greater than 018.
    +
    26 C> - 8 - 18 Total length of bulletin in bytes [octets]
    +
    27 C> (not including the flag field block).
    +
    28 C> - 19 - nnn-5 Reserved for future use.
    +
    29 C> - nnn-4 - nnn-1 Marker string (####).
    +
    30 C> - nnn Line Feed (ASCII "0A").
    +
    31 C>
    +
    32 C> Bulletin "Flag Field Separator" block - OPTION 2 (limited)
    +
    33 C> - bytes:
    +
    34 C> - 1 - 4 Marker string (****).
    +
    35 C> - 5 - 14 Total length of bulletin in bytes [octets]
    +
    36 C> (not including the flag field block).
    +
    37 C> - 15 - 18 Marker string (****).
    +
    38 C> - 19 Line Feed (ASCII "0A").
    +
    39 C>
    +
    40 C>
    +
    41 C> Program history log:
    +
    42 C> - Stephen Gilbert 2002-09-16
    +
    43 C>
    +
    44 C> @param[in] iopt Flag Field Separator block option:
    +
    45 C> = 1: Separator block for use with alphanumeric bulletins.
    +
    46 C> if lenin <= 18 and lenbull <= 999999, OPTION 1 block will be generated.
    +
    47 C> if lenin > 18 or lenbull > 999999, OPTION 1a block will be generated.
    +
    48 C> = 2: Separator block for use with GRIB/BUFR bulletins.
    +
    49 C> @param[in] lenin Desired length of the flag field separator block.
    +
    50 C> ignored, if iopt=2.
    +
    51 C> @param[in] lenbull Integer length of the bulletin (in bytes) that will follow
    +
    52 C> this separator block.
    +
    53 C> @param[out] csep*(*) Character array containing the flag field separator.
    +
    54 C> @param[out] lenout Integer length of the flag field separator block.
    +
    55 C>
    +
    56 C> @author Stephen Gilbert @date 2002-09-16
    +
    57  subroutine mkfldsep(csep,iopt,lenin,lenbull,lenout)
    +
    58 C
    +
    59  character*(*),intent(out) :: csep
    +
    60  integer,intent(in) :: iopt,lenin,lenbull
    +
    61  integer,intent(out) :: lenout
    +
    62 C
    +
    63  character(len=4),parameter :: cstar='****',clb='####'
    +
    64 C
    +
    65  if (iopt.eq.1) then
    +
    66  if ( lenin .le. 18 .and. lenbull .le. 999999 ) then
    +
    67  ! Create OPTION 1 separator block
    +
    68  csep(1:4)=clb
    +
    69  csep(5:7)='018'
    +
    70  write(csep(8:13),fmt='(I6.6)') lenbull
    +
    71  csep(14:17)=clb
    +
    72  csep(18:18)=char(10)
    +
    73  lenout=18
    +
    74  else ! Create OPTION 1a separator block
    +
    75  nnn=lenin
    +
    76  if ( nnn.lt.23 ) nnn=23
    +
    77  csep(1:4)=clb
    +
    78  write(csep(5:7),fmt='(I3.3)') nnn
    +
    79  write(csep(8:18),fmt='(I11.11)') lenbull
    +
    80  csep(19:nnn-5)='0'
    +
    81  csep(nnn-4:nnn-1)=clb
    +
    82  csep(nnn:nnn)=char(10)
    +
    83  lenout=nnn
    +
    84  endif
    +
    85  elseif (iopt.eq.2) then ! Create OPTION 2 separator block
    +
    86  csep(1:4)=cstar
    +
    87  write(csep(5:14),fmt='(I10.10)') lenbull
    +
    88  csep(15:18)=cstar
    +
    89  csep(19:19)=char(10)
    +
    90  lenout=19
    +
    91  else
    +
    92  print *,"mkfldsep: Option ",iopt," not recognized."
    +
    93  csep(1:lenin)=' '
    +
    94  endif
    +
    95 C
    +
    96  return
    +
    97  end
    +
    +
    +
    mkfldsep
    subroutine mkfldsep(csep, iopt, lenin, lenbull, lenout)
    Generates a TOC Flag Field Separator Block used to separate WMO Bulletins within a transmission file ...
    Definition: mkfldsep.f:58
    + + + + diff --git a/ver-2.10.0/mova2i_8f.html b/ver-2.10.0/mova2i_8f.html new file mode 100644 index 00000000..4d351fa6 --- /dev/null +++ b/ver-2.10.0/mova2i_8f.html @@ -0,0 +1,156 @@ + + + + + + + +NCEPLIBS-w3emc: mova2i.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    mova2i.f File Reference
    +
    +
    + +

    This Function copies a bit string from a Character*1 variable to an integer variable. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    integer function mova2i (a)
     This Function copies a bit string from a Character*1 variable to an integer variable. More...
     
    +

    Detailed Description

    +

    This Function copies a bit string from a Character*1 variable to an integer variable.

    +
    Author
    Stephen Gilbert
    +
    Date
    1998-12-15
    + +

    Definition in file mova2i.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ mova2i()

    + +
    +
    + + + + + + + + +
    integer function mova2i (character(len=1) a)
    +
    + +

    This Function copies a bit string from a Character*1 variable to an integer variable.

    +

    It is intended to replace the Fortran Intrinsic Function ICHAR, which only supports 0 <= ICHAR(a) <= 127 on the IBM SP. If "a" is greater than 127 in the collating sequence, ICHAR(a) does not return the expected bit value when the -qhot ( and therefore -qsmp) option is used when compiling. This function can be used for all values 0 <= ICHAR(a) <= 255 and will work with or without the -qhot compiler option.

    +

    Program history log:

      +
    • Stephen Gilbert 1998-12-15
      • +
    • Stephen Gilbert 2001-06-11 Added a step to fill an 8-byte character array with the same value so that the f90 transfer function is more predictable. All bytes will now contain the desired value.
      • +
    +
    Parameters
    + + +
    [in]aCharacter*1 variable that holds the bitstring to extract.
    +
    +
    +
    Returns
    mova2i() Integer value of the bitstring in character a.
    + +

    Definition at line 25 of file mova2i.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/mova2i_8f.js b/ver-2.10.0/mova2i_8f.js new file mode 100644 index 00000000..828c64d2 --- /dev/null +++ b/ver-2.10.0/mova2i_8f.js @@ -0,0 +1,4 @@ +var mova2i_8f = +[ + [ "mova2i", "mova2i_8f.html#aed1be7b63ac5c89c04f701e75bb4fbe0", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/mova2i_8f_source.html b/ver-2.10.0/mova2i_8f_source.html new file mode 100644 index 00000000..04f6299c --- /dev/null +++ b/ver-2.10.0/mova2i_8f_source.html @@ -0,0 +1,137 @@ + + + + + + + +NCEPLIBS-w3emc: mova2i.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    mova2i.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief This Function copies a bit string from a Character*1 variable
    +
    3 C> to an integer variable.
    +
    4 C> @author Stephen Gilbert @date 1998-12-15
    +
    5 
    +
    6 C> This Function copies a bit string from a Character*1 variable
    +
    7 C> to an integer variable. It is intended to replace the Fortran Intrinsic
    +
    8 C> Function ICHAR, which only supports 0 <= ICHAR(a) <= 127 on the
    +
    9 C> IBM SP. If "a" is greater than 127 in the collating sequence,
    +
    10 C> ICHAR(a) does not return the expected bit value when the -qhot
    +
    11 C> ( and therefore -qsmp) option is used when compiling.
    +
    12 C> This function can be used for all values 0 <= ICHAR(a) <= 255 and
    +
    13 C> will work with or without the -qhot compiler option.
    +
    14 C>
    +
    15 C> Program history log:
    +
    16 C> - Stephen Gilbert 1998-12-15
    +
    17 C> - Stephen Gilbert 2001-06-11 Added a step to fill an 8-byte character
    +
    18 C> array with the same value so that the f90 transfer function is more
    +
    19 C> predictable. All bytes will now contain the desired value.
    +
    20 C>
    +
    21 C> @param[in] a Character*1 variable that holds the bitstring to extract.
    +
    22 C> @return mova2i() Integer value of the bitstring in character a.
    +
    23 C>
    +
    24  Integer Function mova2i(a)
    +
    25 C
    +
    26  integer mold
    +
    27  character(len=1) a
    +
    28  character(len=1) ctemp(8)
    +
    29 
    +
    30  ctemp(1:8)=a
    +
    31 c mova2i=ishft(transfer(ctemp,mold),8-bit_size(mold))
    +
    32  mova2i=iand(transfer(ctemp,mold),255)
    +
    33 
    +
    34  return
    +
    35  end
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    + + + + diff --git a/ver-2.10.0/namespaceargs__mod.html b/ver-2.10.0/namespaceargs__mod.html new file mode 100644 index 00000000..c9524afc --- /dev/null +++ b/ver-2.10.0/namespaceargs__mod.html @@ -0,0 +1,129 @@ + + + + + + + +NCEPLIBS-w3emc: args_mod Module Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Data Types | +Functions/Subroutines
    +
    +
    args_mod Module Reference
    +
    +
    + +

    This Fortran Module acts as a wrapper to the system routines IARGC and GETARG. +More...

    + + + + + + +

    +Data Types

    interface  getarg
     
    interface  iargc
     
    + + + + + +

    +Functions/Subroutines

    +subroutine getarg_8 (k, c)
     
    +integer(8) function iargc_8 ()
     
    +

    Detailed Description

    +

    This Fortran Module acts as a wrapper to the system routines IARGC and GETARG.

    +

    Use of this module allows IARGC and GETARG to work properly with 4-byte or 8-byte integer arguments.

    +
    Author
    Mark Iredell
    +
    Date
    1998-11-DD
    +
    +
    + + + + diff --git a/ver-2.10.0/namespaceargs__mod.js b/ver-2.10.0/namespaceargs__mod.js new file mode 100644 index 00000000..cd99326b --- /dev/null +++ b/ver-2.10.0/namespaceargs__mod.js @@ -0,0 +1,5 @@ +var namespaceargs__mod = +[ + [ "getarg", "interfaceargs__mod_1_1getarg.html", "interfaceargs__mod_1_1getarg" ], + [ "iargc", "interfaceargs__mod_1_1iargc.html", "interfaceargs__mod_1_1iargc" ] +]; \ No newline at end of file diff --git a/ver-2.10.0/namespacemembers.html b/ver-2.10.0/namespacemembers.html new file mode 100644 index 00000000..f45c07f6 --- /dev/null +++ b/ver-2.10.0/namespacemembers.html @@ -0,0 +1,110 @@ + + + + + + + +NCEPLIBS-w3emc: Module Members + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    Here is a list of all documented module members with links to the modules they belong to:
    +
    +
    + + + + diff --git a/ver-2.10.0/namespacemembers_func.html b/ver-2.10.0/namespacemembers_func.html new file mode 100644 index 00000000..d3d70e72 --- /dev/null +++ b/ver-2.10.0/namespacemembers_func.html @@ -0,0 +1,110 @@ + + + + + + + +NCEPLIBS-w3emc: Module Members + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +  +
    +
    + + + + diff --git a/ver-2.10.0/namespacemersenne__twister.html b/ver-2.10.0/namespacemersenne__twister.html new file mode 100644 index 00000000..4bc3aba8 --- /dev/null +++ b/ver-2.10.0/namespacemersenne__twister.html @@ -0,0 +1,293 @@ + + + + + + + +NCEPLIBS-w3emc: mersenne_twister Module Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Data Types | +Functions/Subroutines
    +
    +
    mersenne_twister Module Reference
    +
    +
    + +

    This module calculates random numbers using the Mersenne twister. +More...

    + + + + + + + + + + + + + + +

    +Functions/Subroutines

    real function, public random_gauss_f ()
     Generates Gaussian random numbers in functional mode. More...
     
    integer function, public random_index_f (imax)
     Generates random indices in functional mode. More...
     
    real function, public random_number_f ()
     Generates random numbers in functional mode. More...
     
    subroutine, public random_seed (size, put, get, stat)
     Sets and gets state; overloads Fortran 90 standard. More...
     
    +

    Detailed Description

    +

    This module calculates random numbers using the Mersenne twister.

    +

    (It has been adapted to a Fortran 90 module from open source software. The comments from the original software are given below in the remarks.) The Mersenne twister (aka MT19937) is a state-of-the-art random number generator based on Mersenne primes and originally developed in 1997 by Matsumoto and Nishimura. It has a period before repeating of 2^19937-1, which certainly should be good enough for geophysical purposes. :-) Considering the algorithm's robustness, it runs fairly speedily. (Some timing statistics are given below in the remarks.) This adaptation uses the standard Fortran 90 random number interface, which can generate an arbitrary number of random numbers at one time. The random numbers generated are uniformly distributed between 0 and 1. The module also can generate random numbers from a Gaussian distribution with mean 0 and standard deviation 1, using a Numerical Recipes algorithm. The module also can generate uniformly random integer indices. There are also thread-safe versions of the generators in this adaptation, necessitating the passing of generator states which must be kept private.

    +

    Usage:

      +
    • The module can be compiled with 4-byte reals or with 8-byte reals, but 4-byte integers are required. The module should be endian-independent.
      • +
    • The Fortran 90 interfaces random_seed and random_number are overloaded and can be used as in the standard by adding the appropriate use statement +
      • +
    • In the below use cases, harvest is a real array of arbitrary size, and iharvest is an integer array of arbitrary size.
      • +
    • To generate uniformly distributed random numbers between 0 and 1,
        +
      • call random_number(harvest)
        • +
      +
      • +
    • To generate Gaussian distributed random numbers with 0 mean and 1 sigma,
        +
      • call random_gauss(harvest)
        • +
      +
      • +
    • To generate uniformly distributed random integer indices between 0 and n,
        +
      • call random_index(n,iharvest)
        • +
      +
      • +
    • In standard "saved" mode, the random number generator can be used without setting a seed. But to set a seed, only 1 non-zero integer is required, e.g.
        +
      • call random_setseed(4357) ! set default seed
        • +
      +
      • +
    • The full generator state can be set via the standard interface random_seed, but it is recommended to use this method only to restore saved states, e.g.
        +
      • call random_seed(size=lsave) ! get size of generator state seed array
        • +
      • allocate isave(lsave) ! allocate seed array
        • +
      • call random_seed(get=isave) ! fill seed array (then maybe save to disk)
        • +
      • call random_seed(put=isave) ! restore state (after read from disk maybe)
        • +
      +
      • +
    • Locally kept generator states can also be saved in a seed array, e.g.
        +
      • type(random_stat):: stat
        • +
      • call random_seed(get=isave,stat=stat) ! fill seed array
        • +
      • call random_seed(put=isave,stat=stat) ! restore state
        • +
      +
      • +
    • To generate random numbers in a threaded region, the "thread-safe" mode must be used where generator states of type random_state are passed, e.g.
      • +
    +

    Public Defined Types:

      +
    • random_stat Generator state (private contents)
      • +
    +
    Note
    Here are the comments in the original open source code: A C-program for MT19937: Real number version genrand() generates one pseudorandom real number (double) which is uniformly distributed on [0,1]-interval, for each call. sgenrand(seed) set initial values to the working area of 624 words. Before genrand(), sgenrand(seed) must be called once. (seed is any 32-bit integer except for 0). Integer generator is obtained by modifying two lines. Coded by Takuji Nishimura, considering the suggestions by Topher Cooper and Marc Rieffel in July-Aug. 1997. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. You should have received a copy of the GNU Library General Public License along with this library; if not, write to the Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Copyright (C) 1997 Makoto Matsumoto and Takuji Nishimura. When you use this, send an email to: matum.nosp@m.oto@.nosp@m.math..nosp@m.keio.nosp@m..ac.j.nosp@m.p with an appropriate reference to your work. Fortran translation by Hiroshi Takano. Jan. 13, 1999.
    +
    +On a single IBM Power4 processor on the NCEP operational cluster (2005) each Mersenne twister random number takes less than 30 ns, about 3 times slower than the default random number generator, and each random number from a Gaussian distribution takes less than 150 ns.
    +
    Author
    Mark Iredell
    +
    Date
    2005-06-14
    +

    Function/Subroutine Documentation

    + +

    ◆ random_gauss_f()

    + +
    +
    + + + + +
    real function, public mersenne_twister::random_gauss_f
    +
    + +

    Generates Gaussian random numbers in functional mode.

    +
    Returns
    harvest Real number output.
    + +

    Definition at line 306 of file mersenne_twister.f.

    + +
    +
    + +

    ◆ random_index_f()

    + +
    +
    + + + + + + + + +
    integer function, public mersenne_twister::random_index_f (integer, intent(in) imax)
    +
    + +

    Generates random indices in functional mode.

    +
    Parameters
    + + +
    [in]imaxInteger maximum index input
    +
    +
    +
    Returns
    iharvest Integer number output
    + +

    Definition at line 397 of file mersenne_twister.f.

    + +
    +
    + +

    ◆ random_number_f()

    + +
    +
    + + + + +
    real function, public mersenne_twister::random_number_f
    +
    + +

    Generates random numbers in functional mode.

    +
    Returns
    harvest Real number output.
    + +

    Definition at line 234 of file mersenne_twister.f.

    + +
    +
    + +

    ◆ random_seed()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine, public mersenne_twister::random_seed (integer, intent(out), optional size,
    integer, dimension(nrest), intent(in), optional put,
    integer, dimension(nrest), intent(out), optional get,
    type(random_stat), intent(inout), optional stat 
    )
    +
    + +

    Sets and gets state; overloads Fortran 90 standard.

    +
    Parameters
    + + + + + +
    [out]sizeOptional integer output size of seed array.
    [in]putOptional integer(:) input seed array.
    [out]getOptional integer(:) output seed array.
    [in,out]statOptional type(random_stat) (thread-safe mode).
    +
    +
    + +

    Definition at line 151 of file mersenne_twister.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/namespaces.html b/ver-2.10.0/namespaces.html new file mode 100644 index 00000000..f13eed61 --- /dev/null +++ b/ver-2.10.0/namespaces.html @@ -0,0 +1,106 @@ + + + + + + + +NCEPLIBS-w3emc: Modules List + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    Modules List
    +
    +
    +
    Here is a list of all documented modules with brief descriptions:
    + + + +
     Nargs_modThis Fortran Module acts as a wrapper to the system routines IARGC and GETARG
     Nmersenne_twisterThis module calculates random numbers using the Mersenne twister
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/namespaces_dup.js b/ver-2.10.0/namespaces_dup.js new file mode 100644 index 00000000..2d5e69e4 --- /dev/null +++ b/ver-2.10.0/namespaces_dup.js @@ -0,0 +1,5 @@ +var namespaces_dup = +[ + [ "args_mod", "namespaceargs__mod.html", null ], + [ "mersenne_twister", "namespacemersenne__twister.html", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/nav_f.png b/ver-2.10.0/nav_f.png new file mode 100644 index 00000000..72a58a52 Binary files /dev/null and b/ver-2.10.0/nav_f.png differ diff --git a/ver-2.10.0/nav_g.png b/ver-2.10.0/nav_g.png new file mode 100644 index 00000000..2093a237 Binary files /dev/null and b/ver-2.10.0/nav_g.png differ diff --git a/ver-2.10.0/nav_h.png b/ver-2.10.0/nav_h.png new file mode 100644 index 00000000..33389b10 Binary files /dev/null and b/ver-2.10.0/nav_h.png differ diff --git a/ver-2.10.0/navtree.css b/ver-2.10.0/navtree.css new file mode 100644 index 00000000..33341a67 --- /dev/null +++ b/ver-2.10.0/navtree.css @@ -0,0 +1,146 @@ +#nav-tree .children_ul { + margin:0; + padding:4px; +} + +#nav-tree ul { + list-style:none outside none; + margin:0px; + padding:0px; +} + +#nav-tree li { + white-space:nowrap; + margin:0px; + padding:0px; +} + +#nav-tree .plus { + margin:0px; +} + +#nav-tree .selected { + background-image: url('tab_a.png'); + background-repeat:repeat-x; + color: #fff; + text-shadow: 0px 1px 1px rgba(0, 0, 0, 1.0); +} + +#nav-tree img { + margin:0px; + padding:0px; + border:0px; + vertical-align: middle; +} + +#nav-tree a { + text-decoration:none; + padding:0px; + margin:0px; + outline:none; +} + +#nav-tree .label { + margin:0px; + padding:0px; + font: 12px 'Lucida Grande',Geneva,Helvetica,Arial,sans-serif; +} + +#nav-tree .label a { + padding:2px; +} + +#nav-tree .selected a { + text-decoration:none; + color:#fff; +} + +#nav-tree .children_ul { + margin:0px; + padding:0px; +} + +#nav-tree .item { + margin:0px; + padding:0px; +} + +#nav-tree { + padding: 0px 0px; + background-color: #FAFAFF; + font-size:14px; + overflow:auto; +} + +#doc-content { + overflow:auto; + display:block; + padding:0px; + margin:0px; + -webkit-overflow-scrolling : touch; /* iOS 5+ */ +} + +#side-nav { + padding:0 6px 0 0; + margin: 0px; + display:block; + position: absolute; + left: 0px; + width: 250px; +} + +.ui-resizable .ui-resizable-handle { + display:block; +} + +.ui-resizable-e { + background-image:url("splitbar.png"); + background-size:100%; + background-repeat:repeat-y; + background-attachment: scroll; + cursor:ew-resize; + height:100%; + right:0; + top:0; + width:6px; +} + +.ui-resizable-handle { + display:none; + font-size:0.1px; + position:absolute; + z-index:1; +} + +#nav-tree-contents { + margin: 6px 0px 0px 0px; +} + +#nav-tree { + background-image:url('nav_h.png'); + background-repeat:repeat-x; + background-color: #F9FAFC; + -webkit-overflow-scrolling : touch; /* iOS 5+ */ +} + +#nav-sync { + position:absolute; + top:5px; + right:24px; + z-index:0; +} + +#nav-sync img { + opacity:0.3; +} + +#nav-sync img:hover { + opacity:0.9; +} + +@media print +{ + #nav-tree { display: none; } + div.ui-resizable-handle { display: none; position: relative; } +} + diff --git a/ver-2.10.0/navtree.js b/ver-2.10.0/navtree.js new file mode 100644 index 00000000..edc31efc --- /dev/null +++ b/ver-2.10.0/navtree.js @@ -0,0 +1,544 @@ +/* + @licstart The following is the entire license notice for the + JavaScript code in this file. + + Copyright (C) 1997-2019 by Dimitri van Heesch + + This program is free software; you can redistribute it and/or modify + it under the terms of version 2 of the GNU General Public License as + published by the Free Software Foundation. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + + @licend The above is the entire license notice + for the JavaScript code in this file + */ +var navTreeSubIndices = new Array(); +var arrowDown = '▼'; +var arrowRight = '►'; + +function getData(varName) +{ + var i = varName.lastIndexOf('/'); + var n = i>=0 ? varName.substring(i+1) : varName; + return eval(n.replace(/\-/g,'_')); +} + +function stripPath(uri) +{ + return uri.substring(uri.lastIndexOf('/')+1); +} + +function stripPath2(uri) +{ + var i = uri.lastIndexOf('/'); + var s = uri.substring(i+1); + var m = uri.substring(0,i+1).match(/\/d\w\/d\w\w\/$/); + return m ? uri.substring(i-6) : s; +} + +function hashValue() +{ + return $(location).attr('hash').substring(1).replace(/[^\w\-]/g,''); +} + +function hashUrl() +{ + return '#'+hashValue(); +} + +function pathName() +{ + return $(location).attr('pathname').replace(/[^-A-Za-z0-9+&@#/%?=~_|!:,.;\(\)]/g, ''); +} + +function localStorageSupported() +{ + try { + return 'localStorage' in window && window['localStorage'] !== null && window.localStorage.getItem; + } + catch(e) { + return false; + } +} + +function storeLink(link) +{ + if (!$("#nav-sync").hasClass('sync') && localStorageSupported()) { + window.localStorage.setItem('navpath',link); + } +} + +function deleteLink() +{ + if (localStorageSupported()) { + window.localStorage.setItem('navpath',''); + } +} + +function cachedLink() +{ + if (localStorageSupported()) { + return window.localStorage.getItem('navpath'); + } else { + return ''; + } +} + +function getScript(scriptName,func,show) +{ + var head = document.getElementsByTagName("head")[0]; + var script = document.createElement('script'); + script.id = scriptName; + script.type = 'text/javascript'; + script.onload = func; + script.src = scriptName+'.js'; + head.appendChild(script); +} + +function createIndent(o,domNode,node,level) +{ + var level=-1; + var n = node; + while (n.parentNode) { level++; n=n.parentNode; } + if (node.childrenData) { + var imgNode = document.createElement("span"); + imgNode.className = 'arrow'; + imgNode.style.paddingLeft=(16*level).toString()+'px'; + imgNode.innerHTML=arrowRight; + node.plus_img = imgNode; + node.expandToggle = document.createElement("a"); + node.expandToggle.href = "javascript:void(0)"; + node.expandToggle.onclick = function() { + if (node.expanded) { + $(node.getChildrenUL()).slideUp("fast"); + node.plus_img.innerHTML=arrowRight; + node.expanded = false; + } else { + expandNode(o, node, false, false); + } + } + node.expandToggle.appendChild(imgNode); + domNode.appendChild(node.expandToggle); + } else { + var span = document.createElement("span"); + span.className = 'arrow'; + span.style.width = 16*(level+1)+'px'; + span.innerHTML = ' '; + domNode.appendChild(span); + } +} + +var animationInProgress = false; + +function gotoAnchor(anchor,aname,updateLocation) +{ + var pos, docContent = $('#doc-content'); + var ancParent = $(anchor.parent()); + if (ancParent.hasClass('memItemLeft') || + ancParent.hasClass('memtitle') || + ancParent.hasClass('fieldname') || + ancParent.hasClass('fieldtype') || + ancParent.is(':header')) + { + pos = ancParent.position().top; + } else if (anchor.position()) { + pos = anchor.position().top; + } + if (pos) { + var dist = Math.abs(Math.min( + pos-docContent.offset().top, + docContent[0].scrollHeight- + docContent.height()-docContent.scrollTop())); + animationInProgress=true; + docContent.animate({ + scrollTop: pos + docContent.scrollTop() - docContent.offset().top + },Math.max(50,Math.min(500,dist)),function(){ + if (updateLocation) window.location.href=aname; + animationInProgress=false; + }); + } +} + +function newNode(o, po, text, link, childrenData, lastNode) +{ + var node = new Object(); + node.children = Array(); + node.childrenData = childrenData; + node.depth = po.depth + 1; + node.relpath = po.relpath; + node.isLast = lastNode; + + node.li = document.createElement("li"); + po.getChildrenUL().appendChild(node.li); + node.parentNode = po; + + node.itemDiv = document.createElement("div"); + node.itemDiv.className = "item"; + + node.labelSpan = document.createElement("span"); + node.labelSpan.className = "label"; + + createIndent(o,node.itemDiv,node,0); + node.itemDiv.appendChild(node.labelSpan); + node.li.appendChild(node.itemDiv); + + var a = document.createElement("a"); + node.labelSpan.appendChild(a); + node.label = document.createTextNode(text); + node.expanded = false; + a.appendChild(node.label); + if (link) { + var url; + if (link.substring(0,1)=='^') { + url = link.substring(1); + link = url; + } else { + url = node.relpath+link; + } + a.className = stripPath(link.replace('#',':')); + if (link.indexOf('#')!=-1) { + var aname = '#'+link.split('#')[1]; + var srcPage = stripPath(pathName()); + var targetPage = stripPath(link.split('#')[0]); + a.href = srcPage!=targetPage ? url : "javascript:void(0)"; + a.onclick = function(){ + storeLink(link); + if (!$(a).parent().parent().hasClass('selected')) + { + $('.item').removeClass('selected'); + $('.item').removeAttr('id'); + $(a).parent().parent().addClass('selected'); + $(a).parent().parent().attr('id','selected'); + } + var anchor = $(aname); + gotoAnchor(anchor,aname,true); + }; + } else { + a.href = url; + a.onclick = function() { storeLink(link); } + } + } else { + if (childrenData != null) + { + a.className = "nolink"; + a.href = "javascript:void(0)"; + a.onclick = node.expandToggle.onclick; + } + } + + node.childrenUL = null; + node.getChildrenUL = function() { + if (!node.childrenUL) { + node.childrenUL = document.createElement("ul"); + node.childrenUL.className = "children_ul"; + node.childrenUL.style.display = "none"; + node.li.appendChild(node.childrenUL); + } + return node.childrenUL; + }; + + return node; +} + +function showRoot() +{ + var headerHeight = $("#top").height(); + var footerHeight = $("#nav-path").height(); + var windowHeight = $(window).height() - headerHeight - footerHeight; + (function (){ // retry until we can scroll to the selected item + try { + var navtree=$('#nav-tree'); + navtree.scrollTo('#selected',100,{offset:-windowHeight/2}); + } catch (err) { + setTimeout(arguments.callee, 0); + } + })(); +} + +function expandNode(o, node, imm, showRoot) +{ + if (node.childrenData && !node.expanded) { + if (typeof(node.childrenData)==='string') { + var varName = node.childrenData; + getScript(node.relpath+varName,function(){ + node.childrenData = getData(varName); + expandNode(o, node, imm, showRoot); + }, showRoot); + } else { + if (!node.childrenVisited) { + getNode(o, node); + } + $(node.getChildrenUL()).slideDown("fast"); + node.plus_img.innerHTML = arrowDown; + node.expanded = true; + } + } +} + +function glowEffect(n,duration) +{ + n.addClass('glow').delay(duration).queue(function(next){ + $(this).removeClass('glow');next(); + }); +} + +function highlightAnchor() +{ + var aname = hashUrl(); + var anchor = $(aname); + if (anchor.parent().attr('class')=='memItemLeft'){ + var rows = $('.memberdecls tr[class$="'+hashValue()+'"]'); + glowEffect(rows.children(),300); // member without details + } else if (anchor.parent().attr('class')=='fieldname'){ + glowEffect(anchor.parent().parent(),1000); // enum value + } else if (anchor.parent().attr('class')=='fieldtype'){ + glowEffect(anchor.parent().parent(),1000); // struct field + } else if (anchor.parent().is(":header")) { + glowEffect(anchor.parent(),1000); // section header + } else { + glowEffect(anchor.next(),1000); // normal member + } +} + +function selectAndHighlight(hash,n) +{ + var a; + if (hash) { + var link=stripPath(pathName())+':'+hash.substring(1); + a=$('.item a[class$="'+link+'"]'); + } + if (a && a.length) { + a.parent().parent().addClass('selected'); + a.parent().parent().attr('id','selected'); + highlightAnchor(); + } else if (n) { + $(n.itemDiv).addClass('selected'); + $(n.itemDiv).attr('id','selected'); + } + if ($('#nav-tree-contents .item:first').hasClass('selected')) { + $('#nav-sync').css('top','30px'); + } else { + $('#nav-sync').css('top','5px'); + } + showRoot(); +} + +function showNode(o, node, index, hash) +{ + if (node && node.childrenData) { + if (typeof(node.childrenData)==='string') { + var varName = node.childrenData; + getScript(node.relpath+varName,function(){ + node.childrenData = getData(varName); + showNode(o,node,index,hash); + },true); + } else { + if (!node.childrenVisited) { + getNode(o, node); + } + $(node.getChildrenUL()).css({'display':'block'}); + node.plus_img.innerHTML = arrowDown; + node.expanded = true; + var n = node.children[o.breadcrumbs[index]]; + if (index+11) hash = '#'+parts[1].replace(/[^\w\-]/g,''); + else hash=''; + } + if (hash.match(/^#l\d+$/)) { + var anchor=$('a[name='+hash.substring(1)+']'); + glowEffect(anchor.parent(),1000); // line number + hash=''; // strip line number anchors + } + var url=root+hash; + var i=-1; + while (NAVTREEINDEX[i+1]<=url) i++; + if (i==-1) { i=0; root=NAVTREE[0][1]; } // fallback: show index + if (navTreeSubIndices[i]) { + gotoNode(o,i,root,hash,relpath) + } else { + getScript(relpath+'navtreeindex'+i,function(){ + navTreeSubIndices[i] = eval('NAVTREEINDEX'+i); + if (navTreeSubIndices[i]) { + gotoNode(o,i,root,hash,relpath); + } + },true); + } +} + +function showSyncOff(n,relpath) +{ + n.html(''); +} + +function showSyncOn(n,relpath) +{ + n.html(''); +} + +function toggleSyncButton(relpath) +{ + var navSync = $('#nav-sync'); + if (navSync.hasClass('sync')) { + navSync.removeClass('sync'); + showSyncOff(navSync,relpath); + storeLink(stripPath2(pathName())+hashUrl()); + } else { + navSync.addClass('sync'); + showSyncOn(navSync,relpath); + deleteLink(); + } +} + +var loadTriggered = false; +var readyTriggered = false; +var loadObject,loadToRoot,loadUrl,loadRelPath; + +$(window).on('load',function(){ + if (readyTriggered) { // ready first + navTo(loadObject,loadToRoot,loadUrl,loadRelPath); + showRoot(); + } + loadTriggered=true; +}); + +function initNavTree(toroot,relpath) +{ + var o = new Object(); + o.toroot = toroot; + o.node = new Object(); + o.node.li = document.getElementById("nav-tree-contents"); + o.node.childrenData = NAVTREE; + o.node.children = new Array(); + o.node.childrenUL = document.createElement("ul"); + o.node.getChildrenUL = function() { return o.node.childrenUL; }; + o.node.li.appendChild(o.node.childrenUL); + o.node.depth = 0; + o.node.relpath = relpath; + o.node.expanded = false; + o.node.isLast = true; + o.node.plus_img = document.createElement("span"); + o.node.plus_img.className = 'arrow'; + o.node.plus_img.innerHTML = arrowRight; + + if (localStorageSupported()) { + var navSync = $('#nav-sync'); + if (cachedLink()) { + showSyncOff(navSync,relpath); + navSync.removeClass('sync'); + } else { + showSyncOn(navSync,relpath); + } + navSync.click(function(){ toggleSyncButton(relpath); }); + } + + if (loadTriggered) { // load before ready + navTo(o,toroot,hashUrl(),relpath); + showRoot(); + } else { // ready before load + loadObject = o; + loadToRoot = toroot; + loadUrl = hashUrl(); + loadRelPath = relpath; + readyTriggered=true; + } + + $(window).bind('hashchange', function(){ + if (window.location.hash && window.location.hash.length>1){ + var a; + if ($(location).attr('hash')){ + var clslink=stripPath(pathName())+':'+hashValue(); + a=$('.item a[class$="'+clslink.replace(/ + + + + + + +NCEPLIBS-w3emc: orders.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    orders.f File Reference
    +
    +
    + +

    A Fast and stable sort routine suitable for efficient, multiple-pass sorting on variable length characters, integers, or real numbers. +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + + + +

    +Functions/Subroutines

    +subroutine ordec4 (IN, ISORT, IDATA, INDEX, N, M, I1, I2)
     
    +subroutine ordec8 (IN, ISORT, IDATA, INDEX, N, M, I1, I2)
     
    +subroutine order4 (IN, ISORT, IDATA, INDEX, N, M, I1, I2)
     
    subroutine orders (IN, ISORT, IDATA, INDEX, N, M, I1, I2)
     Orders is a fast and stable sort routine suitable for efficient, multiple-pass sorting on variable length characters, integers, or real numbers. More...
     
    +

    Detailed Description

    +

    A Fast and stable sort routine suitable for efficient, multiple-pass sorting on variable length characters, integers, or real numbers.

    +
    Author
    Jack Woollen
    +
    Date
    1999-06-03
    + +

    Definition in file orders.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ orders()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine orders ( IN,
    dimension(n) ISORT,
    integer(8), dimension(m,n) IDATA,
    dimension(n) INDEX,
     N,
     M,
     I1,
     I2 
    )
    +
    + +

    Orders is a fast and stable sort routine suitable for efficient, multiple-pass sorting on variable length characters, integers, or real numbers.

    +

    The algorithm derives from the radix or bucket sort procedure. The form of the orders subroutine is defined by a cray man page. The sort works by computing frequency distribution of the set of sort keys and using that as a map of the reordered data. Orders rearranges indexes instead of the sort keys, which simplifies multi-pass record sorting. The radix of the sort determines how many "buckets" there are in the frequency distribution array. The larger the radix the more buckets. The simplest is a one bit radix, which has two buckets, and requires as many passes through the keys as the keys have bits. A one byte radix requires less passes through the data with more buckets (256 to be exact). The one byte radix is implemented here. An additional complication is the fact that radix sort only works on key sets of positive values, so this implementation includes a biasing of the (numeric) keys before sorting. To save space the keys themselves are adjusted and then readjusted before returning. A simple example of a one bit radix sort on a list of four, four bit, numbers is diagramed below to illustrate the concept.

    +
    +-----------------------------------------------------------------------
+                 PASS1  >  PASS2  >  PASS3  >  PASS4  >   FINISHED
+-----------------------------------------------------------------------
+                     |        |        |        |
+    THE LIST      0011      0100      0100      1001      0011
+                  0101      0011      0101      0011      0100
+                  1001      0101      1001      0100      0101
+                  0100      1001      0011      0101      1001
+-----------------------------------------------------------------------
+    BUCKET 0      0100      0100      1001      0011
+                     |      0101      0011      0100
+                     |      1001       |        0101
+-----------------------------------------------------------------------
+    BUCKET 1      0011      0011      0100      1001
+                  0101        |       0101      |
+                  1001        |        |        |
+-----------------------------------------------------------------------
+

    PROGRAM HISTORY LOG:

      +
    • Jack Woollen 1998-02-21 Original version for implementation
      • +
    • Boi Vuong 1998-04-11 Replaced operand .and. with intrinsic iand
      • +
    • D. Keyser 1999-06-03 Modified to port to ibm sp and run in 4 or 8 Byte storage
      • +
    • Jack Woollen 1999-06-09 Added potential for four or eight byte keys in either a four or eight byte environment
      • +
    • Jack Woollen 2012-09-16 Made sorting characters work on little endian
      • +
    +

    INPUT ARGUMENTS:

    Parameters
    + + + + + + + + + +
    [in]INIndicator of key form and index state.
      +
    • IN = 0 Initialize indexes and sort characters.
      • +
    • IN = 1 Initialize indexes and sort integers.
      • +
    • IN = 2 Initialize indexes and sort real numbers.
      • +
    • IN = 10 Sort characters with indexes as is.
      • +
    • IN = 11 Sort integers with indexes as is.
      • +
    • IN = 12 Sort real numbers with indexes asis.
      • +
    +
    [in]ISORTWork array with the same dimension as idata.
    [in]IDATAArray of sort keys as described by in.
    [out]INDEXArray of indexes representing the sorted idata.
    [in]NDimension of isort, idata, and index.
    [in]MOffset (in key-words) between successive members of idata.
    [in]I1Byte length of the key-words.
    [in]I2Not used; Included for compatability with original cray routine.
    +
    +
    +
    Note
    The one byte radix method was selected for orders because it offers a good ratio of memory requirement to operation count for producing a sort. Because of recursive manipulation of indexes in one of the loops, this may actually take slightly longer on some vector machines than a (more work intensive) one bit radix method. In general, though, the one byte method is faster. Any larger radix presents exponentially increasing memory required. Note that the implementation uses very little local data space, and only modest user-supplied memory.
    +
    Author
    Jack Woollen
    +
    Date
    1999-06-03
    + +

    Definition at line 86 of file orders.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/orders_8f.js b/ver-2.10.0/orders_8f.js new file mode 100644 index 00000000..a3ff35b1 --- /dev/null +++ b/ver-2.10.0/orders_8f.js @@ -0,0 +1,7 @@ +var orders_8f = +[ + [ "ordec4", "orders_8f.html#a0d08639e724c57aca8fba5548dac6670", null ], + [ "ordec8", "orders_8f.html#a67b0efbe9479a73fe938f47f80520c50", null ], + [ "order4", "orders_8f.html#a384818081314939dbda21524cf8efc95", null ], + [ "orders", "orders_8f.html#a311c2453b613d259dc8e998f6d6aa944", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/orders_8f_source.html b/ver-2.10.0/orders_8f_source.html new file mode 100644 index 00000000..8af9aae5 --- /dev/null +++ b/ver-2.10.0/orders_8f_source.html @@ -0,0 +1,487 @@ + + + + + + + +NCEPLIBS-w3emc: orders.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    orders.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief A Fast and stable sort routine suitable for efficient,
    +
    3 C> multiple-pass sorting on variable length characters, integers, or
    +
    4 C> real numbers.
    +
    5 C> @author Jack Woollen @date 1999-06-03
    +
    6 
    +
    7 C> Orders is a fast and stable sort routine suitable for efficient,
    +
    8 C> multiple-pass sorting on variable length characters, integers, or
    +
    9 C> real numbers. The algorithm derives from the radix or bucket sort
    +
    10 C> procedure. The form of the orders subroutine is defined by a cray
    +
    11 C> man page. The sort works by computing frequency distribution of the
    +
    12 C> set of sort keys and using that as a map of the reordered data.
    +
    13 C> Orders rearranges indexes instead of the sort keys, which simplifies
    +
    14 C> multi-pass record sorting. The radix of the sort determines how many
    +
    15 C> "buckets" there are in the frequency distribution array. The larger
    +
    16 C> the radix the more buckets. The simplest is a one bit radix, which
    +
    17 C> has two buckets, and requires as many passes through the keys as
    +
    18 C> the keys have bits. A one byte radix requires less passes through
    +
    19 C> the data with more buckets (256 to be exact). The one byte radix
    +
    20 C> is implemented here. An additional complication is the fact that
    +
    21 C> radix sort only works on key sets of positive values, so this
    +
    22 C> implementation includes a biasing of the (numeric) keys before
    +
    23 C> sorting. To save space the keys themselves are adjusted and then
    +
    24 C> readjusted before returning. A simple example of a one bit radix
    +
    25 C> sort on a list of four, four bit, numbers is diagramed below to
    +
    26 C> illustrate the concept.
    +
    27 C>
    +
    28 C> <pre>
    +
    29 C>-----------------------------------------------------------------------
    +
    30 C> PASS1 > PASS2 > PASS3 > PASS4 > FINISHED
    +
    31 C>-----------------------------------------------------------------------
    +
    32 C> | | | |
    +
    33 C> THE LIST 0011 0100 0100 1001 0011
    +
    34 C> 0101 0011 0101 0011 0100
    +
    35 C> 1001 0101 1001 0100 0101
    +
    36 C> 0100 1001 0011 0101 1001
    +
    37 C>-----------------------------------------------------------------------
    +
    38 C> BUCKET 0 0100 0100 1001 0011
    +
    39 C> | 0101 0011 0100
    +
    40 C> | 1001 | 0101
    +
    41 C>-----------------------------------------------------------------------
    +
    42 C> BUCKET 1 0011 0011 0100 1001
    +
    43 C> 0101 | 0101 |
    +
    44 C> 1001 | | |
    +
    45 C>-----------------------------------------------------------------------
    +
    46 C> </pre>
    +
    47 C>
    +
    48 C> PROGRAM HISTORY LOG:
    +
    49 C> - Jack Woollen 1998-02-21 Original version for implementation
    +
    50 C> - Boi Vuong 1998-04-11 Replaced operand .and. with intrinsic iand
    +
    51 C> - D. Keyser 1999-06-03 Modified to port to ibm sp and run in 4 or
    +
    52 C> 8 Byte storage
    +
    53 C> - Jack Woollen 1999-06-09 Added potential for four or eight byte keys
    +
    54 C> in either a four or eight byte environment
    +
    55 C> - Jack Woollen 2012-09-16 Made sorting characters work on little endian
    +
    56 C>
    +
    57 C> INPUT ARGUMENTS:
    +
    58 C> @param[in] IN Indicator of key form and index state.
    +
    59 C> - IN = 0 Initialize indexes and sort characters.
    +
    60 C> - IN = 1 Initialize indexes and sort integers.
    +
    61 C> - IN = 2 Initialize indexes and sort real numbers.
    +
    62 C> - IN = 10 Sort characters with indexes as is.
    +
    63 C> - IN = 11 Sort integers with indexes as is.
    +
    64 C> - IN = 12 Sort real numbers with indexes asis.
    +
    65 C> @param[in] ISORT Work array with the same dimension as idata.
    +
    66 C> @param[in] IDATA Array of sort keys as described by in.
    +
    67 C> @param[out] INDEX Array of indexes representing the sorted idata.
    +
    68 C> @param[in] N Dimension of isort, idata, and index.
    +
    69 C> @param[in] M Offset (in key-words) between successive members of idata.
    +
    70 C> @param[in] I1 Byte length of the key-words.
    +
    71 C> @param[in] I2 Not used; Included for compatability with original cray
    +
    72 C> routine.
    +
    73 C>
    +
    74 C> @note The one byte radix method was selected for orders because it
    +
    75 C> offers a good ratio of memory requirement to operation count
    +
    76 C> for producing a sort. Because of recursive manipulation of indexes
    +
    77 C> in one of the loops, this may actually take slightly longer on some
    +
    78 C> vector machines than a (more work intensive) one bit radix method.
    +
    79 C> In general, though, the one byte method is faster. Any larger radix
    +
    80 C> presents exponentially increasing memory required. Note that the
    +
    81 C> implementation uses very little local data space, and only modest
    +
    82 C> user-supplied memory.
    +
    83 C>
    +
    84 C> @author Jack Woollen @date 1999-06-03
    +
    85  SUBROUTINE orders(IN,ISORT,IDATA,INDEX,N,M,I1,I2)
    +
    86 
    +
    87  dimension isort(n),index(n)
    +
    88  INTEGER(8) IDATA(M,N),ICHEK,IBYT
    +
    89  REAL(8) SMAL,RCHEK
    +
    90  dimension indx(0:255),kndx(0:255)
    +
    91  equivalence(ichek,rchek)
    +
    92 
    +
    93 C-----------------------------------------------------------------------
    +
    94 C-----------------------------------------------------------------------
    +
    95 
    +
    96 C DISCERN THE VARIABLE TYPE OF THE INPUT ARRAY, AND MAYBE SET INDEXES
    +
    97 C -------------------------------------------------------------------
    +
    98 
    +
    99  itype = mod(in,10)
    +
    100  IF(in.LT.10) THEN
    +
    101  DO i=1,n
    +
    102  index(i) = i
    +
    103  ENDDO
    +
    104  ENDIF
    +
    105 
    +
    106 c call different branches for different types of keys
    +
    107 c ---------------------------------------------------
    +
    108 
    +
    109  IF(i1.EQ.4) THEN
    +
    110  if(itype==0) CALL ordec4(in,isort,idata,index,n,m,i1,i2)
    +
    111  if(itype/=0) CALL order4(in,isort,idata,index,n,m,i1,i2)
    +
    112  RETURN
    +
    113  ELSEIF(i1.EQ.8) then
    +
    114  IF(itype==0) CALL ordec8(in,isort,idata,index,n,m,i1,i2)
    +
    115  IF(itype==0) RETURN
    +
    116  ELSEIF(i1.NE.8) THEN
    +
    117  print*,'ORDERS argument i1 (keyword size) can be 4 or 8'
    +
    118  print*,'ORDERS argument i1 here=',i1
    +
    119  CALL errexit(99_4)
    +
    120  ENDIF
    +
    121 
    +
    122 C COMPUTE A POSITIVE BIAS FOR INTEGER OR REAL NUMBERS
    +
    123 C ---------------------------------------------------
    +
    124 
    +
    125  IF(itype.GT.0) THEN
    +
    126  smal = 1
    +
    127  DO i=1,n
    +
    128  ichek = idata(1,i)
    +
    129  IF(itype.EQ.1 .AND. ichek.LT.smal) smal = ichek
    +
    130  IF(itype.EQ.2 .AND. rchek.LT.smal) smal = rchek
    +
    131  ENDDO
    +
    132  smal = 1-smal
    +
    133  DO i=1,n
    +
    134  ichek = idata(1,i)
    +
    135  IF(itype.EQ.1) ichek = ichek+smal
    +
    136  IF(itype.EQ.2) rchek = rchek+smal
    +
    137  idata(1,i) = ichek
    +
    138  ENDDO
    +
    139  ENDIF
    +
    140 
    +
    141 C SORT THE INPUT SET W/1BYTE RADIX - REARRANGE SORT LIST INDEXES ONLY
    +
    142 C -------------------------------------------------------------------
    +
    143 
    +
    144  DO ibyt=0,i1-1
    +
    145 
    +
    146  kndx(0) = 1
    +
    147  DO i=0,255
    +
    148  indx(i) = 0
    +
    149  ENDDO
    +
    150 
    +
    151  DO i=1,n
    +
    152  jbyt = iand(ishft(idata(1,index(i)),-ibyt*8_8),255_8)
    +
    153  indx(jbyt) = indx(jbyt)+1
    +
    154  isort(i) = index(i)
    +
    155  ENDDO
    +
    156 
    +
    157  DO i=1,255
    +
    158  kndx(i) = kndx(i-1)+indx(i-1)
    +
    159  ENDDO
    +
    160 
    +
    161  DO i=1,n
    +
    162  jbyt = iand(ishft(idata(1,isort(i)),-ibyt*8_8),255_8)
    +
    163  index(kndx(jbyt)) = isort(i)
    +
    164  kndx(jbyt) = kndx(jbyt)+1
    +
    165  ENDDO
    +
    166 
    +
    167  ENDDO
    +
    168 
    +
    169 C UNBIAS THE INPUT ARRAY ON THE WAY OUT
    +
    170 C -------------------------------------
    +
    171 
    +
    172  IF(itype.GT.0) THEN
    +
    173  DO i=1,n
    +
    174  ichek = idata(1,i)
    +
    175  IF(itype.EQ.1) ichek = ichek-smal
    +
    176  IF(itype.EQ.2) rchek = rchek-smal
    +
    177  idata(1,i) = ichek
    +
    178  ENDDO
    +
    179  ENDIF
    +
    180 
    +
    181 C FINISHED!
    +
    182 C ---------
    +
    183 
    +
    184  RETURN
    +
    185  END
    +
    186 C-----------------------------------------------------------------------
    +
    187 C-----------------------------------------------------------------------
    +
    188  SUBROUTINE order4(IN,ISORT,IDATA,INDEX,N,M,I1,I2)
    +
    189 
    +
    190  dimension isort(n),index(n)
    +
    191  INTEGER(4) IDATA(M,N),ICHEK,IBYT
    +
    192  REAL(4) SMAL,RCHEK
    +
    193  dimension indx(0:255),kndx(0:255)
    +
    194  equivalence(ichek,rchek)
    +
    195 
    +
    196 C-----------------------------------------------------------------------
    +
    197 C-----------------------------------------------------------------------
    +
    198 
    +
    199 C DISCERN THE VARIABLE TYPE OF THE INPUT ARRAY, AND MAYBE SET INDEXES
    +
    200 C -------------------------------------------------------------------
    +
    201 
    +
    202  itype = mod(in,10)
    +
    203  IF(in.LT.10) THEN
    +
    204  DO i=1,n
    +
    205  index(i) = i
    +
    206  ENDDO
    +
    207  ENDIF
    +
    208 
    +
    209 C COMPUTE A POSITIVE BIAS FOR INTEGER OR REAL NUMBERS
    +
    210 C ---------------------------------------------------
    +
    211 
    +
    212  IF(itype.GT.0) THEN
    +
    213  smal = 1
    +
    214  DO i=1,n
    +
    215  ichek = idata(1,i)
    +
    216  IF(itype.EQ.1 .AND. ichek.LT.smal) smal = ichek
    +
    217  IF(itype.EQ.2 .AND. rchek.LT.smal) smal = rchek
    +
    218  ENDDO
    +
    219  smal = 1-smal
    +
    220  DO i=1,n
    +
    221  ichek = idata(1,i)
    +
    222  IF(itype.EQ.1) ichek = ichek+smal
    +
    223  IF(itype.EQ.2) rchek = rchek+smal
    +
    224  idata(1,i) = ichek
    +
    225  ENDDO
    +
    226  ENDIF
    +
    227 
    +
    228 C SORT THE INPUT SET W/1BYTE RADIX - REARRANGE SORT LIST INDEXES ONLY
    +
    229 C -------------------------------------------------------------------
    +
    230 
    +
    231  DO ibyt=0,i1-1
    +
    232 
    +
    233  kndx(0) = 1
    +
    234  DO i=0,255
    +
    235  indx(i) = 0
    +
    236  ENDDO
    +
    237 
    +
    238  DO i=1,n
    +
    239  jbyt = iand(ishft(idata(1,index(i)),-ibyt*8_4),255_4)
    +
    240  indx(jbyt) = indx(jbyt)+1
    +
    241  isort(i) = index(i)
    +
    242  ENDDO
    +
    243 
    +
    244  DO i=1,255
    +
    245  kndx(i) = kndx(i-1)+indx(i-1)
    +
    246  ENDDO
    +
    247 
    +
    248  DO i=1,n
    +
    249  jbyt = iand(ishft(idata(1,isort(i)),-ibyt*8_4),255_4)
    +
    250  index(kndx(jbyt)) = isort(i)
    +
    251  kndx(jbyt) = kndx(jbyt)+1
    +
    252  ENDDO
    +
    253 
    +
    254  ENDDO
    +
    255 
    +
    256 C UNBIAS THE INPUT ARRAY ON THE WAY OUT
    +
    257 C -------------------------------------
    +
    258 
    +
    259  IF(itype.GT.0) THEN
    +
    260  DO i=1,n
    +
    261  ichek = idata(1,i)
    +
    262  IF(itype.EQ.1) ichek = ichek-smal
    +
    263  IF(itype.EQ.2) rchek = rchek-smal
    +
    264  idata(1,i) = ichek
    +
    265  ENDDO
    +
    266  ENDIF
    +
    267 
    +
    268 C FINISHED!
    +
    269 C ---------
    +
    270 
    +
    271  RETURN
    +
    272  END
    +
    273 C-----------------------------------------------------------------------
    +
    274 C-----------------------------------------------------------------------
    +
    275  SUBROUTINE ordec8(IN,ISORT,IDATA,INDEX,N,M,I1,I2)
    +
    276 
    +
    277  dimension isort(n),index(n)
    +
    278  character(8) IDATA(M,N)
    +
    279  dimension indx(0:255),kndx(0:255)
    +
    280 
    +
    281 C-----------------------------------------------------------------------
    +
    282 C-----------------------------------------------------------------------
    +
    283 
    +
    284 C DISCERN THE VARIABLE TYPE OF THE INPUT ARRAY, AND MAYBE SET INDEXES
    +
    285 C -------------------------------------------------------------------
    +
    286 
    +
    287  itype = mod(in,10)
    +
    288  IF(in.LT.10) THEN
    +
    289  DO i=1,n
    +
    290  index(i) = i
    +
    291  ENDDO
    +
    292  ENDIF
    +
    293 
    +
    294 C SORT THE INPUT SET W/1BYTE RADIX - REARRANGE SORT LIST INDEXES ONLY
    +
    295 C -------------------------------------------------------------------
    +
    296 
    +
    297  DO ibyt=0,i1-1
    +
    298 
    +
    299  kndx(0) = 1
    +
    300  DO i=0,255
    +
    301  indx(i) = 0
    +
    302  ENDDO
    +
    303 
    +
    304  ii=i1-ibyt
    +
    305 
    +
    306  DO i=1,n
    +
    307  jbyt = ichar(idata(1,index(i))(ii:ii))
    +
    308  indx(jbyt) = indx(jbyt)+1
    +
    309  isort(i) = index(i)
    +
    310  ENDDO
    +
    311 
    +
    312  DO i=1,255
    +
    313  kndx(i) = kndx(i-1)+indx(i-1)
    +
    314  ENDDO
    +
    315 
    +
    316  DO i=1,n
    +
    317  jbyt = ichar(idata(1,isort(i))(ii:ii))
    +
    318  index(kndx(jbyt)) = isort(i)
    +
    319  kndx(jbyt) = kndx(jbyt)+1
    +
    320  ENDDO
    +
    321 
    +
    322  ENDDO
    +
    323 
    +
    324 C FINISHED!
    +
    325 C ---------
    +
    326 
    +
    327  RETURN
    +
    328  END
    +
    329 C-----------------------------------------------------------------------
    +
    330 C-----------------------------------------------------------------------
    +
    331  SUBROUTINE ordec4(IN,ISORT,IDATA,INDEX,N,M,I1,I2)
    +
    332 
    +
    333  dimension isort(n),index(n)
    +
    334  character(4) IDATA(M,N)
    +
    335  dimension indx(0:255),kndx(0:255)
    +
    336 
    +
    337 C-----------------------------------------------------------------------
    +
    338 C-----------------------------------------------------------------------
    +
    339 
    +
    340 C DISCERN THE VARIABLE TYPE OF THE INPUT ARRAY, AND MAYBE SET INDEXES
    +
    341 C -------------------------------------------------------------------
    +
    342 
    +
    343  itype = mod(in,10)
    +
    344  IF(in.LT.10) THEN
    +
    345  DO i=1,n
    +
    346  index(i) = i
    +
    347  ENDDO
    +
    348  ENDIF
    +
    349 
    +
    350 C SORT THE INPUT SET W/1BYTE RADIX - REARRANGE SORT LIST INDEXES ONLY
    +
    351 C -------------------------------------------------------------------
    +
    352 
    +
    353  DO ibyt=0,i1-1
    +
    354 
    +
    355  kndx(0) = 1
    +
    356  DO i=0,255
    +
    357  indx(i) = 0
    +
    358  ENDDO
    +
    359 
    +
    360  ii=i1-ibyt
    +
    361 
    +
    362  DO i=1,n
    +
    363  jbyt = ichar(idata(1,index(i))(ii:ii))
    +
    364  indx(jbyt) = indx(jbyt)+1
    +
    365  isort(i) = index(i)
    +
    366  ENDDO
    +
    367 
    +
    368  DO i=1,255
    +
    369  kndx(i) = kndx(i-1)+indx(i-1)
    +
    370  ENDDO
    +
    371 
    +
    372  DO i=1,n
    +
    373  jbyt = ichar(idata(1,isort(i))(ii:ii))
    +
    374  index(kndx(jbyt)) = isort(i)
    +
    375  kndx(jbyt) = kndx(jbyt)+1
    +
    376  ENDDO
    +
    377 
    +
    378  ENDDO
    +
    379 
    +
    380 C FINISHED!
    +
    381 C ---------
    +
    382 
    +
    383  RETURN
    +
    384  END
    +
    +
    +
    errexit
    subroutine errexit(IRET)
    Exit with a return code.
    Definition: errexit.f:20
    +
    orders
    subroutine orders(IN, ISORT, IDATA, INDEX, N, M, I1, I2)
    Orders is a fast and stable sort routine suitable for efficient, multiple-pass sorting on variable le...
    Definition: orders.f:86
    + + + + diff --git a/ver-2.10.0/pdsens_8f.html b/ver-2.10.0/pdsens_8f.html new file mode 100644 index 00000000..f3e494e6 --- /dev/null +++ b/ver-2.10.0/pdsens_8f.html @@ -0,0 +1,206 @@ + + + + + + + +NCEPLIBS-w3emc: pdsens.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    pdsens.f File Reference
    +
    +
    + +

    Packs grib pds extension 41- for ensemble. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine pdsens (KENS, KPROB, XPROB, KCLUST, KMEMBR, ILAST, MSGA)
     Packs brib pds extension starting on byte 41 for ensemble forecast products. More...
     
    +

    Detailed Description

    +

    Packs grib pds extension 41- for ensemble.

    +
    Author
    Zoltan Toth & Mark Iredell
    +
    Date
    1995-03-14
    + +

    Definition in file pdsens.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ pdsens()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine pdsens (integer, dimension(5) KENS,
    integer, dimension(2) KPROB,
    dimension(2) XPROB,
    integer, dimension(16) KCLUST,
    integer, dimension(80) KMEMBR,
     ILAST,
    character*1, dimension(100) MSGA 
    )
    +
    + +

    Packs brib pds extension starting on byte 41 for ensemble forecast products.

    +

    For format of pds extension, see nmc office note 38.

    +

    Program history log:

      +
    • Zoltan Toth and Mark Iredell 1995-03-14
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints.
      • +
    • Richard Wobus 1998-09-28 Corrected member entry, blank all unused fields.
      • +
    • Mark Iredell 2001-06-05 Apply linux port by Ebisuzaki.
      • +
    +
    Parameters
    + + + + + + + + +
    [in]KENS(5) Bytes 41-45 (general section, always present.)
    [in]KPROB(2) Bytes 46-47 (probability section, present only if needed).
    [in]XPROB(2) Bytes 48-51&52-55 (probability section, if needed.).
    [in]KCLUST(16) Bytes 61-76 (clustering section, if needed.).
    [in]KMEMBR(80) Bytes 77-86 (cluster membership section, if needed.).
    [in]ILASTLast byte to be packed (if greater or equal to first byte in any of four sections above, whole section is packed).
    [out]MSGA- Full pds section, including new ensemble extension.
    +
    +
    +
    Note
    Use pdseup() for unpacking pds ensemble extension. subprogram can be called from a multiprocessing environment.
    +
    Author
    Zoltan Toth & Mark Iredell
    +
    Date
    1995-03-14
    + +

    Definition at line 28 of file pdsens.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/pdsens_8f.js b/ver-2.10.0/pdsens_8f.js new file mode 100644 index 00000000..ca22b5da --- /dev/null +++ b/ver-2.10.0/pdsens_8f.js @@ -0,0 +1,4 @@ +var pdsens_8f = +[ + [ "pdsens", "pdsens_8f.html#ac0ab2fe3df3fc664f2c413214700206e", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/pdsens_8f_source.html b/ver-2.10.0/pdsens_8f_source.html new file mode 100644 index 00000000..43142831 --- /dev/null +++ b/ver-2.10.0/pdsens_8f_source.html @@ -0,0 +1,170 @@ + + + + + + + +NCEPLIBS-w3emc: pdsens.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    pdsens.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Packs grib pds extension 41- for ensemble.
    +
    3 C> @author Zoltan Toth & Mark Iredell @date 1995-03-14
    +
    4 
    +
    5 C> Packs brib pds extension starting on byte 41 for ensemble
    +
    6 c> forecast products. For format of pds extension, see nmc office note 38.
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - Zoltan Toth and Mark Iredell 1995-03-14
    +
    10 C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    11 C> - Richard Wobus 1998-09-28 Corrected member entry, blank all unused fields.
    +
    12 C> - Mark Iredell 2001-06-05 Apply linux port by Ebisuzaki.
    +
    13 C>
    +
    14 C> @param[in] KENS (5) Bytes 41-45 (general section, always present.)
    +
    15 C> @param[in] KPROB (2) Bytes 46-47 (probability section, present only if needed).
    +
    16 C> @param[in] XPROB (2) Bytes 48-51&52-55 (probability section, if needed.).
    +
    17 C> @param[in] KCLUST (16) Bytes 61-76 (clustering section, if needed.).
    +
    18 C> @param[in] KMEMBR (80) Bytes 77-86 (cluster membership section, if needed.).
    +
    19 C> @param[in] ILAST Last byte to be packed (if greater or equal to first byte
    +
    20 C> in any of four sections above, whole section is packed).
    +
    21 C> @param[out] MSGA - Full pds section, including new ensemble extension.
    +
    22 C>
    +
    23 C> @note Use pdseup() for unpacking pds ensemble extension.
    +
    24 c> subprogram can be called from a multiprocessing environment.
    +
    25 C>
    +
    26 C> @author Zoltan Toth & Mark Iredell @date 1995-03-14
    +
    27  SUBROUTINE pdsens(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA)
    +
    28  INTEGER KENS(5),KPROB(2),KCLUST(16),KMEMBR(80)
    +
    29  dimension xprob(2)
    +
    30  CHARACTER*1 MSGA(100)
    +
    31  IF(ilast.LT.41) THEN
    +
    32  GO TO 333
    +
    33  ENDIF
    +
    34 C PACKING IS DONE IN FOUR SECTIONS ENDING AT BYTE IL
    +
    35  IF(ilast.GE.41) il=45
    +
    36  IF(ilast.GE.46) il=55
    +
    37  IF(ilast.GE.61) il=76
    +
    38  IF(ilast.GE.77) il=86
    +
    39  do i=42,il
    +
    40  CALL sbytec(msga, 0, i*8, 8)
    +
    41  enddo
    +
    42 C CHANGING THE NUMBER OF BYTES (FIRST THREE BYTES IN PDS)
    +
    43  CALL sbytec(msga, il, 0,24)
    +
    44 C PACKING FIRST SECTION (GENERAL INTORMATION SECTION)
    +
    45  IF(il.GE.45) CALL sbytesc(msga,kens,40*8,8,0,5)
    +
    46 C PACKING 2ND SECTION (PROBABILITY SECTION)
    +
    47  IF(il.GE.55) THEN
    +
    48  CALL sbytesc(msga,kprob,45*8,8,0,2)
    +
    49  CALL w3fi01(lw)
    +
    50  CALL w3fi76(xprob(1),iexp,imant,8*lw)
    +
    51  CALL sbytec(msga,iexp,47*8,8)
    +
    52  CALL sbytec(msga,imant,48*8,24)
    +
    53  CALL w3fi76(xprob(2),iexp,imant,8*lw)
    +
    54  CALL sbytec(msga,iexp,51*8,8)
    +
    55  CALL sbytec(msga,imant,52*8,24)
    +
    56  ENDIF
    +
    57 C PACKING 3RD SECTION (CLUSTERING INFORMATION)
    +
    58  IF(il.GE.76) CALL sbytesc(msga,kclust,60*8,8,0,16)
    +
    59 C PACKING 4TH SECTION (CLUSTER MEMBERSHIP)
    +
    60  IF(il.GE.86) CALL sbytesc(msga,kmembr,76*8,1,0,80)
    +
    61 C
    +
    62  333 CONTINUE
    +
    63  RETURN
    +
    64  END
    +
    +
    +
    w3fi76
    subroutine w3fi76(PVAL, KEXP, KMANT, KBITS)
    Converts floating point number from machine representation to grib representation (ibm370 32 bit f....
    Definition: w3fi76.f:24
    +
    pdsens
    subroutine pdsens(KENS, KPROB, XPROB, KCLUST, KMEMBR, ILAST, MSGA)
    Packs brib pds extension starting on byte 41 for ensemble forecast products.
    Definition: pdsens.f:28
    +
    sbytesc
    subroutine sbytesc(OUT, IN, ISKIP, NBYTE, NSKIP, N)
    Store bytes - pack bits: Put arbitrary size values into a packed bit string, taking the low order bit...
    Definition: sbytesc.f:17
    +
    sbytec
    subroutine sbytec(OUT, IN, ISKIP, NBYTE)
    This is a wrapper for sbytesc()
    Definition: sbytec.f:14
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    + + + + diff --git a/ver-2.10.0/pdseup_8f.html b/ver-2.10.0/pdseup_8f.html new file mode 100644 index 00000000..60525a34 --- /dev/null +++ b/ver-2.10.0/pdseup_8f.html @@ -0,0 +1,206 @@ + + + + + + + +NCEPLIBS-w3emc: pdseup.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    pdseup.f File Reference
    +
    +
    + +

    Unpacks grib pds extension 41- for ensemble. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine pdseup (KENS, KPROB, XPROB, KCLUST, KMEMBR, ILAST, MSGA)
     Unpacks grib pds extension starting on byte 41 for ensemble forecast products. More...
     
    +

    Detailed Description

    +

    Unpacks grib pds extension 41- for ensemble.

    +
    Author
    Zoltan Toth and Mark Iredell
    +
    Date
    DATE: 1995-03-14
    + +

    Definition in file pdseup.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ pdseup()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine pdseup (integer, dimension(5) KENS,
    integer, dimension(2) KPROB,
    dimension(2) XPROB,
    integer, dimension(16) KCLUST,
    integer, dimension(80) KMEMBR,
     ILAST,
    character*1, dimension(100) MSGA 
    )
    +
    + +

    Unpacks grib pds extension starting on byte 41 for ensemble forecast products.

    +

    for format of pds extension, see nmc office note 38

    +

    Program history log:

      +
    • Zoltan Toth and Mark Iredell 1995-03-14
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints.
      • +
    • Richard Wobus 1998-09-28 Corrected member extraction.
      • +
    • Mark Iredell 2001-06-05 Apply linux port by ebisuzaki.
      • +
    +
    Parameters
    + + + + + + + + +
    [out]KENS(5) Bytes 41-45 (general section, always present.).
    [out]KPROB(2) Bytes 46-47 (probability section, present only if neede.
    [out]XPROB(2) Bytes 48-51&52-55 (probability section, if needed.).
    [out]KCLUST(16) Bytes 61-76 (clustering section, if needed.).
    [out]KMEMBR(80) Bytes 77-86 (cluster membership section, if needed.).
    [in]ILASTLast byte to be unpacked (if greater/equal to first byte in any of four sections below, whole section is packed).
    [in]MSGAFull pds section, including new ensemble extension.
    +
    +
    +
    Note
    Use pdsens() for packing pds ensemble extension. Subprogram can be called from a multiprocessing environment.
    +
    Author
    Zoltan Toth and Mark Iredell
    +
    Date
    DATE: 1995-03-14
    + +

    Definition at line 28 of file pdseup.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/pdseup_8f.js b/ver-2.10.0/pdseup_8f.js new file mode 100644 index 00000000..235b2543 --- /dev/null +++ b/ver-2.10.0/pdseup_8f.js @@ -0,0 +1,4 @@ +var pdseup_8f = +[ + [ "pdseup", "pdseup_8f.html#a62cf775ad87c64a28b7e395792eabfca", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/pdseup_8f_source.html b/ver-2.10.0/pdseup_8f_source.html new file mode 100644 index 00000000..137bbad6 --- /dev/null +++ b/ver-2.10.0/pdseup_8f_source.html @@ -0,0 +1,168 @@ + + + + + + + +NCEPLIBS-w3emc: pdseup.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    pdseup.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Unpacks grib pds extension 41- for ensemble.
    +
    3 C> @author Zoltan Toth and Mark Iredell @date DATE: 1995-03-14
    +
    4 
    +
    5 C> Unpacks grib pds extension starting on byte 41 for ensemble
    +
    6 C> forecast products. for format of pds extension, see nmc office note 38
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - Zoltan Toth and Mark Iredell 1995-03-14
    +
    10 C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    11 C> - Richard Wobus 1998-09-28 Corrected member extraction.
    +
    12 C> - Mark Iredell 2001-06-05 Apply linux port by ebisuzaki.
    +
    13 C>
    +
    14 C> @param[out] KENS (5) Bytes 41-45 (general section, always present.).
    +
    15 C> @param[out] KPROB (2) Bytes 46-47 (probability section, present only if neede.
    +
    16 C> @param[out] XPROB (2) Bytes 48-51&52-55 (probability section, if needed.).
    +
    17 C> @param[out] KCLUST (16) Bytes 61-76 (clustering section, if needed.).
    +
    18 C> @param[out] KMEMBR (80) Bytes 77-86 (cluster membership section, if needed.).
    +
    19 C> @param[in] ILAST Last byte to be unpacked (if greater/equal to first byte
    +
    20 C> in any of four sections below, whole section is packed).
    +
    21 C> @param[in] MSGA Full pds section, including new ensemble extension.
    +
    22 C>
    +
    23 C> @note Use pdsens() for packing pds ensemble extension.
    +
    24 C> Subprogram can be called from a multiprocessing environment.
    +
    25 C>
    +
    26 C> @author Zoltan Toth and Mark Iredell @date DATE: 1995-03-14
    +
    27  SUBROUTINE pdseup(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA)
    +
    28  INTEGER KENS(5),KPROB(2),KCLUST(16),KMEMBR(80)
    +
    29  dimension xprob(2)
    +
    30  CHARACTER*1 MSGA(100)
    +
    31 C CHECKING TOTAL NUMBER OF BYTES IN PDS (IBYTES)
    +
    32  CALL gbytec(msga, ibytes, 0,24)
    +
    33  IF(ilast.GT.ibytes) THEN
    +
    34 C ILAST=IBYTES
    +
    35  GO TO 333
    +
    36  ENDIF
    +
    37  IF(ilast.LT.41) THEN
    +
    38  GO TO 333
    +
    39  ENDIF
    +
    40 C UNPACKING FIRST SECTION (GENERAL INFORMATION)
    +
    41  CALL gbytesc(msga,kens,40*8,8,0,5)
    +
    42 C UNPACKING 2ND SECTION (PROBABILITY SECTION)
    +
    43  IF(ilast.GE.46) THEN
    +
    44  CALL gbytesc(msga,kprob,45*8,8,0,2)
    +
    45 C
    +
    46  CALL gbytec (msga,jsgn,47*8,1)
    +
    47  CALL gbytec (msga,jexp,47*8+1,7)
    +
    48  CALL gbytec (msga,ifr,47*8+8,24)
    +
    49  xprob(1)=(-1)**jsgn*ifr*16.**(jexp-70)
    +
    50 C
    +
    51  CALL gbytec (msga,jsgn,51*8,1)
    +
    52  CALL gbytec (msga,jexp,51*8+1,7)
    +
    53  CALL gbytec (msga,ifr,51*8+8,24)
    +
    54  xprob(2)=(-1)**jsgn*ifr*16.**(jexp-70)
    +
    55  ENDIF
    +
    56 C
    +
    57 C UNPACKING 3RD SECTION (CLUSTERING INFORMATION)
    +
    58  IF(ilast.GE.61) CALL gbytesc(msga,kclust,60*8,8,0,16)
    +
    59 C UNPACKING 4TH SECTION (CLUSTERMEMBERSHIP INFORMATION)
    +
    60  IF(ilast.GE.77) CALL gbytesc(msga,kmembr,76*8,1,0,80)
    +
    61 C
    +
    62  333 CONTINUE
    +
    63  RETURN
    +
    64  END
    +
    +
    +
    gbytesc
    subroutine gbytesc(IN, IOUT, ISKIP, NBYTE, NSKIP, N)
    Extract arbitrary size values from a packed bit string, right justifying each value in the unpacked a...
    Definition: gbytesc.f:16
    +
    gbytec
    subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
    Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
    Definition: gbytec.f:14
    +
    pdseup
    subroutine pdseup(KENS, KPROB, XPROB, KCLUST, KMEMBR, ILAST, MSGA)
    Unpacks grib pds extension starting on byte 41 for ensemble forecast products.
    Definition: pdseup.f:28
    + + + + diff --git a/ver-2.10.0/putgb_8f.html b/ver-2.10.0/putgb_8f.html new file mode 100644 index 00000000..78dbcbd0 --- /dev/null +++ b/ver-2.10.0/putgb_8f.html @@ -0,0 +1,329 @@ + + + + + + + +NCEPLIBS-w3emc: putgb.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    putgb.f File Reference
    +
    +
    + +

    Packs and writes a grib message. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine putgb (LUGB, KF, KPDS, KGDS, LB, F, IRET)
     This subprogram is nearly the inverse of getgb. More...
     
    +

    Detailed Description

    +

    Packs and writes a grib message.

    +
    Author
    Mark Iredell
    +
    +1994-04-01
    + +

    Definition in file putgb.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ putgb()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine putgb ( LUGB,
     KF,
    integer, dimension(200) KPDS,
    integer, dimension(200) KGDS,
    logical*1, dimension(kf) LB,
    real, dimension(kf) F,
     IRET 
    )
    +
    + +

    This subprogram is nearly the inverse of getgb.

    +

    Program history log:

      +
    • Mark Iredell 1994-04-01
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints.
      • +
    • George Gayno 2009-10-15 Increased maxbit from 16 to 32.
      • +
    +
    Parameters
    + + + + + + + + +
    [in]LUGBInteger unit of the unblocked grib data file.
    [in]KFInteger number of data points.
    [in]KPDSInteger (200) pds parameters.
      +
    • 1: id of center.
      • +
    • 2: generating process id number.
      • +
    • 3: grid definition.
      • +
    • 4: gds/bms flag (right adj copy of octet 8).
      • +
    • 5: indicator of parameter.
      • +
    • 6: type of level.
      • +
    • 7: height/pressure , etc of level.
      • +
    • 8: year including (century-1).
      • +
    • 9: month of year.
      • +
    • 10: day of month.
      • +
    • 11: hour of day.
      • +
    • 12: minute of hour.
      • +
    • 13: indicator of forecast time unit.
      • +
    • 14: time range 1.
      • +
    • 15: time range 2.
      • +
    • 16: time range flag.
      • +
    • 17: number included in average.
      • +
    • 18: version nr of grib specification.
      • +
    • 19: version nr of parameter table.
      • +
    • 20: nr missing from average/accumulation.
      • +
    • 21: century of reference time of data.
      • +
    • 22: units decimal scale factor.
      • +
    • 23: subcenter number.
      • +
    • 24: pds byte 29, for nmc ensemble products.
        +
      • 128 if forecast field error.
        • +
      • 64 if bias corrected fcst field.
        • +
      • 32 if smoothed field.
        • +
      • warning: can be combination of more than 1.
        • +
      +
      • +
    • 25: pds byte 30, not used.
      • +
    +
    [in]kgdsInteger (200) gds parameters
      +
    • 1: data representation type.
      • +
    • 19: number of vertical coordinate parameters.
      • +
    • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
      • +
    • 21: for grids with pl, number of points in grid.
      • +
    • 22: number of words in each row.
      • +
    • Latitude/longitude grids.
        +
      • 2: n(i) nr points on latitude circle.
        • +
      • 3: n(j) nr points on longitude meridian.
        • +
      • 4: la(1) latitude of origin.
        • +
      • 5: lo(1) longitude of origin.
        • +
      • 6: resolution flag (right adj copy of octet 17).
        • +
      • 7: la(2) latitude of extreme point.
        • +
      • 8: lo(2) longitude of extreme point.
        • +
      • 9: di longitudinal direction of increment.
        • +
      • 10: dj latitudinal direction increment.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      +
      • +
    • Gaussian grids.
        +
      • 2: n(i) nr points on latitude circle.
        • +
      • 3: n(j) nr points on longitude meridian.
        • +
      • 4: la(1) latitude of origin.
        • +
      • 5: lo(1) longitude of origin.
        • +
      • 6: resolution flag (right adj copy of octet 17).
        • +
      • 7: la(2) latitude of extreme point.
        • +
      • 8: lo(2) longitude of extreme point.
        • +
      • 9: di longitudinal direction of increment.
        • +
      • 10: n - nr of circles pole to equator.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: nv - nr of vert coord parameters.
        • +
      • 13: pv - octet nr of list of vert coord parameters or pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present.
        • +
      +
      • +
    • Polar stereographic grids.
        +
      • 2: n(i) nr points along lat circle.
        • +
      • 3: n(j) nr points along lon circle.
        • +
      • 4: la(1) latitude of origin.
        • +
      • 5: lo(1) longitude of origin.
        • +
      • 6: resolution flag (right adj copy of octet 17).
        • +
      • 7: lov grid orientation.
        • +
      • 8: dx - x direction increment.
        • +
      • 9: dy - y direction increment.
        • +
      • 10: projection center flag.
        • +
      • 11: scanning mode (right adj copy of octet 28).
        • +
      +
      • +
    • Spherical harmonic coefficients.
        +
      • 2: j pentagonal resolution parameter.
        • +
      • 3: k pentagonal resolution parameter.
        • +
      • 4: m pentagonal resolution parameter.
        • +
      • 5: representation type.
        • +
      • 6: coefficient storage mode.
        • +
      +
      • +
    • Mercator grids.
        +
      • 2: n(i) nr points on latitude circle.
        • +
      • 3: n(j) nr points on longitude meridian.
        • +
      • 4: la(1) latitude of origin.
        • +
      • 5: lo(1) longitude of origin.
        • +
      • 6: resolution flag (right adj copy of octet 17).
        • +
      • 7: la(2) latitude of last grid point.
        • +
      • 8: lo(2) longitude of last grid point.
        • +
      • 9: latit - latitude of projection intersection.
        • +
      • 10: reserved.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: longitudinal dir grid length.
        • +
      • 13: latitudinal dir grid length.
        • +
      +
      • +
    • Lambert conformal grids.
        +
      • 2: nx nr points along x-axis.
        • +
      • 3: ny nr points along y-axis.
        • +
      • 4: la1 lat of origin (lower left).
        • +
      • 5: lo1 lon of origin (lower left).
        • +
      • 6: resolution (right adj copy of octet 17).
        • +
      • 7: lov - orientation of grid.
        • +
      • 8: dx - x-dir increment.
        • +
      • 9: dy - y-dir increment.
        • +
      • 10: projection center flag.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: latin 1 - first lat from pole of secant cone inter.
        • +
      • 13: latin 2 - second lat from pole of secant cone inter.
        • +
      +
      • +
    +
    [in]lblogical*1 (kf) bitmap if present
    [in]freal (kf) data
    [out]iretinteger return code.
      +
    • 0 all ok.
      • +
    • other w3fi72 grib packer return code.
      • +
    +
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
    +
    Author
    Mark Iredell
    +
    +1994-04-01
    + +

    Definition at line 135 of file putgb.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/putgb_8f.js b/ver-2.10.0/putgb_8f.js new file mode 100644 index 00000000..df38426d --- /dev/null +++ b/ver-2.10.0/putgb_8f.js @@ -0,0 +1,4 @@ +var putgb_8f = +[ + [ "putgb", "putgb_8f.html#aa61b5b2b00eb09531ef126983ad1d724", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/putgb_8f_source.html b/ver-2.10.0/putgb_8f_source.html new file mode 100644 index 00000000..96abc4d3 --- /dev/null +++ b/ver-2.10.0/putgb_8f_source.html @@ -0,0 +1,284 @@ + + + + + + + +NCEPLIBS-w3emc: putgb.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    putgb.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Packs and writes a grib message.
    +
    3 C> @author Mark Iredell @author 1994-04-01
    +
    4 
    +
    5 C> This subprogram is nearly the inverse of getgb.
    +
    6 C>
    +
    7 C> Program history log:
    +
    8 C> - Mark Iredell 1994-04-01
    +
    9 C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    10 C> - George Gayno 2009-10-15 Increased maxbit from 16 to 32.
    +
    11 C>
    +
    12 C> @param[in] LUGB Integer unit of the unblocked grib data file.
    +
    13 C> @param[in] KF Integer number of data points.
    +
    14 C> @param[in] KPDS Integer (200) pds parameters.
    +
    15 C> - 1: id of center.
    +
    16 C> - 2: generating process id number.
    +
    17 C> - 3: grid definition.
    +
    18 C> - 4: gds/bms flag (right adj copy of octet 8).
    +
    19 C> - 5: indicator of parameter.
    +
    20 C> - 6: type of level.
    +
    21 C> - 7: height/pressure , etc of level.
    +
    22 C> - 8: year including (century-1).
    +
    23 C> - 9: month of year.
    +
    24 C> - 10: day of month.
    +
    25 C> - 11: hour of day.
    +
    26 C> - 12: minute of hour.
    +
    27 C> - 13: indicator of forecast time unit.
    +
    28 C> - 14: time range 1.
    +
    29 C> - 15: time range 2.
    +
    30 C> - 16: time range flag.
    +
    31 C> - 17: number included in average.
    +
    32 C> - 18: version nr of grib specification.
    +
    33 C> - 19: version nr of parameter table.
    +
    34 C> - 20: nr missing from average/accumulation.
    +
    35 C> - 21: century of reference time of data.
    +
    36 C> - 22: units decimal scale factor.
    +
    37 C> - 23: subcenter number.
    +
    38 C> - 24: pds byte 29, for nmc ensemble products.
    +
    39 C> - 128 if forecast field error.
    +
    40 C> - 64 if bias corrected fcst field.
    +
    41 C> - 32 if smoothed field.
    +
    42 C> - warning: can be combination of more than 1.
    +
    43 C> - 25: pds byte 30, not used.
    +
    44 C> @param[in] kgds Integer (200) gds parameters
    +
    45 C> - 1: data representation type.
    +
    46 C> - 19: number of vertical coordinate parameters.
    +
    47 C> - 20: octet number of the list of vertical coordinate parameters or
    +
    48 C> octet number of the list of numbers of points in each row or
    +
    49 C> 255 if neither are present.
    +
    50 C> - 21: for grids with pl, number of points in grid.
    +
    51 C> - 22: number of words in each row.
    +
    52 C>
    +
    53 C> - Latitude/longitude grids.
    +
    54 C> - 2: n(i) nr points on latitude circle.
    +
    55 C> - 3: n(j) nr points on longitude meridian.
    +
    56 C> - 4: la(1) latitude of origin.
    +
    57 C> - 5: lo(1) longitude of origin.
    +
    58 C> - 6: resolution flag (right adj copy of octet 17).
    +
    59 C> - 7: la(2) latitude of extreme point.
    +
    60 C> - 8: lo(2) longitude of extreme point.
    +
    61 C> - 9: di longitudinal direction of increment.
    +
    62 C> - 10: dj latitudinal direction increment.
    +
    63 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    64 C> - Gaussian grids.
    +
    65 C> - 2: n(i) nr points on latitude circle.
    +
    66 C> - 3: n(j) nr points on longitude meridian.
    +
    67 C> - 4: la(1) latitude of origin.
    +
    68 C> - 5: lo(1) longitude of origin.
    +
    69 C> - 6: resolution flag (right adj copy of octet 17).
    +
    70 C> - 7: la(2) latitude of extreme point.
    +
    71 C> - 8: lo(2) longitude of extreme point.
    +
    72 C> - 9: di longitudinal direction of increment.
    +
    73 C> - 10: n - nr of circles pole to equator.
    +
    74 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    75 C> - 12: nv - nr of vert coord parameters.
    +
    76 C> - 13: pv - octet nr of list of vert coord parameters or
    +
    77 C> pl - location of the list of numbers of points in each row
    +
    78 C> (if no vert coord parameters are present) or 255 if neither are present.
    +
    79 C> - Polar stereographic grids.
    +
    80 C> - 2: n(i) nr points along lat circle.
    +
    81 C> - 3: n(j) nr points along lon circle.
    +
    82 C> - 4: la(1) latitude of origin.
    +
    83 C> - 5: lo(1) longitude of origin.
    +
    84 C> - 6: resolution flag (right adj copy of octet 17).
    +
    85 C> - 7: lov grid orientation.
    +
    86 C> - 8: dx - x direction increment.
    +
    87 C> - 9: dy - y direction increment.
    +
    88 C> - 10: projection center flag.
    +
    89 C> - 11: scanning mode (right adj copy of octet 28).
    +
    90 C> - Spherical harmonic coefficients.
    +
    91 C> - 2: j pentagonal resolution parameter.
    +
    92 C> - 3: k pentagonal resolution parameter.
    +
    93 C> - 4: m pentagonal resolution parameter.
    +
    94 C> - 5: representation type.
    +
    95 C> - 6: coefficient storage mode.
    +
    96 C> - Mercator grids.
    +
    97 C> - 2: n(i) nr points on latitude circle.
    +
    98 C> - 3: n(j) nr points on longitude meridian.
    +
    99 C> - 4: la(1) latitude of origin.
    +
    100 C> - 5: lo(1) longitude of origin.
    +
    101 C> - 6: resolution flag (right adj copy of octet 17).
    +
    102 C> - 7: la(2) latitude of last grid point.
    +
    103 C> - 8: lo(2) longitude of last grid point.
    +
    104 C> - 9: latit - latitude of projection intersection.
    +
    105 C> - 10: reserved.
    +
    106 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    107 C> - 12: longitudinal dir grid length.
    +
    108 C> - 13: latitudinal dir grid length.
    +
    109 C> - Lambert conformal grids.
    +
    110 C> - 2: nx nr points along x-axis.
    +
    111 C> - 3: ny nr points along y-axis.
    +
    112 C> - 4: la1 lat of origin (lower left).
    +
    113 C> - 5: lo1 lon of origin (lower left).
    +
    114 C> - 6: resolution (right adj copy of octet 17).
    +
    115 C> - 7: lov - orientation of grid.
    +
    116 C> - 8: dx - x-dir increment.
    +
    117 C> - 9: dy - y-dir increment.
    +
    118 C> - 10: projection center flag.
    +
    119 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    120 C> - 12: latin 1 - first lat from pole of secant cone inter.
    +
    121 C> - 13: latin 2 - second lat from pole of secant cone inter.
    +
    122 C>
    +
    123 C> @param[in] lb logical*1 (kf) bitmap if present
    +
    124 C> @param[in] f real (kf) data
    +
    125 C> @param[out] iret integer return code.
    +
    126 C> - 0 all ok.
    +
    127 C> - other w3fi72 grib packer return code.
    +
    128 C>
    +
    129 C> @note Subprogram can be called from a multiprocessing environment.
    +
    130 C> Do not engage the same logical unit from more than one processor.
    +
    131 C>
    +
    132 C> @author Mark Iredell @author 1994-04-01
    +
    133 C-----------------------------------------------------------------------
    +
    134  SUBROUTINE putgb(LUGB,KF,KPDS,KGDS,LB,F,IRET)
    +
    135  INTEGER KPDS(200),KGDS(200)
    +
    136  LOGICAL*1 LB(KF)
    +
    137  REAL F(KF)
    +
    138  parameter(maxbit=32)
    +
    139  INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200)
    +
    140  REAL FR(KF)
    +
    141  CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8)
    +
    142 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    143 C GET W3FI72 PARAMETERS
    +
    144  CALL r63w72(kpds,kgds,ipds,igds)
    +
    145  ibds=0
    +
    146 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    147 C COUNT VALID DATA
    +
    148  kbm=kf
    +
    149  IF(ipds(7).NE.0) THEN
    +
    150  kbm=0
    +
    151  DO i=1,kf
    +
    152  IF(lb(i)) THEN
    +
    153  ibm(i)=1
    +
    154  kbm=kbm+1
    +
    155  ELSE
    +
    156  ibm(i)=0
    +
    157  ENDIF
    +
    158  ENDDO
    +
    159  IF(kbm.EQ.kf) ipds(7)=0
    +
    160  ENDIF
    +
    161 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    162 C GET NUMBER OF BITS AND ROUND DATA
    +
    163  IF(kbm.EQ.0) THEN
    +
    164  DO i=1,kf
    +
    165  fr(i)=0.
    +
    166  ENDDO
    +
    167  nbit=0
    +
    168  ELSE
    +
    169  CALL getbit(ipds(7),0,ipds(25),kf,ibm,f,fr,fmin,fmax,nbit)
    +
    170  nbit=min(nbit,maxbit)
    +
    171  ENDIF
    +
    172 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    173 C PACK AND WRITE GRIB DATA
    +
    174  CALL w3fi72(0,fr,0,nbit,0,ipds,pds,
    +
    175  & 1,255,igds,0,0,ibm,kf,ibds,
    +
    176  & kfo,grib,lgrib,iret)
    +
    177  IF(iret.EQ.0) CALL wryte(lugb,lgrib,grib)
    +
    178 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    179  RETURN
    +
    180  END
    +
    +
    +
    putgb
    subroutine putgb(LUGB, KF, KPDS, KGDS, LB, F, IRET)
    This subprogram is nearly the inverse of getgb.
    Definition: putgb.f:135
    +
    r63w72
    subroutine r63w72(KPDS, KGDS, IPDS, IGDS)
    Determines the integer PDS and GDS parameters for the GRIB1 packing routine w3fi72() given the parame...
    Definition: r63w72.f:27
    +
    w3fi72
    subroutine w3fi72(ITYPE, FLD, IFLD, IBITL, IPFLAG, ID, PDS, IGFLAG, IGRID, IGDS, ICOMP, IBFLAG, IBMAP, IBLEN, IBDSFL, NPTS, KBUF, ITOT, JERR)
    Makes a complete GRIB message from a user supplied array of floating point or integer data.
    Definition: w3fi72.f:121
    + + + + diff --git a/ver-2.10.0/putgbe_8f.html b/ver-2.10.0/putgbe_8f.html new file mode 100644 index 00000000..d119896a --- /dev/null +++ b/ver-2.10.0/putgbe_8f.html @@ -0,0 +1,341 @@ + + + + + + + +NCEPLIBS-w3emc: putgbe.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    putgbe.f File Reference
    +
    +
    + +

    Packs and writes a grib message. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine putgbe (LUGB, KF, KPDS, KGDS, KENS, LB, F, IRET)
     THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE. More...
     
    +

    Detailed Description

    +

    Packs and writes a grib message.

    +
    Author
    Mark Iredell
    +
    Date
    1994-04-01
    + +

    Definition in file putgbe.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ putgbe()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine putgbe ( LUGB,
     KF,
    integer, dimension(200) KPDS,
    integer, dimension(200) KGDS,
    integer, dimension(200) KENS,
    logical*1, dimension(kf) LB,
    real, dimension(kf) F,
     IRET 
    )
    +
    + +

    THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE.

    +

    Program history log:

      +
    • Mark Iredell 1994-04-01
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints.
      • +
    +
    Parameters
    + + + + + + + + + +
    [in]lugbInteger unit of the unblocked grib data file.
    [in]kfInteger number of data points.
    [in]kpdsInteger (200) pds parameters.
      +
    • 1: id of center.
      • +
    • 2: generating process id number.
      • +
    • 3: grid definition.
      • +
    • 4: gds/bms flag (right adj copy of octet 8).
      • +
    • 5: indicator of parameter.
      • +
    • 6: type of level.
      • +
    • 7: height/pressure , etc of level.
      • +
    • 8: year including (century-1).
      • +
    • 9: month of year.
      • +
    • 10: day of month.
      • +
    • 11: hour of day.
      • +
    • 12: minute of hour.
      • +
    • 13: indicator of forecast time unit.
      • +
    • 14: time range 1.
      • +
    • 15: time range 2.
      • +
    • 16: time range flag.
      • +
    • 17: number included in average.
      • +
    • 18: version nr of grib specification.
      • +
    • 19: version nr of parameter table.
      • +
    • 20: nr missing from average/accumulation.
      • +
    • 21: century of reference time of data.
      • +
    • 22: units decimal scale factor.
      • +
    • 23: subcenter number.
      • +
    • 24: pds byte.
        +
      • 29 for nmc ensemble products.
        • +
      • 28 if forecast field error.
        • +
      • 64 if bias corrected fcst field.
        • +
      • 32 if smoothed field.
        • +
      • warning: can be combination of more than 1.
        • +
      +
      • +
    • 25: pds byte 30, not used.
      • +
    +
    [in]kgdsinteger (200) gds parameters.
      +
    • 1): data representation type.
      • +
    • 19: number of vertical coordinate parameters.
      • +
    • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
      • +
    • 21: for grids with pl, number of points in grid.
      • +
    • 22: number of words in each row.
      • +
    • Latitude/longitude grids.
        +
      • 2: n(i) nr points on latitude circle.
        • +
      • 3: n(j) nr points on longitude meridian.
        • +
      • 4: la(1) latitude of origin.
        • +
      • 5: lo(1) longitude of origin.
        • +
      • 6: resolution flag (right adj copy of octet 17).
        • +
      • 7: la(2) latitude of extreme point.
        • +
      • 8: lo(2) longitude of extreme point.
        • +
      • 9: di longitudinal direction of increment.
        • +
      • 10: dj latitudinal direction increment.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      +
      • +
    • Gaussian grids.
        +
      • 2: n(i) nr points on latitude circle.
        • +
      • 3: n(j) nr points on longitude meridian.
        • +
      • 4: la(1) latitude of origin.
        • +
      • 5: lo(1) longitude of origin.
        • +
      • 6: resolution flag (right adj copy of octet 17).
        • +
      • 7: la(2) latitude of extreme point.
        • +
      • 8: lo(2) longitude of extreme point.
        • +
      • 9: di longitudinal direction of increment.
        • +
      • 10: n - nr of circles pole to equator.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: nv - nr of vert coord parameters.
        • +
      • 13: pv - octet nr of list of vert coord parameters or pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present.
        • +
      +
      • +
    • Polar stereographic grids.
        +
      • 2: n(i) nr points along lat circle.
        • +
      • 3: n(j) nr points along lon circle.
        • +
      • 4: la(1) latitude of origin.
        • +
      • 5: lo(1) longitude of origin.
        • +
      • 6: resolution flag (right adj copy of octet 17).
        • +
      • 7: lov grid orientation.
        • +
      • 8: dx - x direction increment.
        • +
      • 9: dy - y direction increment.
        • +
      • 10: projection center flag.
        • +
      • 11: scanning mode (right adj copy of octet 28).
        • +
      +
      • +
    • Spherical harmonic coefficients.
        +
      • 2: j pentagonal resolution parameter.
        • +
      • 3: k pentagonal resolution parameter.
        • +
      • 4: m pentagonal resolution parameter.
        • +
      • 5: representation type.
        • +
      • 6: coefficient storage mode.
        • +
      +
      • +
    • Mercator grids.
        +
      • 2: n(i) nr points on latitude circle.
        • +
      • 3: n(j) nr points on longitude meridian.
        • +
      • 4: la(1) latitude of origin.
        • +
      • 5: lo(1) longitude of origin.
        • +
      • 6: resolution flag (right adj copy of octet 17).
        • +
      • 7: la(2) latitude of last grid point.
        • +
      • 8: lo(2) longitude of last grid point.
        • +
      • 9: latit - latitude of projection intersection.
        • +
      • 10: reserved.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: longitudinal dir grid length.
        • +
      • 13: latitudinal dir grid length.
        • +
      +
      • +
    • Lambert conformal grids.
        +
      • 2: nx nr points along x-axis.
        • +
      • 3: ny nr points along y-axis.
        • +
      • 4: la1 lat of origin (lower left).
        • +
      • 5: lo1 lon of origin (lower left).
        • +
      • 6: resolution (right adj copy of octet 17).
        • +
      • 7: lov - orientation of grid.
        • +
      • 8: dx - x-dir increment.
        • +
      • 9: dy - y-dir increment.
        • +
      • 10: projection center flag.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: latin 1 - first lat from pole of secant cone inter.
        • +
      • 13: latin 2 - second lat from pole of secant cone inter.
        • +
      +
      • +
    +
    [in]kensInteger (200) ensemble pds parms.
      +
    • 1: application identifier.
      • +
    • 2: ensemble type.
      • +
    • 3: ensemble identifier.
      • +
    • 4: product identifier.
      • +
    • 5: smoothing flag.
      • +
    +
    [in]lbLogical*1 (kf) bitmap if present.
    [in]fReal (kf) data.
    [out]iretInteger return code.
      +
    • 0 all ok.
      • +
    • other w3fi72 grib packer return code.
      • +
    +
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
    +
    Author
    Mark Iredell
    +
    Date
    1994-04-01
    + +

    Definition at line 140 of file putgbe.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/putgbe_8f.js b/ver-2.10.0/putgbe_8f.js new file mode 100644 index 00000000..0844682e --- /dev/null +++ b/ver-2.10.0/putgbe_8f.js @@ -0,0 +1,4 @@ +var putgbe_8f = +[ + [ "putgbe", "putgbe_8f.html#aff43ef1fa54eed421433340d5954fcfe", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/putgbe_8f_source.html b/ver-2.10.0/putgbe_8f_source.html new file mode 100644 index 00000000..1db7e035 --- /dev/null +++ b/ver-2.10.0/putgbe_8f_source.html @@ -0,0 +1,298 @@ + + + + + + + +NCEPLIBS-w3emc: putgbe.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    putgbe.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Packs and writes a grib message.
    +
    3 C> @author Mark Iredell @date 1994-04-01
    +
    4 
    +
    5 C> THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE.
    +
    6 C>
    +
    7 C> Program history log:
    +
    8 C> - Mark Iredell 1994-04-01
    +
    9 C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    10 C>
    +
    11 C> @param[in] lugb Integer unit of the unblocked grib data file.
    +
    12 C> @param[in] kf Integer number of data points.
    +
    13 C> @param[in] kpds Integer (200) pds parameters.
    +
    14 C> - 1: id of center.
    +
    15 C> - 2: generating process id number.
    +
    16 C> - 3: grid definition.
    +
    17 C> - 4: gds/bms flag (right adj copy of octet 8).
    +
    18 C> - 5: indicator of parameter.
    +
    19 C> - 6: type of level.
    +
    20 C> - 7: height/pressure , etc of level.
    +
    21 C> - 8: year including (century-1).
    +
    22 C> - 9: month of year.
    +
    23 C> - 10: day of month.
    +
    24 C> - 11: hour of day.
    +
    25 C> - 12: minute of hour.
    +
    26 C> - 13: indicator of forecast time unit.
    +
    27 C> - 14: time range 1.
    +
    28 C> - 15: time range 2.
    +
    29 C> - 16: time range flag.
    +
    30 C> - 17: number included in average.
    +
    31 C> - 18: version nr of grib specification.
    +
    32 C> - 19: version nr of parameter table.
    +
    33 C> - 20: nr missing from average/accumulation.
    +
    34 C> - 21: century of reference time of data.
    +
    35 C> - 22: units decimal scale factor.
    +
    36 C> - 23: subcenter number.
    +
    37 C> - 24: pds byte.
    +
    38 C> - 29 for nmc ensemble products.
    +
    39 C> - 28 if forecast field error.
    +
    40 C> - 64 if bias corrected fcst field.
    +
    41 C> - 32 if smoothed field.
    +
    42 C> - warning: can be combination of more than 1.
    +
    43 C> - 25: pds byte 30, not used.
    +
    44 C> @param[in] kgds integer (200) gds parameters.
    +
    45 C> - 1): data representation type.
    +
    46 C> - 19: number of vertical coordinate parameters.
    +
    47 C> - 20: octet number of the list of vertical coordinate parameters or
    +
    48 C> octet number of the list of numbers of points in each row or
    +
    49 C> 255 if neither are present.
    +
    50 C> - 21: for grids with pl, number of points in grid.
    +
    51 C> - 22: number of words in each row.
    +
    52 C> - Latitude/longitude grids.
    +
    53 C> - 2: n(i) nr points on latitude circle.
    +
    54 C> - 3: n(j) nr points on longitude meridian.
    +
    55 C> - 4: la(1) latitude of origin.
    +
    56 C> - 5: lo(1) longitude of origin.
    +
    57 C> - 6: resolution flag (right adj copy of octet 17).
    +
    58 C> - 7: la(2) latitude of extreme point.
    +
    59 C> - 8: lo(2) longitude of extreme point.
    +
    60 C> - 9: di longitudinal direction of increment.
    +
    61 C> - 10: dj latitudinal direction increment.
    +
    62 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    63 C> - Gaussian grids.
    +
    64 C> - 2: n(i) nr points on latitude circle.
    +
    65 C> - 3: n(j) nr points on longitude meridian.
    +
    66 C> - 4: la(1) latitude of origin.
    +
    67 C> - 5: lo(1) longitude of origin.
    +
    68 C> - 6: resolution flag (right adj copy of octet 17).
    +
    69 C> - 7: la(2) latitude of extreme point.
    +
    70 C> - 8: lo(2) longitude of extreme point.
    +
    71 C> - 9: di longitudinal direction of increment.
    +
    72 C> - 10: n - nr of circles pole to equator.
    +
    73 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    74 C> - 12: nv - nr of vert coord parameters.
    +
    75 C> - 13: pv - octet nr of list of vert coord parameters or
    +
    76 C> pl - location of the list of numbers of points in
    +
    77 C> each row (if no vert coord parameters are present) or
    +
    78 C> 255 if neither are present.
    +
    79 C> - Polar stereographic grids.
    +
    80 C> - 2: n(i) nr points along lat circle.
    +
    81 C> - 3: n(j) nr points along lon circle.
    +
    82 C> - 4: la(1) latitude of origin.
    +
    83 C> - 5: lo(1) longitude of origin.
    +
    84 C> - 6: resolution flag (right adj copy of octet 17).
    +
    85 C> - 7: lov grid orientation.
    +
    86 C> - 8: dx - x direction increment.
    +
    87 C> - 9: dy - y direction increment.
    +
    88 C> - 10: projection center flag.
    +
    89 C> - 11: scanning mode (right adj copy of octet 28).
    +
    90 C> - Spherical harmonic coefficients.
    +
    91 C> - 2: j pentagonal resolution parameter.
    +
    92 C> - 3: k pentagonal resolution parameter.
    +
    93 C> - 4: m pentagonal resolution parameter.
    +
    94 C> - 5: representation type.
    +
    95 C> - 6: coefficient storage mode.
    +
    96 C> - Mercator grids.
    +
    97 C> - 2: n(i) nr points on latitude circle.
    +
    98 C> - 3: n(j) nr points on longitude meridian.
    +
    99 C> - 4: la(1) latitude of origin.
    +
    100 C> - 5: lo(1) longitude of origin.
    +
    101 C> - 6: resolution flag (right adj copy of octet 17).
    +
    102 C> - 7: la(2) latitude of last grid point.
    +
    103 C> - 8: lo(2) longitude of last grid point.
    +
    104 C> - 9: latit - latitude of projection intersection.
    +
    105 C> - 10: reserved.
    +
    106 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    107 C> - 12: longitudinal dir grid length.
    +
    108 C> - 13: latitudinal dir grid length.
    +
    109 C> - Lambert conformal grids.
    +
    110 C> - 2: nx nr points along x-axis.
    +
    111 C> - 3: ny nr points along y-axis.
    +
    112 C> - 4: la1 lat of origin (lower left).
    +
    113 C> - 5: lo1 lon of origin (lower left).
    +
    114 C> - 6: resolution (right adj copy of octet 17).
    +
    115 C> - 7: lov - orientation of grid.
    +
    116 C> - 8: dx - x-dir increment.
    +
    117 C> - 9: dy - y-dir increment.
    +
    118 C> - 10: projection center flag.
    +
    119 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    120 C> - 12: latin 1 - first lat from pole of secant cone inter.
    +
    121 C> - 13: latin 2 - second lat from pole of secant cone inter.
    +
    122 C> @param[in] kens Integer (200) ensemble pds parms.
    +
    123 C> - 1: application identifier.
    +
    124 C> - 2: ensemble type.
    +
    125 C> - 3: ensemble identifier.
    +
    126 C> - 4: product identifier.
    +
    127 C> - 5: smoothing flag.
    +
    128 C> @param[in] lb Logical*1 (kf) bitmap if present.
    +
    129 C> @param[in] f Real (kf) data.
    +
    130 C> @param[out] iret Integer return code.
    +
    131 C> - 0 all ok.
    +
    132 C> - other w3fi72 grib packer return code.
    +
    133 C>
    +
    134 C> @note Subprogram can be called from a multiprocessing environment.
    +
    135 C> Do not engage the same logical unit from more than one processor.
    +
    136 C>
    +
    137 C> @author Mark Iredell @date 1994-04-01
    +
    138 C-----------------------------------------------------------------------
    +
    139  SUBROUTINE putgbe(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET)
    +
    140  INTEGER KPDS(200),KGDS(200),KENS(200)
    +
    141  LOGICAL*1 LB(KF)
    +
    142  REAL F(KF)
    +
    143  parameter(maxbit=16)
    +
    144  INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200)
    +
    145  REAL FR(KF)
    +
    146  CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8)
    +
    147 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    148 C GET W3FI72 PARAMETERS
    +
    149  CALL r63w72(kpds,kgds,ipds,igds)
    +
    150  ibds=0
    +
    151 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    152 C COUNT VALID DATA
    +
    153  kbm=kf
    +
    154  IF(ipds(7).NE.0) THEN
    +
    155  kbm=0
    +
    156  DO i=1,kf
    +
    157  IF(lb(i)) THEN
    +
    158  ibm(i)=1
    +
    159  kbm=kbm+1
    +
    160  ELSE
    +
    161  ibm(i)=0
    +
    162  ENDIF
    +
    163  ENDDO
    +
    164  IF(kbm.EQ.kf) ipds(7)=0
    +
    165  ENDIF
    +
    166 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    167 C GET NUMBER OF BITS AND ROUND DATA
    +
    168  IF(kbm.EQ.0) THEN
    +
    169  DO i=1,kf
    +
    170  fr(i)=0.
    +
    171  ENDDO
    +
    172  nbit=0
    +
    173  ELSE
    +
    174  CALL getbit(ipds(7),0,ipds(25),kf,ibm,f,fr,fmin,fmax,nbit)
    +
    175  nbit=min(nbit,maxbit)
    +
    176  ENDIF
    +
    177 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    178 C CREATE PRODUCT DEFINITION SECTION
    +
    179  CALL w3fi68(ipds,pds)
    +
    180  IF(ipds(24).EQ.2) THEN
    +
    181  ilast=45
    +
    182  CALL pdsens(kens,kprob,xprob,kclust,kmembr,ilast,pds)
    +
    183  ENDIF
    +
    184 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    185 C PACK AND WRITE GRIB DATA
    +
    186  CALL w3fi72(0,fr,0,nbit,1,ipds,pds,
    +
    187  & 1,255,igds,0,0,ibm,kf,ibds,
    +
    188  & kfo,grib,lgrib,iret)
    +
    189  IF(iret.EQ.0) CALL wryte(lugb,lgrib,grib)
    +
    190 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    191  RETURN
    +
    192  END
    +
    +
    +
    r63w72
    subroutine r63w72(KPDS, KGDS, IPDS, IGDS)
    Determines the integer PDS and GDS parameters for the GRIB1 packing routine w3fi72() given the parame...
    Definition: r63w72.f:27
    +
    pdsens
    subroutine pdsens(KENS, KPROB, XPROB, KCLUST, KMEMBR, ILAST, MSGA)
    Packs brib pds extension starting on byte 41 for ensemble forecast products.
    Definition: pdsens.f:28
    +
    w3fi72
    subroutine w3fi72(ITYPE, FLD, IFLD, IBITL, IPFLAG, ID, PDS, IGFLAG, IGRID, IGDS, ICOMP, IBFLAG, IBMAP, IBLEN, IBDSFL, NPTS, KBUF, ITOT, JERR)
    Makes a complete GRIB message from a user supplied array of floating point or integer data.
    Definition: w3fi72.f:121
    +
    w3fi68
    subroutine w3fi68(ID, PDS)
    Converts an array of 25, or 27 integer words into a grib product definition section (pds) of 28 bytes...
    Definition: w3fi68.f:85
    +
    putgbe
    subroutine putgbe(LUGB, KF, KPDS, KGDS, KENS, LB, F, IRET)
    THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE.
    Definition: putgbe.f:140
    + + + + diff --git a/ver-2.10.0/putgben_8f.html b/ver-2.10.0/putgben_8f.html new file mode 100644 index 00000000..caeff4ec --- /dev/null +++ b/ver-2.10.0/putgben_8f.html @@ -0,0 +1,355 @@ + + + + + + + +NCEPLIBS-w3emc: putgben.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    putgben.f File Reference
    +
    +
    + +

    Packs and writes a grib message. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine putgben (LUGB, KF, KPDS, KGDS, KENS, IBS, NBITS, LB, F, IRET)
     THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE. More...
     
    +

    Detailed Description

    +

    Packs and writes a grib message.

    +
    Author
    Mark Iredell
    +
    Date
    1994-04-01
    + +

    Definition in file putgben.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ putgben()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine putgben ( LUGB,
     KF,
    integer, dimension(200) KPDS,
    integer, dimension(200) KGDS,
    integer, dimension(200) KENS,
     IBS,
     NBITS,
    logical*1, dimension(kf) LB,
    real, dimension(kf) F,
     IRET 
    )
    +
    + +

    THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE.

    +

    Program history log:

      +
    • Mark Iredell 1994-04-01
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints.
      • +
    • Mark Iredell 2001-03-16 Corrected argument list to include ibs.
      • +
    +
    Parameters
    + + + + + + + + + + + +
    [in]lugbInteger unit of the unblocked grib data file.
    [in]kfInteger number of data points.
    [in]kpdsInteger (200) pds parameters.
      +
    • 1): id of center.
      • +
    • 2): generating process id number.
      • +
    • 3): grid definition.
      • +
    • 4): gds/bms flag (right adj copy of octet 8).
      • +
    • 5): indicator of parameter.
      • +
    • 6): type of level.
      • +
    • 7): height/pressure , etc of level.
      • +
    • 8): year including (century-1).
      • +
    • 9): month of year.
      • +
    • 10: day of month.
      • +
    • 11: hour of day.
      • +
    • 12: minute of hour.
      • +
    • 13: indicator of forecast time unit.
      • +
    • 14: time range 1.
      • +
    • 15: time range 2.
      • +
    • 16: time range flag.
      • +
    • 17: number included in average.
      • +
    • 18: version nr of grib specification.
      • +
    • 19: version nr of parameter table.
      • +
    • 20: nr missing from average/accumulation.
      • +
    • 21: century of reference time of data.
      • +
    • 22: units decimal scale factor.
      • +
    • 23: subcenter number.
      • +
    • 24: pds byte 29, for nmc ensemble products.
        +
      • 128 if forecast field error.
        • +
      • 64 if bias corrected fcst field.
        • +
      • 32 if smoothed field.
        • +
      • warning: can be combination of more than 1.
        • +
      +
      • +
    • 25: pds byte 30, not used.
      • +
    +
    [in]kgdsInteger (200) gds parameters.
      +
    • 1): data representation type.
      • +
    • 19: number of vertical coordinate parameters.
      • +
    • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
      • +
    • 21: for grids with pl, number of points in grid.
      • +
    • 22: number of words in each row.
      • +
    • Latitude/longitude grids.
        +
      • 2): n(i) nr points on latitude circle.
        • +
      • 3): n(j) nr points on longitude meridian.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): la(2) latitude of extreme point.
        • +
      • 8): lo(2) longitude of extreme point.
        • +
      • 9): di longitudinal direction of increment.
        • +
      • 10: dj latitudinal direction increment.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      +
      • +
    • Gaussian grids.
        +
      • 2): n(i) nr points on latitude circle.
        • +
      • 3): n(j) nr points on longitude meridian.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): la(2) latitude of extreme point.
        • +
      • 8): lo(2) longitude of extreme point.
        • +
      • 9): di longitudinal direction of increment.
        • +
      • 10: n - nr of circles pole to equator.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: nv - nr of vert coord parameters.
        • +
      • 13: pv - octet nr of list of vert coord parameters or. pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present
        • +
      +
      • +
    • Polar stereographic grids.
        +
      • 2): n(i) nr points along lat circle.
        • +
      • 3): n(j) nr points along lon circle.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): lov grid orientation.
        • +
      • 8): dx - x direction increment.
        • +
      • 9): dy - y direction increment.
        • +
      • 10: projection center flag.
        • +
      • 11: scanning mode (right adj copy of octet 28).
        • +
      +
      • +
    • Spherical harmonic coefficients.
        +
      • 2): j pentagonal resolution parameter.
        • +
      • 3): k pentagonal resolution parameter.
        • +
      • 4): m pentagonal resolution parameter.
        • +
      • 5): representation type.
        • +
      • 6): coefficient storage mode.
        • +
      +
      • +
    • Mercator grids.
        +
      • 2): n(i) nr points on latitude circle.
        • +
      • 3): n(j) nr points on longitude meridian.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): la(2) latitude of last grid point.
        • +
      • 8): lo(2) longitude of last grid point.
        • +
      • 9): latit - latitude of projection intersection.
        • +
      • 10: reserved.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: longitudinal dir grid length.
        • +
      • 13: latitudinal dir grid length.
        • +
      +
      • +
    • Lambert conformal grids.
        +
      • 2): nx nr points along x-axis.
        • +
      • 3): ny nr points along y-axis.
        • +
      • 4): la1 lat of origin (lower left).
        • +
      • 5): lo1 lon of origin (lower left).
        • +
      • 6): resolution (right adj copy of octet 17).
        • +
      • 7): lov - orientation of grid.
        • +
      • 8): dx - x-dir increment.
        • +
      • 9): dy - y-dir increment.
        • +
      • 10: projection center flag.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: latin 1 - first lat from pole of secant cone inter.
        • +
      • 13: latin 2 - second lat from pole of secant cone inter.
        • +
      +
      • +
    +
    [in]kensInteger (200) ensemble pds parms.
      +
    • 1): application identifier.
      • +
    • 2): ensemble type.
      • +
    • 3): ensemble identifier.
      • +
    • 4): product identifier.
      • +
    • 5): smoothing flag.
      • +
    +
    [in]ibsinteger binary scale factor (0 to ignore).
    [in]nbitsinteger number of bits in which to pack (0 to ignore).
    [in]lblogical*1 (kf) bitmap if present.
    [in]freal (kf) data.
    [out]iretinteger return code.
      +
    • all ok.
      • +
    • other w3fi72 grib packer return code.
      • +
    +
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
    +
    Author
    Mark Iredell
    +
    Date
    1994-04-01
    + +

    Definition at line 142 of file putgben.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/putgben_8f.js b/ver-2.10.0/putgben_8f.js new file mode 100644 index 00000000..43a1584d --- /dev/null +++ b/ver-2.10.0/putgben_8f.js @@ -0,0 +1,4 @@ +var putgben_8f = +[ + [ "putgben", "putgben_8f.html#a094e5a410a4e995f25665a750ac2bc8c", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/putgben_8f_source.html b/ver-2.10.0/putgben_8f_source.html new file mode 100644 index 00000000..b79f0517 --- /dev/null +++ b/ver-2.10.0/putgben_8f_source.html @@ -0,0 +1,307 @@ + + + + + + + +NCEPLIBS-w3emc: putgben.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    putgben.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Packs and writes a grib message.
    +
    3 C> @author Mark Iredell @date 1994-04-01
    +
    4 
    +
    5 C> THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE.
    +
    6 C>
    +
    7 C> Program history log:
    +
    8 C> - Mark Iredell 1994-04-01
    +
    9 C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    10 C> - Mark Iredell 2001-03-16 Corrected argument list to include ibs.
    +
    11 C>
    +
    12 C> @param[in] lugb Integer unit of the unblocked grib data file.
    +
    13 C> @param[in] kf Integer number of data points.
    +
    14 C> @param[in] kpds Integer (200) pds parameters.
    +
    15 C> - 1): id of center.
    +
    16 C> - 2): generating process id number.
    +
    17 C> - 3): grid definition.
    +
    18 C> - 4): gds/bms flag (right adj copy of octet 8).
    +
    19 C> - 5): indicator of parameter.
    +
    20 C> - 6): type of level.
    +
    21 C> - 7): height/pressure , etc of level.
    +
    22 C> - 8): year including (century-1).
    +
    23 C> - 9): month of year.
    +
    24 C> - 10: day of month.
    +
    25 C> - 11: hour of day.
    +
    26 C> - 12: minute of hour.
    +
    27 C> - 13: indicator of forecast time unit.
    +
    28 C> - 14: time range 1.
    +
    29 C> - 15: time range 2.
    +
    30 C> - 16: time range flag.
    +
    31 C> - 17: number included in average.
    +
    32 C> - 18: version nr of grib specification.
    +
    33 C> - 19: version nr of parameter table.
    +
    34 C> - 20: nr missing from average/accumulation.
    +
    35 C> - 21: century of reference time of data.
    +
    36 C> - 22: units decimal scale factor.
    +
    37 C> - 23: subcenter number.
    +
    38 C> - 24: pds byte 29, for nmc ensemble products.
    +
    39 C> - 128 if forecast field error.
    +
    40 C> - 64 if bias corrected fcst field.
    +
    41 C> - 32 if smoothed field.
    +
    42 C> - warning: can be combination of more than 1.
    +
    43 C> - 25: pds byte 30, not used.
    +
    44 C> @param[in] kgds Integer (200) gds parameters.
    +
    45 C> - 1): data representation type.
    +
    46 C> - 19: number of vertical coordinate parameters.
    +
    47 C> - 20: octet number of the list of vertical coordinate parameters or
    +
    48 C> octet number of the list of numbers of points in each row or
    +
    49 C> 255 if neither are present.
    +
    50 C> - 21: for grids with pl, number of points in grid.
    +
    51 C> - 22: number of words in each row.
    +
    52 C> - Latitude/longitude grids.
    +
    53 C> - 2): n(i) nr points on latitude circle.
    +
    54 C> - 3): n(j) nr points on longitude meridian.
    +
    55 C> - 4): la(1) latitude of origin.
    +
    56 C> - 5): lo(1) longitude of origin.
    +
    57 C> - 6): resolution flag (right adj copy of octet 17).
    +
    58 C> - 7): la(2) latitude of extreme point.
    +
    59 C> - 8): lo(2) longitude of extreme point.
    +
    60 C> - 9): di longitudinal direction of increment.
    +
    61 C> - 10: dj latitudinal direction increment.
    +
    62 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    63 C> - Gaussian grids.
    +
    64 C> - 2): n(i) nr points on latitude circle.
    +
    65 C> - 3): n(j) nr points on longitude meridian.
    +
    66 C> - 4): la(1) latitude of origin.
    +
    67 C> - 5): lo(1) longitude of origin.
    +
    68 C> - 6): resolution flag (right adj copy of octet 17).
    +
    69 C> - 7): la(2) latitude of extreme point.
    +
    70 C> - 8): lo(2) longitude of extreme point.
    +
    71 C> - 9): di longitudinal direction of increment.
    +
    72 C> - 10: n - nr of circles pole to equator.
    +
    73 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    74 C> - 12: nv - nr of vert coord parameters.
    +
    75 C> - 13: pv - octet nr of list of vert coord parameters or.
    +
    76 C> pl - location of the list of numbers of points in
    +
    77 C> each row (if no vert coord parameters are present) or
    +
    78 C> 255 if neither are present
    +
    79 C> - Polar stereographic grids.
    +
    80 C> - 2): n(i) nr points along lat circle.
    +
    81 C> - 3): n(j) nr points along lon circle.
    +
    82 C> - 4): la(1) latitude of origin.
    +
    83 C> - 5): lo(1) longitude of origin.
    +
    84 C> - 6): resolution flag (right adj copy of octet 17).
    +
    85 C> - 7): lov grid orientation.
    +
    86 C> - 8): dx - x direction increment.
    +
    87 C> - 9): dy - y direction increment.
    +
    88 C> - 10: projection center flag.
    +
    89 C> - 11: scanning mode (right adj copy of octet 28).
    +
    90 C> - Spherical harmonic coefficients.
    +
    91 C> - 2): j pentagonal resolution parameter.
    +
    92 C> - 3): k pentagonal resolution parameter.
    +
    93 C> - 4): m pentagonal resolution parameter.
    +
    94 C> - 5): representation type.
    +
    95 C> - 6): coefficient storage mode.
    +
    96 C> - Mercator grids.
    +
    97 C> - 2): n(i) nr points on latitude circle.
    +
    98 C> - 3): n(j) nr points on longitude meridian.
    +
    99 C> - 4): la(1) latitude of origin.
    +
    100 C> - 5): lo(1) longitude of origin.
    +
    101 C> - 6): resolution flag (right adj copy of octet 17).
    +
    102 C> - 7): la(2) latitude of last grid point.
    +
    103 C> - 8): lo(2) longitude of last grid point.
    +
    104 C> - 9): latit - latitude of projection intersection.
    +
    105 C> - 10: reserved.
    +
    106 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    107 C> - 12: longitudinal dir grid length.
    +
    108 C> - 13: latitudinal dir grid length.
    +
    109 C> - Lambert conformal grids.
    +
    110 C> - 2): nx nr points along x-axis.
    +
    111 C> - 3): ny nr points along y-axis.
    +
    112 C> - 4): la1 lat of origin (lower left).
    +
    113 C> - 5): lo1 lon of origin (lower left).
    +
    114 C> - 6): resolution (right adj copy of octet 17).
    +
    115 C> - 7): lov - orientation of grid.
    +
    116 C> - 8): dx - x-dir increment.
    +
    117 C> - 9): dy - y-dir increment.
    +
    118 C> - 10: projection center flag.
    +
    119 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    120 C> - 12: latin 1 - first lat from pole of secant cone inter.
    +
    121 C> - 13: latin 2 - second lat from pole of secant cone inter.
    +
    122 C> @param[in] kens Integer (200) ensemble pds parms.
    +
    123 C> - 1): application identifier.
    +
    124 C> - 2): ensemble type.
    +
    125 C> - 3): ensemble identifier.
    +
    126 C> - 4): product identifier.
    +
    127 C> - 5): smoothing flag.
    +
    128 C> @param[in] ibs integer binary scale factor (0 to ignore).
    +
    129 C> @param[in] nbits integer number of bits in which to pack (0 to ignore).
    +
    130 C> @param[in] lb logical*1 (kf) bitmap if present.
    +
    131 C> @param[in] f real (kf) data.
    +
    132 C> @param[out] iret integer return code.
    +
    133 C> - all ok.
    +
    134 C> - other w3fi72 grib packer return code.
    +
    135 C>
    +
    136 C> @note Subprogram can be called from a multiprocessing environment.
    +
    137 C> Do not engage the same logical unit from more than one processor.
    +
    138 C>
    +
    139 C> @author Mark Iredell @date 1994-04-01
    +
    140 C-----------------------------------------------------------------------
    +
    141  SUBROUTINE putgben(LUGB,KF,KPDS,KGDS,KENS,IBS,NBITS,LB,F,IRET)
    +
    142  INTEGER KPDS(200),KGDS(200),KENS(200)
    +
    143  LOGICAL*1 LB(KF)
    +
    144  REAL F(KF)
    +
    145  parameter(maxbit=16)
    +
    146  INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200)
    +
    147  REAL FR(KF)
    +
    148  CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8)
    +
    149 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    150 C GET W3FI72 PARAMETERS
    +
    151  CALL r63w72(kpds,kgds,ipds,igds)
    +
    152  ibds=0
    +
    153 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    154 C COUNT VALID DATA
    +
    155  kbm=kf
    +
    156  IF(ipds(7).NE.0) THEN
    +
    157  kbm=0
    +
    158  DO i=1,kf
    +
    159  IF(lb(i)) THEN
    +
    160  ibm(i)=1
    +
    161  kbm=kbm+1
    +
    162  ELSE
    +
    163  ibm(i)=0
    +
    164  ENDIF
    +
    165  ENDDO
    +
    166  IF(kbm.EQ.kf) ipds(7)=0
    +
    167  ENDIF
    +
    168 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    169 C GET NUMBER OF BITS AND ROUND DATA
    +
    170  IF(nbits.GT.0) THEN
    +
    171  DO i=1,kf
    +
    172  fr(i)=f(i)
    +
    173  ENDDO
    +
    174  nbit=nbits
    +
    175  ELSE
    +
    176  IF(kbm.EQ.0) THEN
    +
    177  DO i=1,kf
    +
    178  fr(i)=0.
    +
    179  ENDDO
    +
    180  nbit=0
    +
    181  ELSE
    +
    182  CALL getbit(ipds(7),ibs,ipds(25),kf,ibm,f,fr,fmin,fmax,nbit)
    +
    183  nbit=min(nbit,maxbit)
    +
    184  ENDIF
    +
    185  ENDIF
    +
    186 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    187 C CREATE PRODUCT DEFINITION SECTION
    +
    188  CALL w3fi68(ipds,pds)
    +
    189  IF(ipds(24).EQ.2) THEN
    +
    190  ilast=45
    +
    191  CALL pdsens(kens,kprob,xprob,kclust,kmembr,ilast,pds)
    +
    192  ENDIF
    +
    193 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    194 C PACK AND WRITE GRIB DATA
    +
    195  CALL w3fi72(0,fr,0,nbit,1,ipds,pds,
    +
    196  & 1,255,igds,0,0,ibm,kf,ibds,
    +
    197  & kfo,grib,lgrib,iret)
    +
    198  IF(iret.EQ.0) CALL wryte(lugb,lgrib,grib)
    +
    199 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    200  RETURN
    +
    201  END
    +
    +
    +
    r63w72
    subroutine r63w72(KPDS, KGDS, IPDS, IGDS)
    Determines the integer PDS and GDS parameters for the GRIB1 packing routine w3fi72() given the parame...
    Definition: r63w72.f:27
    +
    pdsens
    subroutine pdsens(KENS, KPROB, XPROB, KCLUST, KMEMBR, ILAST, MSGA)
    Packs brib pds extension starting on byte 41 for ensemble forecast products.
    Definition: pdsens.f:28
    +
    putgben
    subroutine putgben(LUGB, KF, KPDS, KGDS, KENS, IBS, NBITS, LB, F, IRET)
    THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE.
    Definition: putgben.f:142
    +
    w3fi72
    subroutine w3fi72(ITYPE, FLD, IFLD, IBITL, IPFLAG, ID, PDS, IGFLAG, IGRID, IGDS, ICOMP, IBFLAG, IBMAP, IBLEN, IBDSFL, NPTS, KBUF, ITOT, JERR)
    Makes a complete GRIB message from a user supplied array of floating point or integer data.
    Definition: w3fi72.f:121
    +
    w3fi68
    subroutine w3fi68(ID, PDS)
    Converts an array of 25, or 27 integer words into a grib product definition section (pds) of 28 bytes...
    Definition: w3fi68.f:85
    + + + + diff --git a/ver-2.10.0/putgbens_8f.html b/ver-2.10.0/putgbens_8f.html new file mode 100644 index 00000000..34781d16 --- /dev/null +++ b/ver-2.10.0/putgbens_8f.html @@ -0,0 +1,339 @@ + + + + + + + +NCEPLIBS-w3emc: putgbens.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    putgbens.f File Reference
    +
    +
    + +

    Packs and writes a grib message. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine putgbens (LUGB, KF, KPDS, KGDS, KENS, LB, F, IRET)
     This subprogram is nearly the inverse of getgbens. More...
     
    +

    Detailed Description

    +

    Packs and writes a grib message.

    +
    Author
    Mark Iredell
    +
    Date
    1994-04-01
    + +

    Definition in file putgbens.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ putgbens()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine putgbens ( LUGB,
     KF,
    integer, dimension(200) KPDS,
    integer, dimension(200) KGDS,
    integer, dimension(200) KENS,
    logical*1, dimension(kf) LB,
    real, dimension(kf) F,
     IRET 
    )
    +
    + +

    This subprogram is nearly the inverse of getgbens.

    +

    This obsolescent version has been replaced by putgbe.

    +

    Program history log:

      +
    • Mark Iredell 1994-04-01
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    +
    Parameters
    + + + + + + + + + +
    [in]lugbinteger unit of the unblocked grib data file.
    [in]kfinteger number of data points.
    [in]kpdsinteger (200) pds parameters.
      +
    • 1): id of center.
      • +
    • 2): generating process id number.
      • +
    • 3): grid definition.
      • +
    • 4): gds/bms flag (right adj copy of octet 8).
      • +
    • 5): indicator of parameter.
      • +
    • 6): type of level.
      • +
    • 7): height/pressure , etc of level.
      • +
    • 8): year including (century-1).
      • +
    • 9): month of year.
      • +
    • 10: day of month.
      • +
    • 11: hour of day.
      • +
    • 12: minute of hour.
      • +
    • 13: indicator of forecast time unit.
      • +
    • 14: time range 1.
      • +
    • 15: time range 2.
      • +
    • 16: time range flag.
      • +
    • 17: number included in average.
      • +
    • 18: version nr of grib specification.
      • +
    • 19: version nr of parameter table.
      • +
    • 20: nr missing from average/accumulation.
      • +
    • 21: century of reference time of data.
      • +
    • 22: units decimal scale factor.
      • +
    • 23: subcenter number.
      • +
    • 24: pds byte 29, for nmc ensemble products.
      • +
    • 128 if forecast field error.
      • +
    • 64 if bias corrected fcst field.
      • +
    • 32 if smoothed field.
      • +
    • warning: can be combination of more than 1.
      • +
    • 25: pds byte 30, not used.
      • +
    +
    [in]kgdsinteger (200) gds parameters.
      +
    • 1): data representation type.
      • +
    • 19: number of vertical coordinate parameters.
      • +
    • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
      • +
    • 21: for grids with pl, number of points in grid.
      • +
    • 22: number of words in each row.
      • +
    • Latitude/longitude grids.
        +
      • 2): n(i) nr points on latitude circle.
        • +
      • 3): n(j) nr points on longitude meridian.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): la(2) latitude of extreme point.
        • +
      • 8): lo(2) longitude of extreme point.
        • +
      • 9): di longitudinal direction of increment.
        • +
      • 10: dj latitudinal direction increment.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      +
      • +
    • Gaussian grids.
        +
      • 2): n(i) nr points on latitude circle.
        • +
      • 3): n(j) nr points on longitude meridian.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): la(2) latitude of extreme point.
        • +
      • 8): lo(2) longitude of extreme point.
        • +
      • 9): di longitudinal direction of increment.
        • +
      • 10: n - nr of circles pole to equator.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: nv - nr of vert coord parameters.
        • +
      • 13: pv - octet nr of list of vert coord parameters or pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present.
        • +
      +
      • +
    • Polar stereographic grids.
        +
      • 2): n(i) nr points along lat circle.
        • +
      • 3): n(j) nr points along lon circle.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): lov grid orientation.
        • +
      • 8): dx - x direction increment.
        • +
      • 9): dy - y direction increment.
        • +
      • 10: projection center flag.
        • +
      • 11: scanning mode (right adj copy of octet 28).
        • +
      +
      • +
    • Spherical harmonic coefficients.
        +
      • 2): j pentagonal resolution parameter.
        • +
      • 3): k pentagonal resolution parameter.
        • +
      • 4): m pentagonal resolution parameter.
        • +
      • 5): representation type.
        • +
      • 6): coefficient storage mode.
        • +
      +
      • +
    • Mercator grids.
        +
      • 2): n(i) nr points on latitude circle.
        • +
      • 3): n(j) nr points on longitude meridian.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): la(2) latitude of last grid point.
        • +
      • 8): lo(2) longitude of last grid point.
        • +
      • 9): latit - latitude of projection intersection.
        • +
      • 10: reserved.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: longitudinal dir grid length.
        • +
      • 13: latitudinal dir grid length.
        • +
      +
      • +
    • Lambert conformal grids.
        +
      • 2): nx nr points along x-axis.
        • +
      • 3): ny nr points along y-axis.
        • +
      • 4): la1 lat of origin (lower left).
        • +
      • 5): lo1 lon of origin (lower left).
        • +
      • 6): resolution (right adj copy of octet 17).
        • +
      • 7): lov - orientation of grid.
        • +
      • 8): dx - x-dir increment.
        • +
      • 9): dy - y-dir increment.
        • +
      • 10: projection center flag.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: latin 1 - first lat from pole of secant cone inter.
        • +
      • 13: latin 2 - second lat from pole of secant cone inter.
        • +
      +
      • +
    +
    [in]kensinteger (200) ensemble pds parms.
      +
    • 1): application identifier.
      • +
    • 2): ensemble type.
      • +
    • 3): ensemble identifier.
      • +
    • 4): product identifier.
      • +
    • 5): smoothing flag.
      • +
    +
    [in]lblogical*1 (kf) bitmap if present.
    [in]freal (kf) data.
    [out]iretinteger return code.
      +
    • 0 all ok.
      • +
    • other w3fi72 grib packer return code.
      • +
    +
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
    +
    Author
    Mark Iredell
    +
    Date
    1994-04-01
    + +

    Definition at line 140 of file putgbens.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/putgbens_8f.js b/ver-2.10.0/putgbens_8f.js new file mode 100644 index 00000000..faf1707e --- /dev/null +++ b/ver-2.10.0/putgbens_8f.js @@ -0,0 +1,4 @@ +var putgbens_8f = +[ + [ "putgbens", "putgbens_8f.html#a1a125225f33ac856c34ce692adeef0b2", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/putgbens_8f_source.html b/ver-2.10.0/putgbens_8f_source.html new file mode 100644 index 00000000..bb4fbcd5 --- /dev/null +++ b/ver-2.10.0/putgbens_8f_source.html @@ -0,0 +1,251 @@ + + + + + + + +NCEPLIBS-w3emc: putgbens.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    putgbens.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Packs and writes a grib message.
    +
    3 C> @author Mark Iredell @date 1994-04-01
    +
    4 
    +
    5 C> This subprogram is nearly the inverse of getgbens.
    +
    6 C> This obsolescent version has been replaced by putgbe.
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - Mark Iredell 1994-04-01
    +
    10 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    11 C>
    +
    12 C> @param[in] lugb integer unit of the unblocked grib data file.
    +
    13 C> @param[in] kf integer number of data points.
    +
    14 C> @param[in] kpds integer (200) pds parameters.
    +
    15 C> - 1): id of center.
    +
    16 C> - 2): generating process id number.
    +
    17 C> - 3): grid definition.
    +
    18 C> - 4): gds/bms flag (right adj copy of octet 8).
    +
    19 C> - 5): indicator of parameter.
    +
    20 C> - 6): type of level.
    +
    21 C> - 7): height/pressure , etc of level.
    +
    22 C> - 8): year including (century-1).
    +
    23 C> - 9): month of year.
    +
    24 C> - 10: day of month.
    +
    25 C> - 11: hour of day.
    +
    26 C> - 12: minute of hour.
    +
    27 C> - 13: indicator of forecast time unit.
    +
    28 C> - 14: time range 1.
    +
    29 C> - 15: time range 2.
    +
    30 C> - 16: time range flag.
    +
    31 C> - 17: number included in average.
    +
    32 C> - 18: version nr of grib specification.
    +
    33 C> - 19: version nr of parameter table.
    +
    34 C> - 20: nr missing from average/accumulation.
    +
    35 C> - 21: century of reference time of data.
    +
    36 C> - 22: units decimal scale factor.
    +
    37 C> - 23: subcenter number.
    +
    38 C> - 24: pds byte 29, for nmc ensemble products.
    +
    39 C> - 128 if forecast field error.
    +
    40 C> - 64 if bias corrected fcst field.
    +
    41 C> - 32 if smoothed field.
    +
    42 C> - warning: can be combination of more than 1.
    +
    43 C> - 25: pds byte 30, not used.
    +
    44 C> @param[in] kgds integer (200) gds parameters.
    +
    45 C> - 1): data representation type.
    +
    46 C> - 19: number of vertical coordinate parameters.
    +
    47 C> - 20: octet number of the list of vertical coordinate parameters or
    +
    48 C> octet number of the list of numbers of points in each row or
    +
    49 C> 255 if neither are present.
    +
    50 C> - 21: for grids with pl, number of points in grid.
    +
    51 C> - 22: number of words in each row.
    +
    52 C> - Latitude/longitude grids.
    +
    53 C> - 2): n(i) nr points on latitude circle.
    +
    54 C> - 3): n(j) nr points on longitude meridian.
    +
    55 C> - 4): la(1) latitude of origin.
    +
    56 C> - 5): lo(1) longitude of origin.
    +
    57 C> - 6): resolution flag (right adj copy of octet 17).
    +
    58 C> - 7): la(2) latitude of extreme point.
    +
    59 C> - 8): lo(2) longitude of extreme point.
    +
    60 C> - 9): di longitudinal direction of increment.
    +
    61 C> - 10: dj latitudinal direction increment.
    +
    62 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    63 C> - Gaussian grids.
    +
    64 C> - 2): n(i) nr points on latitude circle.
    +
    65 C> - 3): n(j) nr points on longitude meridian.
    +
    66 C> - 4): la(1) latitude of origin.
    +
    67 C> - 5): lo(1) longitude of origin.
    +
    68 C> - 6): resolution flag (right adj copy of octet 17).
    +
    69 C> - 7): la(2) latitude of extreme point.
    +
    70 C> - 8): lo(2) longitude of extreme point.
    +
    71 C> - 9): di longitudinal direction of increment.
    +
    72 C> - 10: n - nr of circles pole to equator.
    +
    73 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    74 C> - 12: nv - nr of vert coord parameters.
    +
    75 C> - 13: pv - octet nr of list of vert coord parameters or
    +
    76 C> pl - location of the list of numbers of points in
    +
    77 C> each row (if no vert coord parameters are present) or
    +
    78 C> 255 if neither are present.
    +
    79 C> - Polar stereographic grids.
    +
    80 C> - 2): n(i) nr points along lat circle.
    +
    81 C> - 3): n(j) nr points along lon circle.
    +
    82 C> - 4): la(1) latitude of origin.
    +
    83 C> - 5): lo(1) longitude of origin.
    +
    84 C> - 6): resolution flag (right adj copy of octet 17).
    +
    85 C> - 7): lov grid orientation.
    +
    86 C> - 8): dx - x direction increment.
    +
    87 C> - 9): dy - y direction increment.
    +
    88 C> - 10: projection center flag.
    +
    89 C> - 11: scanning mode (right adj copy of octet 28).
    +
    90 C> - Spherical harmonic coefficients.
    +
    91 C> - 2): j pentagonal resolution parameter.
    +
    92 C> - 3): k pentagonal resolution parameter.
    +
    93 C> - 4): m pentagonal resolution parameter.
    +
    94 C> - 5): representation type.
    +
    95 C> - 6): coefficient storage mode.
    +
    96 C> - Mercator grids.
    +
    97 C> - 2): n(i) nr points on latitude circle.
    +
    98 C> - 3): n(j) nr points on longitude meridian.
    +
    99 C> - 4): la(1) latitude of origin.
    +
    100 C> - 5): lo(1) longitude of origin.
    +
    101 C> - 6): resolution flag (right adj copy of octet 17).
    +
    102 C> - 7): la(2) latitude of last grid point.
    +
    103 C> - 8): lo(2) longitude of last grid point.
    +
    104 C> - 9): latit - latitude of projection intersection.
    +
    105 C> - 10: reserved.
    +
    106 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    107 C> - 12: longitudinal dir grid length.
    +
    108 C> - 13: latitudinal dir grid length.
    +
    109 C> - Lambert conformal grids.
    +
    110 C> - 2): nx nr points along x-axis.
    +
    111 C> - 3): ny nr points along y-axis.
    +
    112 C> - 4): la1 lat of origin (lower left).
    +
    113 C> - 5): lo1 lon of origin (lower left).
    +
    114 C> - 6): resolution (right adj copy of octet 17).
    +
    115 C> - 7): lov - orientation of grid.
    +
    116 C> - 8): dx - x-dir increment.
    +
    117 C> - 9): dy - y-dir increment.
    +
    118 C> - 10: projection center flag.
    +
    119 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    120 C> - 12: latin 1 - first lat from pole of secant cone inter.
    +
    121 C> - 13: latin 2 - second lat from pole of secant cone inter.
    +
    122 C> @param[in] kens integer (200) ensemble pds parms.
    +
    123 C> - 1): application identifier.
    +
    124 C> - 2): ensemble type.
    +
    125 C> - 3): ensemble identifier.
    +
    126 C> - 4): product identifier.
    +
    127 C> - 5): smoothing flag.
    +
    128 C> @param[in] lb logical*1 (kf) bitmap if present.
    +
    129 C> @param[in] f real (kf) data.
    +
    130 C> @param[out] iret integer return code.
    +
    131 C> - 0 all ok.
    +
    132 C> - other w3fi72 grib packer return code.
    +
    133 C>
    +
    134 C> @note Subprogram can be called from a multiprocessing environment.
    +
    135 C> Do not engage the same logical unit from more than one processor.
    +
    136 C>
    +
    137 C> @author Mark Iredell @date 1994-04-01
    +
    138 C-----------------------------------------------------------------------
    +
    139  SUBROUTINE putgbens(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET)
    +
    140  INTEGER KPDS(200),KGDS(200),KENS(200)
    +
    141  LOGICAL*1 LB(KF)
    +
    142  REAL F(KF)
    +
    143 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    144  print *,'PLEASE USE PUTGBE RATHER THAN PUTGBENS'
    +
    145  CALL putgbe(lugb,kf,kpds,kgds,kens,lb,f,iret)
    +
    146 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    147  RETURN
    +
    148  END
    +
    +
    +
    putgbens
    subroutine putgbens(LUGB, KF, KPDS, KGDS, KENS, LB, F, IRET)
    This subprogram is nearly the inverse of getgbens.
    Definition: putgbens.f:140
    +
    putgbe
    subroutine putgbe(LUGB, KF, KPDS, KGDS, KENS, LB, F, IRET)
    THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE.
    Definition: putgbe.f:140
    + + + + diff --git a/ver-2.10.0/putgbex_8f.html b/ver-2.10.0/putgbex_8f.html new file mode 100644 index 00000000..32c07c89 --- /dev/null +++ b/ver-2.10.0/putgbex_8f.html @@ -0,0 +1,369 @@ + + + + + + + +NCEPLIBS-w3emc: putgbex.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    putgbex.f File Reference
    +
    +
    + +

    Packs and writes a grib message. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine putgbex (LUGB, KF, KPDS, KGDS, KENS, KPROB, XPROB, KCLUST, KMEMBR, LB, F, IRET)
     This subprogram is nearly the inverse of getgbe. More...
     
    +

    Detailed Description

    +

    Packs and writes a grib message.

    +
    Author
    Mark Iredell
    +
    Date
    1994-04-01
    + +

    Definition in file putgbex.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ putgbex()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine putgbex ( LUGB,
     KF,
    integer, dimension(200) KPDS,
    integer, dimension(200) KGDS,
    integer, dimension(200) KENS,
    integer, dimension(2) KPROB,
    real, dimension(2) XPROB,
    integer, dimension(16) KCLUST,
    integer, dimension(80) KMEMBR,
    logical*1, dimension(kf) LB,
    real, dimension(kf) F,
     IRET 
    )
    +
    + +

    This subprogram is nearly the inverse of getgbe.

    +

    Program history log:

      +
    • Mark Iredell 1994-04-01
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints.
      • +
    • Y. Zhu 1997-02-11 Included probability and cluster arguments.
      • +
    +
    Parameters
    + + + + + + + + + + + + + +
    [in]lugbinteger unit of the unblocked grib data file.
    [in]kfinteger number of data points.
    [in]kpdsinteger (200) pds parameters.
      +
    • 1): id of center.
      • +
    • 2): generating process id number.
      • +
    • 3): grid definition.
      • +
    • 4): gds/bms flag (right adj copy of octet 8).
      • +
    • 5): indicator of parameter.
      • +
    • 6): type of level.
      • +
    • 7): height/pressure , etc of level.
      • +
    • 8): year including (century-1).
      • +
    • 9): month of year.
      • +
    • 10: day of month.
      • +
    • 11: hour of day.
      • +
    • 12: minute of hour.
      • +
    • 13: indicator of forecast time unit.
      • +
    • 14: time range 1.
      • +
    • 15: time range 2.
      • +
    • 16: time range flag.
      • +
    • 17: number included in average.
      • +
    • 18: version nr of grib specification.
      • +
    • 19: version nr of parameter table.
      • +
    • 20: nr missing from average/accumulation.
      • +
    • 21: century of reference time of data.
      • +
    • 22: units decimal scale factor.
      • +
    • 23: subcenter number.
      • +
    • 24: pds byte 29, for nmc ensemble products.
        +
      • 128 if forecast field error.
        • +
      • 64 if bias corrected fcst field.
        • +
      • 32 if smoothed field.
        • +
      • warning: can be combination of more than 1.
        • +
      +
      • +
    • 25: pds byte 30, not used.
      • +
    +
    [in]kgdsInteger (200) gds parameters.
      +
    • 1): data representation type.
      • +
    • 19: number of vertical coordinate parameters.
      • +
    • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
      • +
    • 21: for grids with pl, number of points in grid.
      • +
    • 22: number of words in each row.
      • +
    • Latitude/longitude grids.
        +
      • 2): n(i) nr points on latitude circle.
        • +
      • 3): n(j) nr points on longitude meridian.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): la(2) latitude of extreme point.
        • +
      • 8): lo(2) longitude of extreme point.
        • +
      • 9): di longitudinal direction of increment.
        • +
      • 10: dj latitudinal direction increment.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      +
      • +
    • Gaussian grids.
        +
      • 2): n(i) nr points on latitude circle.
        • +
      • 3): n(j) nr points on longitude meridian.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): la(2) latitude of extreme point.
        • +
      • 8): lo(2) longitude of extreme point.
        • +
      • 9): di longitudinal direction of increment.
        • +
      • 10: n - nr of circles pole to equator.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: nv - nr of vert coord parameters.
        • +
      • 13: pv - octet nr of list of vert coord parameters or pl - location of the list of numbers of points in each row (if no vert coord parameters are present or 255 if neither are present
        • +
      +
      • +
    • Polar stereographic grids.
        +
      • 2): n(i) nr points along lat circle.
        • +
      • 3): n(j) nr points along lon circle.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): lov grid orientation.
        • +
      • 8): dx - x direction increment.
        • +
      • 9): dy - y direction increment.
        • +
      • 10: projection center flag.
        • +
      • 11: scanning mode (right adj copy of octet 28).
        • +
      +
      • +
    • Spherical harmonic coefficients.
        +
      • 2): j pentagonal resolution parameter.
        • +
      • 3): k pentagonal resolution parameter.
        • +
      • 4): m pentagonal resolution parameter.
        • +
      • 5): representation type.
        • +
      • 6): coefficient storage mode.
        • +
      +
      • +
    • Mercator grids.
        +
      • 2): n(i) nr points on latitude circle.
        • +
      • 3): n(j) nr points on longitude meridian.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): la(2) latitude of last grid point.
        • +
      • 8): lo(2) longitude of last grid point.
        • +
      • 9): latit - latitude of projection intersection.
        • +
      • 10: reserved.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: longitudinal dir grid length.
        • +
      • 13: latitudinal dir grid length.
        • +
      +
      • +
    • Lambert conformal grids.
        +
      • 2): nx nr points along x-axis.
        • +
      • 3): ny nr points along y-axis.
        • +
      • 4): la1 lat of origin (lower left).
        • +
      • 5): lo1 lon of origin (lower left).
        • +
      • 6): resolution (right adj copy of octet 17).
        • +
      • 7): lov - orientation of grid.
        • +
      • 8): dx - x-dir increment.
        • +
      • 9): dy - y-dir increment.
        • +
      • 10: projection center flag.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: latin 1 - first lat from pole of secant cone inter.
        • +
      • 13: latin 2 - second lat from pole of secant cone inter.
        • +
      +
      • +
    +
    [in]kensinteger (200) ensemble pds parms.
      +
    • 1): application identifier.
      • +
    • 2): ensemble type.
      • +
    • 3): ensemble identifier.
      • +
    • 4): product identifier.
      • +
    • 5): smoothing flag.
      • +
    +
    [in]kprobinteger (2) probability ensemble parms.
    [in]xprobreal (2) probability ensemble parms.
    [in]kclustinteger (16) cluster ensemble parms.
    [in]kmembrinteger (8) cluster ensemble parms.
    [in]lblogical*1 (kf) bitmap if present.
    [in]freal (kf) data.
    [out]iretinteger return code.
      +
    • 0 all ok.
      • +
    • other w3fi72 grib packer return code.
      • +
    +
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
    +
    Author
    Mark Iredell
    +
    Date
    1994-04-01
    + +

    Definition at line 145 of file putgbex.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/putgbex_8f.js b/ver-2.10.0/putgbex_8f.js new file mode 100644 index 00000000..cd6af2c5 --- /dev/null +++ b/ver-2.10.0/putgbex_8f.js @@ -0,0 +1,4 @@ +var putgbex_8f = +[ + [ "putgbex", "putgbex_8f.html#a64977c953757490ae3b8b72a5fd7c4cb", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/putgbex_8f_source.html b/ver-2.10.0/putgbex_8f_source.html new file mode 100644 index 00000000..6fd22ff2 --- /dev/null +++ b/ver-2.10.0/putgbex_8f_source.html @@ -0,0 +1,305 @@ + + + + + + + +NCEPLIBS-w3emc: putgbex.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    putgbex.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Packs and writes a grib message.
    +
    3 C> @author Mark Iredell @date 1994-04-01
    +
    4 
    +
    5 C> This subprogram is nearly the inverse of getgbe.
    +
    6 C>
    +
    7 C> Program history log:
    +
    8 C> - Mark Iredell 1994-04-01
    +
    9 C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    10 C> - Y. Zhu 1997-02-11 Included probability and cluster arguments.
    +
    11 C>
    +
    12 C> @param[in] lugb integer unit of the unblocked grib data file.
    +
    13 C> @param[in] kf integer number of data points.
    +
    14 C> @param[in] kpds integer (200) pds parameters.
    +
    15 C> - 1): id of center.
    +
    16 C> - 2): generating process id number.
    +
    17 C> - 3): grid definition.
    +
    18 C> - 4): gds/bms flag (right adj copy of octet 8).
    +
    19 C> - 5): indicator of parameter.
    +
    20 C> - 6): type of level.
    +
    21 C> - 7): height/pressure , etc of level.
    +
    22 C> - 8): year including (century-1).
    +
    23 C> - 9): month of year.
    +
    24 C> - 10: day of month.
    +
    25 C> - 11: hour of day.
    +
    26 C> - 12: minute of hour.
    +
    27 C> - 13: indicator of forecast time unit.
    +
    28 C> - 14: time range 1.
    +
    29 C> - 15: time range 2.
    +
    30 C> - 16: time range flag.
    +
    31 C> - 17: number included in average.
    +
    32 C> - 18: version nr of grib specification.
    +
    33 C> - 19: version nr of parameter table.
    +
    34 C> - 20: nr missing from average/accumulation.
    +
    35 C> - 21: century of reference time of data.
    +
    36 C> - 22: units decimal scale factor.
    +
    37 C> - 23: subcenter number.
    +
    38 C> - 24: pds byte 29, for nmc ensemble products.
    +
    39 C> - 128 if forecast field error.
    +
    40 C> - 64 if bias corrected fcst field.
    +
    41 C> - 32 if smoothed field.
    +
    42 C> - warning: can be combination of more than 1.
    +
    43 C> - 25: pds byte 30, not used.
    +
    44 C> @param[in] kgds Integer (200) gds parameters.
    +
    45 C> - 1): data representation type.
    +
    46 C> - 19: number of vertical coordinate parameters.
    +
    47 C> - 20: octet number of the list of vertical coordinate parameters or
    +
    48 C> octet number of the list of numbers of points in each row or
    +
    49 C> 255 if neither are present.
    +
    50 C> - 21: for grids with pl, number of points in grid.
    +
    51 C> - 22: number of words in each row.
    +
    52 C> - Latitude/longitude grids.
    +
    53 C> - 2): n(i) nr points on latitude circle.
    +
    54 C> - 3): n(j) nr points on longitude meridian.
    +
    55 C> - 4): la(1) latitude of origin.
    +
    56 C> - 5): lo(1) longitude of origin.
    +
    57 C> - 6): resolution flag (right adj copy of octet 17).
    +
    58 C> - 7): la(2) latitude of extreme point.
    +
    59 C> - 8): lo(2) longitude of extreme point.
    +
    60 C> - 9): di longitudinal direction of increment.
    +
    61 C> - 10: dj latitudinal direction increment.
    +
    62 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    63 C> - Gaussian grids.
    +
    64 C> - 2): n(i) nr points on latitude circle.
    +
    65 C> - 3): n(j) nr points on longitude meridian.
    +
    66 C> - 4): la(1) latitude of origin.
    +
    67 C> - 5): lo(1) longitude of origin.
    +
    68 C> - 6): resolution flag (right adj copy of octet 17).
    +
    69 C> - 7): la(2) latitude of extreme point.
    +
    70 C> - 8): lo(2) longitude of extreme point.
    +
    71 C> - 9): di longitudinal direction of increment.
    +
    72 C> - 10: n - nr of circles pole to equator.
    +
    73 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    74 C> - 12: nv - nr of vert coord parameters.
    +
    75 C> - 13: pv - octet nr of list of vert coord parameters or
    +
    76 C> pl - location of the list of numbers of points in
    +
    77 C> each row (if no vert coord parameters are present or
    +
    78 C> 255 if neither are present
    +
    79 C> - Polar stereographic grids.
    +
    80 C> - 2): n(i) nr points along lat circle.
    +
    81 C> - 3): n(j) nr points along lon circle.
    +
    82 C> - 4): la(1) latitude of origin.
    +
    83 C> - 5): lo(1) longitude of origin.
    +
    84 C> - 6): resolution flag (right adj copy of octet 17).
    +
    85 C> - 7): lov grid orientation.
    +
    86 C> - 8): dx - x direction increment.
    +
    87 C> - 9): dy - y direction increment.
    +
    88 C> - 10: projection center flag.
    +
    89 C> - 11: scanning mode (right adj copy of octet 28).
    +
    90 C> - Spherical harmonic coefficients.
    +
    91 C> - 2): j pentagonal resolution parameter.
    +
    92 C> - 3): k pentagonal resolution parameter.
    +
    93 C> - 4): m pentagonal resolution parameter.
    +
    94 C> - 5): representation type.
    +
    95 C> - 6): coefficient storage mode.
    +
    96 C> - Mercator grids.
    +
    97 C> - 2): n(i) nr points on latitude circle.
    +
    98 C> - 3): n(j) nr points on longitude meridian.
    +
    99 C> - 4): la(1) latitude of origin.
    +
    100 C> - 5): lo(1) longitude of origin.
    +
    101 C> - 6): resolution flag (right adj copy of octet 17).
    +
    102 C> - 7): la(2) latitude of last grid point.
    +
    103 C> - 8): lo(2) longitude of last grid point.
    +
    104 C> - 9): latit - latitude of projection intersection.
    +
    105 C> - 10: reserved.
    +
    106 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    107 C> - 12: longitudinal dir grid length.
    +
    108 C> - 13: latitudinal dir grid length.
    +
    109 C> - Lambert conformal grids.
    +
    110 C> - 2): nx nr points along x-axis.
    +
    111 C> - 3): ny nr points along y-axis.
    +
    112 C> - 4): la1 lat of origin (lower left).
    +
    113 C> - 5): lo1 lon of origin (lower left).
    +
    114 C> - 6): resolution (right adj copy of octet 17).
    +
    115 C> - 7): lov - orientation of grid.
    +
    116 C> - 8): dx - x-dir increment.
    +
    117 C> - 9): dy - y-dir increment.
    +
    118 C> - 10: projection center flag.
    +
    119 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    120 C> - 12: latin 1 - first lat from pole of secant cone inter.
    +
    121 C> - 13: latin 2 - second lat from pole of secant cone inter.
    +
    122 C> @param[in] kens integer (200) ensemble pds parms.
    +
    123 C> - 1): application identifier.
    +
    124 C> - 2): ensemble type.
    +
    125 C> - 3): ensemble identifier.
    +
    126 C> - 4): product identifier.
    +
    127 C> - 5): smoothing flag.
    +
    128 C> @param[in] kprob integer (2) probability ensemble parms.
    +
    129 C> @param[in] xprob real (2) probability ensemble parms.
    +
    130 C> @param[in] kclust integer (16) cluster ensemble parms.
    +
    131 C> @param[in] kmembr integer (8) cluster ensemble parms.
    +
    132 C> @param[in] lb logical*1 (kf) bitmap if present.
    +
    133 C> @param[in] f real (kf) data.
    +
    134 C> @param[out] iret integer return code.
    +
    135 C> - 0 all ok.
    +
    136 C> - other w3fi72 grib packer return code.
    +
    137 C>
    +
    138 C> @note Subprogram can be called from a multiprocessing environment.
    +
    139 C> Do not engage the same logical unit from more than one processor.
    +
    140 C>
    +
    141 C> @author Mark Iredell @date 1994-04-01
    +
    142 C-----------------------------------------------------------------------
    +
    143  SUBROUTINE putgbex(LUGB,KF,KPDS,KGDS,KENS,
    +
    144  & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET)
    +
    145  INTEGER KPDS(200),KGDS(200),KENS(200)
    +
    146  INTEGER KPROB(2),KCLUST(16),KMEMBR(80)
    +
    147  REAL XPROB(2)
    +
    148  LOGICAL*1 LB(KF)
    +
    149  REAL F(KF)
    +
    150  parameter(maxbit=16)
    +
    151  INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200)
    +
    152  REAL FR(KF)
    +
    153  CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8)
    +
    154 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    155 C GET W3FI72 PARAMETERS
    +
    156  CALL r63w72(kpds,kgds,ipds,igds)
    +
    157  ibds=0
    +
    158 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    159 C COUNT VALID DATA
    +
    160  kbm=kf
    +
    161  IF(ipds(7).NE.0) THEN
    +
    162  kbm=0
    +
    163  DO i=1,kf
    +
    164  IF(lb(i)) THEN
    +
    165  ibm(i)=1
    +
    166  kbm=kbm+1
    +
    167  ELSE
    +
    168  ibm(i)=0
    +
    169  ENDIF
    +
    170  ENDDO
    +
    171  IF(kbm.EQ.kf) ipds(7)=0
    +
    172  ENDIF
    +
    173 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    174 C GET NUMBER OF BITS AND ROUND DATA
    +
    175  IF(kbm.EQ.0) THEN
    +
    176  DO i=1,kf
    +
    177  fr(i)=0.
    +
    178  ENDDO
    +
    179  nbit=0
    +
    180  ELSE
    +
    181  CALL getbit(ipds(7),0,ipds(25),kf,ibm,f,fr,fmin,fmax,nbit)
    +
    182  nbit=min(nbit,maxbit)
    +
    183  ENDIF
    +
    184 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    185 C CREATE PRODUCT DEFINITION SECTION
    +
    186  CALL w3fi68(ipds,pds)
    +
    187  IF(ipds(24).EQ.2) THEN
    +
    188  ilast=86
    +
    189  CALL pdsens(kens,kprob,xprob,kclust,kmembr,ilast,pds)
    +
    190  ENDIF
    +
    191 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    192 C PACK AND WRITE GRIB DATA
    +
    193  CALL w3fi72(0,fr,0,nbit,1,ipds,pds,
    +
    194  & 1,255,igds,0,0,ibm,kf,ibds,
    +
    195  & kfo,grib,lgrib,iret)
    +
    196  IF(iret.EQ.0) CALL wryte(lugb,lgrib,grib)
    +
    197 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    198  RETURN
    +
    199  END
    +
    +
    +
    r63w72
    subroutine r63w72(KPDS, KGDS, IPDS, IGDS)
    Determines the integer PDS and GDS parameters for the GRIB1 packing routine w3fi72() given the parame...
    Definition: r63w72.f:27
    +
    putgbex
    subroutine putgbex(LUGB, KF, KPDS, KGDS, KENS, KPROB, XPROB, KCLUST, KMEMBR, LB, F, IRET)
    This subprogram is nearly the inverse of getgbe.
    Definition: putgbex.f:145
    +
    pdsens
    subroutine pdsens(KENS, KPROB, XPROB, KCLUST, KMEMBR, ILAST, MSGA)
    Packs brib pds extension starting on byte 41 for ensemble forecast products.
    Definition: pdsens.f:28
    +
    w3fi72
    subroutine w3fi72(ITYPE, FLD, IFLD, IBITL, IPFLAG, ID, PDS, IGFLAG, IGRID, IGDS, ICOMP, IBFLAG, IBMAP, IBLEN, IBDSFL, NPTS, KBUF, ITOT, JERR)
    Makes a complete GRIB message from a user supplied array of floating point or integer data.
    Definition: w3fi72.f:121
    +
    w3fi68
    subroutine w3fi68(ID, PDS)
    Converts an array of 25, or 27 integer words into a grib product definition section (pds) of 28 bytes...
    Definition: w3fi68.f:85
    + + + + diff --git a/ver-2.10.0/putgbn_8f.html b/ver-2.10.0/putgbn_8f.html new file mode 100644 index 00000000..3f4bf084 --- /dev/null +++ b/ver-2.10.0/putgbn_8f.html @@ -0,0 +1,340 @@ + + + + + + + +NCEPLIBS-w3emc: putgbn.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    putgbn.f File Reference
    +
    +
    + +

    Packs and writes a grib message. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine putgbn (LUGB, KF, KPDS, KGDS, IBS, NBITS, LB, F, IRET)
     This subprogram is nearly the inverse of getgb. More...
     
    +

    Detailed Description

    +

    Packs and writes a grib message.

    +
    Author
    Mark Iredell
    +
    Date
    1994-04-01
    + +

    Definition in file putgbn.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ putgbn()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine putgbn ( LUGB,
     KF,
    integer, dimension(200) KPDS,
    integer, dimension(200) KGDS,
     IBS,
     NBITS,
    logical*1, dimension(kf) LB,
    real, dimension(kf) F,
     IRET 
    )
    +
    + +

    This subprogram is nearly the inverse of getgb.

    +

    Program history log:

      +
    • Mark Iredell 1994-04-01
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints.
      • +
    +
    Parameters
    + + + + + + + + + + +
    [in]lugbinteger unit of the unblocked grib data file.
    [in]kfinteger number of data points.
    [in]kpdsinteger (200) pds parameters.
      +
    • 1): id of center.
      • +
    • 2): generating process id number.
      • +
    • 3): grid definition.
      • +
    • 4): gds/bms flag (right adj copy of octet 8).
      • +
    • 5): indicator of parameter.
      • +
    • 6): type of level.
      • +
    • 7): height/pressure , etc of level.
      • +
    • 8): year including (century-1).
      • +
    • 9): month of year.
      • +
    • 10: day of month.
      • +
    • 11: hour of day.
      • +
    • 12: minute of hour.
      • +
    • 13: indicator of forecast time unit.
      • +
    • 14: time range 1.
      • +
    • 15: time range 2.
      • +
    • 16: time range flag.
      • +
    • 17: number included in average.
      • +
    • 18: version nr of grib specification.
      • +
    • 19: version nr of parameter table.
      • +
    • 20: nr missing from average/accumulation.
      • +
    • 21: century of reference time of data.
      • +
    • 22: units decimal scale factor.
      • +
    • 23: subcenter number.
      • +
    • 24: pds byte 29, for nmc ensemble products.
        +
      • 128 if forecast field error.
        • +
      • 64 if bias corrected fcst field.
        • +
      • 32 if smoothed field.
        • +
      • warning: can be combination of more than 1.
        • +
      +
      • +
    • 25: pds byte 30, not used.
      • +
    +
    [in]kgdsinteger (200) gds parameters.
      +
    • 1): data representation type.
      • +
    • 19: number of vertical coordinate parameters.
      • +
    • 20: octet number of the list of vertical coordinate parameters or octet number of the list of numbers of points in each row or 255 if neither are present.
      • +
    • 21: for grids with pl, number of points in grid.
      • +
    • 22: number of words in each row.
      • +
    • Latitude/longitude grids.
        +
      • 2): n(i) nr points on latitude circle.
        • +
      • 3): n(j) nr points on longitude meridian.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): la(2) latitude of extreme point.
        • +
      • 8): lo(2) longitude of extreme point.
        • +
      • 9): di longitudinal direction of increment.
        • +
      • 10: dj latitudinal direction increment.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      +
      • +
    • Gaussian grids.
        +
      • 2): n(i) nr points on latitude circle.
        • +
      • 3): n(j) nr points on longitude meridian.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): la(2) latitude of extreme point.
        • +
      • 8): lo(2) longitude of extreme point.
        • +
      • 9): di longitudinal direction of increment.
        • +
      • 10: n - nr of circles pole to equator.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: nv - nr of vert coord parameters.
        • +
      • 13: pv - octet nr of list of vert coord parameters or pl - location of the list of numbers of points in each row (if no vert coord parameters are present) or 255 if neither are present.
        • +
      +
      • +
    • Polar stereographic grids.
        +
      • 2): n(i) nr points along lat circle.
        • +
      • 3): n(j) nr points along lon circle.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): lov grid orientation.
        • +
      • 8): dx - x direction increment.
        • +
      • 9): dy - y direction increment.
        • +
      • 10: projection center flag.
        • +
      • 11: scanning mode (right adj copy of octet 28).
        • +
      +
      • +
    • Spherical harmonic coefficients.
        +
      • 2): j pentagonal resolution parameter.
        • +
      • 3): k pentagonal resolution parameter.
        • +
      • 4): m pentagonal resolution parameter.
        • +
      • 5): representation type.
        • +
      • 6): coefficient storage mode.
        • +
      +
      • +
    • Mercator grids.
        +
      • 2): n(i) nr points on latitude circle.
        • +
      • 3): n(j) nr points on longitude meridian.
        • +
      • 4): la(1) latitude of origin.
        • +
      • 5): lo(1) longitude of origin.
        • +
      • 6): resolution flag (right adj copy of octet 17).
        • +
      • 7): la(2) latitude of last grid point.
        • +
      • 8): lo(2) longitude of last grid point.
        • +
      • 9): latit - latitude of projection intersection.
        • +
      • 10: reserved.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: longitudinal dir grid length.
        • +
      • 13: latitudinal dir grid length.
        • +
      +
      • +
    • Lambert conformal grids.
        +
      • 2): nx nr points along x-axis.
        • +
      • 3): ny nr points along y-axis.
        • +
      • 4): la1 lat of origin (lower left).
        • +
      • 5): lo1 lon of origin (lower left).
        • +
      • 6): resolution (right adj copy of octet 17).
        • +
      • 7): lov - orientation of grid.
        • +
      • 8): dx - x-dir increment.
        • +
      • 9): dy - y-dir increment.
        • +
      • 10: projection center flag.
        • +
      • 11: scanning mode flag (right adj copy of octet 28).
        • +
      • 12: latin 1 - first lat from pole of secant cone inter.
        • +
      • 13: latin 2 - second lat from pole of secant cone inter.
        • +
      +
      • +
    +
    [in]ibsinteger binary scale factor (0 to ignore).
    [in]nbitsinteger number of bits in which to pack (0 to ignore).
    [in]lblogical*1 (kf) bitmap if present.
    [in]freal (kf) data.
    [out]iretinteger return code.
      +
    • 0 all ok.
      • +
    • other w3fi72 grib packer return code.
      • +
    +
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment. Do not engage the same logical unit from more than one processor.
    +
    Author
    Mark Iredell
    +
    Date
    1994-04-01
    + +

    Definition at line 135 of file putgbn.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/putgbn_8f.js b/ver-2.10.0/putgbn_8f.js new file mode 100644 index 00000000..db45184a --- /dev/null +++ b/ver-2.10.0/putgbn_8f.js @@ -0,0 +1,4 @@ +var putgbn_8f = +[ + [ "putgbn", "putgbn_8f.html#ad639ec06d322cda9f568c75b98aacc67", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/putgbn_8f_source.html b/ver-2.10.0/putgbn_8f_source.html new file mode 100644 index 00000000..37588a5d --- /dev/null +++ b/ver-2.10.0/putgbn_8f_source.html @@ -0,0 +1,291 @@ + + + + + + + +NCEPLIBS-w3emc: putgbn.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    putgbn.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Packs and writes a grib message.
    +
    3 C> @author Mark Iredell @date 1994-04-01
    +
    4 
    +
    5 C> This subprogram is nearly the inverse of getgb.
    +
    6 C>
    +
    7 C> Program history log:
    +
    8 C> - Mark Iredell 1994-04-01
    +
    9 C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    10 C>
    +
    11 C> @param[in] lugb integer unit of the unblocked grib data file.
    +
    12 C> @param[in] kf integer number of data points.
    +
    13 C> @param[in] kpds integer (200) pds parameters.
    +
    14 C> - 1): id of center.
    +
    15 C> - 2): generating process id number.
    +
    16 C> - 3): grid definition.
    +
    17 C> - 4): gds/bms flag (right adj copy of octet 8).
    +
    18 C> - 5): indicator of parameter.
    +
    19 C> - 6): type of level.
    +
    20 C> - 7): height/pressure , etc of level.
    +
    21 C> - 8): year including (century-1).
    +
    22 C> - 9): month of year.
    +
    23 C> - 10: day of month.
    +
    24 C> - 11: hour of day.
    +
    25 C> - 12: minute of hour.
    +
    26 C> - 13: indicator of forecast time unit.
    +
    27 C> - 14: time range 1.
    +
    28 C> - 15: time range 2.
    +
    29 C> - 16: time range flag.
    +
    30 C> - 17: number included in average.
    +
    31 C> - 18: version nr of grib specification.
    +
    32 C> - 19: version nr of parameter table.
    +
    33 C> - 20: nr missing from average/accumulation.
    +
    34 C> - 21: century of reference time of data.
    +
    35 C> - 22: units decimal scale factor.
    +
    36 C> - 23: subcenter number.
    +
    37 C> - 24: pds byte 29, for nmc ensemble products.
    +
    38 C> - 128 if forecast field error.
    +
    39 C> - 64 if bias corrected fcst field.
    +
    40 C> - 32 if smoothed field.
    +
    41 C> - warning: can be combination of more than 1.
    +
    42 C> - 25: pds byte 30, not used.
    +
    43 C> @param[in] kgds integer (200) gds parameters.
    +
    44 C> - 1): data representation type.
    +
    45 C> - 19: number of vertical coordinate parameters.
    +
    46 C> - 20: octet number of the list of vertical coordinate parameters or
    +
    47 C> octet number of the list of numbers of points in each row or
    +
    48 C> 255 if neither are present.
    +
    49 C> - 21: for grids with pl, number of points in grid.
    +
    50 C> - 22: number of words in each row.
    +
    51 C> - Latitude/longitude grids.
    +
    52 C> - 2): n(i) nr points on latitude circle.
    +
    53 C> - 3): n(j) nr points on longitude meridian.
    +
    54 C> - 4): la(1) latitude of origin.
    +
    55 C> - 5): lo(1) longitude of origin.
    +
    56 C> - 6): resolution flag (right adj copy of octet 17).
    +
    57 C> - 7): la(2) latitude of extreme point.
    +
    58 C> - 8): lo(2) longitude of extreme point.
    +
    59 C> - 9): di longitudinal direction of increment.
    +
    60 C> - 10: dj latitudinal direction increment.
    +
    61 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    62 C> - Gaussian grids.
    +
    63 C> - 2): n(i) nr points on latitude circle.
    +
    64 C> - 3): n(j) nr points on longitude meridian.
    +
    65 C> - 4): la(1) latitude of origin.
    +
    66 C> - 5): lo(1) longitude of origin.
    +
    67 C> - 6): resolution flag (right adj copy of octet 17).
    +
    68 C> - 7): la(2) latitude of extreme point.
    +
    69 C> - 8): lo(2) longitude of extreme point.
    +
    70 C> - 9): di longitudinal direction of increment.
    +
    71 C> - 10: n - nr of circles pole to equator.
    +
    72 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    73 C> - 12: nv - nr of vert coord parameters.
    +
    74 C> - 13: pv - octet nr of list of vert coord parameters or
    +
    75 C> pl - location of the list of numbers of points in
    +
    76 C> each row (if no vert coord parameters are present) or
    +
    77 C> 255 if neither are present.
    +
    78 C> - Polar stereographic grids.
    +
    79 C> - 2): n(i) nr points along lat circle.
    +
    80 C> - 3): n(j) nr points along lon circle.
    +
    81 C> - 4): la(1) latitude of origin.
    +
    82 C> - 5): lo(1) longitude of origin.
    +
    83 C> - 6): resolution flag (right adj copy of octet 17).
    +
    84 C> - 7): lov grid orientation.
    +
    85 C> - 8): dx - x direction increment.
    +
    86 C> - 9): dy - y direction increment.
    +
    87 C> - 10: projection center flag.
    +
    88 C> - 11: scanning mode (right adj copy of octet 28).
    +
    89 C> - Spherical harmonic coefficients.
    +
    90 C> - 2): j pentagonal resolution parameter.
    +
    91 C> - 3): k pentagonal resolution parameter.
    +
    92 C> - 4): m pentagonal resolution parameter.
    +
    93 C> - 5): representation type.
    +
    94 C> - 6): coefficient storage mode.
    +
    95 C> - Mercator grids.
    +
    96 C> - 2): n(i) nr points on latitude circle.
    +
    97 C> - 3): n(j) nr points on longitude meridian.
    +
    98 C> - 4): la(1) latitude of origin.
    +
    99 C> - 5): lo(1) longitude of origin.
    +
    100 C> - 6): resolution flag (right adj copy of octet 17).
    +
    101 C> - 7): la(2) latitude of last grid point.
    +
    102 C> - 8): lo(2) longitude of last grid point.
    +
    103 C> - 9): latit - latitude of projection intersection.
    +
    104 C> - 10: reserved.
    +
    105 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    106 C> - 12: longitudinal dir grid length.
    +
    107 C> - 13: latitudinal dir grid length.
    +
    108 C> - Lambert conformal grids.
    +
    109 C> - 2): nx nr points along x-axis.
    +
    110 C> - 3): ny nr points along y-axis.
    +
    111 C> - 4): la1 lat of origin (lower left).
    +
    112 C> - 5): lo1 lon of origin (lower left).
    +
    113 C> - 6): resolution (right adj copy of octet 17).
    +
    114 C> - 7): lov - orientation of grid.
    +
    115 C> - 8): dx - x-dir increment.
    +
    116 C> - 9): dy - y-dir increment.
    +
    117 C> - 10: projection center flag.
    +
    118 C> - 11: scanning mode flag (right adj copy of octet 28).
    +
    119 C> - 12: latin 1 - first lat from pole of secant cone inter.
    +
    120 C> - 13: latin 2 - second lat from pole of secant cone inter.
    +
    121 C> @param[in] ibs integer binary scale factor (0 to ignore).
    +
    122 C> @param[in] nbits integer number of bits in which to pack (0 to ignore).
    +
    123 C> @param[in] lb logical*1 (kf) bitmap if present.
    +
    124 C> @param[in] f real (kf) data.
    +
    125 C> @param[out] iret integer return code.
    +
    126 C> - 0 all ok.
    +
    127 C> - other w3fi72 grib packer return code.
    +
    128 C>
    +
    129 C> @note Subprogram can be called from a multiprocessing environment.
    +
    130 C> Do not engage the same logical unit from more than one processor.
    +
    131 C>
    +
    132 C> @author Mark Iredell @date 1994-04-01
    +
    133 C-----------------------------------------------------------------------
    +
    134  SUBROUTINE putgbn(LUGB,KF,KPDS,KGDS,IBS,NBITS,LB,F,IRET)
    +
    135  INTEGER KPDS(200),KGDS(200)
    +
    136  LOGICAL*1 LB(KF)
    +
    137  REAL F(KF)
    +
    138  parameter(maxbit=16)
    +
    139  INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200)
    +
    140  REAL FR(KF)
    +
    141  CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8)
    +
    142 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    143 C GET W3FI72 PARAMETERS
    +
    144  CALL r63w72(kpds,kgds,ipds,igds)
    +
    145  ibds=0
    +
    146 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    147 C COUNT VALID DATA
    +
    148  kbm=kf
    +
    149  IF(ipds(7).NE.0) THEN
    +
    150  kbm=0
    +
    151  DO i=1,kf
    +
    152  IF(lb(i)) THEN
    +
    153  ibm(i)=1
    +
    154  kbm=kbm+1
    +
    155  ELSE
    +
    156  ibm(i)=0
    +
    157  ENDIF
    +
    158  ENDDO
    +
    159  IF(kbm.EQ.kf) ipds(7)=0
    +
    160  ENDIF
    +
    161 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    162 C GET NUMBER OF BITS AND ROUND DATA
    +
    163  IF(nbits.GT.0) THEN
    +
    164  DO i=1,kf
    +
    165  fr(i)=f(i)
    +
    166  ENDDO
    +
    167  nbit=nbits
    +
    168  ELSE
    +
    169  IF(kbm.EQ.0) THEN
    +
    170  DO i=1,kf
    +
    171  fr(i)=0.
    +
    172  ENDDO
    +
    173  nbit=0
    +
    174  ELSE
    +
    175  CALL getbit(ipds(7),ibs,ipds(25),kf,ibm,f,fr,fmin,fmax,nbit)
    +
    176  nbit=min(nbit,maxbit)
    +
    177  ENDIF
    +
    178  ENDIF
    +
    179 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    180 C PACK AND WRITE GRIB DATA
    +
    181  CALL w3fi72(0,fr,0,nbit,0,ipds,pds,
    +
    182  & 1,255,igds,0,0,ibm,kf,ibds,
    +
    183  & kfo,grib,lgrib,iret)
    +
    184  IF(iret.EQ.0) CALL wryte(lugb,lgrib,grib)
    +
    185 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    186  RETURN
    +
    187  END
    +
    +
    +
    putgbn
    subroutine putgbn(LUGB, KF, KPDS, KGDS, IBS, NBITS, LB, F, IRET)
    This subprogram is nearly the inverse of getgb.
    Definition: putgbn.f:135
    +
    r63w72
    subroutine r63w72(KPDS, KGDS, IPDS, IGDS)
    Determines the integer PDS and GDS parameters for the GRIB1 packing routine w3fi72() given the parame...
    Definition: r63w72.f:27
    +
    w3fi72
    subroutine w3fi72(ITYPE, FLD, IFLD, IBITL, IPFLAG, ID, PDS, IGFLAG, IGRID, IGDS, ICOMP, IBFLAG, IBMAP, IBLEN, IBDSFL, NPTS, KBUF, ITOT, JERR)
    Makes a complete GRIB message from a user supplied array of floating point or integer data.
    Definition: w3fi72.f:121
    + + + + diff --git a/ver-2.10.0/q9ie32_8f.html b/ver-2.10.0/q9ie32_8f.html new file mode 100644 index 00000000..cc237125 --- /dev/null +++ b/ver-2.10.0/q9ie32_8f.html @@ -0,0 +1,186 @@ + + + + + + + +NCEPLIBS-w3emc: q9ie32.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    q9ie32.f File Reference
    +
    +
    + +

    Convert IBM370 F.P. to IEEE F.P. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine q9ie32 (A, B, N, ISTAT)
     Convert ibm370 32 bit floating point numbers to ieee 32 bit task 754 floating point numbers. More...
     
    +

    Detailed Description

    +

    Convert IBM370 F.P. to IEEE F.P.

    +
    Author
    Ralph Jones
    +
    Date
    1990-06-04
    + +

    Definition in file q9ie32.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ q9ie32()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine q9ie32 (integer(4), dimension(*) A,
    integer(4), dimension(*) B,
     N,
     ISTAT 
    )
    +
    + +

    Convert ibm370 32 bit floating point numbers to ieee 32 bit task 754 floating point numbers.

    +

    Program history log:

      +
    • Ralph Jones 1990-06-04 Change to sun fortran 1.3
      • +
    • Ralph Jones 1990-07-14 Change ishft to lshift or lrshft
      • +
    • Ralph Jones 1991-03-09 Change to silicongraphics fortran
      • +
    • Ralph Jones 1992-07-20 Change to ibm aix xl fortran
      • +
    • Ralph Jones 1995-11-15 Add save statement
      • +
    • Stephen Gilbert 1998-11-15 Specified 4-byte integers for IBM SP
      • +
    +
    Parameters
    + + + + + +
    [in]AREAL*4 Array of ibm370 32 bit floating point numbers.
    [out]NNumber of points to convert.
    [out]BREAL*4 Array of ieee 32 bit floating point numbers.
    [out]ISTATNumber of point greater than 10e+38, numbers are set to ieee infinity, one is added to istat. Numbers less than e-38 are set to zero, one is not added to istat.
    +
    +
    +
    Note
    See ieee task 754 standard floating point arithmetic for more information about IEEE F.P.
    +
    Author
    Ralph Jones
    +
    Date
    1990-06-04
    + +

    Definition at line 28 of file q9ie32.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/q9ie32_8f.js b/ver-2.10.0/q9ie32_8f.js new file mode 100644 index 00000000..2190eb9e --- /dev/null +++ b/ver-2.10.0/q9ie32_8f.js @@ -0,0 +1,4 @@ +var q9ie32_8f = +[ + [ "q9ie32", "q9ie32_8f.html#a7cfc294cd548b96adbe4ccd72fc656c1", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/q9ie32_8f_source.html b/ver-2.10.0/q9ie32_8f_source.html new file mode 100644 index 00000000..1174aac5 --- /dev/null +++ b/ver-2.10.0/q9ie32_8f_source.html @@ -0,0 +1,232 @@ + + + + + + + +NCEPLIBS-w3emc: q9ie32.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    q9ie32.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert IBM370 F.P. to IEEE F.P.
    +
    3 C> @author Ralph Jones @date 1990-06-04
    +
    4 
    +
    5 C> Convert ibm370 32 bit floating point numbers to ieee
    +
    6 C> 32 bit task 754 floating point numbers.
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - Ralph Jones 1990-06-04 Change to sun fortran 1.3
    +
    10 C> - Ralph Jones 1990-07-14 Change ishft to lshift or lrshft
    +
    11 C> - Ralph Jones 1991-03-09 Change to silicongraphics fortran
    +
    12 C> - Ralph Jones 1992-07-20 Change to ibm aix xl fortran
    +
    13 C> - Ralph Jones 1995-11-15 Add save statement
    +
    14 C> - Stephen Gilbert 1998-11-15 Specified 4-byte integers for IBM SP
    +
    15 C>
    +
    16 C> @param[in] A REAL*4 Array of ibm370 32 bit floating point numbers.
    +
    17 C> @param[out] N Number of points to convert.
    +
    18 C> @param[out] B REAL*4 Array of ieee 32 bit floating point numbers.
    +
    19 C> @param[out] ISTAT Number of point greater than 10e+38, numbers are set to
    +
    20 c> ieee infinity, one is added to istat. Numbers less than
    +
    21 c> e-38 are set to zero, one is not added to istat.
    +
    22 C>
    +
    23 C> @note See ieee task 754 standard floating point arithmetic
    +
    24 C> for more information about IEEE F.P.
    +
    25 C>
    +
    26 C> @author Ralph Jones @date 1990-06-04
    +
    27  SUBROUTINE q9ie32(A,B,N,ISTAT)
    +
    28 C
    +
    29  INTEGER(4) A(*)
    +
    30  INTEGER(4) B(*)
    +
    31  INTEGER(4) SIGN
    +
    32  INTEGER(4) INFIN,MASKFR,MASKSN,MASK21,MASK22,MASK23
    +
    33  INTEGER(4) ITEMP,ISIGN,IEEEXP,K,LTEMP
    +
    34 C
    +
    35  SAVE
    +
    36 C
    +
    37  DATA infin /z'7F800000'/
    +
    38  DATA maskfr/z'007FFFFF'/
    +
    39  DATA masksn/z'7FFFFFFF'/
    +
    40  DATA mask21/z'00200000'/
    +
    41  DATA mask22/z'00400000'/
    +
    42  DATA mask23/z'00800000'/
    +
    43  DATA sign /z'80000000'/
    +
    44 C
    +
    45  IF (n.LT.1) THEN
    +
    46  istat = -1
    +
    47  RETURN
    +
    48  ENDIF
    +
    49 C
    +
    50  istat = 0
    +
    51 C
    +
    52  DO 40 i = 1,n
    +
    53  isign = 0
    +
    54  itemp = a(i)
    +
    55 C
    +
    56 C TEST SIGN BIT
    +
    57 C
    +
    58  IF (itemp.EQ.0) GO TO 30
    +
    59 C
    +
    60  IF (itemp.LT.0) THEN
    +
    61 C
    +
    62  isign = sign
    +
    63 C
    +
    64 C SET SIGN BIT TO ZERO
    +
    65 C
    +
    66  itemp = iand(itemp,masksn)
    +
    67 C
    +
    68  END IF
    +
    69 C
    +
    70 C
    +
    71 C CONVERT IBM EXPONENT TO IEEE EXPONENT
    +
    72 C
    +
    73  ieeexp = (ishft(itemp,-24_4) - 64_4) * 4 + 126
    +
    74 C
    +
    75  k = 0
    +
    76 C
    +
    77 C TEST BIT 23, 22, 21
    +
    78 C ADD UP NUMBER OF ZERO BITS IN FRONT OF IBM370 FRACTION
    +
    79 C
    +
    80  IF (iand(itemp,mask23).NE.0) GO TO 10
    +
    81  k = k + 1
    +
    82  IF (iand(itemp,mask22).NE.0) GO TO 10
    +
    83  k = k + 1
    +
    84  IF (iand(itemp,mask21).NE.0) GO TO 10
    +
    85  k = k + 1
    +
    86 C
    +
    87  10 CONTINUE
    +
    88 C
    +
    89 C SUBTRACT ZERO BITS FROM EXPONENT
    +
    90 C
    +
    91  ieeexp = ieeexp - k
    +
    92 C
    +
    93 C TEST FOR OVERFLOW
    +
    94 C
    +
    95  IF (ieeexp.GT.254) GO TO 20
    +
    96 C
    +
    97 C TEST FOR UNDERFLOW
    +
    98 C
    +
    99  IF (ieeexp.LT.1) GO TO 30
    +
    100 C
    +
    101 C SHIFT IEEE EXPONENT TO BITS 1 TO 8
    +
    102 C
    +
    103  ltemp = ishft(ieeexp,23_4)
    +
    104 C
    +
    105 C SHIFT IBM370 FRACTION LEFT K BIT, AND OUT BITS 0 - 8
    +
    106 C OR TOGETHER THE EXPONENT AND THE FRACTION
    +
    107 C OR IN SIGN BIT
    +
    108 C
    +
    109  b(i) = ior(ior(iand(ishft(itemp,k),maskfr),ltemp),isign)
    +
    110 C
    +
    111  GO TO 40
    +
    112 C
    +
    113  20 CONTINUE
    +
    114 C
    +
    115 C OVERFLOW , SET TO IEEE INFINITY, ADD 1 TO OVERFLOW COUNTER
    +
    116 C
    +
    117  istat = istat + 1
    +
    118  b(i) = ior(infin,isign)
    +
    119  GO TO 40
    +
    120 C
    +
    121  30 CONTINUE
    +
    122 C
    +
    123 C UNDERFLOW , SET TO ZERO
    +
    124 C
    +
    125  b(i) = 0
    +
    126 C
    +
    127  40 CONTINUE
    +
    128 C
    +
    129  RETURN
    +
    130  END
    +
    +
    +
    q9ie32
    subroutine q9ie32(A, B, N, ISTAT)
    Convert ibm370 32 bit floating point numbers to ieee 32 bit task 754 floating point numbers.
    Definition: q9ie32.f:28
    + + + + diff --git a/ver-2.10.0/r63w72_8f.html b/ver-2.10.0/r63w72_8f.html new file mode 100644 index 00000000..9542c90d --- /dev/null +++ b/ver-2.10.0/r63w72_8f.html @@ -0,0 +1,185 @@ + + + + + + + +NCEPLIBS-w3emc: r63w72.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    r63w72.f File Reference
    +
    +
    + +

    Convert w3fi63() parms to w3fi72() parms. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine r63w72 (KPDS, KGDS, IPDS, IGDS)
     Determines the integer PDS and GDS parameters for the GRIB1 packing routine w3fi72() given the parameters returned from the GRIB1 unpacking routine w3fi63(). More...
     
    +

    Detailed Description

    +

    Convert w3fi63() parms to w3fi72() parms.

    +
    Author
    Mark Iredell
    +
    Date
    1992-10-31
    + +

    Definition in file r63w72.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ r63w72()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine r63w72 (dimension(200) KPDS,
    dimension(200) KGDS,
    dimension(200) IPDS,
    dimension(200) IGDS 
    )
    +
    + +

    Determines the integer PDS and GDS parameters for the GRIB1 packing routine w3fi72() given the parameters returned from the GRIB1 unpacking routine w3fi63().

    +

    Program history log:

      +
    • Mark Iredell 1991-10-31
      • +
    • Mark Iredell 1996-05-03 Corrected some level types and some data representation types
      • +
    • Mark Iredell 1997-02-14 Only altered ipds(26:27) for extended pds
      • +
    • Chris Caruso 1998-06-01 Y2K fix for year of century
      • +
    • Diane Stoken 2005-05-06 Recognize level 236
      • +
    +
    Note
    kgds and igds extend beyond their dimensions here if pl parameters are present.
    +
    Parameters
    + + + + + +
    [in]kpdsinteger (200) PDS parameters from w3fi63().
    [in]kgdsinteger (200) GDS parameters from w3fi63().
    [out]ipdsinteger (200) PDS parameters for w3fi72().
    [out]igdsinteger (200) GDS parameters for w3fi72().
    +
    +
    +
    Author
    Mark Iredell
    +
    Date
    1992-10-31
    + +

    Definition at line 27 of file r63w72.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/r63w72_8f.js b/ver-2.10.0/r63w72_8f.js new file mode 100644 index 00000000..c5c92870 --- /dev/null +++ b/ver-2.10.0/r63w72_8f.js @@ -0,0 +1,4 @@ +var r63w72_8f = +[ + [ "r63w72", "r63w72_8f.html#a071601493ea893c59ed2b8fac3cf9116", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/r63w72_8f_source.html b/ver-2.10.0/r63w72_8f_source.html new file mode 100644 index 00000000..917693ca --- /dev/null +++ b/ver-2.10.0/r63w72_8f_source.html @@ -0,0 +1,218 @@ + + + + + + + +NCEPLIBS-w3emc: r63w72.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    r63w72.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert w3fi63() parms to w3fi72() parms.
    +
    3 C> @author Mark Iredell @date 1992-10-31
    +
    4 
    +
    5 C> Determines the integer PDS and GDS parameters
    +
    6 C> for the GRIB1 packing routine w3fi72() given the parameters
    +
    7 C> returned from the GRIB1 unpacking routine w3fi63().
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - Mark Iredell 1991-10-31
    +
    11 C> - Mark Iredell 1996-05-03 Corrected some level types and
    +
    12 C> some data representation types
    +
    13 C> - Mark Iredell 1997-02-14 Only altered ipds(26:27) for extended pds
    +
    14 C> - Chris Caruso 1998-06-01 Y2K fix for year of century
    +
    15 C> - Diane Stoken 2005-05-06 Recognize level 236
    +
    16 C>
    +
    17 C> @note kgds and igds extend beyond their dimensions here
    +
    18 C> if pl parameters are present.
    +
    19 C>
    +
    20 C> @param[in] kpds integer (200) PDS parameters from w3fi63().
    +
    21 C> @param[in] kgds integer (200) GDS parameters from w3fi63().
    +
    22 C> @param[out] ipds integer (200) PDS parameters for w3fi72().
    +
    23 C> @param[out] igds integer (200) GDS parameters for w3fi72().
    +
    24 C>
    +
    25 C> @author Mark Iredell @date 1992-10-31
    +
    26  SUBROUTINE r63w72(KPDS,KGDS,IPDS,IGDS)
    +
    27  dimension kpds(200),kgds(200),ipds(200),igds(200)
    +
    28 
    +
    29 C DETERMINE PRODUCT DEFINITION SECTION (PDS) PARAMETERS
    +
    30  IF(kpds(23).NE.2) THEN
    +
    31  ipds(1)=28 ! LENGTH OF PDS
    +
    32  ELSE
    +
    33  ipds(1)=45 ! LENGTH OF PDS
    +
    34  ENDIF
    +
    35  ipds(2)=kpds(19) ! PARAMETER TABLE VERSION
    +
    36  ipds(3)=kpds(1) ! ORIGINATING CENTER
    +
    37  ipds(4)=kpds(2) ! GENERATING MODEL
    +
    38  ipds(5)=kpds(3) ! GRID DEFINITION
    +
    39  ipds(6)=mod(kpds(4)/128,2) ! GDS FLAG
    +
    40  ipds(7)=mod(kpds(4)/64,2) ! BMS FLAG
    +
    41  ipds(8)=kpds(5) ! PARAMETER INDICATOR
    +
    42  ipds(9)=kpds(6) ! LEVEL TYPE
    +
    43  IF(kpds(6).EQ.101.OR.kpds(6).EQ.104.OR.kpds(6).EQ.106.OR.
    +
    44  & kpds(6).EQ.108.OR.kpds(6).EQ.110.OR.kpds(6).EQ.112.OR.
    +
    45  & kpds(6).EQ.114.OR.kpds(6).EQ.116.OR.kpds(6).EQ.121.OR.
    +
    46  & kpds(6).EQ.128.OR.kpds(6).EQ.141.OR.kpds(6).EQ.236) THEN
    +
    47  ipds(10)=mod(kpds(7)/256,256) ! LEVEL VALUE 1
    +
    48  ipds(11)=mod(kpds(7),256) ! LEVEL VALUE 2
    +
    49  ELSE
    +
    50  ipds(10)=0 ! LEVEL VALUE 1
    +
    51  ipds(11)=kpds(7) ! LEVEL VALUE 2
    +
    52  ENDIF
    +
    53  ipds(12)=kpds(8) ! YEAR OF CENTURY
    +
    54  ipds(13)=kpds(9) ! MONTH
    +
    55  ipds(14)=kpds(10) ! DAY
    +
    56  ipds(15)=kpds(11) ! HOUR
    +
    57  ipds(16)=kpds(12) ! MINUTE
    +
    58  ipds(17)=kpds(13) ! FORECAST TIME UNIT
    +
    59  ipds(18)=kpds(14) ! TIME RANGE 1
    +
    60  ipds(19)=kpds(15) ! TIME RANGE 2
    +
    61  ipds(20)=kpds(16) ! TIME RANGE INDICATOR
    +
    62  ipds(21)=kpds(17) ! NUMBER IN AVERAGE
    +
    63  ipds(22)=kpds(20) ! NUMBER MISSING IN AVERAGE
    +
    64  ipds(23)=kpds(21) ! CENTURY
    +
    65  ipds(24)=kpds(23) ! SUBCENTER
    +
    66  ipds(25)=kpds(22) ! DECIMAL SCALING
    +
    67  IF(ipds(1).GT.28) THEN
    +
    68  ipds(26)=0 ! PDS BYTE 29
    +
    69  ipds(27)=0 ! PDS BYTE 30
    +
    70  ENDIF
    +
    71 
    +
    72 C DETERMINE GRID DEFINITION SECTION (GDS) PARAMETERS
    +
    73  igds(1)=kgds(19) ! NUMBER OF VERTICAL COORDINATES
    +
    74  igds(2)=kgds(20) ! VERTICAL COORDINATES
    +
    75  igds(3)=kgds(1) ! DATA REPRESENTATION
    +
    76  igds(4)=kgds(2) ! (UNIQUE TO REPRESENTATION)
    +
    77  igds(5)=kgds(3) ! (UNIQUE TO REPRESENTATION)
    +
    78  igds(6)=kgds(4) ! (UNIQUE TO REPRESENTATION)
    +
    79  igds(7)=kgds(5) ! (UNIQUE TO REPRESENTATION)
    +
    80  igds(8)=kgds(6) ! (UNIQUE TO REPRESENTATION)
    +
    81  igds(9)=kgds(7) ! (UNIQUE TO REPRESENTATION)
    +
    82  igds(10)=kgds(8) ! (UNIQUE TO REPRESENTATION)
    +
    83  igds(11)=kgds(9) ! (UNIQUE TO REPRESENTATION)
    +
    84  igds(12)=kgds(10) ! (UNIQUE TO REPRESENTATION)
    +
    85  igds(13)=kgds(11) ! (UNIQUE TO REPRESENTATION)
    +
    86  igds(14)=kgds(12) ! (UNIQUE TO REPRESENTATION)
    +
    87  igds(15)=kgds(13) ! (UNIQUE TO REPRESENTATION)
    +
    88  igds(16)=kgds(14) ! (UNIQUE TO REPRESENTATION)
    +
    89  igds(17)=kgds(15) ! (UNIQUE TO REPRESENTATION)
    +
    90  igds(18)=kgds(16) ! (UNIQUE TO REPRESENTATION)
    +
    91 C EXCEPTIONS FOR LATLON OR GAUSSIAN
    +
    92  IF(kgds(1).EQ.0.OR.kgds(1).EQ.4) THEN
    +
    93  igds(11)=kgds(10)
    +
    94  igds(12)=kgds(9)
    +
    95 C EXCEPTIONS FOR MERCATOR
    +
    96  ELSEIF(kgds(1).EQ.1) THEN
    +
    97  igds(11)=kgds(13)
    +
    98  igds(12)=kgds(12)
    +
    99  igds(13)=kgds(9)
    +
    100  igds(14)=kgds(11)
    +
    101 C EXCEPTIONS FOR LAMBERT CONFORMAL
    +
    102  ELSEIF(kgds(1).EQ.3) THEN
    +
    103  igds(15)=kgds(12)
    +
    104  igds(16)=kgds(13)
    +
    105  igds(17)=kgds(14)
    +
    106  igds(18)=kgds(15)
    +
    107  ENDIF
    +
    108 C EXTENSION FOR PL PARAMETERS
    +
    109  IF(kgds(1).EQ.0.AND.kgds(19).EQ.0.AND.kgds(20).NE.255) THEN
    +
    110  DO j=1,kgds(3)
    +
    111  igds(18+j)=kgds(21+j)
    +
    112  ENDDO
    +
    113  ENDIF
    +
    114 
    +
    115  RETURN
    +
    116  END
    +
    +
    +
    r63w72
    subroutine r63w72(KPDS, KGDS, IPDS, IGDS)
    Determines the integer PDS and GDS parameters for the GRIB1 packing routine w3fi72() given the parame...
    Definition: r63w72.f:27
    + + + + diff --git a/ver-2.10.0/resize.js b/ver-2.10.0/resize.js new file mode 100644 index 00000000..a0bb5f45 --- /dev/null +++ b/ver-2.10.0/resize.js @@ -0,0 +1,137 @@ +/* + @licstart The following is the entire license notice for the + JavaScript code in this file. + + Copyright (C) 1997-2017 by Dimitri van Heesch + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + + @licend The above is the entire license notice + for the JavaScript code in this file + */ +function initResizable() +{ + var cookie_namespace = 'doxygen'; + var sidenav,navtree,content,header,collapsed,collapsedWidth=0,barWidth=6,desktop_vp=768,titleHeight; + + function readCookie(cookie) + { + var myCookie = cookie_namespace+"_"+cookie+"="; + if (document.cookie) { + var index = document.cookie.indexOf(myCookie); + if (index != -1) { + var valStart = index + myCookie.length; + var valEnd = document.cookie.indexOf(";", valStart); + if (valEnd == -1) { + valEnd = document.cookie.length; + } + var val = document.cookie.substring(valStart, valEnd); + return val; + } + } + return 0; + } + + function writeCookie(cookie, val, expiration) + { + if (val==undefined) return; + if (expiration == null) { + var date = new Date(); + date.setTime(date.getTime()+(10*365*24*60*60*1000)); // default expiration is one week + expiration = date.toGMTString(); + } + document.cookie = cookie_namespace + "_" + cookie + "=" + val + "; expires=" + expiration+"; path=/"; + } + + function resizeWidth() + { + var windowWidth = $(window).width() + "px"; + var sidenavWidth = $(sidenav).outerWidth(); + content.css({marginLeft:parseInt(sidenavWidth)+"px"}); + writeCookie('width',sidenavWidth-barWidth, null); + } + + function restoreWidth(navWidth) + { + var windowWidth = $(window).width() + "px"; + content.css({marginLeft:parseInt(navWidth)+barWidth+"px"}); + sidenav.css({width:navWidth + "px"}); + } + + function resizeHeight() + { + var headerHeight = header.outerHeight(); + var footerHeight = footer.outerHeight(); + var windowHeight = $(window).height() - headerHeight - footerHeight; + content.css({height:windowHeight + "px"}); + navtree.css({height:windowHeight + "px"}); + sidenav.css({height:windowHeight + "px"}); + var width=$(window).width(); + if (width!=collapsedWidth) { + if (width=desktop_vp) { + if (!collapsed) { + collapseExpand(); + } + } else if (width>desktop_vp && collapsedWidth0) { + restoreWidth(0); + collapsed=true; + } + else { + var width = readCookie('width'); + if (width>200 && width<$(window).width()) { restoreWidth(width); } else { restoreWidth(200); } + collapsed=false; + } + } + + header = $("#top"); + sidenav = $("#side-nav"); + content = $("#doc-content"); + navtree = $("#nav-tree"); + footer = $("#nav-path"); + $(".side-nav-resizable").resizable({resize: function(e, ui) { resizeWidth(); } }); + $(sidenav).resizable({ minWidth: 0 }); + $(window).resize(function() { resizeHeight(); }); + var device = navigator.userAgent.toLowerCase(); + var touch_device = device.match(/(iphone|ipod|ipad|android)/); + if (touch_device) { /* wider split bar for touch only devices */ + $(sidenav).css({ paddingRight:'20px' }); + $('.ui-resizable-e').css({ width:'20px' }); + $('#nav-sync').css({ right:'34px' }); + barWidth=20; + } + var width = readCookie('width'); + if (width) { restoreWidth(width); } else { resizeWidth(); } + resizeHeight(); + var url = location.href; + var i=url.indexOf("#"); + if (i>=0) window.location.hash=url.substr(i); + var _preventDefault = function(evt) { evt.preventDefault(); }; + $("#splitbar").bind("dragstart", _preventDefault).bind("selectstart", _preventDefault); + $(".ui-resizable-handle").dblclick(collapseExpand); + $(window).on('load',resizeHeight); +} +/* @license-end */ diff --git a/ver-2.10.0/sbyte_8f.html b/ver-2.10.0/sbyte_8f.html new file mode 100644 index 00000000..85f78a41 --- /dev/null +++ b/ver-2.10.0/sbyte_8f.html @@ -0,0 +1,174 @@ + + + + + + + +NCEPLIBS-w3emc: sbyte.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    sbyte.f File Reference
    +
    +
    + +

    This is the fortran 32 bit version of sbyte(). +More...

    + +

    Go to the source code of this file.

    + + + + +

    +Functions/Subroutines

    subroutine sbyte (IOUT, IN, ISKIP, NBYTE)
     
    +

    Detailed Description

    +

    This is the fortran 32 bit version of sbyte().

    +
    Author
    Robert Gammill
    +
    Date
    1972-07
    + +

    Definition in file sbyte.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ sbyte()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine sbyte (integer, dimension(*) IOUT,
    integer IN,
     ISKIP,
     NBYTE 
    )
    +
    +
    Parameters
    + + + + + +
    [out]IOUT
    [in]INUnpacked array input
    [in]ISKIPInitial number of bits to skip
    [in]NBYTENumber of bits to pack
    +
    +
    +
    Author
    Robert Gammill
    +
    Date
    1972-07
    + +

    Definition at line 12 of file sbyte.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/sbyte_8f.js b/ver-2.10.0/sbyte_8f.js new file mode 100644 index 00000000..3e980f2a --- /dev/null +++ b/ver-2.10.0/sbyte_8f.js @@ -0,0 +1,4 @@ +var sbyte_8f = +[ + [ "sbyte", "sbyte_8f.html#afbbfa5a4daed1898e1235a221dcf54b2", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/sbyte_8f_source.html b/ver-2.10.0/sbyte_8f_source.html new file mode 100644 index 00000000..c9aaa166 --- /dev/null +++ b/ver-2.10.0/sbyte_8f_source.html @@ -0,0 +1,180 @@ + + + + + + + +NCEPLIBS-w3emc: sbyte.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    sbyte.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief This is the fortran 32 bit version of sbyte().
    +
    3 C> @author Robert Gammill @date 1972-07
    +
    4 
    +
    5 C> @param[out] IOUT
    +
    6 C> @param[in] IN Unpacked array input
    +
    7 C> @param[in] ISKIP Initial number of bits to skip
    +
    8 C> @param[in] NBYTE Number of bits to pack
    +
    9 C>
    +
    10 C> @author Robert Gammill @date 1972-07
    +
    11  SUBROUTINE sbyte(IOUT,IN,ISKIP,NBYTE)
    +
    12  INTEGER IN
    +
    13  INTEGER IOUT(*)
    +
    14  INTEGER MASKS(32)
    +
    15 C
    +
    16  SAVE
    +
    17 C
    +
    18  DATA nbitsw/32/
    +
    19 C
    +
    20 C DATA MASKS /Z'00000001',Z'00000003',Z'00000007',Z'0000000F',
    +
    21 C & Z'0000001F',Z'0000003F',Z'0000007F',Z'000000FF',
    +
    22 C & Z'000001FF',Z'000003FF',Z'000007FF',Z'00000FFF',
    +
    23 C & Z'00001FFF',Z'00003FFF',Z'00007FFF',Z'0000FFFF',
    +
    24 C & Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF',
    +
    25 C & Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF',
    +
    26 C & Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF',
    +
    27 C & Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/
    +
    28 C
    +
    29 C MASK TABLE PUT IN DECIMAL SO IT WILL COMPILE ON AN 32 BIT
    +
    30 C COMPUTER
    +
    31 C
    +
    32  DATA masks / 1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047,
    +
    33  & 4095, 8191, 16383, 32767, 65535, 131071, 262143, 524287,
    +
    34  & 1048575, 2097151, 4194303, 8388607, 16777215, 33554431,
    +
    35  & 67108863, 134217727, 268435455, 536870911, 1073741823,
    +
    36  & 2147483647, -1/
    +
    37 C
    +
    38 C NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW
    +
    39 C
    +
    40  icon = nbitsw - nbyte
    +
    41  IF (icon.LT.0) RETURN
    +
    42  mask = masks(nbyte)
    +
    43 C
    +
    44 C INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED.
    +
    45 C
    +
    46  index = ishft(iskip,-5)
    +
    47 C
    +
    48 C II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT.
    +
    49 C
    +
    50  ii = mod(iskip,nbitsw)
    +
    51 C
    +
    52  j = iand(mask,in)
    +
    53  movel = icon - ii
    +
    54 C
    +
    55 C BYTE IS TO BE STORED IN MIDDLE OF WORD. SHIFT LEFT.
    +
    56 C
    +
    57  IF (movel.GT.0) THEN
    +
    58  msk = ishft(mask,movel)
    +
    59  iout(index+1) = ior(iand(not(msk),iout(index+1)),
    +
    60  & ishft(j,movel))
    +
    61 C
    +
    62 C THE BYTE IS TO BE SPLIT ACROSS A WORD BREAK.
    +
    63 C
    +
    64  ELSE IF (movel.LT.0) THEN
    +
    65  msk = masks(nbyte+movel)
    +
    66  iout(index+1) = ior(iand(not(msk),iout(index+1)),
    +
    67  & ishft(j,movel))
    +
    68  itemp = iand(masks(nbitsw+movel),iout(index+2))
    +
    69  iout(index+2) = ior(itemp,ishft(j,nbitsw+movel))
    +
    70 C
    +
    71 C BYTE IS TO BE STORED RIGHT-ADJUSTED.
    +
    72 C
    +
    73  ELSE
    +
    74  iout(index+1) = ior(iand(not(mask),iout(index+1)),j)
    +
    75  ENDIF
    +
    76 C
    +
    77  RETURN
    +
    78  END
    +
    +
    +
    sbyte
    subroutine sbyte(IOUT, IN, ISKIP, NBYTE)
    Definition: sbyte.f:12
    + + + + diff --git a/ver-2.10.0/sbytec_8f.html b/ver-2.10.0/sbytec_8f.html new file mode 100644 index 00000000..b92e0397 --- /dev/null +++ b/ver-2.10.0/sbytec_8f.html @@ -0,0 +1,175 @@ + + + + + + + +NCEPLIBS-w3emc: sbytec.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    sbytec.f File Reference
    +
    +
    + +

    Wrapper for sbytesc() +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine sbytec (OUT, IN, ISKIP, NBYTE)
     This is a wrapper for sbytesc() More...
     
    +

    Detailed Description

    +

    Wrapper for sbytesc()

    +
    Author
    Unknown
    + +

    Definition in file sbytec.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ sbytec()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine sbytec (character*1, dimension(*) OUT,
    integer, dimension(*) IN,
     ISKIP,
     NBYTE 
    )
    +
    + +

    This is a wrapper for sbytesc()

    +
    Parameters
    + + + + + +
    [in]OUT= packed array output
    [in]IN= unpacked array input
    [in]ISKIP= initial number of bits to skip
    [in]NBYTE= number of bits to pack
    +
    +
    +
    Author
    Unknown
    + +

    Definition at line 14 of file sbytec.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/sbytec_8f.js b/ver-2.10.0/sbytec_8f.js new file mode 100644 index 00000000..a83e6e83 --- /dev/null +++ b/ver-2.10.0/sbytec_8f.js @@ -0,0 +1,4 @@ +var sbytec_8f = +[ + [ "sbytec", "sbytec_8f.html#aa252e1e9e9f8808f95473792d319231b", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/sbytec_8f_source.html b/ver-2.10.0/sbytec_8f_source.html new file mode 100644 index 00000000..0e29fef8 --- /dev/null +++ b/ver-2.10.0/sbytec_8f_source.html @@ -0,0 +1,121 @@ + + + + + + + +NCEPLIBS-w3emc: sbytec.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    sbytec.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Wrapper for sbytesc()
    +
    3 C> @author Unknown
    +
    4 
    +
    5 C> This is a wrapper for sbytesc()
    +
    6 C> @param[in] OUT = packed array output
    +
    7 C> @param[in] IN = unpacked array input
    +
    8 C> @param[in] ISKIP = initial number of bits to skip
    +
    9 C> @param[in] NBYTE = number of bits to pack
    +
    10 C>
    +
    11 C> @author Unknown
    +
    12 
    +
    13  SUBROUTINE sbytec(OUT,IN,ISKIP,NBYTE)
    +
    14  character*1 out(*)
    +
    15  integer in(*)
    +
    16  CALL sbytesc(out,in,iskip,nbyte,0,1)
    +
    17  RETURN
    +
    18  END
    +
    +
    +
    sbytesc
    subroutine sbytesc(OUT, IN, ISKIP, NBYTE, NSKIP, N)
    Store bytes - pack bits: Put arbitrary size values into a packed bit string, taking the low order bit...
    Definition: sbytesc.f:17
    +
    sbytec
    subroutine sbytec(OUT, IN, ISKIP, NBYTE)
    This is a wrapper for sbytesc()
    Definition: sbytec.f:14
    + + + + diff --git a/ver-2.10.0/sbytes_8f.html b/ver-2.10.0/sbytes_8f.html new file mode 100644 index 00000000..a297f94c --- /dev/null +++ b/ver-2.10.0/sbytes_8f.html @@ -0,0 +1,134 @@ + + + + + + + +NCEPLIBS-w3emc: sbytes.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    sbytes.f File Reference
    +
    +
    + +

    This is the fortran versions of sbytes(). +More...

    + +

    Go to the source code of this file.

    + + + + +

    +Functions/Subroutines

    +subroutine sbytes (IOUT, IN, ISKIP, NBYTE, NSKIP, N)
     
    +

    Detailed Description

    +

    This is the fortran versions of sbytes().

    +
    Author
    Robert C. Gammill
    +
    Date
    1972-07
    +
    Parameters
    + + + + + + + +
    IOUT
    IN= unpacked array input
    ISKIP= initial number of bits to skip
    NBYTE= number of bits to pack
    NSKIP= additional number of bits to skip on each iteration
    N= number of iterations
    +
    +
    +
    Author
    Robert C. Gammill
    +
    Date
    1972-07
    + +

    Definition in file sbytes.f.

    +
    +
    + + + + diff --git a/ver-2.10.0/sbytes_8f.js b/ver-2.10.0/sbytes_8f.js new file mode 100644 index 00000000..b729f03c --- /dev/null +++ b/ver-2.10.0/sbytes_8f.js @@ -0,0 +1,4 @@ +var sbytes_8f = +[ + [ "sbytes", "sbytes_8f.html#a1035e9be6e9ea85af3581de7da3e90bc", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/sbytes_8f_source.html b/ver-2.10.0/sbytes_8f_source.html new file mode 100644 index 00000000..749f6bcc --- /dev/null +++ b/ver-2.10.0/sbytes_8f_source.html @@ -0,0 +1,210 @@ + + + + + + + +NCEPLIBS-w3emc: sbytes.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    sbytes.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief This is the fortran versions of sbytes().
    +
    3 C> @author Robert C. Gammill @date 1972-07
    +
    4 C>
    +
    5 C> @param IOUT
    +
    6 C> @param IN = unpacked array input
    +
    7 C> @param ISKIP = initial number of bits to skip
    +
    8 C> @param NBYTE = number of bits to pack
    +
    9 C> @param NSKIP = additional number of bits to skip on each iteration
    +
    10 C> @param N = number of iterations
    +
    11 C>
    +
    12 C> @author Robert C. Gammill @date 1972-07
    +
    13  SUBROUTINE sbytes(IOUT,IN,ISKIP,NBYTE,NSKIP,N)
    +
    14 C
    +
    15 C
    +
    16 C Changes for SiliconGraphics IRIS-4D/25
    +
    17 C SiliconGraphics 3.3 FORTRAN 77
    +
    18 C March 1991 RUSSELL E. JONES
    +
    19 C NATIONAL WEATHER SERVICE
    +
    20 C
    +
    21  INTEGER IN(*)
    +
    22  INTEGER IOUT(*)
    +
    23  INTEGER MASKS(32)
    +
    24 C
    +
    25  SAVE
    +
    26 C
    +
    27  DATA nbitsw/32/
    +
    28 C
    +
    29 C DATA MASKS /Z'00000001',Z'00000003',Z'00000007',Z'0000000F',
    +
    30 C & Z'0000001F',Z'0000003F',Z'0000007F',Z'000000FF',
    +
    31 C & Z'000001FF',Z'000003FF',Z'000007FF',Z'00000FFF',
    +
    32 C & Z'00001FFF',Z'00003FFF',Z'00007FFF',Z'0000FFFF',
    +
    33 C & Z'0001FFFF',Z'0003FFFF',Z'0007FFFF',Z'000FFFFF',
    +
    34 C & Z'001FFFFF',Z'003FFFFF',Z'007FFFFF',Z'00FFFFFF',
    +
    35 C & Z'01FFFFFF',Z'03FFFFFF',Z'07FFFFFF',Z'0FFFFFFF',
    +
    36 C & Z'1FFFFFFF',Z'3FFFFFFF',Z'7FFFFFFF',Z'FFFFFFFF'/
    +
    37 C
    +
    38 C MASKS TABLE PUT IN DECIMAL SO IT WILL COMPILE ON ANY 32 BIT
    +
    39 C COMPUTER
    +
    40 C
    +
    41  DATA masks / 1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047,
    +
    42  & 4095, 8191, 16383, 32767, 65535, 131071, 262143, 524287,
    +
    43  & 1048575, 2097151, 4194303, 8388607, 16777215, 33554431,
    +
    44  & 67108863, 134217727, 268435455, 536870911, 1073741823,
    +
    45  & 2147483647, -1/
    +
    46 C
    +
    47 C NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW
    +
    48 C
    +
    49  icon = nbitsw - nbyte
    +
    50  IF (icon.LT.0) RETURN
    +
    51  mask = masks(nbyte)
    +
    52 C
    +
    53 C INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED.
    +
    54 C
    +
    55  index = ishft(iskip,-5)
    +
    56 C
    +
    57 C II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT.
    +
    58 C
    +
    59  ii = mod(iskip,nbitsw)
    +
    60 C
    +
    61 C ISTEP IS THE DISTANCE IN BITS FROM ONE BYTE POSITION TO THE NEXT.
    +
    62 C
    +
    63  istep = nbyte + nskip
    +
    64 C
    +
    65 C IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT.
    +
    66 C
    +
    67  iwords = istep / nbitsw
    +
    68 C
    +
    69 C IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS.
    +
    70 C
    +
    71  ibits = mod(istep,nbitsw)
    +
    72 C
    +
    73  DO 10 i = 1,n
    +
    74  j = iand(mask,in(i))
    +
    75  movel = icon - ii
    +
    76 C
    +
    77 C BYTE IS TO BE STORED IN MIDDLE OF WORD. SHIFT LEFT.
    +
    78 C
    +
    79  IF (movel.GT.0) THEN
    +
    80  msk = ishft(mask,movel)
    +
    81  iout(index+1) = ior(iand(not(msk),iout(index+1)),
    +
    82  & ishft(j,movel))
    +
    83 C
    +
    84 C THE BYTE IS TO BE SPLIT ACROSS A WORD BREAK.
    +
    85 C
    +
    86  ELSE IF (movel.LT.0) THEN
    +
    87  msk = masks(nbyte+movel)
    +
    88  iout(index+1) = ior(iand(not(msk),iout(index+1)),
    +
    89  & ishft(j,movel))
    +
    90  itemp = iand(masks(nbitsw+movel),iout(index+2))
    +
    91  iout(index+2) = ior(itemp,ishft(j,nbitsw+movel))
    +
    92 C
    +
    93 C BYTE IS TO BE STORED RIGHT-ADJUSTED.
    +
    94 C
    +
    95  ELSE
    +
    96  iout(index+1) = ior(iand(not(mask),iout(index+1)),j)
    +
    97  ENDIF
    +
    98 C
    +
    99  ii = ii + ibits
    +
    100  index = index + iwords
    +
    101  IF (ii.GE.nbitsw) THEN
    +
    102  ii = ii - nbitsw
    +
    103  index = index + 1
    +
    104  ENDIF
    +
    105 C
    +
    106 10 CONTINUE
    +
    107 C
    +
    108  RETURN
    +
    109  END
    +
    +
    + + + + diff --git a/ver-2.10.0/sbytesc_8f.html b/ver-2.10.0/sbytesc_8f.html new file mode 100644 index 00000000..c8e23b46 --- /dev/null +++ b/ver-2.10.0/sbytesc_8f.html @@ -0,0 +1,189 @@ + + + + + + + +NCEPLIBS-w3emc: sbytesc.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    sbytesc.f File Reference
    +
    +
    + +

    Put arbitrary size values into a packed bit string. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine sbytesc (OUT, IN, ISKIP, NBYTE, NSKIP, N)
     Store bytes - pack bits: Put arbitrary size values into a packed bit string, taking the low order bits from each value in the unpacked array. More...
     
    +

    Detailed Description

    +

    Put arbitrary size values into a packed bit string.

    +
    Author
    Unknown
    + +

    Definition in file sbytesc.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ sbytesc()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine sbytesc (character*1, dimension(*) OUT,
    integer, dimension(n) IN,
     ISKIP,
     NBYTE,
     NSKIP,
     N 
    )
    +
    + +

    Store bytes - pack bits: Put arbitrary size values into a packed bit string, taking the low order bits from each value in the unpacked array.

    +
    Parameters
    + + + + + + + +
    OUT= packed array output.
    IN= unpacked array input.
    ISKIP= initial number of bits to skip.
    NBYTE= number of bits to pack.
    NSKIP= additional number of bits to skip on each iteration.
    N= number of iterations.
    +
    +
    +
    Author
    Unknown
    + +

    Definition at line 17 of file sbytesc.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/sbytesc_8f.js b/ver-2.10.0/sbytesc_8f.js new file mode 100644 index 00000000..30ce0d00 --- /dev/null +++ b/ver-2.10.0/sbytesc_8f.js @@ -0,0 +1,4 @@ +var sbytesc_8f = +[ + [ "sbytesc", "sbytesc_8f.html#aa527f56385adc86efba0d8605f251088", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/sbytesc_8f_source.html b/ver-2.10.0/sbytesc_8f_source.html new file mode 100644 index 00000000..9964b43c --- /dev/null +++ b/ver-2.10.0/sbytesc_8f_source.html @@ -0,0 +1,168 @@ + + + + + + + +NCEPLIBS-w3emc: sbytesc.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    sbytesc.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Put arbitrary size values into a packed bit string.
    +
    3 C> @author Unknown
    +
    4 
    +
    5 C> Store bytes - pack bits: Put arbitrary size values into a
    +
    6 C> packed bit string, taking the low order bits from each value
    +
    7 C> in the unpacked array.
    +
    8 C> @param OUT = packed array output.
    +
    9 C> @param IN = unpacked array input.
    +
    10 C> @param ISKIP = initial number of bits to skip.
    +
    11 C> @param NBYTE = number of bits to pack.
    +
    12 C> @param NSKIP = additional number of bits to skip on each iteration.
    +
    13 C> @param N = number of iterations.
    +
    14 C>
    +
    15 C> @author Unknown
    +
    16  SUBROUTINE sbytesc(OUT,IN,ISKIP,NBYTE,NSKIP,N)
    +
    17  character*1 out(*)
    +
    18  integer in(N), bitcnt, ones(8), tbit
    +
    19  save ones
    +
    20  data ones/ 1, 3, 7, 15, 31, 63,127,255/
    +
    21 
    +
    22 c number bits from zero to ...
    +
    23 c nbit is the last bit of the field to be filled
    +
    24 
    +
    25  nbit = iskip + nbyte - 1
    +
    26  do i = 1, n
    +
    27  itmp = in(i)
    +
    28  bitcnt = nbyte
    +
    29  index=nbit/8+1
    +
    30  ibit=mod(nbit,8)
    +
    31  nbit = nbit + nbyte + nskip
    +
    32 
    +
    33 c make byte aligned
    +
    34  if (ibit.ne.7) then
    +
    35  tbit = min(bitcnt,ibit+1)
    +
    36  imask = ishft(ones(tbit),7-ibit)
    +
    37  itmp2 = iand(ishft(itmp,7-ibit),imask)
    +
    38  itmp3 = iand(mova2i(out(index)), 255-imask)
    +
    39  out(index) = char(ior(itmp2,itmp3))
    +
    40  bitcnt = bitcnt - tbit
    +
    41  itmp = ishft(itmp, -tbit)
    +
    42  index = index - 1
    +
    43  endif
    +
    44 
    +
    45 c now byte aligned
    +
    46 
    +
    47 c do by bytes
    +
    48  do while (bitcnt.ge.8)
    +
    49  out(index) = char(iand(itmp,255))
    +
    50  itmp = ishft(itmp,-8)
    +
    51  bitcnt = bitcnt - 8
    +
    52  index = index - 1
    +
    53  enddo
    +
    54 
    +
    55 c do last byte
    +
    56 
    +
    57  if (bitcnt.gt.0) then
    +
    58  itmp2 = iand(itmp,ones(bitcnt))
    +
    59  itmp3 = iand(mova2i(out(index)), 255-ones(bitcnt))
    +
    60  out(index) = char(ior(itmp2,itmp3))
    +
    61  endif
    +
    62  enddo
    +
    63 
    +
    64  return
    +
    65  end
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    sbytesc
    subroutine sbytesc(OUT, IN, ISKIP, NBYTE, NSKIP, N)
    Store bytes - pack bits: Put arbitrary size values into a packed bit string, taking the low order bit...
    Definition: sbytesc.f:17
    + + + + diff --git a/ver-2.10.0/search/all_0.html b/ver-2.10.0/search/all_0.html new file mode 100644 index 00000000..26dd244f --- /dev/null +++ b/ver-2.10.0/search/all_0.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_0.js b/ver-2.10.0/search/all_0.js new file mode 100644 index 00000000..e8e20918 --- /dev/null +++ b/ver-2.10.0/search/all_0.js @@ -0,0 +1,15 @@ +var searchData= +[ + ['aea_0',['aea',['../aea_8f.html#a9c58c678406a71b9db512ab40864666c',1,'aea.f']]], + ['aea_2ef_1',['aea.f',['../aea_8f.html',1,'']]], + ['ai081_2',['ai081',['../w3ai08_8f.html#a441b7146a653d41877d19a7cd64efb7c',1,'w3ai08.f']]], + ['ai082_3',['ai082',['../w3ai08_8f.html#afa6093fcf5580f32f3ff8be92af6b0e3',1,'w3ai08.f']]], + ['ai082a_4',['ai082a',['../w3ai08_8f.html#a720103ce8519bc682230c8757c6fb8e9',1,'w3ai08.f']]], + ['ai083_5',['ai083',['../w3ai08_8f.html#a7031bf0f0b33cba1e5c2334224e735a1',1,'w3ai08.f']]], + ['ai084_6',['ai084',['../w3ai08_8f.html#a1ac753d2f7d6ce69d4e1412af879b7b9',1,'w3ai08.f']]], + ['ai085_7',['ai085',['../w3ai08_8f.html#a220caa94dfc83c8a73d224245c9469da',1,'w3ai08.f']]], + ['ai085a_8',['ai085a',['../w3ai08_8f.html#a7ecf84941a754cb8d8a328c77f038de0',1,'w3ai08.f']]], + ['ai087_9',['ai087',['../w3ai08_8f.html#ac73cef7b08d3fbe6549b6db66ae7b49f',1,'w3ai08.f']]], + ['args_5fmod_10',['args_mod',['../namespaceargs__mod.html',1,'']]], + ['args_5fmod_2ef_11',['args_mod.f',['../args__mod_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/all_1.html b/ver-2.10.0/search/all_1.html new file mode 100644 index 00000000..8eb215b9 --- /dev/null +++ b/ver-2.10.0/search/all_1.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_1.js b/ver-2.10.0/search/all_1.js new file mode 100644 index 00000000..9ed90eef --- /dev/null +++ b/ver-2.10.0/search/all_1.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['bucket_12',['bucket',['../summary_8c.html#ac30f918e4632256526a027a73c95da78',1,'summary.c']]] +]; diff --git a/ver-2.10.0/search/all_10.html b/ver-2.10.0/search/all_10.html new file mode 100644 index 00000000..6fd3a4aa --- /dev/null +++ b/ver-2.10.0/search/all_10.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_10.js b/ver-2.10.0/search/all_10.js new file mode 100644 index 00000000..4a8e56ab --- /dev/null +++ b/ver-2.10.0/search/all_10.js @@ -0,0 +1,288 @@ +var searchData= +[ + ['w3ai00_236',['w3ai00',['../w3ai00_8f.html#a076bf45857d517709ef249c89a0791e5',1,'w3ai00.f']]], + ['w3ai00_2ef_237',['w3ai00.f',['../w3ai00_8f.html',1,'']]], + ['w3ai01_238',['w3ai01',['../w3ai01_8f.html#a222326720cc27c198b6808bd3f601e4a',1,'w3ai01.f']]], + ['w3ai01_2ef_239',['w3ai01.f',['../w3ai01_8f.html',1,'']]], + ['w3ai08_240',['w3ai08',['../w3ai08_8f.html#a8ca96c27a72b383415773ff07d2027dd',1,'w3ai08.f']]], + ['w3ai08_2ef_241',['w3ai08.f',['../w3ai08_8f.html',1,'']]], + ['w3ai15_242',['w3ai15',['../w3ai15_8f.html#acb162c72ac381b1874762eff242118d5',1,'w3ai15.f']]], + ['w3ai15_2ef_243',['w3ai15.f',['../w3ai15_8f.html',1,'']]], + ['w3ai18_244',['w3ai18',['../w3ai18_8f.html#ae424dd6b4902f8abc7a21f878eea26f5',1,'w3ai18.f']]], + ['w3ai18_2ef_245',['w3ai18.f',['../w3ai18_8f.html',1,'']]], + ['w3ai19_246',['w3ai19',['../w3ai19_8f.html#ada69d8346ce6a030bc9f722fb842529c',1,'w3ai19.f']]], + ['w3ai19_2ef_247',['w3ai19.f',['../w3ai19_8f.html',1,'']]], + ['w3ai24_248',['w3ai24',['../w3ai24_8f.html#a425d9890956ae872557a04b715deb3f2',1,'w3ai24.f']]], + ['w3ai24_2ef_249',['w3ai24.f',['../w3ai24_8f.html',1,'']]], + ['w3ai38_250',['w3ai38',['../w3ai38_8f.html#a65ce63976c2011a17a8f44e0d20e074f',1,'w3ai38.f']]], + ['w3ai38_2ef_251',['w3ai38.f',['../w3ai38_8f.html',1,'']]], + ['w3ai39_252',['w3ai39',['../w3ai39_8f.html#a28ca73de8fec4c73859576d1d2e0a219',1,'w3ai39.f']]], + ['w3ai39_2ef_253',['w3ai39.f',['../w3ai39_8f.html',1,'']]], + ['w3ai40_254',['w3ai40',['../w3ai40_8f.html#afecf619ca48a8909617176d5e3b2de84',1,'w3ai40.f']]], + ['w3ai40_2ef_255',['w3ai40.f',['../w3ai40_8f.html',1,'']]], + ['w3ai41_256',['w3ai41',['../w3ai41_8f.html#a07de865f47db3f841722760476742c04',1,'w3ai41.f']]], + ['w3ai41_2ef_257',['w3ai41.f',['../w3ai41_8f.html',1,'']]], + ['w3aq15_258',['w3aq15',['../w3aq15_8f.html#aa2f10d43798cbba2f9089d37ab1fcdaa',1,'w3aq15.f']]], + ['w3aq15_2ef_259',['w3aq15.f',['../w3aq15_8f.html',1,'']]], + ['w3as00_260',['w3as00',['../w3as00_8f.html#ac8d842c4ccf854fbe44fc54123c40529',1,'w3as00.f']]], + ['w3as00_2ef_261',['w3as00.f',['../w3as00_8f.html',1,'']]], + ['w3ctzdat_262',['w3ctzdat',['../w3ctzdat_8f.html#a7a6f88432171c9c1d03d4fc7c3e2d035',1,'w3ctzdat.f']]], + ['w3ctzdat_2ef_263',['w3ctzdat.f',['../w3ctzdat_8f.html',1,'']]], + ['w3difdat_264',['w3difdat',['../w3difdat_8f.html#a2936ff0b58e9174ca023c557fe3d57b1',1,'w3difdat.f']]], + ['w3difdat_2ef_265',['w3difdat.f',['../w3difdat_8f.html',1,'']]], + ['w3doxdat_266',['w3doxdat',['../w3doxdat_8f.html#aac79cad5709e4bc418ee85ac469afa29',1,'w3doxdat.f']]], + ['w3doxdat_2ef_267',['w3doxdat.f',['../w3doxdat_8f.html',1,'']]], + ['w3fa01_268',['w3fa01',['../w3fa01_8f.html#ae5c40f5b79f9833cb7012d9401bfa7b8',1,'w3fa01.f']]], + ['w3fa01_2ef_269',['w3fa01.f',['../w3fa01_8f.html',1,'']]], + ['w3fa03_270',['w3fa03',['../w3fa03_8f.html#a682b3b6383a8cf898b6f57ce304501e3',1,'w3fa03.f']]], + ['w3fa03_2ef_271',['w3fa03.f',['../w3fa03_8f.html',1,'']]], + ['w3fa03v_2ef_272',['w3fa03v.f',['../w3fa03v_8f.html',1,'']]], + ['w3fa04_273',['w3fa04',['../w3fa04_8f.html#a5f4b61c8c65ffd2662ca4918d08c8fc6',1,'w3fa04.f']]], + ['w3fa04_2ef_274',['w3fa04.f',['../w3fa04_8f.html',1,'']]], + ['w3fa06_275',['w3fa06',['../w3fa06_8f.html#a232d431173943399677b1eb13275bb05',1,'w3fa06.f']]], + ['w3fa06_2ef_276',['w3fa06.f',['../w3fa06_8f.html',1,'']]], + ['w3fa09_277',['w3fa09',['../w3fa09_8f.html#a97cb87ce42a1cba4c96dd80fefb9eafe',1,'w3fa09.f']]], + ['w3fa09_2ef_278',['w3fa09.f',['../w3fa09_8f.html',1,'']]], + ['w3fa11_279',['w3fa11',['../w3fa11_8f.html#ad62a05c9654e2a4aa35667a814dee8a2',1,'w3fa11.f']]], + ['w3fa11_2ef_280',['w3fa11.f',['../w3fa11_8f.html',1,'']]], + ['w3fa12_2ef_281',['w3fa12.f',['../w3fa12_8f.html',1,'']]], + ['w3fa13_282',['w3fa13',['../w3fa13_8f.html#ae3485639e68c6074ead756064096216a',1,'w3fa13.f']]], + ['w3fa13_2ef_283',['w3fa13.f',['../w3fa13_8f.html',1,'']]], + ['w3fb00_284',['w3fb00',['../w3fb00_8f.html#a007817ca2f1dd94a58abdb00f54aab28',1,'w3fb00.f']]], + ['w3fb00_2ef_285',['w3fb00.f',['../w3fb00_8f.html',1,'']]], + ['w3fb01_286',['w3fb01',['../w3fb01_8f.html#a17796145ddabcec090b9d7249091293b',1,'w3fb01.f']]], + ['w3fb01_2ef_287',['w3fb01.f',['../w3fb01_8f.html',1,'']]], + ['w3fb02_288',['w3fb02',['../w3fb02_8f.html#a86b57ee57a85c801ccca67cc7e6ef2a9',1,'w3fb02.f']]], + ['w3fb02_2ef_289',['w3fb02.f',['../w3fb02_8f.html',1,'']]], + ['w3fb03_290',['w3fb03',['../w3fb03_8f.html#a0b68e4622016d2c2fe409ac880d66a3f',1,'w3fb03.f']]], + ['w3fb03_2ef_291',['w3fb03.f',['../w3fb03_8f.html',1,'']]], + ['w3fb04_292',['w3fb04',['../w3fb04_8f.html#a239793420ab239a1a96df658749018ff',1,'w3fb04.f']]], + ['w3fb04_2ef_293',['w3fb04.f',['../w3fb04_8f.html',1,'']]], + ['w3fb05_2ef_294',['w3fb05.f',['../w3fb05_8f.html',1,'']]], + ['w3fb06_295',['w3fb06',['../w3fb06_8f.html#a04de76d1aea61cb48ebcd1470101bca9',1,'w3fb06.f']]], + ['w3fb06_2ef_296',['w3fb06.f',['../w3fb06_8f.html',1,'']]], + ['w3fb07_297',['w3fb07',['../w3fb07_8f.html#a2c8196faf8798dbc2b7593e0a1ec5b68',1,'w3fb07.f']]], + ['w3fb07_2ef_298',['w3fb07.f',['../w3fb07_8f.html',1,'']]], + ['w3fb08_299',['w3fb08',['../w3fb08_8f.html#ad3b516b61a4b4b53e680c775f3e92a5b',1,'w3fb08.f']]], + ['w3fb08_2ef_300',['w3fb08.f',['../w3fb08_8f.html',1,'']]], + ['w3fb09_301',['w3fb09',['../w3fb09_8f.html#a44a5c4c417459876b5cbc4aaab8e4a25',1,'w3fb09.f']]], + ['w3fb09_2ef_302',['w3fb09.f',['../w3fb09_8f.html',1,'']]], + ['w3fb10_303',['w3fb10',['../w3fb10_8f.html#a5f021ccf55ac42f4034f0fd60e612911',1,'w3fb10.f']]], + ['w3fb10_2ef_304',['w3fb10.f',['../w3fb10_8f.html',1,'']]], + ['w3fb11_305',['w3fb11',['../w3fb11_8f.html#a28b19a1336d3f885a04a97831726a3c0',1,'w3fb11.f']]], + ['w3fb11_2ef_306',['w3fb11.f',['../w3fb11_8f.html',1,'']]], + ['w3fb12_307',['w3fb12',['../w3fb12_8f.html#ae5e7ad09f49bf57227336e663c180ee2',1,'w3fb12.f']]], + ['w3fb12_2ef_308',['w3fb12.f',['../w3fb12_8f.html',1,'']]], + ['w3fc02_309',['w3fc02',['../w3fc02_8f.html#a2572657557b50b4f9580f1cf204d7aaf',1,'w3fc02.f']]], + ['w3fc02_2ef_310',['w3fc02.f',['../w3fc02_8f.html',1,'']]], + ['w3fc05_311',['w3fc05',['../w3fc05_8f.html#ae77a21f468d05a34fa3a201c89b30530',1,'w3fc05.f']]], + ['w3fc05_2ef_312',['w3fc05.f',['../w3fc05_8f.html',1,'']]], + ['w3fc06_313',['w3fc06',['../w3fc06_8f.html#a586eff5e859341d86f5ab00dbcca2169',1,'w3fc06.f']]], + ['w3fc06_2ef_314',['w3fc06.f',['../w3fc06_8f.html',1,'']]], + ['w3fc07_315',['w3fc07',['../w3fc07_8f.html#a84dac72c47bb275c7c251c620052b54d',1,'w3fc07.f']]], + ['w3fc07_2ef_316',['w3fc07.f',['../w3fc07_8f.html',1,'']]], + ['w3fc08_317',['w3fc08',['../w3fc08_8f.html#ac768b413af58dd51c57c6bf6d2d48a84',1,'w3fc08.f']]], + ['w3fc08_2ef_318',['w3fc08.f',['../w3fc08_8f.html',1,'']]], + ['w3fi01_319',['w3fi01',['../w3fi01_8f.html#a10ac20498f7eca8e2281cad1218bede4',1,'w3fi01.f']]], + ['w3fi01_2ef_320',['w3fi01.f',['../w3fi01_8f.html',1,'']]], + ['w3fi02_321',['w3fi02',['../w3fi02_8f.html#a217b3130b7e509776b74fde620e5b715',1,'w3fi02.f']]], + ['w3fi02_2ef_322',['w3fi02.f',['../w3fi02_8f.html',1,'']]], + ['w3fi03_323',['w3fi03',['../w3fi03_8f.html#a3cfc13ff3a45dea4c4f6f7c1832df3d3',1,'w3fi03.f']]], + ['w3fi03_2ef_324',['w3fi03.f',['../w3fi03_8f.html',1,'']]], + ['w3fi04_325',['w3fi04',['../w3fi04_8f.html#a43d8dd578a2f24d52b45332ed3ccc6c9',1,'w3fi04.f']]], + ['w3fi04_2ef_326',['w3fi04.f',['../w3fi04_8f.html',1,'']]], + ['w3fi18_327',['w3fi18',['../w3fi18_8f.html#a684daaf76526713839d9d702a2c8aff7',1,'w3fi18.f']]], + ['w3fi18_2ef_328',['w3fi18.f',['../w3fi18_8f.html',1,'']]], + ['w3fi19_329',['w3fi19',['../w3fi19_8f.html#afcb6e01340c836fbd0f940b8c0e6814f',1,'w3fi19.f']]], + ['w3fi19_2ef_330',['w3fi19.f',['../w3fi19_8f.html',1,'']]], + ['w3fi20_331',['w3fi20',['../w3fi20_8f.html#a4d5864f48a1b0a2c1223f3dd4a06059f',1,'w3fi20.f']]], + ['w3fi20_2ef_332',['w3fi20.f',['../w3fi20_8f.html',1,'']]], + ['w3fi32_333',['w3fi32',['../w3fi32_8f.html#a28af7a8a671a5e22f09ba6f371a348db',1,'w3fi32.f']]], + ['w3fi32_2ef_334',['w3fi32.f',['../w3fi32_8f.html',1,'']]], + ['w3fi47_335',['w3fi47',['../w3fi47_8f.html#aa65811b21988f0ddf7568b0a88f12282',1,'w3fi47.f']]], + ['w3fi47_2ef_336',['w3fi47.f',['../w3fi47_8f.html',1,'']]], + ['w3fi48_337',['w3fi48',['../w3fi48_8f.html#af4be979e393742d638626918089c9374',1,'w3fi48.f']]], + ['w3fi48_2ef_338',['w3fi48.f',['../w3fi48_8f.html',1,'']]], + ['w3fi52_339',['w3fi52',['../w3fi52_8f.html#a8ce70b189d09ff2d3acfb478833c640c',1,'w3fi52.f']]], + ['w3fi52_2ef_340',['w3fi52.f',['../w3fi52_8f.html',1,'']]], + ['w3fi58_341',['w3fi58',['../w3fi58_8f.html#a9e29ba5f6e80a0133fdf08c4374d6e5e',1,'w3fi58.f']]], + ['w3fi58_2ef_342',['w3fi58.f',['../w3fi58_8f.html',1,'']]], + ['w3fi59_343',['w3fi59',['../w3fi59_8f.html#ab4f28b2c5e95c681036ef83142a58601',1,'w3fi59.f']]], + ['w3fi59_2ef_344',['w3fi59.f',['../w3fi59_8f.html',1,'']]], + ['w3fi61_345',['w3fi61',['../w3fi61_8f.html#a1b9630713670570f4aef4d99b284bfec',1,'w3fi61.f']]], + ['w3fi61_2ef_346',['w3fi61.f',['../w3fi61_8f.html',1,'']]], + ['w3fi62_347',['w3fi62',['../w3fi62_8f.html#a0dd3e7a53e1e42357c2579cbe74a4f77',1,'w3fi62.f']]], + ['w3fi62_2ef_348',['w3fi62.f',['../w3fi62_8f.html',1,'']]], + ['w3fi63_349',['w3fi63',['../w3fi63_8f.html#aa59740e4c6a30f9c5f201204603d302f',1,'w3fi63.f']]], + ['w3fi63_2ef_350',['w3fi63.f',['../w3fi63_8f.html',1,'']]], + ['w3fi64_351',['w3fi64',['../w3fi64_8f.html#abd64595a92fa11f1d11661e1e94b9dcc',1,'w3fi64.f']]], + ['w3fi64_2ef_352',['w3fi64.f',['../w3fi64_8f.html',1,'']]], + ['w3fi65_353',['w3fi65',['../w3fi65_8f.html#a1651042ec008fbdb77f6b66ee9643d0e',1,'w3fi65.f']]], + ['w3fi65_2ef_354',['w3fi65.f',['../w3fi65_8f.html',1,'']]], + ['w3fi66_355',['w3fi66',['../w3fi66_8f.html#af8839a41e56c22bda1be01a7f877eb5e',1,'w3fi66.f']]], + ['w3fi66_2ef_356',['w3fi66.f',['../w3fi66_8f.html',1,'']]], + ['w3fi67_357',['w3fi67',['../w3fi67_8f.html#af1ebc9eb3165bf0f76af6472109fb4db',1,'w3fi67.f']]], + ['w3fi67_2ef_358',['w3fi67.f',['../w3fi67_8f.html',1,'']]], + ['w3fi68_359',['w3fi68',['../w3fi68_8f.html#a627b0d3ff494874dd3fb243e39cfa991',1,'w3fi68.f']]], + ['w3fi68_2ef_360',['w3fi68.f',['../w3fi68_8f.html',1,'']]], + ['w3fi69_361',['w3fi69',['../w3fi69_8f.html#a725f7f35c86515ca113aa3a36ac133e0',1,'w3fi69.f']]], + ['w3fi69_2ef_362',['w3fi69.f',['../w3fi69_8f.html',1,'']]], + ['w3fi70_363',['w3fi70',['../w3fi70_8f.html#a15c47f82fe6330c213820e90fbe63a92',1,'w3fi70.f']]], + ['w3fi70_2ef_364',['w3fi70.f',['../w3fi70_8f.html',1,'']]], + ['w3fi71_365',['w3fi71',['../w3fi71_8f.html#add1b6b2b2c9fda60094914f5e676ec42',1,'w3fi71.f']]], + ['w3fi71_2ef_366',['w3fi71.f',['../w3fi71_8f.html',1,'']]], + ['w3fi72_367',['w3fi72',['../w3fi72_8f.html#aaac6e022f341c919316466672ef3e70c',1,'w3fi72.f']]], + ['w3fi72_2ef_368',['w3fi72.f',['../w3fi72_8f.html',1,'']]], + ['w3fi73_369',['w3fi73',['../w3fi73_8f.html#a89eedc9b7ba4fd46b1f6ac9eba1f773e',1,'w3fi73.f']]], + ['w3fi73_2ef_370',['w3fi73.f',['../w3fi73_8f.html',1,'']]], + ['w3fi74_371',['w3fi74',['../w3fi74_8f.html#ab921a7e370356989116ba2ac3e429d61',1,'w3fi74.f']]], + ['w3fi74_2ef_372',['w3fi74.f',['../w3fi74_8f.html',1,'']]], + ['w3fi75_373',['w3fi75',['../w3fi75_8f.html#aa4b8fc64e075cd7c24ab51663d4d6912',1,'w3fi75.f']]], + ['w3fi75_2ef_374',['w3fi75.f',['../w3fi75_8f.html',1,'']]], + ['w3fi76_375',['w3fi76',['../w3fi76_8f.html#a5af5a733105c5ce75ddfe99f7249f999',1,'w3fi76.f']]], + ['w3fi76_2ef_376',['w3fi76.f',['../w3fi76_8f.html',1,'']]], + ['w3fi78_377',['w3fi78',['../w3fi78_8f.html#a9c08a6a24a9527776d2b533108dbf261',1,'w3fi78.f']]], + ['w3fi78_2ef_378',['w3fi78.f',['../w3fi78_8f.html',1,'']]], + ['w3fi82_379',['w3fi82',['../w3fi82_8f.html#a9d5c017171cdbf13bde5edff05dcd997',1,'w3fi82.f']]], + ['w3fi82_2ef_380',['w3fi82.f',['../w3fi82_8f.html',1,'']]], + ['w3fi83_381',['w3fi83',['../w3fi83_8f.html#abaae8db75615b215003d0b2591b4e49d',1,'w3fi83.f']]], + ['w3fi83_2ef_382',['w3fi83.f',['../w3fi83_8f.html',1,'']]], + ['w3fi85_383',['w3fi85',['../w3fi85_8f.html#a952501a26ebad493c05a3b8028fc6cd7',1,'w3fi85.f']]], + ['w3fi85_2ef_384',['w3fi85.f',['../w3fi85_8f.html',1,'']]], + ['w3fi88_385',['w3fi88',['../w3fi88_8f.html#aaa3b36f853bace0e172b8191ce3a4f17',1,'w3fi88.f']]], + ['w3fi88_2ef_386',['w3fi88.f',['../w3fi88_8f.html',1,'']]], + ['w3fi92_387',['w3fi92',['../w3fi92_8f.html#a2e8b8ef3dcf66d40422987430e28545a',1,'w3fi92.f']]], + ['w3fi92_2ef_388',['w3fi92.f',['../w3fi92_8f.html',1,'']]], + ['w3fm07_389',['w3fm07',['../w3fm07_8f.html#a3fb4f69f29d16715851691eae8cd482b',1,'w3fm07.f']]], + ['w3fm07_2ef_390',['w3fm07.f',['../w3fm07_8f.html',1,'']]], + ['w3fm08_391',['w3fm08',['../w3fm08_8f.html#ad2e28d805a383d0025c930544cb36155',1,'w3fm08.f']]], + ['w3fm08_2ef_392',['w3fm08.f',['../w3fm08_8f.html',1,'']]], + ['w3fp04_393',['w3fp04',['../w3fp04_8f.html#af033f564bf5f078cbfc4700e62291470',1,'w3fp04.f']]], + ['w3fp04_2ef_394',['w3fp04.f',['../w3fp04_8f.html',1,'']]], + ['w3fp05_395',['w3fp05',['../w3fp05_8f.html#a5d4251a5f962d24d56f5ce0b3b4212b8',1,'w3fp05.f']]], + ['w3fp05_2ef_396',['w3fp05.f',['../w3fp05_8f.html',1,'']]], + ['w3fp06_397',['w3fp06',['../w3fp06_8f.html#afb6a19727a1186c10ede9bba2d3315c0',1,'w3fp06.f']]], + ['w3fp06_2ef_398',['w3fp06.f',['../w3fp06_8f.html',1,'']]], + ['w3fp10_399',['w3fp10',['../w3fp10_8f.html#a2d0f404c14f9e2ea8e6a9f0e911a825e',1,'w3fp10.f']]], + ['w3fp10_2ef_400',['w3fp10.f',['../w3fp10_8f.html',1,'']]], + ['w3fp11_401',['w3fp11',['../w3fp11_8f.html#a60348721f6e1b543427aba610af0a85d',1,'w3fp11.f']]], + ['w3fp11_2ef_402',['w3fp11.f',['../w3fp11_8f.html',1,'']]], + ['w3fp12_403',['w3fp12',['../w3fp12_8f.html#a43259ead9ef06e1822639a8f2aa106aa',1,'w3fp12.f']]], + ['w3fp12_2ef_404',['w3fp12.f',['../w3fp12_8f.html',1,'']]], + ['w3fp13_405',['w3fp13',['../w3fp13_8f.html#a4bb36ff2a73a0614b75ec00e2b804740',1,'w3fp13.f']]], + ['w3fp13_2ef_406',['w3fp13.f',['../w3fp13_8f.html',1,'']]], + ['w3fq07_407',['w3fq07',['../w3fq07_8f.html#a621d5a7f77939450e814033c6f3b1535',1,'w3fq07.f']]], + ['w3fq07_2ef_408',['w3fq07.f',['../w3fq07_8f.html',1,'']]], + ['w3fs13_409',['w3fs13',['../w3fs13_8f.html#a7ae96960810e2a780cc1dfaa4740e4ec',1,'w3fs13.f']]], + ['w3fs13_2ef_410',['w3fs13.f',['../w3fs13_8f.html',1,'']]], + ['w3fs15_411',['w3fs15',['../w3fs15_8f.html#ada3b10209aac56c01b05d096d84e6471',1,'w3fs15.f']]], + ['w3fs15_2ef_412',['w3fs15.f',['../w3fs15_8f.html',1,'']]], + ['w3fs21_413',['w3fs21',['../w3fs21_8f.html#a337c53a535dd6a8066f313eb9889201c',1,'w3fs21.f']]], + ['w3fs21_2ef_414',['w3fs21.f',['../w3fs21_8f.html',1,'']]], + ['w3fs26_415',['w3fs26',['../w3fs26_8f.html#ab9c55405126eb6b249eb3d6542c0bb30',1,'w3fs26.f']]], + ['w3fs26_2ef_416',['w3fs26.f',['../w3fs26_8f.html',1,'']]], + ['w3ft00_417',['w3ft00',['../w3ft00_8f.html#a0df888e118ff615726dfe75f1f268c21',1,'w3ft00.f']]], + ['w3ft00_2ef_418',['w3ft00.f',['../w3ft00_8f.html',1,'']]], + ['w3ft01_419',['w3ft01',['../w3ft01_8f.html#a5712b189cf471fffe9b1529a75949729',1,'w3ft01.f']]], + ['w3ft01_2ef_420',['w3ft01.f',['../w3ft01_8f.html',1,'']]], + ['w3ft02_421',['w3ft02',['../w3ft02_8f.html#ab2829ffb3ea29d17638612b1e6f4bcdf',1,'w3ft02.f']]], + ['w3ft02_2ef_422',['w3ft02.f',['../w3ft02_8f.html',1,'']]], + ['w3ft03_423',['w3ft03',['../w3ft03_8f.html#a86672f0df93a525a9c2f295bf3e9de0b',1,'w3ft03.f']]], + ['w3ft03_2ef_424',['w3ft03.f',['../w3ft03_8f.html',1,'']]], + ['w3ft05_425',['w3ft05',['../w3ft05_8f.html#a752b36aee00d233764c2d4fc9aa83d48',1,'w3ft05.f']]], + ['w3ft05_2ef_426',['w3ft05.f',['../w3ft05_8f.html',1,'']]], + ['w3ft05v_427',['w3ft05v',['../w3ft05v_8f.html#a77ae0ff42d73bc3e901c84d6fae74d60',1,'w3ft05v.f']]], + ['w3ft05v_2ef_428',['w3ft05v.f',['../w3ft05v_8f.html',1,'']]], + ['w3ft06_429',['w3ft06',['../w3ft06_8f.html#a251b117d0bb18aa51a81c14180fda635',1,'w3ft06.f']]], + ['w3ft06_2ef_430',['w3ft06.f',['../w3ft06_8f.html',1,'']]], + ['w3ft06v_431',['w3ft06v',['../w3ft06v_8f.html#a02340fb38509abdb031c638362609844',1,'w3ft06v.f']]], + ['w3ft06v_2ef_432',['w3ft06v.f',['../w3ft06v_8f.html',1,'']]], + ['w3ft07_433',['w3ft07',['../w3ft07_8f.html#a226490ee379923e202ba1f7d0d14102a',1,'w3ft07.f']]], + ['w3ft07_2ef_434',['w3ft07.f',['../w3ft07_8f.html',1,'']]], + ['w3ft08_435',['w3ft08',['../w3ft08_8f.html#ae48a19283d690c37fe8c3dc355e8e609',1,'w3ft08.f']]], + ['w3ft08_2ef_436',['w3ft08.f',['../w3ft08_8f.html',1,'']]], + ['w3ft09_437',['w3ft09',['../w3ft09_8f.html#ac50128472db184365bc4c2dfb1ea1a47',1,'w3ft09.f']]], + ['w3ft09_2ef_438',['w3ft09.f',['../w3ft09_8f.html',1,'']]], + ['w3ft10_439',['w3ft10',['../w3ft10_8f.html#a17871a93f588bd482470dd30d88f6b8c',1,'w3ft10.f']]], + ['w3ft10_2ef_440',['w3ft10.f',['../w3ft10_8f.html',1,'']]], + ['w3ft11_441',['w3ft11',['../w3ft11_8f.html#af60fd501521a85612c264e601718bb68',1,'w3ft11.f']]], + ['w3ft11_2ef_442',['w3ft11.f',['../w3ft11_8f.html',1,'']]], + ['w3ft12_443',['w3ft12',['../w3ft12_8f.html#afb994008cf891b44e3fe4a25c0b46157',1,'w3ft12.f']]], + ['w3ft12_2ef_444',['w3ft12.f',['../w3ft12_8f.html',1,'']]], + ['w3ft16_445',['w3ft16',['../w3ft16_8f.html#a3eb1bcdeb5163086f4e319d036fa9b8f',1,'w3ft16.f']]], + ['w3ft16_2ef_446',['w3ft16.f',['../w3ft16_8f.html',1,'']]], + ['w3ft17_447',['w3ft17',['../w3ft17_8f.html#ac26d2dfc790515275a019ab4588f0751',1,'w3ft17.f']]], + ['w3ft17_2ef_448',['w3ft17.f',['../w3ft17_8f.html',1,'']]], + ['w3ft201_449',['w3ft201',['../w3ft201_8f.html#adf01350dac0812280321527151e91c76',1,'w3ft201.f']]], + ['w3ft201_2ef_450',['w3ft201.f',['../w3ft201_8f.html',1,'']]], + ['w3ft202_451',['w3ft202',['../w3ft202_8f.html#a250a1c3e5855f0481b17a3bf264cb2cd',1,'w3ft202.f']]], + ['w3ft202_2ef_452',['w3ft202.f',['../w3ft202_8f.html',1,'']]], + ['w3ft203_453',['w3ft203',['../w3ft203_8f.html#ac0fba620647d28d2dfd0424c2d3543e8',1,'w3ft203.f']]], + ['w3ft203_2ef_454',['w3ft203.f',['../w3ft203_8f.html',1,'']]], + ['w3ft204_455',['w3ft204',['../w3ft204_8f.html#abb78410bc09aaf18f345e4a90c7cff9f',1,'w3ft204.f']]], + ['w3ft204_2ef_456',['w3ft204.f',['../w3ft204_8f.html',1,'']]], + ['w3ft205_457',['w3ft205',['../w3ft205_8f.html#ad9a3463156cbb99e97f7f3c2f9e0bc26',1,'w3ft205.f']]], + ['w3ft205_2ef_458',['w3ft205.f',['../w3ft205_8f.html',1,'']]], + ['w3ft206_459',['w3ft206',['../w3ft206_8f.html#a8a2d9d2de5ecb622756c8138eab5377c',1,'w3ft206.f']]], + ['w3ft206_2ef_460',['w3ft206.f',['../w3ft206_8f.html',1,'']]], + ['w3ft207_461',['w3ft207',['../w3ft207_8f.html#aa4de7ddd4f65373756f6cd70b3fd6fec',1,'w3ft207.f']]], + ['w3ft207_2ef_462',['w3ft207.f',['../w3ft207_8f.html',1,'']]], + ['w3ft208_463',['w3ft208',['../w3ft208_8f.html#ab3380c5bf59fbd57210787bb91f5584f',1,'w3ft208.f']]], + ['w3ft208_2ef_464',['w3ft208.f',['../w3ft208_8f.html',1,'']]], + ['w3ft209_465',['w3ft209',['../w3ft209_8f.html#a8d2adf2c3f2603ed6555c88d77f0b51b',1,'w3ft209.f']]], + ['w3ft209_2ef_466',['w3ft209.f',['../w3ft209_8f.html',1,'']]], + ['w3ft21_467',['w3ft21',['../w3ft21_8f.html#a681f756a8ebbb0bed83c216be180c4ae',1,'w3ft21.f']]], + ['w3ft21_2ef_468',['w3ft21.f',['../w3ft21_8f.html',1,'']]], + ['w3ft210_469',['w3ft210',['../w3ft210_8f.html#a3803de9cbf2932eb2aa3b36ed8fef355',1,'w3ft210.f']]], + ['w3ft210_2ef_470',['w3ft210.f',['../w3ft210_8f.html',1,'']]], + ['w3ft211_471',['w3ft211',['../w3ft211_8f.html#a353f8903a8cbe06aa931ab815e317708',1,'w3ft211.f']]], + ['w3ft211_2ef_472',['w3ft211.f',['../w3ft211_8f.html',1,'']]], + ['w3ft212_473',['w3ft212',['../w3ft212_8f.html#a80630575cad8c3e8743fb7b161d2b18e',1,'w3ft212.f']]], + ['w3ft212_2ef_474',['w3ft212.f',['../w3ft212_8f.html',1,'']]], + ['w3ft213_475',['w3ft213',['../w3ft213_8f.html#a1de78ace88fde1b28429425c20838344',1,'w3ft213.f']]], + ['w3ft213_2ef_476',['w3ft213.f',['../w3ft213_8f.html',1,'']]], + ['w3ft214_477',['w3ft214',['../w3ft214_8f.html#a87c1f4b3ef6dccfe37b0a288d2143848',1,'w3ft214.f']]], + ['w3ft214_2ef_478',['w3ft214.f',['../w3ft214_8f.html',1,'']]], + ['w3ft26_479',['w3ft26',['../w3ft26_8f.html#a584757389b1cf4707abb4cadb47850ab',1,'w3ft26.f']]], + ['w3ft26_2ef_480',['w3ft26.f',['../w3ft26_8f.html',1,'']]], + ['w3ft32_481',['w3ft32',['../w3ft32_8f.html#acfaec65cdd9e813295e8e83626c176cd',1,'w3ft32.f']]], + ['w3ft32_2ef_482',['w3ft32.f',['../w3ft32_8f.html',1,'']]], + ['w3ft33_483',['w3ft33',['../w3ft33_8f.html#aa788035129e6f04923f7f351fb343ff0',1,'w3ft33.f']]], + ['w3ft33_2ef_484',['w3ft33.f',['../w3ft33_8f.html',1,'']]], + ['w3ft38_485',['w3ft38',['../w3ft38_8f.html#a1826351145421b3de7f51f5b798ae391',1,'w3ft38.f']]], + ['w3ft38_2ef_486',['w3ft38.f',['../w3ft38_8f.html',1,'']]], + ['w3ft39_487',['w3ft39',['../w3ft39_8f.html#a858e5d96caaef7d2d5882420f7bc3556',1,'w3ft39.f']]], + ['w3ft39_2ef_488',['w3ft39.f',['../w3ft39_8f.html',1,'']]], + ['w3ft40_489',['w3ft40',['../w3ft40_8f.html#a3bc42dc396a768eb87167924c73c65d6',1,'w3ft40.f']]], + ['w3ft40_2ef_490',['w3ft40.f',['../w3ft40_8f.html',1,'']]], + ['w3ft41_491',['w3ft41',['../w3ft41_8f.html#a261b10911c4a789b882deef2c1f312ca',1,'w3ft41.f']]], + ['w3ft41_2ef_492',['w3ft41.f',['../w3ft41_8f.html',1,'']]], + ['w3ft43v_493',['w3ft43v',['../w3ft43v_8f.html#a2296d6ab6d8638d5d0d59468cc6402d5',1,'w3ft43v.f']]], + ['w3ft43v_2ef_494',['w3ft43v.f',['../w3ft43v_8f.html',1,'']]], + ['w3kind_495',['w3kind',['../w3kind_8f.html#adbff650124d647848a96ff9e35b0fa4a',1,'w3kind.f']]], + ['w3kind_2ef_496',['w3kind.f',['../w3kind_8f.html',1,'']]], + ['w3locdat_497',['w3locdat',['../w3locdat_8f.html#aa6df8f7e0aa6aa5067becb1ca7a6ebe1',1,'w3locdat.f']]], + ['w3locdat_2ef_498',['w3locdat.f',['../w3locdat_8f.html',1,'']]], + ['w3miscan_499',['w3miscan',['../w3miscan_8f.html#af1352ee5db91f6a057c1378cf9b00df1',1,'w3miscan.f']]], + ['w3miscan_2ef_500',['w3miscan.f',['../w3miscan_8f.html',1,'']]], + ['w3movdat_501',['w3movdat',['../w3movdat_8f.html#a999d6ea7410cb2a3a220722b4ddb7339',1,'w3movdat.f']]], + ['w3movdat_2ef_502',['w3movdat.f',['../w3movdat_8f.html',1,'']]], + ['w3nogds_503',['w3nogds',['../w3nogds_8f.html#a9fee3e95f39d96f49f71d4fe1a681e6a',1,'w3nogds.f']]], + ['w3nogds_2ef_504',['w3nogds.f',['../w3nogds_8f.html',1,'']]], + ['w3pradat_505',['w3pradat',['../w3pradat_8f.html#a519f334382b52df31bbe2240584e41b6',1,'w3pradat.f']]], + ['w3pradat_2ef_506',['w3pradat.f',['../w3pradat_8f.html',1,'']]], + ['w3reddat_507',['w3reddat',['../w3reddat_8f.html#a0b2ac29ce428bb8876dca351df7fb7fb',1,'w3reddat.f']]], + ['w3reddat_2ef_508',['w3reddat.f',['../w3reddat_8f.html',1,'']]], + ['w3tagb_509',['w3tagb',['../w3tagb_8f.html#ac295260f62d3bdcf6c621177ff7d9275',1,'w3tagb.f']]], + ['w3tagb_2ef_510',['w3tagb.f',['../w3tagb_8f.html',1,'']]], + ['w3trnarg_511',['w3trnarg',['../w3trnarg_8f.html#a469f580bad86541dc4ffe778b0eaf9bf',1,'w3trnarg.f']]], + ['w3trnarg_2ef_512',['w3trnarg.f',['../w3trnarg_8f.html',1,'']]], + ['w3unpk77_513',['w3unpk77',['../w3unpk77_8f.html#a162c40d765efa43eeae668a6af507843',1,'w3unpk77.f']]], + ['w3unpk77_2ef_514',['w3unpk77.f',['../w3unpk77_8f.html',1,'']]], + ['w3utcdat_515',['w3utcdat',['../w3utcdat_8f.html#aa33d08dc203b9cc4e7c96e566c7db42a',1,'w3utcdat.f']]], + ['w3utcdat_2ef_516',['w3utcdat.f',['../w3utcdat_8f.html',1,'']]], + ['w3valdat_517',['w3valdat',['../w3valdat_8f.html#a8a051a793c804f190e2da69fd1e16ebe',1,'w3valdat.f']]], + ['w3valdat_2ef_518',['w3valdat.f',['../w3valdat_8f.html',1,'']]], + ['w3ymdh4_519',['w3ymdh4',['../w3ymdh4_8f.html#a78ffe9a370f362c71bcb5573f595f105',1,'w3ymdh4.f']]], + ['w3ymdh4_2ef_520',['w3ymdh4.f',['../w3ymdh4_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/all_11.html b/ver-2.10.0/search/all_11.html new file mode 100644 index 00000000..f78343b9 --- /dev/null +++ b/ver-2.10.0/search/all_11.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_11.js b/ver-2.10.0/search/all_11.js new file mode 100644 index 00000000..9cb736ec --- /dev/null +++ b/ver-2.10.0/search/all_11.js @@ -0,0 +1,9 @@ +var searchData= +[ + ['xdopen_521',['xdopen',['../xdopen_8f.html#a941a5a5172e73a4d75553437ad275ece',1,'xdopen.f']]], + ['xdopen_2ef_522',['xdopen.f',['../xdopen_8f.html',1,'']]], + ['xmovex_523',['xmovex',['../xmovex_8f.html#a4736b412fd765dc34e51e7ebf774cc61',1,'xmovex.f']]], + ['xmovex_2ef_524',['xmovex.f',['../xmovex_8f.html',1,'']]], + ['xstore_525',['xstore',['../xstore_8f.html#a31e695d6327ff9328c6604bc9d72a245',1,'xstore.f']]], + ['xstore_2ef_526',['xstore.f',['../xstore_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/all_2.html b/ver-2.10.0/search/all_2.html new file mode 100644 index 00000000..b26d9165 --- /dev/null +++ b/ver-2.10.0/search/all_2.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_2.js b/ver-2.10.0/search/all_2.js new file mode 100644 index 00000000..ada9618c --- /dev/null +++ b/ver-2.10.0/search/all_2.js @@ -0,0 +1,6 @@ +var searchData= +[ + ['c01o29_13',['c01o29',['../iw3unp29_8f.html#ade469dc7a458658c23096016179ff9e2',1,'iw3unp29.f']]], + ['climo_14',['climo',['../w3fp06_8f.html#aaf8401635d84331960b1c2985cd74a51',1,'w3fp06.f']]], + ['cputim_15',['cputim',['../summary_8c.html#a85f50c91b93171e345aa393946e62aa9',1,'summary.c']]] +]; diff --git a/ver-2.10.0/search/all_3.html b/ver-2.10.0/search/all_3.html new file mode 100644 index 00000000..b61b96f8 --- /dev/null +++ b/ver-2.10.0/search/all_3.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_3.js b/ver-2.10.0/search/all_3.js new file mode 100644 index 00000000..b1695262 --- /dev/null +++ b/ver-2.10.0/search/all_3.js @@ -0,0 +1,9 @@ +var searchData= +[ + ['elapse_16',['elapse',['../summary_8c.html#a5c5678e05ce08da171d237db078d2c30',1,'summary.c']]], + ['end_5ftimer_17',['end_timer',['../summary_8c.html#a91f9293b85b800dfb07ec0ef110e4c22',1,'summary.c']]], + ['errexit_18',['errexit',['../errexit_8f.html#abcd4c3fc1b8b684d5dc7b9412891de91',1,'errexit.f']]], + ['errexit_2ef_19',['errexit.f',['../errexit_8f.html',1,'']]], + ['errmsg_20',['errmsg',['../errmsg_8f.html#acb908fdaebb814b3210e63ecae74c996',1,'errmsg.f']]], + ['errmsg_2ef_21',['errmsg.f',['../errmsg_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/all_4.html b/ver-2.10.0/search/all_4.html new file mode 100644 index 00000000..06de1550 --- /dev/null +++ b/ver-2.10.0/search/all_4.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_4.js b/ver-2.10.0/search/all_4.js new file mode 100644 index 00000000..17b16808 --- /dev/null +++ b/ver-2.10.0/search/all_4.js @@ -0,0 +1,64 @@ +var searchData= +[ + ['fi631_22',['fi631',['../w3fi63_8f.html#a5e07fb32acda017ce2b31674761eddb0',1,'w3fi63.f']]], + ['fi632_23',['fi632',['../w3fi63_8f.html#a49e798fade46eda6b55035a58e136185',1,'w3fi63.f']]], + ['fi633_24',['fi633',['../w3fi63_8f.html#ae00e4a53f6509a2e49276ecc592522d1',1,'w3fi63.f']]], + ['fi634_25',['fi634',['../w3fi63_8f.html#a573937997ce1f78d799c52ba6812d503',1,'w3fi63.f']]], + ['fi634x_26',['fi634x',['../w3fi63_8f.html#abe401baf1479cb539db68da3358232f1',1,'w3fi63.f']]], + ['fi635_27',['fi635',['../w3fi63_8f.html#a88fef913d620c38a8795ad7b93cb73a7',1,'w3fi63.f']]], + ['fi636_28',['fi636',['../w3fi63_8f.html#acf6e1d529f2d31927f198d24b8ca610b',1,'w3fi63.f']]], + ['fi637_29',['fi637',['../w3fi63_8f.html#a7c07c9973bb0370c09e56fa6aa00665a',1,'w3fi63.f']]], + ['fi6701_30',['fi6701',['../w3fi67_8f.html#af1838e0792e8dacd4ba70b0b844065c6',1,'w3fi67.f']]], + ['fi6702_31',['fi6702',['../w3fi67_8f.html#ab4efc955f13221a830e6c653fbe8326b',1,'w3fi67.f']]], + ['fi6703_32',['fi6703',['../w3fi67_8f.html#a85264d1d80f2dcd1c5aef6998179ed21',1,'w3fi67.f']]], + ['fi6704_33',['fi6704',['../w3fi67_8f.html#ad13befc6a11f1be63345c169e4e2c21a',1,'w3fi67.f']]], + ['fi6705_34',['fi6705',['../w3fi67_8f.html#ac00ebd799c167d32ad1e8d2ccf77d8ed',1,'w3fi67.f']]], + ['fi6706_35',['fi6706',['../w3fi67_8f.html#aa8975059a9c80ae0909d0942907c5b04',1,'w3fi67.f']]], + ['fi6707_36',['fi6707',['../w3fi67_8f.html#a0ba8ee313bbaa81c2d31552c8ba447dd',1,'w3fi67.f']]], + ['fi6708_37',['fi6708',['../w3fi67_8f.html#afc00645e835f1bb662852727afb41980',1,'w3fi67.f']]], + ['fi6709_38',['fi6709',['../w3fi67_8f.html#a450eb49ae26957e0bcadb573ffbcbab2',1,'w3fi67.f']]], + ['fi6710_39',['fi6710',['../w3fi67_8f.html#a2f44d69247df49460acaabe30f7cabb9',1,'w3fi67.f']]], + ['fi7501_40',['fi7501',['../w3fi75_8f.html#a76d712772f7a7b26ca1bba569d377e14',1,'w3fi75.f']]], + ['fi7502_41',['fi7502',['../w3fi75_8f.html#acafb610fbee0d6e272301e3277cf4d32',1,'w3fi75.f']]], + ['fi7503_42',['fi7503',['../w3fi75_8f.html#a96ec02cf0c85d44fc9f0fffff0ef038c',1,'w3fi75.f']]], + ['fi7505_43',['fi7505',['../w3fi75_8f.html#ad8add9d378e5f476eb9a03253aac0673',1,'w3fi75.f']]], + ['fi7513_44',['fi7513',['../w3fi75_8f.html#a36ae6b4d235133cbe224771791cc78a1',1,'w3fi75.f']]], + ['fi7516_45',['fi7516',['../w3fi75_8f.html#a2594a5111d3b15a124e611eee1152fb7',1,'w3fi75.f']]], + ['fi7517_46',['fi7517',['../w3fi75_8f.html#ae605cd757c3b135016711cb96e8ddb12',1,'w3fi75.f']]], + ['fi7518_47',['fi7518',['../w3fi75_8f.html#abdf0aa822fec98a9c20620ea1e170b7a',1,'w3fi75.f']]], + ['fi7801_48',['fi7801',['../w3fi78_8f.html#a78a1ba5576bfc184dbcde9db7647f2c0',1,'w3fi78.f']]], + ['fi7802_49',['fi7802',['../w3fi78_8f.html#afe2cebe5fb34bedc4e028fcaeec3eb0b',1,'w3fi78.f']]], + ['fi7803_50',['fi7803',['../w3fi78_8f.html#abd85631fd2ddaae2c69a597dada4bad5',1,'w3fi78.f']]], + ['fi7804_51',['fi7804',['../w3fi78_8f.html#adde456d0a3cdfb2ada7e27dac62ff5b4',1,'w3fi78.f']]], + ['fi7805_52',['fi7805',['../w3fi78_8f.html#aef0cfcae2b4b6aecddae061ef55c23f7',1,'w3fi78.f']]], + ['fi7806_53',['fi7806',['../w3fi78_8f.html#a759ea3357b94bf332300d7ae6b6e073e',1,'w3fi78.f']]], + ['fi7807_54',['fi7807',['../w3fi78_8f.html#ac6daf60e47a8949569927e2dbe795dc7',1,'w3fi78.f']]], + ['fi7808_55',['fi7808',['../w3fi78_8f.html#aa9b1b7dfb8dd609828a6e0db3271351f',1,'w3fi78.f']]], + ['fi7809_56',['fi7809',['../w3fi78_8f.html#aa30ef437f8f02bfaf3482c3c496d4af5',1,'w3fi78.f']]], + ['fi7810_57',['fi7810',['../w3fi78_8f.html#a1c0312bb81a0d948725334348ba1cbc0',1,'w3fi78.f']]], + ['fi8501_58',['fi8501',['../w3fi85_8f.html#a2dfac12c57c3882ab71df73ae85329ef',1,'w3fi85.f']]], + ['fi8502_59',['fi8502',['../w3fi85_8f.html#aa2db7280cff113d09e4ade7687aaca1a',1,'w3fi85.f']]], + ['fi8503_60',['fi8503',['../w3fi85_8f.html#a65ffb3c26f568c33248204db13547c2f',1,'w3fi85.f']]], + ['fi8505_61',['fi8505',['../w3fi85_8f.html#a52f6aae9ed57d3745d0e142b54366427',1,'w3fi85.f']]], + ['fi8506_62',['fi8506',['../w3fi85_8f.html#a909b8c9399363ed4f51c78bedb57f3cd',1,'w3fi85.f']]], + ['fi8508_63',['fi8508',['../w3fi85_8f.html#a97892186cc13a9f697d5cc447131db26',1,'w3fi85.f']]], + ['fi8509_64',['fi8509',['../w3fi85_8f.html#a43fe930255ffb0865c2329031d294786',1,'w3fi85.f']]], + ['fi8511_65',['fi8511',['../w3fi85_8f.html#ae5983e91fa36267f15a462c84a649de3',1,'w3fi85.f']]], + ['fi8512_66',['fi8512',['../w3fi85_8f.html#ab388b83b7f0918bbae5097408882c6b9',1,'w3fi85.f']]], + ['fi8513_67',['fi8513',['../w3fi85_8f.html#a17405ce8ebd7d06c0bedf0bea6ae2105',1,'w3fi85.f']]], + ['fi8801_68',['fi8801',['../w3fi88_8f.html#ae5d0192919fea00763c2ea1490bff16a',1,'w3fi88.f']]], + ['fi8802_69',['fi8802',['../w3fi88_8f.html#a7829bc0e44ec367834a1a6d83377d428',1,'w3fi88.f']]], + ['fi8803_70',['fi8803',['../w3fi88_8f.html#a228b9ca88ab5e42aa00c6df379ecd470',1,'w3fi88.f']]], + ['fi8804_71',['fi8804',['../w3fi88_8f.html#a94b6d994b2df117c1395048caea2f86b',1,'w3fi88.f']]], + ['fi8805_72',['fi8805',['../w3fi88_8f.html#a45180c8723bc0f7b3eaff47b7fda7ed8',1,'w3fi88.f']]], + ['fi8806_73',['fi8806',['../w3fi88_8f.html#a119b554db1325ff6b2d3742797f107dd',1,'w3fi88.f']]], + ['fi8807_74',['fi8807',['../w3fi88_8f.html#aa56d7f5f943a7bf774c2e9ddc144595f',1,'w3fi88.f']]], + ['fi8808_75',['fi8808',['../w3fi88_8f.html#a2a7856fc62e88d8fa8670e58c4082293',1,'w3fi88.f']]], + ['fi8809_76',['fi8809',['../w3fi88_8f.html#a334e81d3c01ac71a02ef5425671e7bf0',1,'w3fi88.f']]], + ['fi8810_77',['fi8810',['../w3fi88_8f.html#adad8332e2168ab134f2c6f879f133a5f',1,'w3fi88.f']]], + ['fi8811_78',['fi8811',['../w3fi88_8f.html#a12b020b46772271cab997bb781bda9c1',1,'w3fi88.f']]], + ['fparsei_79',['fparsei',['../fparsei_8f.html#a36e302a33bf921be9c7990e94ccc1a1f',1,'fparsei.f']]], + ['fparsei_2ef_80',['fparsei.f',['../fparsei_8f.html',1,'']]], + ['fparser_81',['fparser',['../fparser_8f.html#afd0eece805c9f9aa1afa5b5496298aa5',1,'fparser.f']]], + ['fparser_2ef_82',['fparser.f',['../fparser_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/all_5.html b/ver-2.10.0/search/all_5.html new file mode 100644 index 00000000..2544c4e5 --- /dev/null +++ b/ver-2.10.0/search/all_5.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_5.js b/ver-2.10.0/search/all_5.js new file mode 100644 index 00000000..c52ef60c --- /dev/null +++ b/ver-2.10.0/search/all_5.js @@ -0,0 +1,59 @@ +var searchData= +[ + ['gbyte_83',['gbyte',['../gbyte_8f.html#ad73b69048043b0e9876125b1d839e5c6',1,'gbyte.f']]], + ['gbyte_2ef_84',['gbyte.f',['../gbyte_8f.html',1,'']]], + ['gbytec_85',['gbytec',['../gbytec_8f.html#adcae5457ea7270b3b95a379fec9233d7',1,'gbytec.f']]], + ['gbytec_2ef_86',['gbytec.f',['../gbytec_8f.html',1,'']]], + ['gbytes_87',['gbytes',['../gbytes_8f.html#ac957b0c87f1261d8460c52bfec7d0308',1,'gbytes.f']]], + ['gbytes_2ef_88',['gbytes.f',['../gbytes_8f.html',1,'']]], + ['gbytesc_89',['gbytesc',['../gbytesc_8f.html#a8fd2d6beeef9feaf3ef1e927f66678db',1,'gbytesc.f']]], + ['gbytesc_2ef_90',['gbytesc.f',['../gbytesc_8f.html',1,'']]], + ['getarg_91',['getarg',['../interfaceargs__mod_1_1getarg.html',1,'args_mod']]], + ['getbit_2ef_92',['getbit.f',['../getbit_8f.html',1,'']]], + ['getgb_93',['getgb',['../getgb_8f.html#ab1cec03904b6e6c41840726cd53a69ce',1,'getgb.f']]], + ['getgb_2ef_94',['getgb.f',['../getgb_8f.html',1,'']]], + ['getgb1_95',['getgb1',['../getgb1_8f.html#a124fccd25cd6967ce2b5ba8629e3707c',1,'getgb1.f']]], + ['getgb1_2ef_96',['getgb1.f',['../getgb1_8f.html',1,'']]], + ['getgb1r_97',['getgb1r',['../getgb1r_8f.html#a38f437c2ae06e0aecb78f8841749a09d',1,'getgb1r.f']]], + ['getgb1r_2ef_98',['getgb1r.f',['../getgb1r_8f.html',1,'']]], + ['getgb1re_99',['getgb1re',['../getgb1re_8f.html#a964db1a320f7b795dd353fbd292c06d7',1,'getgb1re.f']]], + ['getgb1re_2ef_100',['getgb1re.f',['../getgb1re_8f.html',1,'']]], + ['getgb1s_101',['getgb1s',['../getgb1s_8f.html#a112566bbdfcf96f3ce3f7c5e2ba8618f',1,'getgb1s.f']]], + ['getgb1s_2ef_102',['getgb1s.f',['../getgb1s_8f.html',1,'']]], + ['getgbe_103',['getgbe',['../getgbe_8f.html#a947b6d97db47adbcce8dde953f7e5de2',1,'getgbe.f']]], + ['getgbe_2ef_104',['getgbe.f',['../getgbe_8f.html',1,'']]], + ['getgbeh_105',['getgbeh',['../getgbeh_8f.html#ae52a0759ee42423a1ad4d714665cdb64',1,'getgbeh.f']]], + ['getgbeh_2ef_106',['getgbeh.f',['../getgbeh_8f.html',1,'']]], + ['getgbem_107',['getgbem',['../getgbem_8f.html#a1b647652df8027c1858a12f78234d246',1,'getgbem.f']]], + ['getgbem_2ef_108',['getgbem.f',['../getgbem_8f.html',1,'']]], + ['getgbemh_109',['getgbemh',['../getgbemh_8f.html#af515ecda0ec8361b15a4596b5773bd5f',1,'getgbemh.f']]], + ['getgbemh_2ef_110',['getgbemh.f',['../getgbemh_8f.html',1,'']]], + ['getgbemn_111',['getgbemn',['../getgbemn_8f.html#aa8900c58b55dacd248734fa3e97c1482',1,'getgbemn.f']]], + ['getgbemn_2ef_112',['getgbemn.f',['../getgbemn_8f.html',1,'']]], + ['getgbemp_113',['getgbemp',['../getgbemp_8f.html#a3703b88e4d6f0e0dc3a8643d7662137c',1,'getgbemp.f']]], + ['getgbemp_2ef_114',['getgbemp.f',['../getgbemp_8f.html',1,'']]], + ['getgbens_115',['getgbens',['../getgbens_8f.html#a0ab50ed386ca101b034a86b960de28b4',1,'getgbens.f']]], + ['getgbens_2ef_116',['getgbens.f',['../getgbens_8f.html',1,'']]], + ['getgbep_117',['getgbep',['../getgbep_8f.html#a0f50efcce1cf858f28518c9f3dd19b40',1,'getgbep.f']]], + ['getgbep_2ef_118',['getgbep.f',['../getgbep_8f.html',1,'']]], + ['getgbex_119',['getgbex',['../getgbex_8f.html#a2dec8fa1731d77d4d81cd9609f04f8f5',1,'getgbex.f']]], + ['getgbex_2ef_120',['getgbex.f',['../getgbex_8f.html',1,'']]], + ['getgbexm_121',['getgbexm',['../getgbexm_8f.html#ab15467040c53a0346d4857a0496c4762',1,'getgbexm.f']]], + ['getgbexm_2ef_122',['getgbexm.f',['../getgbexm_8f.html',1,'']]], + ['getgbh_123',['getgbh',['../getgbh_8f.html#ad15e85bb8f0d1057394c1732840fa128',1,'getgbh.f']]], + ['getgbh_2ef_124',['getgbh.f',['../getgbh_8f.html',1,'']]], + ['getgbm_125',['getgbm',['../getgbm_8f.html#ac004e0201adb9928c5fada5c7372fd78',1,'getgbm.f']]], + ['getgbm_2ef_126',['getgbm.f',['../getgbm_8f.html',1,'']]], + ['getgbmh_127',['getgbmh',['../getgbmh_8f.html#ac4c2d81dcaf427548139d55ca7041022',1,'getgbmh.f']]], + ['getgbmh_2ef_128',['getgbmh.f',['../getgbmh_8f.html',1,'']]], + ['getgbmp_129',['getgbmp',['../getgbmp_8f.html#a3dce03b33b45a2c4f9c859774615cb5a',1,'getgbmp.f']]], + ['getgbmp_2ef_130',['getgbmp.f',['../getgbmp_8f.html',1,'']]], + ['getgbp_131',['getgbp',['../getgbp_8f.html#afc5ba2c9bbd49e77d7a725bf08bcccfd',1,'getgbp.f']]], + ['getgbp_2ef_132',['getgbp.f',['../getgbp_8f.html',1,'']]], + ['getgi_133',['getgi',['../getgi_8f.html#aa6b511267e410648a9961a1aa2e4d27f',1,'getgi.f']]], + ['getgi_2ef_134',['getgi.f',['../getgi_8f.html',1,'']]], + ['getgir_135',['getgir',['../getgir_8f.html#abcd2305cabdf6bb6a000fbb948c608a1',1,'getgir.f']]], + ['getgir_2ef_136',['getgir.f',['../getgir_8f.html',1,'']]], + ['gtbits_137',['gtbits',['../gtbits_8f.html#a31c0ebc8937002fb7b104298f8c439ec',1,'gtbits.f']]], + ['gtbits_2ef_138',['gtbits.f',['../gtbits_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/all_6.html b/ver-2.10.0/search/all_6.html new file mode 100644 index 00000000..43f14eab --- /dev/null +++ b/ver-2.10.0/search/all_6.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_6.js b/ver-2.10.0/search/all_6.js new file mode 100644 index 00000000..c48be789 --- /dev/null +++ b/ver-2.10.0/search/all_6.js @@ -0,0 +1,23 @@ +var searchData= +[ + ['i01o29_139',['i01o29',['../iw3unp29_8f.html#a0d3c45449c312f0e99cdb92777a3220a',1,'iw3unp29.f']]], + ['i02o29_140',['i02o29',['../iw3unp29_8f.html#ae9e0c357df4d0c782d851fdd8ce09e14',1,'iw3unp29.f']]], + ['i03o29_141',['i03o29',['../iw3unp29_8f.html#af0213dc1cf8d73c372bcacc88c16fdf9',1,'iw3unp29.f']]], + ['i05o29_142',['i05o29',['../iw3unp29_8f.html#a89e6f36d2a7dae698c0dff8a77b078a2',1,'iw3unp29.f']]], + ['iargc_143',['iargc',['../interfaceargs__mod_1_1iargc.html',1,'args_mod']]], + ['idsdef_144',['idsdef',['../idsdef_8f.html#a55d6afd1ffb535e0b76701cd33c997e3',1,'idsdef.f']]], + ['idsdef_2ef_145',['idsdef.f',['../idsdef_8f.html',1,'']]], + ['instrument_146',['instrument',['../instrument_8f.html#a1bf5314dfe3e0adf03773a63dadf6173',1,'instrument.f']]], + ['instrument_2ef_147',['instrument.f',['../instrument_8f.html',1,'']]], + ['isrchne_148',['isrchne',['../isrchne_8f.html#aa2ad73a774eaa79cc4134b5a30210c19',1,'isrchne.f']]], + ['isrchne_2ef_149',['isrchne.f',['../isrchne_8f.html',1,'']]], + ['iw3jdn_150',['iw3jdn',['../iw3jdn_8f.html#accbe8d5a05413129a72efa183f1fa3b6',1,'iw3jdn.f']]], + ['iw3jdn_2ef_151',['iw3jdn.f',['../iw3jdn_8f.html',1,'']]], + ['iw3mat_152',['iw3mat',['../iw3mat_8f.html#a2fba35a09957d0d2a2e37b8c63e9ef4f',1,'iw3mat.f']]], + ['iw3mat_2ef_153',['iw3mat.f',['../iw3mat_8f.html',1,'']]], + ['iw3pds_2ef_154',['iw3pds.f',['../iw3pds_8f.html',1,'']]], + ['iw3unp29_155',['iw3unp29',['../iw3unp29_8f.html#a1de5e205645a3843697845185ffaaeb1',1,'iw3unp29.f']]], + ['iw3unp29_2ef_156',['iw3unp29.f',['../iw3unp29_8f.html',1,'']]], + ['ixgb_157',['ixgb',['../ixgb_8f.html#a21b5f70c2205bfb68df79fbb83928066',1,'ixgb.f']]], + ['ixgb_2ef_158',['ixgb.f',['../ixgb_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/all_7.html b/ver-2.10.0/search/all_7.html new file mode 100644 index 00000000..af52f82a --- /dev/null +++ b/ver-2.10.0/search/all_7.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_7.js b/ver-2.10.0/search/all_7.js new file mode 100644 index 00000000..42ad4e67 --- /dev/null +++ b/ver-2.10.0/search/all_7.js @@ -0,0 +1,8 @@ +var searchData= +[ + ['lengds_159',['lengds',['../lengds_8f.html#a53ab57aefe7c9277606708b4c8af7b00',1,'lengds.f']]], + ['lengds_2ef_160',['lengds.f',['../lengds_8f.html',1,'']]], + ['line01_161',['line01',['../w3fp06_8f.html#a771b5aa20028a43dd4e5fed735c85797',1,'w3fp06.f']]], + ['line02_162',['line02',['../w3fp06_8f.html#a69e9f6991efd633d1734e87d0c0cf6f1',1,'w3fp06.f']]], + ['line03_163',['line03',['../w3fp06_8f.html#a07285bde2b2eda3dea091bbb82ab27ee',1,'w3fp06.f']]] +]; diff --git a/ver-2.10.0/search/all_8.html b/ver-2.10.0/search/all_8.html new file mode 100644 index 00000000..cf2b5df9 --- /dev/null +++ b/ver-2.10.0/search/all_8.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_8.js b/ver-2.10.0/search/all_8.js new file mode 100644 index 00000000..e3773657 --- /dev/null +++ b/ver-2.10.0/search/all_8.js @@ -0,0 +1,16 @@ +var searchData= +[ + ['makwmo_164',['makwmo',['../makwmo_8f.html#a8fd8c7e636856ca63ccdd4a0d786636d',1,'makwmo.f']]], + ['makwmo_2ef_165',['makwmo.f',['../makwmo_8f.html',1,'']]], + ['mersenne_5ftwister_166',['mersenne_twister',['../namespacemersenne__twister.html',1,'']]], + ['mersenne_5ftwister_2ef_167',['mersenne_twister.f',['../mersenne__twister_8f.html',1,'']]], + ['misc01_168',['misc01',['../w3miscan_8f.html#afdde0d874410648935ffd0d1c5457321',1,'w3miscan.f']]], + ['misc04_169',['misc04',['../w3miscan_8f.html#acde6036e077def96f8071397d2eec3f5',1,'w3miscan.f']]], + ['misc05_170',['misc05',['../w3miscan_8f.html#a7ee0202db29014a39612fd133a9ca421',1,'w3miscan.f']]], + ['misc06_171',['misc06',['../w3miscan_8f.html#aded626863c4df7539accbced4b6ab799',1,'w3miscan.f']]], + ['misc10_172',['misc10',['../w3miscan_8f.html#adda71e84fc0a136a1b9de35eb6c02d19',1,'w3miscan.f']]], + ['mkfldsep_173',['mkfldsep',['../mkfldsep_8f.html#ac36c3aa46eee1a7f5ce77daa4c3fc045',1,'mkfldsep.f']]], + ['mkfldsep_2ef_174',['mkfldsep.f',['../mkfldsep_8f.html',1,'']]], + ['mova2i_175',['mova2i',['../mova2i_8f.html#aed1be7b63ac5c89c04f701e75bb4fbe0',1,'mova2i.f']]], + ['mova2i_2ef_176',['mova2i.f',['../mova2i_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/all_9.html b/ver-2.10.0/search/all_9.html new file mode 100644 index 00000000..690785a5 --- /dev/null +++ b/ver-2.10.0/search/all_9.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_9.js b/ver-2.10.0/search/all_9.js new file mode 100644 index 00000000..6f34b09d --- /dev/null +++ b/ver-2.10.0/search/all_9.js @@ -0,0 +1,5 @@ +var searchData= +[ + ['orders_177',['orders',['../orders_8f.html#a311c2453b613d259dc8e998f6d6aa944',1,'orders.f']]], + ['orders_2ef_178',['orders.f',['../orders_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/all_a.html b/ver-2.10.0/search/all_a.html new file mode 100644 index 00000000..f2f3d3a3 --- /dev/null +++ b/ver-2.10.0/search/all_a.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_a.js b/ver-2.10.0/search/all_a.js new file mode 100644 index 00000000..22dd8010 --- /dev/null +++ b/ver-2.10.0/search/all_a.js @@ -0,0 +1,20 @@ +var searchData= +[ + ['pdsens_179',['pdsens',['../pdsens_8f.html#ac0ab2fe3df3fc664f2c413214700206e',1,'pdsens.f']]], + ['pdsens_2ef_180',['pdsens.f',['../pdsens_8f.html',1,'']]], + ['pdseup_181',['pdseup',['../pdseup_8f.html#a62cf775ad87c64a28b7e395792eabfca',1,'pdseup.f']]], + ['pdseup_2ef_182',['pdseup.f',['../pdseup_8f.html',1,'']]], + ['print_5ftiming_183',['print_timing',['../summary_8c.html#a375531ea214cead1fa2bdee20bcc2dd0',1,'summary.c']]], + ['putgb_184',['putgb',['../putgb_8f.html#aa61b5b2b00eb09531ef126983ad1d724',1,'putgb.f']]], + ['putgb_2ef_185',['putgb.f',['../putgb_8f.html',1,'']]], + ['putgbe_186',['putgbe',['../putgbe_8f.html#aff43ef1fa54eed421433340d5954fcfe',1,'putgbe.f']]], + ['putgbe_2ef_187',['putgbe.f',['../putgbe_8f.html',1,'']]], + ['putgben_188',['putgben',['../putgben_8f.html#a094e5a410a4e995f25665a750ac2bc8c',1,'putgben.f']]], + ['putgben_2ef_189',['putgben.f',['../putgben_8f.html',1,'']]], + ['putgbens_190',['putgbens',['../putgbens_8f.html#a1a125225f33ac856c34ce692adeef0b2',1,'putgbens.f']]], + ['putgbens_2ef_191',['putgbens.f',['../putgbens_8f.html',1,'']]], + ['putgbex_192',['putgbex',['../putgbex_8f.html#a64977c953757490ae3b8b72a5fd7c4cb',1,'putgbex.f']]], + ['putgbex_2ef_193',['putgbex.f',['../putgbex_8f.html',1,'']]], + ['putgbn_194',['putgbn',['../putgbn_8f.html#ad639ec06d322cda9f568c75b98aacc67',1,'putgbn.f']]], + ['putgbn_2ef_195',['putgbn.f',['../putgbn_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/all_b.html b/ver-2.10.0/search/all_b.html new file mode 100644 index 00000000..14f34036 --- /dev/null +++ b/ver-2.10.0/search/all_b.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_b.js b/ver-2.10.0/search/all_b.js new file mode 100644 index 00000000..76fcc223 --- /dev/null +++ b/ver-2.10.0/search/all_b.js @@ -0,0 +1,7 @@ +var searchData= +[ + ['q9e3i6_196',['q9e3i6',['../w3ai00_8f.html#a080e60503e36be98db3d35c5e508dbde',1,'w3ai00.f']]], + ['q9ei32_197',['q9ei32',['../w3ai00_8f.html#aa9b74cf19854cae0066bd5d905a65873',1,'w3ai00.f']]], + ['q9ie32_198',['q9ie32',['../q9ie32_8f.html#a7cfc294cd548b96adbe4ccd72fc656c1',1,'q9ie32.f']]], + ['q9ie32_2ef_199',['q9ie32.f',['../q9ie32_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/all_c.html b/ver-2.10.0/search/all_c.html new file mode 100644 index 00000000..da60ab8d --- /dev/null +++ b/ver-2.10.0/search/all_c.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_c.js b/ver-2.10.0/search/all_c.js new file mode 100644 index 00000000..61c8ef0f --- /dev/null +++ b/ver-2.10.0/search/all_c.js @@ -0,0 +1,14 @@ +var searchData= +[ + ['r01o29_200',['r01o29',['../iw3unp29_8f.html#af252340bc4d8811a4d6e799bdf1c3790',1,'iw3unp29.f']]], + ['r63w72_201',['r63w72',['../r63w72_8f.html#a071601493ea893c59ed2b8fac3cf9116',1,'r63w72.f']]], + ['r63w72_2ef_202',['r63w72.f',['../r63w72_8f.html',1,'']]], + ['random_5fgauss_5ff_203',['random_gauss_f',['../namespacemersenne__twister.html#acd01aa05ecfbe1c3283dc3552fc9a437',1,'mersenne_twister']]], + ['random_5findex_5ff_204',['random_index_f',['../namespacemersenne__twister.html#acc59b5b06bcd98e292ffeaeae88c9c5e',1,'mersenne_twister']]], + ['random_5fnumber_5ff_205',['random_number_f',['../namespacemersenne__twister.html#a72d5b1cd21e6af407325bb8b0e18481a',1,'mersenne_twister']]], + ['random_5fseed_206',['random_seed',['../namespacemersenne__twister.html#ab5807578f927f719be280774b17803ad',1,'mersenne_twister']]], + ['resource_207',['resource',['../summary_8c.html#a585b71c74faea63d161810774ef8da9e',1,'summary.c']]], + ['risc02_208',['risc02',['../w3miscan_8f.html#a6edc5e68c541091294d41f99e804a05e',1,'w3miscan.f']]], + ['risc02xx_209',['risc02xx',['../w3miscan_8f.html#a4b77772e4547b0f74a9b1c669a839be6',1,'w3miscan.f']]], + ['risc03_210',['risc03',['../w3miscan_8f.html#ac30ceca6f563c3f755520f227e068930',1,'w3miscan.f']]] +]; diff --git a/ver-2.10.0/search/all_d.html b/ver-2.10.0/search/all_d.html new file mode 100644 index 00000000..bc376fec --- /dev/null +++ b/ver-2.10.0/search/all_d.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_d.js b/ver-2.10.0/search/all_d.js new file mode 100644 index 00000000..e18b4255 --- /dev/null +++ b/ver-2.10.0/search/all_d.js @@ -0,0 +1,18 @@ +var searchData= +[ + ['s06o29_211',['s06o29',['../iw3unp29_8f.html#a2d15cb33d16ceab9921e8add94c30a42',1,'iw3unp29.f']]], + ['sbyte_212',['sbyte',['../sbyte_8f.html#afbbfa5a4daed1898e1235a221dcf54b2',1,'sbyte.f']]], + ['sbyte_2ef_213',['sbyte.f',['../sbyte_8f.html',1,'']]], + ['sbytec_214',['sbytec',['../sbytec_8f.html#aa252e1e9e9f8808f95473792d319231b',1,'sbytec.f']]], + ['sbytec_2ef_215',['sbytec.f',['../sbytec_8f.html',1,'']]], + ['sbytes_2ef_216',['sbytes.f',['../sbytes_8f.html',1,'']]], + ['sbytesc_217',['sbytesc',['../sbytesc_8f.html#aa527f56385adc86efba0d8605f251088',1,'sbytesc.f']]], + ['sbytesc_2ef_218',['sbytesc.f',['../sbytesc_8f.html',1,'']]], + ['setcl_219',['setcl',['../w3fp06_8f.html#a67cf94ad0864f312b980ca2315e729e2',1,'w3fp06.f']]], + ['skgb_220',['skgb',['../skgb_8f.html#a7654c30923c8fa28091b5cb300c93311',1,'skgb.f']]], + ['skgb_2ef_221',['skgb.f',['../skgb_8f.html',1,'']]], + ['start_5f_222',['start_',['../summary_8c.html#ad890855d9ece9845912ab1f12f8ee31e',1,'summary.c']]], + ['start_5ftimer_223',['start_timer',['../summary_8c.html#a9078a5949f4d6fe30ed2a5bf7c0cf4d7',1,'summary.c']]], + ['summary_2ec_224',['summary.c',['../summary_8c.html',1,'']]], + ['summary_5f_225',['summary_',['../summary_8c.html#a60f2dd974b43d33df8d7a6b4c2a47110',1,'summary.c']]] +]; diff --git a/ver-2.10.0/search/all_e.html b/ver-2.10.0/search/all_e.html new file mode 100644 index 00000000..2e3c74dc --- /dev/null +++ b/ver-2.10.0/search/all_e.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_e.js b/ver-2.10.0/search/all_e.js new file mode 100644 index 00000000..f7c357e4 --- /dev/null +++ b/ver-2.10.0/search/all_e.js @@ -0,0 +1,12 @@ +var searchData= +[ + ['unpk7701_226',['unpk7701',['../w3unpk77_8f.html#ab50a57de79ddc4377c2c17512e58c6ea',1,'w3unpk77.f']]], + ['unpk7702_227',['unpk7702',['../w3unpk77_8f.html#affac66f51c4a903f7e20d643da19f4df',1,'w3unpk77.f']]], + ['unpk7703_228',['unpk7703',['../w3unpk77_8f.html#ab7a2a42f29d7122f4273548568b0168a',1,'w3unpk77.f']]], + ['unpk7704_229',['unpk7704',['../w3unpk77_8f.html#a9589ef1331e503fdbdc2ff306ae60143',1,'w3unpk77.f']]], + ['unpk7705_230',['unpk7705',['../w3unpk77_8f.html#a83668f95551d6806db9d28f6ce577f22',1,'w3unpk77.f']]], + ['unpk7706_231',['unpk7706',['../w3unpk77_8f.html#a4196e848ecd6558e30a6c0617a35737c',1,'w3unpk77.f']]], + ['unpk7707_232',['unpk7707',['../w3unpk77_8f.html#a87aaaaef2fb86ea98c45d5c206961033',1,'w3unpk77.f']]], + ['unpk7708_233',['unpk7708',['../w3unpk77_8f.html#ab038d6f2a6c28d162b38828264552068',1,'w3unpk77.f']]], + ['unpk7709_234',['unpk7709',['../w3unpk77_8f.html#a38fd0aaaeb7ad9a2f9f9453afc11cd1e',1,'w3unpk77.f']]] +]; diff --git a/ver-2.10.0/search/all_f.html b/ver-2.10.0/search/all_f.html new file mode 100644 index 00000000..246f8ab1 --- /dev/null +++ b/ver-2.10.0/search/all_f.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/all_f.js b/ver-2.10.0/search/all_f.js new file mode 100644 index 00000000..bcc8dd79 --- /dev/null +++ b/ver-2.10.0/search/all_f.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['value1_235',['value1',['../w3fp06_8f.html#a857d20cd6a97ba1e266d803b2092670c',1,'w3fp06.f']]] +]; diff --git a/ver-2.10.0/search/classes_0.html b/ver-2.10.0/search/classes_0.html new file mode 100644 index 00000000..f7e4c14e --- /dev/null +++ b/ver-2.10.0/search/classes_0.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/classes_0.js b/ver-2.10.0/search/classes_0.js new file mode 100644 index 00000000..f1654397 --- /dev/null +++ b/ver-2.10.0/search/classes_0.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['getarg_527',['getarg',['../interfaceargs__mod_1_1getarg.html',1,'args_mod']]] +]; diff --git a/ver-2.10.0/search/classes_1.html b/ver-2.10.0/search/classes_1.html new file mode 100644 index 00000000..c7ff4b31 --- /dev/null +++ b/ver-2.10.0/search/classes_1.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/classes_1.js b/ver-2.10.0/search/classes_1.js new file mode 100644 index 00000000..0119cb95 --- /dev/null +++ b/ver-2.10.0/search/classes_1.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['iargc_528',['iargc',['../interfaceargs__mod_1_1iargc.html',1,'args_mod']]] +]; diff --git a/ver-2.10.0/search/close.png b/ver-2.10.0/search/close.png new file mode 100644 index 00000000..9342d3df Binary files /dev/null and b/ver-2.10.0/search/close.png differ diff --git a/ver-2.10.0/search/files_0.html b/ver-2.10.0/search/files_0.html new file mode 100644 index 00000000..737608e1 --- /dev/null +++ b/ver-2.10.0/search/files_0.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_0.js b/ver-2.10.0/search/files_0.js new file mode 100644 index 00000000..7fb0b6f5 --- /dev/null +++ b/ver-2.10.0/search/files_0.js @@ -0,0 +1,5 @@ +var searchData= +[ + ['aea_2ef_531',['aea.f',['../aea_8f.html',1,'']]], + ['args_5fmod_2ef_532',['args_mod.f',['../args__mod_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_1.html b/ver-2.10.0/search/files_1.html new file mode 100644 index 00000000..f27a62de --- /dev/null +++ b/ver-2.10.0/search/files_1.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_1.js b/ver-2.10.0/search/files_1.js new file mode 100644 index 00000000..95b8d186 --- /dev/null +++ b/ver-2.10.0/search/files_1.js @@ -0,0 +1,5 @@ +var searchData= +[ + ['errexit_2ef_533',['errexit.f',['../errexit_8f.html',1,'']]], + ['errmsg_2ef_534',['errmsg.f',['../errmsg_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_2.html b/ver-2.10.0/search/files_2.html new file mode 100644 index 00000000..a45066e9 --- /dev/null +++ b/ver-2.10.0/search/files_2.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_2.js b/ver-2.10.0/search/files_2.js new file mode 100644 index 00000000..702a4e0a --- /dev/null +++ b/ver-2.10.0/search/files_2.js @@ -0,0 +1,5 @@ +var searchData= +[ + ['fparsei_2ef_535',['fparsei.f',['../fparsei_8f.html',1,'']]], + ['fparser_2ef_536',['fparser.f',['../fparser_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_3.html b/ver-2.10.0/search/files_3.html new file mode 100644 index 00000000..1076bc5a --- /dev/null +++ b/ver-2.10.0/search/files_3.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_3.js b/ver-2.10.0/search/files_3.js new file mode 100644 index 00000000..3af7b5f9 --- /dev/null +++ b/ver-2.10.0/search/files_3.js @@ -0,0 +1,31 @@ +var searchData= +[ + ['gbyte_2ef_537',['gbyte.f',['../gbyte_8f.html',1,'']]], + ['gbytec_2ef_538',['gbytec.f',['../gbytec_8f.html',1,'']]], + ['gbytes_2ef_539',['gbytes.f',['../gbytes_8f.html',1,'']]], + ['gbytesc_2ef_540',['gbytesc.f',['../gbytesc_8f.html',1,'']]], + ['getbit_2ef_541',['getbit.f',['../getbit_8f.html',1,'']]], + ['getgb_2ef_542',['getgb.f',['../getgb_8f.html',1,'']]], + ['getgb1_2ef_543',['getgb1.f',['../getgb1_8f.html',1,'']]], + ['getgb1r_2ef_544',['getgb1r.f',['../getgb1r_8f.html',1,'']]], + ['getgb1re_2ef_545',['getgb1re.f',['../getgb1re_8f.html',1,'']]], + ['getgb1s_2ef_546',['getgb1s.f',['../getgb1s_8f.html',1,'']]], + ['getgbe_2ef_547',['getgbe.f',['../getgbe_8f.html',1,'']]], + ['getgbeh_2ef_548',['getgbeh.f',['../getgbeh_8f.html',1,'']]], + ['getgbem_2ef_549',['getgbem.f',['../getgbem_8f.html',1,'']]], + ['getgbemh_2ef_550',['getgbemh.f',['../getgbemh_8f.html',1,'']]], + ['getgbemn_2ef_551',['getgbemn.f',['../getgbemn_8f.html',1,'']]], + ['getgbemp_2ef_552',['getgbemp.f',['../getgbemp_8f.html',1,'']]], + ['getgbens_2ef_553',['getgbens.f',['../getgbens_8f.html',1,'']]], + ['getgbep_2ef_554',['getgbep.f',['../getgbep_8f.html',1,'']]], + ['getgbex_2ef_555',['getgbex.f',['../getgbex_8f.html',1,'']]], + ['getgbexm_2ef_556',['getgbexm.f',['../getgbexm_8f.html',1,'']]], + ['getgbh_2ef_557',['getgbh.f',['../getgbh_8f.html',1,'']]], + ['getgbm_2ef_558',['getgbm.f',['../getgbm_8f.html',1,'']]], + ['getgbmh_2ef_559',['getgbmh.f',['../getgbmh_8f.html',1,'']]], + ['getgbmp_2ef_560',['getgbmp.f',['../getgbmp_8f.html',1,'']]], + ['getgbp_2ef_561',['getgbp.f',['../getgbp_8f.html',1,'']]], + ['getgi_2ef_562',['getgi.f',['../getgi_8f.html',1,'']]], + ['getgir_2ef_563',['getgir.f',['../getgir_8f.html',1,'']]], + ['gtbits_2ef_564',['gtbits.f',['../gtbits_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_4.html b/ver-2.10.0/search/files_4.html new file mode 100644 index 00000000..e5cd7f43 --- /dev/null +++ b/ver-2.10.0/search/files_4.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_4.js b/ver-2.10.0/search/files_4.js new file mode 100644 index 00000000..dfdc5b94 --- /dev/null +++ b/ver-2.10.0/search/files_4.js @@ -0,0 +1,11 @@ +var searchData= +[ + ['idsdef_2ef_565',['idsdef.f',['../idsdef_8f.html',1,'']]], + ['instrument_2ef_566',['instrument.f',['../instrument_8f.html',1,'']]], + ['isrchne_2ef_567',['isrchne.f',['../isrchne_8f.html',1,'']]], + ['iw3jdn_2ef_568',['iw3jdn.f',['../iw3jdn_8f.html',1,'']]], + ['iw3mat_2ef_569',['iw3mat.f',['../iw3mat_8f.html',1,'']]], + ['iw3pds_2ef_570',['iw3pds.f',['../iw3pds_8f.html',1,'']]], + ['iw3unp29_2ef_571',['iw3unp29.f',['../iw3unp29_8f.html',1,'']]], + ['ixgb_2ef_572',['ixgb.f',['../ixgb_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_5.html b/ver-2.10.0/search/files_5.html new file mode 100644 index 00000000..2cc480f2 --- /dev/null +++ b/ver-2.10.0/search/files_5.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_5.js b/ver-2.10.0/search/files_5.js new file mode 100644 index 00000000..8ed3ba37 --- /dev/null +++ b/ver-2.10.0/search/files_5.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['lengds_2ef_573',['lengds.f',['../lengds_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_6.html b/ver-2.10.0/search/files_6.html new file mode 100644 index 00000000..6510245f --- /dev/null +++ b/ver-2.10.0/search/files_6.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_6.js b/ver-2.10.0/search/files_6.js new file mode 100644 index 00000000..54257dc3 --- /dev/null +++ b/ver-2.10.0/search/files_6.js @@ -0,0 +1,7 @@ +var searchData= +[ + ['makwmo_2ef_574',['makwmo.f',['../makwmo_8f.html',1,'']]], + ['mersenne_5ftwister_2ef_575',['mersenne_twister.f',['../mersenne__twister_8f.html',1,'']]], + ['mkfldsep_2ef_576',['mkfldsep.f',['../mkfldsep_8f.html',1,'']]], + ['mova2i_2ef_577',['mova2i.f',['../mova2i_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_7.html b/ver-2.10.0/search/files_7.html new file mode 100644 index 00000000..819f7b86 --- /dev/null +++ b/ver-2.10.0/search/files_7.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_7.js b/ver-2.10.0/search/files_7.js new file mode 100644 index 00000000..4bcd3224 --- /dev/null +++ b/ver-2.10.0/search/files_7.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['orders_2ef_578',['orders.f',['../orders_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_8.html b/ver-2.10.0/search/files_8.html new file mode 100644 index 00000000..fa1a27f7 --- /dev/null +++ b/ver-2.10.0/search/files_8.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_8.js b/ver-2.10.0/search/files_8.js new file mode 100644 index 00000000..f290deba --- /dev/null +++ b/ver-2.10.0/search/files_8.js @@ -0,0 +1,11 @@ +var searchData= +[ + ['pdsens_2ef_579',['pdsens.f',['../pdsens_8f.html',1,'']]], + ['pdseup_2ef_580',['pdseup.f',['../pdseup_8f.html',1,'']]], + ['putgb_2ef_581',['putgb.f',['../putgb_8f.html',1,'']]], + ['putgbe_2ef_582',['putgbe.f',['../putgbe_8f.html',1,'']]], + ['putgben_2ef_583',['putgben.f',['../putgben_8f.html',1,'']]], + ['putgbens_2ef_584',['putgbens.f',['../putgbens_8f.html',1,'']]], + ['putgbex_2ef_585',['putgbex.f',['../putgbex_8f.html',1,'']]], + ['putgbn_2ef_586',['putgbn.f',['../putgbn_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_9.html b/ver-2.10.0/search/files_9.html new file mode 100644 index 00000000..3af3e474 --- /dev/null +++ b/ver-2.10.0/search/files_9.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_9.js b/ver-2.10.0/search/files_9.js new file mode 100644 index 00000000..59b3242a --- /dev/null +++ b/ver-2.10.0/search/files_9.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['q9ie32_2ef_587',['q9ie32.f',['../q9ie32_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_a.html b/ver-2.10.0/search/files_a.html new file mode 100644 index 00000000..17f65ad9 --- /dev/null +++ b/ver-2.10.0/search/files_a.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_a.js b/ver-2.10.0/search/files_a.js new file mode 100644 index 00000000..3995dd2c --- /dev/null +++ b/ver-2.10.0/search/files_a.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['r63w72_2ef_588',['r63w72.f',['../r63w72_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_b.html b/ver-2.10.0/search/files_b.html new file mode 100644 index 00000000..aaa7731b --- /dev/null +++ b/ver-2.10.0/search/files_b.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_b.js b/ver-2.10.0/search/files_b.js new file mode 100644 index 00000000..30635ac0 --- /dev/null +++ b/ver-2.10.0/search/files_b.js @@ -0,0 +1,9 @@ +var searchData= +[ + ['sbyte_2ef_589',['sbyte.f',['../sbyte_8f.html',1,'']]], + ['sbytec_2ef_590',['sbytec.f',['../sbytec_8f.html',1,'']]], + ['sbytes_2ef_591',['sbytes.f',['../sbytes_8f.html',1,'']]], + ['sbytesc_2ef_592',['sbytesc.f',['../sbytesc_8f.html',1,'']]], + ['skgb_2ef_593',['skgb.f',['../skgb_8f.html',1,'']]], + ['summary_2ec_594',['summary.c',['../summary_8c.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_c.html b/ver-2.10.0/search/files_c.html new file mode 100644 index 00000000..79e79635 --- /dev/null +++ b/ver-2.10.0/search/files_c.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_c.js b/ver-2.10.0/search/files_c.js new file mode 100644 index 00000000..a0b920d9 --- /dev/null +++ b/ver-2.10.0/search/files_c.js @@ -0,0 +1,147 @@ +var searchData= +[ + ['w3ai00_2ef_595',['w3ai00.f',['../w3ai00_8f.html',1,'']]], + ['w3ai01_2ef_596',['w3ai01.f',['../w3ai01_8f.html',1,'']]], + ['w3ai08_2ef_597',['w3ai08.f',['../w3ai08_8f.html',1,'']]], + ['w3ai15_2ef_598',['w3ai15.f',['../w3ai15_8f.html',1,'']]], + ['w3ai18_2ef_599',['w3ai18.f',['../w3ai18_8f.html',1,'']]], + ['w3ai19_2ef_600',['w3ai19.f',['../w3ai19_8f.html',1,'']]], + ['w3ai24_2ef_601',['w3ai24.f',['../w3ai24_8f.html',1,'']]], + ['w3ai38_2ef_602',['w3ai38.f',['../w3ai38_8f.html',1,'']]], + ['w3ai39_2ef_603',['w3ai39.f',['../w3ai39_8f.html',1,'']]], + ['w3ai40_2ef_604',['w3ai40.f',['../w3ai40_8f.html',1,'']]], + ['w3ai41_2ef_605',['w3ai41.f',['../w3ai41_8f.html',1,'']]], + ['w3aq15_2ef_606',['w3aq15.f',['../w3aq15_8f.html',1,'']]], + ['w3as00_2ef_607',['w3as00.f',['../w3as00_8f.html',1,'']]], + ['w3ctzdat_2ef_608',['w3ctzdat.f',['../w3ctzdat_8f.html',1,'']]], + ['w3difdat_2ef_609',['w3difdat.f',['../w3difdat_8f.html',1,'']]], + ['w3doxdat_2ef_610',['w3doxdat.f',['../w3doxdat_8f.html',1,'']]], + ['w3fa01_2ef_611',['w3fa01.f',['../w3fa01_8f.html',1,'']]], + ['w3fa03_2ef_612',['w3fa03.f',['../w3fa03_8f.html',1,'']]], + ['w3fa03v_2ef_613',['w3fa03v.f',['../w3fa03v_8f.html',1,'']]], + ['w3fa04_2ef_614',['w3fa04.f',['../w3fa04_8f.html',1,'']]], + ['w3fa06_2ef_615',['w3fa06.f',['../w3fa06_8f.html',1,'']]], + ['w3fa09_2ef_616',['w3fa09.f',['../w3fa09_8f.html',1,'']]], + ['w3fa11_2ef_617',['w3fa11.f',['../w3fa11_8f.html',1,'']]], + ['w3fa12_2ef_618',['w3fa12.f',['../w3fa12_8f.html',1,'']]], + ['w3fa13_2ef_619',['w3fa13.f',['../w3fa13_8f.html',1,'']]], + ['w3fb00_2ef_620',['w3fb00.f',['../w3fb00_8f.html',1,'']]], + ['w3fb01_2ef_621',['w3fb01.f',['../w3fb01_8f.html',1,'']]], + ['w3fb02_2ef_622',['w3fb02.f',['../w3fb02_8f.html',1,'']]], + ['w3fb03_2ef_623',['w3fb03.f',['../w3fb03_8f.html',1,'']]], + ['w3fb04_2ef_624',['w3fb04.f',['../w3fb04_8f.html',1,'']]], + ['w3fb05_2ef_625',['w3fb05.f',['../w3fb05_8f.html',1,'']]], + ['w3fb06_2ef_626',['w3fb06.f',['../w3fb06_8f.html',1,'']]], + ['w3fb07_2ef_627',['w3fb07.f',['../w3fb07_8f.html',1,'']]], + ['w3fb08_2ef_628',['w3fb08.f',['../w3fb08_8f.html',1,'']]], + ['w3fb09_2ef_629',['w3fb09.f',['../w3fb09_8f.html',1,'']]], + ['w3fb10_2ef_630',['w3fb10.f',['../w3fb10_8f.html',1,'']]], + ['w3fb11_2ef_631',['w3fb11.f',['../w3fb11_8f.html',1,'']]], + ['w3fb12_2ef_632',['w3fb12.f',['../w3fb12_8f.html',1,'']]], + ['w3fc02_2ef_633',['w3fc02.f',['../w3fc02_8f.html',1,'']]], + ['w3fc05_2ef_634',['w3fc05.f',['../w3fc05_8f.html',1,'']]], + ['w3fc06_2ef_635',['w3fc06.f',['../w3fc06_8f.html',1,'']]], + ['w3fc07_2ef_636',['w3fc07.f',['../w3fc07_8f.html',1,'']]], + ['w3fc08_2ef_637',['w3fc08.f',['../w3fc08_8f.html',1,'']]], + ['w3fi01_2ef_638',['w3fi01.f',['../w3fi01_8f.html',1,'']]], + ['w3fi02_2ef_639',['w3fi02.f',['../w3fi02_8f.html',1,'']]], + ['w3fi03_2ef_640',['w3fi03.f',['../w3fi03_8f.html',1,'']]], + ['w3fi04_2ef_641',['w3fi04.f',['../w3fi04_8f.html',1,'']]], + ['w3fi18_2ef_642',['w3fi18.f',['../w3fi18_8f.html',1,'']]], + ['w3fi19_2ef_643',['w3fi19.f',['../w3fi19_8f.html',1,'']]], + ['w3fi20_2ef_644',['w3fi20.f',['../w3fi20_8f.html',1,'']]], + ['w3fi32_2ef_645',['w3fi32.f',['../w3fi32_8f.html',1,'']]], + ['w3fi47_2ef_646',['w3fi47.f',['../w3fi47_8f.html',1,'']]], + ['w3fi48_2ef_647',['w3fi48.f',['../w3fi48_8f.html',1,'']]], + ['w3fi52_2ef_648',['w3fi52.f',['../w3fi52_8f.html',1,'']]], + ['w3fi58_2ef_649',['w3fi58.f',['../w3fi58_8f.html',1,'']]], + ['w3fi59_2ef_650',['w3fi59.f',['../w3fi59_8f.html',1,'']]], + ['w3fi61_2ef_651',['w3fi61.f',['../w3fi61_8f.html',1,'']]], + ['w3fi62_2ef_652',['w3fi62.f',['../w3fi62_8f.html',1,'']]], + ['w3fi63_2ef_653',['w3fi63.f',['../w3fi63_8f.html',1,'']]], + ['w3fi64_2ef_654',['w3fi64.f',['../w3fi64_8f.html',1,'']]], + ['w3fi65_2ef_655',['w3fi65.f',['../w3fi65_8f.html',1,'']]], + ['w3fi66_2ef_656',['w3fi66.f',['../w3fi66_8f.html',1,'']]], + ['w3fi67_2ef_657',['w3fi67.f',['../w3fi67_8f.html',1,'']]], + ['w3fi68_2ef_658',['w3fi68.f',['../w3fi68_8f.html',1,'']]], + ['w3fi69_2ef_659',['w3fi69.f',['../w3fi69_8f.html',1,'']]], + ['w3fi70_2ef_660',['w3fi70.f',['../w3fi70_8f.html',1,'']]], + ['w3fi71_2ef_661',['w3fi71.f',['../w3fi71_8f.html',1,'']]], + ['w3fi72_2ef_662',['w3fi72.f',['../w3fi72_8f.html',1,'']]], + ['w3fi73_2ef_663',['w3fi73.f',['../w3fi73_8f.html',1,'']]], + ['w3fi74_2ef_664',['w3fi74.f',['../w3fi74_8f.html',1,'']]], + ['w3fi75_2ef_665',['w3fi75.f',['../w3fi75_8f.html',1,'']]], + ['w3fi76_2ef_666',['w3fi76.f',['../w3fi76_8f.html',1,'']]], + ['w3fi78_2ef_667',['w3fi78.f',['../w3fi78_8f.html',1,'']]], + ['w3fi82_2ef_668',['w3fi82.f',['../w3fi82_8f.html',1,'']]], + ['w3fi83_2ef_669',['w3fi83.f',['../w3fi83_8f.html',1,'']]], + ['w3fi85_2ef_670',['w3fi85.f',['../w3fi85_8f.html',1,'']]], + ['w3fi88_2ef_671',['w3fi88.f',['../w3fi88_8f.html',1,'']]], + ['w3fi92_2ef_672',['w3fi92.f',['../w3fi92_8f.html',1,'']]], + ['w3fm07_2ef_673',['w3fm07.f',['../w3fm07_8f.html',1,'']]], + ['w3fm08_2ef_674',['w3fm08.f',['../w3fm08_8f.html',1,'']]], + ['w3fp04_2ef_675',['w3fp04.f',['../w3fp04_8f.html',1,'']]], + ['w3fp05_2ef_676',['w3fp05.f',['../w3fp05_8f.html',1,'']]], + ['w3fp06_2ef_677',['w3fp06.f',['../w3fp06_8f.html',1,'']]], + ['w3fp10_2ef_678',['w3fp10.f',['../w3fp10_8f.html',1,'']]], + ['w3fp11_2ef_679',['w3fp11.f',['../w3fp11_8f.html',1,'']]], + ['w3fp12_2ef_680',['w3fp12.f',['../w3fp12_8f.html',1,'']]], + ['w3fp13_2ef_681',['w3fp13.f',['../w3fp13_8f.html',1,'']]], + ['w3fq07_2ef_682',['w3fq07.f',['../w3fq07_8f.html',1,'']]], + ['w3fs13_2ef_683',['w3fs13.f',['../w3fs13_8f.html',1,'']]], + ['w3fs15_2ef_684',['w3fs15.f',['../w3fs15_8f.html',1,'']]], + ['w3fs21_2ef_685',['w3fs21.f',['../w3fs21_8f.html',1,'']]], + ['w3fs26_2ef_686',['w3fs26.f',['../w3fs26_8f.html',1,'']]], + ['w3ft00_2ef_687',['w3ft00.f',['../w3ft00_8f.html',1,'']]], + ['w3ft01_2ef_688',['w3ft01.f',['../w3ft01_8f.html',1,'']]], + ['w3ft02_2ef_689',['w3ft02.f',['../w3ft02_8f.html',1,'']]], + ['w3ft03_2ef_690',['w3ft03.f',['../w3ft03_8f.html',1,'']]], + ['w3ft05_2ef_691',['w3ft05.f',['../w3ft05_8f.html',1,'']]], + ['w3ft05v_2ef_692',['w3ft05v.f',['../w3ft05v_8f.html',1,'']]], + ['w3ft06_2ef_693',['w3ft06.f',['../w3ft06_8f.html',1,'']]], + ['w3ft06v_2ef_694',['w3ft06v.f',['../w3ft06v_8f.html',1,'']]], + ['w3ft07_2ef_695',['w3ft07.f',['../w3ft07_8f.html',1,'']]], + ['w3ft08_2ef_696',['w3ft08.f',['../w3ft08_8f.html',1,'']]], + ['w3ft09_2ef_697',['w3ft09.f',['../w3ft09_8f.html',1,'']]], + ['w3ft10_2ef_698',['w3ft10.f',['../w3ft10_8f.html',1,'']]], + ['w3ft11_2ef_699',['w3ft11.f',['../w3ft11_8f.html',1,'']]], + ['w3ft12_2ef_700',['w3ft12.f',['../w3ft12_8f.html',1,'']]], + ['w3ft16_2ef_701',['w3ft16.f',['../w3ft16_8f.html',1,'']]], + ['w3ft17_2ef_702',['w3ft17.f',['../w3ft17_8f.html',1,'']]], + ['w3ft201_2ef_703',['w3ft201.f',['../w3ft201_8f.html',1,'']]], + ['w3ft202_2ef_704',['w3ft202.f',['../w3ft202_8f.html',1,'']]], + ['w3ft203_2ef_705',['w3ft203.f',['../w3ft203_8f.html',1,'']]], + ['w3ft204_2ef_706',['w3ft204.f',['../w3ft204_8f.html',1,'']]], + ['w3ft205_2ef_707',['w3ft205.f',['../w3ft205_8f.html',1,'']]], + ['w3ft206_2ef_708',['w3ft206.f',['../w3ft206_8f.html',1,'']]], + ['w3ft207_2ef_709',['w3ft207.f',['../w3ft207_8f.html',1,'']]], + ['w3ft208_2ef_710',['w3ft208.f',['../w3ft208_8f.html',1,'']]], + ['w3ft209_2ef_711',['w3ft209.f',['../w3ft209_8f.html',1,'']]], + ['w3ft21_2ef_712',['w3ft21.f',['../w3ft21_8f.html',1,'']]], + ['w3ft210_2ef_713',['w3ft210.f',['../w3ft210_8f.html',1,'']]], + ['w3ft211_2ef_714',['w3ft211.f',['../w3ft211_8f.html',1,'']]], + ['w3ft212_2ef_715',['w3ft212.f',['../w3ft212_8f.html',1,'']]], + ['w3ft213_2ef_716',['w3ft213.f',['../w3ft213_8f.html',1,'']]], + ['w3ft214_2ef_717',['w3ft214.f',['../w3ft214_8f.html',1,'']]], + ['w3ft26_2ef_718',['w3ft26.f',['../w3ft26_8f.html',1,'']]], + ['w3ft32_2ef_719',['w3ft32.f',['../w3ft32_8f.html',1,'']]], + ['w3ft33_2ef_720',['w3ft33.f',['../w3ft33_8f.html',1,'']]], + ['w3ft38_2ef_721',['w3ft38.f',['../w3ft38_8f.html',1,'']]], + ['w3ft39_2ef_722',['w3ft39.f',['../w3ft39_8f.html',1,'']]], + ['w3ft40_2ef_723',['w3ft40.f',['../w3ft40_8f.html',1,'']]], + ['w3ft41_2ef_724',['w3ft41.f',['../w3ft41_8f.html',1,'']]], + ['w3ft43v_2ef_725',['w3ft43v.f',['../w3ft43v_8f.html',1,'']]], + ['w3kind_2ef_726',['w3kind.f',['../w3kind_8f.html',1,'']]], + ['w3locdat_2ef_727',['w3locdat.f',['../w3locdat_8f.html',1,'']]], + ['w3miscan_2ef_728',['w3miscan.f',['../w3miscan_8f.html',1,'']]], + ['w3movdat_2ef_729',['w3movdat.f',['../w3movdat_8f.html',1,'']]], + ['w3nogds_2ef_730',['w3nogds.f',['../w3nogds_8f.html',1,'']]], + ['w3pradat_2ef_731',['w3pradat.f',['../w3pradat_8f.html',1,'']]], + ['w3reddat_2ef_732',['w3reddat.f',['../w3reddat_8f.html',1,'']]], + ['w3tagb_2ef_733',['w3tagb.f',['../w3tagb_8f.html',1,'']]], + ['w3trnarg_2ef_734',['w3trnarg.f',['../w3trnarg_8f.html',1,'']]], + ['w3unpk77_2ef_735',['w3unpk77.f',['../w3unpk77_8f.html',1,'']]], + ['w3utcdat_2ef_736',['w3utcdat.f',['../w3utcdat_8f.html',1,'']]], + ['w3valdat_2ef_737',['w3valdat.f',['../w3valdat_8f.html',1,'']]], + ['w3ymdh4_2ef_738',['w3ymdh4.f',['../w3ymdh4_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/files_d.html b/ver-2.10.0/search/files_d.html new file mode 100644 index 00000000..94b2ff2d --- /dev/null +++ b/ver-2.10.0/search/files_d.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/files_d.js b/ver-2.10.0/search/files_d.js new file mode 100644 index 00000000..7aee38ae --- /dev/null +++ b/ver-2.10.0/search/files_d.js @@ -0,0 +1,6 @@ +var searchData= +[ + ['xdopen_2ef_739',['xdopen.f',['../xdopen_8f.html',1,'']]], + ['xmovex_2ef_740',['xmovex.f',['../xmovex_8f.html',1,'']]], + ['xstore_2ef_741',['xstore.f',['../xstore_8f.html',1,'']]] +]; diff --git a/ver-2.10.0/search/functions_0.html b/ver-2.10.0/search/functions_0.html new file mode 100644 index 00000000..e17c7111 --- /dev/null +++ b/ver-2.10.0/search/functions_0.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_0.js b/ver-2.10.0/search/functions_0.js new file mode 100644 index 00000000..20e18052 --- /dev/null +++ b/ver-2.10.0/search/functions_0.js @@ -0,0 +1,12 @@ +var searchData= +[ + ['aea_742',['aea',['../aea_8f.html#a9c58c678406a71b9db512ab40864666c',1,'aea.f']]], + ['ai081_743',['ai081',['../w3ai08_8f.html#a441b7146a653d41877d19a7cd64efb7c',1,'w3ai08.f']]], + ['ai082_744',['ai082',['../w3ai08_8f.html#afa6093fcf5580f32f3ff8be92af6b0e3',1,'w3ai08.f']]], + ['ai082a_745',['ai082a',['../w3ai08_8f.html#a720103ce8519bc682230c8757c6fb8e9',1,'w3ai08.f']]], + ['ai083_746',['ai083',['../w3ai08_8f.html#a7031bf0f0b33cba1e5c2334224e735a1',1,'w3ai08.f']]], + ['ai084_747',['ai084',['../w3ai08_8f.html#a1ac753d2f7d6ce69d4e1412af879b7b9',1,'w3ai08.f']]], + ['ai085_748',['ai085',['../w3ai08_8f.html#a220caa94dfc83c8a73d224245c9469da',1,'w3ai08.f']]], + ['ai085a_749',['ai085a',['../w3ai08_8f.html#a7ecf84941a754cb8d8a328c77f038de0',1,'w3ai08.f']]], + ['ai087_750',['ai087',['../w3ai08_8f.html#ac73cef7b08d3fbe6549b6db66ae7b49f',1,'w3ai08.f']]] +]; diff --git a/ver-2.10.0/search/functions_1.html b/ver-2.10.0/search/functions_1.html new file mode 100644 index 00000000..0ddac0a4 --- /dev/null +++ b/ver-2.10.0/search/functions_1.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_1.js b/ver-2.10.0/search/functions_1.js new file mode 100644 index 00000000..3fbc4341 --- /dev/null +++ b/ver-2.10.0/search/functions_1.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['bucket_751',['bucket',['../summary_8c.html#ac30f918e4632256526a027a73c95da78',1,'summary.c']]] +]; diff --git a/ver-2.10.0/search/functions_10.html b/ver-2.10.0/search/functions_10.html new file mode 100644 index 00000000..09422e1e --- /dev/null +++ b/ver-2.10.0/search/functions_10.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_10.js b/ver-2.10.0/search/functions_10.js new file mode 100644 index 00000000..0fd2f36e --- /dev/null +++ b/ver-2.10.0/search/functions_10.js @@ -0,0 +1,144 @@ +var searchData= +[ + ['w3ai00_910',['w3ai00',['../w3ai00_8f.html#a076bf45857d517709ef249c89a0791e5',1,'w3ai00.f']]], + ['w3ai01_911',['w3ai01',['../w3ai01_8f.html#a222326720cc27c198b6808bd3f601e4a',1,'w3ai01.f']]], + ['w3ai08_912',['w3ai08',['../w3ai08_8f.html#a8ca96c27a72b383415773ff07d2027dd',1,'w3ai08.f']]], + ['w3ai15_913',['w3ai15',['../w3ai15_8f.html#acb162c72ac381b1874762eff242118d5',1,'w3ai15.f']]], + ['w3ai18_914',['w3ai18',['../w3ai18_8f.html#ae424dd6b4902f8abc7a21f878eea26f5',1,'w3ai18.f']]], + ['w3ai19_915',['w3ai19',['../w3ai19_8f.html#ada69d8346ce6a030bc9f722fb842529c',1,'w3ai19.f']]], + ['w3ai24_916',['w3ai24',['../w3ai24_8f.html#a425d9890956ae872557a04b715deb3f2',1,'w3ai24.f']]], + ['w3ai38_917',['w3ai38',['../w3ai38_8f.html#a65ce63976c2011a17a8f44e0d20e074f',1,'w3ai38.f']]], + ['w3ai39_918',['w3ai39',['../w3ai39_8f.html#a28ca73de8fec4c73859576d1d2e0a219',1,'w3ai39.f']]], + ['w3ai40_919',['w3ai40',['../w3ai40_8f.html#afecf619ca48a8909617176d5e3b2de84',1,'w3ai40.f']]], + ['w3ai41_920',['w3ai41',['../w3ai41_8f.html#a07de865f47db3f841722760476742c04',1,'w3ai41.f']]], + ['w3aq15_921',['w3aq15',['../w3aq15_8f.html#aa2f10d43798cbba2f9089d37ab1fcdaa',1,'w3aq15.f']]], + ['w3as00_922',['w3as00',['../w3as00_8f.html#ac8d842c4ccf854fbe44fc54123c40529',1,'w3as00.f']]], + ['w3ctzdat_923',['w3ctzdat',['../w3ctzdat_8f.html#a7a6f88432171c9c1d03d4fc7c3e2d035',1,'w3ctzdat.f']]], + ['w3difdat_924',['w3difdat',['../w3difdat_8f.html#a2936ff0b58e9174ca023c557fe3d57b1',1,'w3difdat.f']]], + ['w3doxdat_925',['w3doxdat',['../w3doxdat_8f.html#aac79cad5709e4bc418ee85ac469afa29',1,'w3doxdat.f']]], + ['w3fa01_926',['w3fa01',['../w3fa01_8f.html#ae5c40f5b79f9833cb7012d9401bfa7b8',1,'w3fa01.f']]], + ['w3fa03_927',['w3fa03',['../w3fa03_8f.html#a682b3b6383a8cf898b6f57ce304501e3',1,'w3fa03.f']]], + ['w3fa04_928',['w3fa04',['../w3fa04_8f.html#a5f4b61c8c65ffd2662ca4918d08c8fc6',1,'w3fa04.f']]], + ['w3fa06_929',['w3fa06',['../w3fa06_8f.html#a232d431173943399677b1eb13275bb05',1,'w3fa06.f']]], + ['w3fa09_930',['w3fa09',['../w3fa09_8f.html#a97cb87ce42a1cba4c96dd80fefb9eafe',1,'w3fa09.f']]], + ['w3fa11_931',['w3fa11',['../w3fa11_8f.html#ad62a05c9654e2a4aa35667a814dee8a2',1,'w3fa11.f']]], + ['w3fa13_932',['w3fa13',['../w3fa13_8f.html#ae3485639e68c6074ead756064096216a',1,'w3fa13.f']]], + ['w3fb00_933',['w3fb00',['../w3fb00_8f.html#a007817ca2f1dd94a58abdb00f54aab28',1,'w3fb00.f']]], + ['w3fb01_934',['w3fb01',['../w3fb01_8f.html#a17796145ddabcec090b9d7249091293b',1,'w3fb01.f']]], + ['w3fb02_935',['w3fb02',['../w3fb02_8f.html#a86b57ee57a85c801ccca67cc7e6ef2a9',1,'w3fb02.f']]], + ['w3fb03_936',['w3fb03',['../w3fb03_8f.html#a0b68e4622016d2c2fe409ac880d66a3f',1,'w3fb03.f']]], + ['w3fb04_937',['w3fb04',['../w3fb04_8f.html#a239793420ab239a1a96df658749018ff',1,'w3fb04.f']]], + ['w3fb06_938',['w3fb06',['../w3fb06_8f.html#a04de76d1aea61cb48ebcd1470101bca9',1,'w3fb06.f']]], + ['w3fb07_939',['w3fb07',['../w3fb07_8f.html#a2c8196faf8798dbc2b7593e0a1ec5b68',1,'w3fb07.f']]], + ['w3fb08_940',['w3fb08',['../w3fb08_8f.html#ad3b516b61a4b4b53e680c775f3e92a5b',1,'w3fb08.f']]], + ['w3fb09_941',['w3fb09',['../w3fb09_8f.html#a44a5c4c417459876b5cbc4aaab8e4a25',1,'w3fb09.f']]], + ['w3fb10_942',['w3fb10',['../w3fb10_8f.html#a5f021ccf55ac42f4034f0fd60e612911',1,'w3fb10.f']]], + ['w3fb11_943',['w3fb11',['../w3fb11_8f.html#a28b19a1336d3f885a04a97831726a3c0',1,'w3fb11.f']]], + ['w3fb12_944',['w3fb12',['../w3fb12_8f.html#ae5e7ad09f49bf57227336e663c180ee2',1,'w3fb12.f']]], + ['w3fc02_945',['w3fc02',['../w3fc02_8f.html#a2572657557b50b4f9580f1cf204d7aaf',1,'w3fc02.f']]], + ['w3fc05_946',['w3fc05',['../w3fc05_8f.html#ae77a21f468d05a34fa3a201c89b30530',1,'w3fc05.f']]], + ['w3fc06_947',['w3fc06',['../w3fc06_8f.html#a586eff5e859341d86f5ab00dbcca2169',1,'w3fc06.f']]], + ['w3fc07_948',['w3fc07',['../w3fc07_8f.html#a84dac72c47bb275c7c251c620052b54d',1,'w3fc07.f']]], + ['w3fc08_949',['w3fc08',['../w3fc08_8f.html#ac768b413af58dd51c57c6bf6d2d48a84',1,'w3fc08.f']]], + ['w3fi01_950',['w3fi01',['../w3fi01_8f.html#a10ac20498f7eca8e2281cad1218bede4',1,'w3fi01.f']]], + ['w3fi02_951',['w3fi02',['../w3fi02_8f.html#a217b3130b7e509776b74fde620e5b715',1,'w3fi02.f']]], + ['w3fi03_952',['w3fi03',['../w3fi03_8f.html#a3cfc13ff3a45dea4c4f6f7c1832df3d3',1,'w3fi03.f']]], + ['w3fi04_953',['w3fi04',['../w3fi04_8f.html#a43d8dd578a2f24d52b45332ed3ccc6c9',1,'w3fi04.f']]], + ['w3fi18_954',['w3fi18',['../w3fi18_8f.html#a684daaf76526713839d9d702a2c8aff7',1,'w3fi18.f']]], + ['w3fi19_955',['w3fi19',['../w3fi19_8f.html#afcb6e01340c836fbd0f940b8c0e6814f',1,'w3fi19.f']]], + ['w3fi20_956',['w3fi20',['../w3fi20_8f.html#a4d5864f48a1b0a2c1223f3dd4a06059f',1,'w3fi20.f']]], + ['w3fi32_957',['w3fi32',['../w3fi32_8f.html#a28af7a8a671a5e22f09ba6f371a348db',1,'w3fi32.f']]], + ['w3fi47_958',['w3fi47',['../w3fi47_8f.html#aa65811b21988f0ddf7568b0a88f12282',1,'w3fi47.f']]], + ['w3fi48_959',['w3fi48',['../w3fi48_8f.html#af4be979e393742d638626918089c9374',1,'w3fi48.f']]], + ['w3fi52_960',['w3fi52',['../w3fi52_8f.html#a8ce70b189d09ff2d3acfb478833c640c',1,'w3fi52.f']]], + ['w3fi58_961',['w3fi58',['../w3fi58_8f.html#a9e29ba5f6e80a0133fdf08c4374d6e5e',1,'w3fi58.f']]], + ['w3fi59_962',['w3fi59',['../w3fi59_8f.html#ab4f28b2c5e95c681036ef83142a58601',1,'w3fi59.f']]], + ['w3fi61_963',['w3fi61',['../w3fi61_8f.html#a1b9630713670570f4aef4d99b284bfec',1,'w3fi61.f']]], + ['w3fi62_964',['w3fi62',['../w3fi62_8f.html#a0dd3e7a53e1e42357c2579cbe74a4f77',1,'w3fi62.f']]], + ['w3fi63_965',['w3fi63',['../w3fi63_8f.html#aa59740e4c6a30f9c5f201204603d302f',1,'w3fi63.f']]], + ['w3fi64_966',['w3fi64',['../w3fi64_8f.html#abd64595a92fa11f1d11661e1e94b9dcc',1,'w3fi64.f']]], + ['w3fi65_967',['w3fi65',['../w3fi65_8f.html#a1651042ec008fbdb77f6b66ee9643d0e',1,'w3fi65.f']]], + ['w3fi66_968',['w3fi66',['../w3fi66_8f.html#af8839a41e56c22bda1be01a7f877eb5e',1,'w3fi66.f']]], + ['w3fi67_969',['w3fi67',['../w3fi67_8f.html#af1ebc9eb3165bf0f76af6472109fb4db',1,'w3fi67.f']]], + ['w3fi68_970',['w3fi68',['../w3fi68_8f.html#a627b0d3ff494874dd3fb243e39cfa991',1,'w3fi68.f']]], + ['w3fi69_971',['w3fi69',['../w3fi69_8f.html#a725f7f35c86515ca113aa3a36ac133e0',1,'w3fi69.f']]], + ['w3fi70_972',['w3fi70',['../w3fi70_8f.html#a15c47f82fe6330c213820e90fbe63a92',1,'w3fi70.f']]], + ['w3fi71_973',['w3fi71',['../w3fi71_8f.html#add1b6b2b2c9fda60094914f5e676ec42',1,'w3fi71.f']]], + ['w3fi72_974',['w3fi72',['../w3fi72_8f.html#aaac6e022f341c919316466672ef3e70c',1,'w3fi72.f']]], + ['w3fi73_975',['w3fi73',['../w3fi73_8f.html#a89eedc9b7ba4fd46b1f6ac9eba1f773e',1,'w3fi73.f']]], + ['w3fi74_976',['w3fi74',['../w3fi74_8f.html#ab921a7e370356989116ba2ac3e429d61',1,'w3fi74.f']]], + ['w3fi75_977',['w3fi75',['../w3fi75_8f.html#aa4b8fc64e075cd7c24ab51663d4d6912',1,'w3fi75.f']]], + ['w3fi76_978',['w3fi76',['../w3fi76_8f.html#a5af5a733105c5ce75ddfe99f7249f999',1,'w3fi76.f']]], + ['w3fi78_979',['w3fi78',['../w3fi78_8f.html#a9c08a6a24a9527776d2b533108dbf261',1,'w3fi78.f']]], + ['w3fi82_980',['w3fi82',['../w3fi82_8f.html#a9d5c017171cdbf13bde5edff05dcd997',1,'w3fi82.f']]], + ['w3fi83_981',['w3fi83',['../w3fi83_8f.html#abaae8db75615b215003d0b2591b4e49d',1,'w3fi83.f']]], + ['w3fi85_982',['w3fi85',['../w3fi85_8f.html#a952501a26ebad493c05a3b8028fc6cd7',1,'w3fi85.f']]], + ['w3fi88_983',['w3fi88',['../w3fi88_8f.html#aaa3b36f853bace0e172b8191ce3a4f17',1,'w3fi88.f']]], + ['w3fi92_984',['w3fi92',['../w3fi92_8f.html#a2e8b8ef3dcf66d40422987430e28545a',1,'w3fi92.f']]], + ['w3fm07_985',['w3fm07',['../w3fm07_8f.html#a3fb4f69f29d16715851691eae8cd482b',1,'w3fm07.f']]], + ['w3fm08_986',['w3fm08',['../w3fm08_8f.html#ad2e28d805a383d0025c930544cb36155',1,'w3fm08.f']]], + ['w3fp04_987',['w3fp04',['../w3fp04_8f.html#af033f564bf5f078cbfc4700e62291470',1,'w3fp04.f']]], + ['w3fp05_988',['w3fp05',['../w3fp05_8f.html#a5d4251a5f962d24d56f5ce0b3b4212b8',1,'w3fp05.f']]], + ['w3fp06_989',['w3fp06',['../w3fp06_8f.html#afb6a19727a1186c10ede9bba2d3315c0',1,'w3fp06.f']]], + ['w3fp10_990',['w3fp10',['../w3fp10_8f.html#a2d0f404c14f9e2ea8e6a9f0e911a825e',1,'w3fp10.f']]], + ['w3fp11_991',['w3fp11',['../w3fp11_8f.html#a60348721f6e1b543427aba610af0a85d',1,'w3fp11.f']]], + ['w3fp12_992',['w3fp12',['../w3fp12_8f.html#a43259ead9ef06e1822639a8f2aa106aa',1,'w3fp12.f']]], + ['w3fp13_993',['w3fp13',['../w3fp13_8f.html#a4bb36ff2a73a0614b75ec00e2b804740',1,'w3fp13.f']]], + ['w3fq07_994',['w3fq07',['../w3fq07_8f.html#a621d5a7f77939450e814033c6f3b1535',1,'w3fq07.f']]], + ['w3fs13_995',['w3fs13',['../w3fs13_8f.html#a7ae96960810e2a780cc1dfaa4740e4ec',1,'w3fs13.f']]], + ['w3fs15_996',['w3fs15',['../w3fs15_8f.html#ada3b10209aac56c01b05d096d84e6471',1,'w3fs15.f']]], + ['w3fs21_997',['w3fs21',['../w3fs21_8f.html#a337c53a535dd6a8066f313eb9889201c',1,'w3fs21.f']]], + ['w3fs26_998',['w3fs26',['../w3fs26_8f.html#ab9c55405126eb6b249eb3d6542c0bb30',1,'w3fs26.f']]], + ['w3ft00_999',['w3ft00',['../w3ft00_8f.html#a0df888e118ff615726dfe75f1f268c21',1,'w3ft00.f']]], + ['w3ft01_1000',['w3ft01',['../w3ft01_8f.html#a5712b189cf471fffe9b1529a75949729',1,'w3ft01.f']]], + ['w3ft02_1001',['w3ft02',['../w3ft02_8f.html#ab2829ffb3ea29d17638612b1e6f4bcdf',1,'w3ft02.f']]], + ['w3ft03_1002',['w3ft03',['../w3ft03_8f.html#a86672f0df93a525a9c2f295bf3e9de0b',1,'w3ft03.f']]], + ['w3ft05_1003',['w3ft05',['../w3ft05_8f.html#a752b36aee00d233764c2d4fc9aa83d48',1,'w3ft05.f']]], + ['w3ft05v_1004',['w3ft05v',['../w3ft05v_8f.html#a77ae0ff42d73bc3e901c84d6fae74d60',1,'w3ft05v.f']]], + ['w3ft06_1005',['w3ft06',['../w3ft06_8f.html#a251b117d0bb18aa51a81c14180fda635',1,'w3ft06.f']]], + ['w3ft06v_1006',['w3ft06v',['../w3ft06v_8f.html#a02340fb38509abdb031c638362609844',1,'w3ft06v.f']]], + ['w3ft07_1007',['w3ft07',['../w3ft07_8f.html#a226490ee379923e202ba1f7d0d14102a',1,'w3ft07.f']]], + ['w3ft08_1008',['w3ft08',['../w3ft08_8f.html#ae48a19283d690c37fe8c3dc355e8e609',1,'w3ft08.f']]], + ['w3ft09_1009',['w3ft09',['../w3ft09_8f.html#ac50128472db184365bc4c2dfb1ea1a47',1,'w3ft09.f']]], + ['w3ft10_1010',['w3ft10',['../w3ft10_8f.html#a17871a93f588bd482470dd30d88f6b8c',1,'w3ft10.f']]], + ['w3ft11_1011',['w3ft11',['../w3ft11_8f.html#af60fd501521a85612c264e601718bb68',1,'w3ft11.f']]], + ['w3ft12_1012',['w3ft12',['../w3ft12_8f.html#afb994008cf891b44e3fe4a25c0b46157',1,'w3ft12.f']]], + ['w3ft16_1013',['w3ft16',['../w3ft16_8f.html#a3eb1bcdeb5163086f4e319d036fa9b8f',1,'w3ft16.f']]], + ['w3ft17_1014',['w3ft17',['../w3ft17_8f.html#ac26d2dfc790515275a019ab4588f0751',1,'w3ft17.f']]], + ['w3ft201_1015',['w3ft201',['../w3ft201_8f.html#adf01350dac0812280321527151e91c76',1,'w3ft201.f']]], + ['w3ft202_1016',['w3ft202',['../w3ft202_8f.html#a250a1c3e5855f0481b17a3bf264cb2cd',1,'w3ft202.f']]], + ['w3ft203_1017',['w3ft203',['../w3ft203_8f.html#ac0fba620647d28d2dfd0424c2d3543e8',1,'w3ft203.f']]], + ['w3ft204_1018',['w3ft204',['../w3ft204_8f.html#abb78410bc09aaf18f345e4a90c7cff9f',1,'w3ft204.f']]], + ['w3ft205_1019',['w3ft205',['../w3ft205_8f.html#ad9a3463156cbb99e97f7f3c2f9e0bc26',1,'w3ft205.f']]], + ['w3ft206_1020',['w3ft206',['../w3ft206_8f.html#a8a2d9d2de5ecb622756c8138eab5377c',1,'w3ft206.f']]], + ['w3ft207_1021',['w3ft207',['../w3ft207_8f.html#aa4de7ddd4f65373756f6cd70b3fd6fec',1,'w3ft207.f']]], + ['w3ft208_1022',['w3ft208',['../w3ft208_8f.html#ab3380c5bf59fbd57210787bb91f5584f',1,'w3ft208.f']]], + ['w3ft209_1023',['w3ft209',['../w3ft209_8f.html#a8d2adf2c3f2603ed6555c88d77f0b51b',1,'w3ft209.f']]], + ['w3ft21_1024',['w3ft21',['../w3ft21_8f.html#a681f756a8ebbb0bed83c216be180c4ae',1,'w3ft21.f']]], + ['w3ft210_1025',['w3ft210',['../w3ft210_8f.html#a3803de9cbf2932eb2aa3b36ed8fef355',1,'w3ft210.f']]], + ['w3ft211_1026',['w3ft211',['../w3ft211_8f.html#a353f8903a8cbe06aa931ab815e317708',1,'w3ft211.f']]], + ['w3ft212_1027',['w3ft212',['../w3ft212_8f.html#a80630575cad8c3e8743fb7b161d2b18e',1,'w3ft212.f']]], + ['w3ft213_1028',['w3ft213',['../w3ft213_8f.html#a1de78ace88fde1b28429425c20838344',1,'w3ft213.f']]], + ['w3ft214_1029',['w3ft214',['../w3ft214_8f.html#a87c1f4b3ef6dccfe37b0a288d2143848',1,'w3ft214.f']]], + ['w3ft26_1030',['w3ft26',['../w3ft26_8f.html#a584757389b1cf4707abb4cadb47850ab',1,'w3ft26.f']]], + ['w3ft32_1031',['w3ft32',['../w3ft32_8f.html#acfaec65cdd9e813295e8e83626c176cd',1,'w3ft32.f']]], + ['w3ft33_1032',['w3ft33',['../w3ft33_8f.html#aa788035129e6f04923f7f351fb343ff0',1,'w3ft33.f']]], + ['w3ft38_1033',['w3ft38',['../w3ft38_8f.html#a1826351145421b3de7f51f5b798ae391',1,'w3ft38.f']]], + ['w3ft39_1034',['w3ft39',['../w3ft39_8f.html#a858e5d96caaef7d2d5882420f7bc3556',1,'w3ft39.f']]], + ['w3ft40_1035',['w3ft40',['../w3ft40_8f.html#a3bc42dc396a768eb87167924c73c65d6',1,'w3ft40.f']]], + ['w3ft41_1036',['w3ft41',['../w3ft41_8f.html#a261b10911c4a789b882deef2c1f312ca',1,'w3ft41.f']]], + ['w3ft43v_1037',['w3ft43v',['../w3ft43v_8f.html#a2296d6ab6d8638d5d0d59468cc6402d5',1,'w3ft43v.f']]], + ['w3kind_1038',['w3kind',['../w3kind_8f.html#adbff650124d647848a96ff9e35b0fa4a',1,'w3kind.f']]], + ['w3locdat_1039',['w3locdat',['../w3locdat_8f.html#aa6df8f7e0aa6aa5067becb1ca7a6ebe1',1,'w3locdat.f']]], + ['w3miscan_1040',['w3miscan',['../w3miscan_8f.html#af1352ee5db91f6a057c1378cf9b00df1',1,'w3miscan.f']]], + ['w3movdat_1041',['w3movdat',['../w3movdat_8f.html#a999d6ea7410cb2a3a220722b4ddb7339',1,'w3movdat.f']]], + ['w3nogds_1042',['w3nogds',['../w3nogds_8f.html#a9fee3e95f39d96f49f71d4fe1a681e6a',1,'w3nogds.f']]], + ['w3pradat_1043',['w3pradat',['../w3pradat_8f.html#a519f334382b52df31bbe2240584e41b6',1,'w3pradat.f']]], + ['w3reddat_1044',['w3reddat',['../w3reddat_8f.html#a0b2ac29ce428bb8876dca351df7fb7fb',1,'w3reddat.f']]], + ['w3tagb_1045',['w3tagb',['../w3tagb_8f.html#ac295260f62d3bdcf6c621177ff7d9275',1,'w3tagb.f']]], + ['w3trnarg_1046',['w3trnarg',['../w3trnarg_8f.html#a469f580bad86541dc4ffe778b0eaf9bf',1,'w3trnarg.f']]], + ['w3unpk77_1047',['w3unpk77',['../w3unpk77_8f.html#a162c40d765efa43eeae668a6af507843',1,'w3unpk77.f']]], + ['w3utcdat_1048',['w3utcdat',['../w3utcdat_8f.html#aa33d08dc203b9cc4e7c96e566c7db42a',1,'w3utcdat.f']]], + ['w3valdat_1049',['w3valdat',['../w3valdat_8f.html#a8a051a793c804f190e2da69fd1e16ebe',1,'w3valdat.f']]], + ['w3ymdh4_1050',['w3ymdh4',['../w3ymdh4_8f.html#a78ffe9a370f362c71bcb5573f595f105',1,'w3ymdh4.f']]] +]; diff --git a/ver-2.10.0/search/functions_11.html b/ver-2.10.0/search/functions_11.html new file mode 100644 index 00000000..1cde7b49 --- /dev/null +++ b/ver-2.10.0/search/functions_11.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_11.js b/ver-2.10.0/search/functions_11.js new file mode 100644 index 00000000..2bfc158f --- /dev/null +++ b/ver-2.10.0/search/functions_11.js @@ -0,0 +1,6 @@ +var searchData= +[ + ['xdopen_1051',['xdopen',['../xdopen_8f.html#a941a5a5172e73a4d75553437ad275ece',1,'xdopen.f']]], + ['xmovex_1052',['xmovex',['../xmovex_8f.html#a4736b412fd765dc34e51e7ebf774cc61',1,'xmovex.f']]], + ['xstore_1053',['xstore',['../xstore_8f.html#a31e695d6327ff9328c6604bc9d72a245',1,'xstore.f']]] +]; diff --git a/ver-2.10.0/search/functions_2.html b/ver-2.10.0/search/functions_2.html new file mode 100644 index 00000000..2737c5ac --- /dev/null +++ b/ver-2.10.0/search/functions_2.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_2.js b/ver-2.10.0/search/functions_2.js new file mode 100644 index 00000000..7bfdf09c --- /dev/null +++ b/ver-2.10.0/search/functions_2.js @@ -0,0 +1,6 @@ +var searchData= +[ + ['c01o29_752',['c01o29',['../iw3unp29_8f.html#ade469dc7a458658c23096016179ff9e2',1,'iw3unp29.f']]], + ['climo_753',['climo',['../w3fp06_8f.html#aaf8401635d84331960b1c2985cd74a51',1,'w3fp06.f']]], + ['cputim_754',['cputim',['../summary_8c.html#a85f50c91b93171e345aa393946e62aa9',1,'summary.c']]] +]; diff --git a/ver-2.10.0/search/functions_3.html b/ver-2.10.0/search/functions_3.html new file mode 100644 index 00000000..6da86e7d --- /dev/null +++ b/ver-2.10.0/search/functions_3.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_3.js b/ver-2.10.0/search/functions_3.js new file mode 100644 index 00000000..76e306cd --- /dev/null +++ b/ver-2.10.0/search/functions_3.js @@ -0,0 +1,7 @@ +var searchData= +[ + ['elapse_755',['elapse',['../summary_8c.html#a5c5678e05ce08da171d237db078d2c30',1,'summary.c']]], + ['end_5ftimer_756',['end_timer',['../summary_8c.html#a91f9293b85b800dfb07ec0ef110e4c22',1,'summary.c']]], + ['errexit_757',['errexit',['../errexit_8f.html#abcd4c3fc1b8b684d5dc7b9412891de91',1,'errexit.f']]], + ['errmsg_758',['errmsg',['../errmsg_8f.html#acb908fdaebb814b3210e63ecae74c996',1,'errmsg.f']]] +]; diff --git a/ver-2.10.0/search/functions_4.html b/ver-2.10.0/search/functions_4.html new file mode 100644 index 00000000..911304e6 --- /dev/null +++ b/ver-2.10.0/search/functions_4.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_4.js b/ver-2.10.0/search/functions_4.js new file mode 100644 index 00000000..e51a9af5 --- /dev/null +++ b/ver-2.10.0/search/functions_4.js @@ -0,0 +1,62 @@ +var searchData= +[ + ['fi631_759',['fi631',['../w3fi63_8f.html#a5e07fb32acda017ce2b31674761eddb0',1,'w3fi63.f']]], + ['fi632_760',['fi632',['../w3fi63_8f.html#a49e798fade46eda6b55035a58e136185',1,'w3fi63.f']]], + ['fi633_761',['fi633',['../w3fi63_8f.html#ae00e4a53f6509a2e49276ecc592522d1',1,'w3fi63.f']]], + ['fi634_762',['fi634',['../w3fi63_8f.html#a573937997ce1f78d799c52ba6812d503',1,'w3fi63.f']]], + ['fi634x_763',['fi634x',['../w3fi63_8f.html#abe401baf1479cb539db68da3358232f1',1,'w3fi63.f']]], + ['fi635_764',['fi635',['../w3fi63_8f.html#a88fef913d620c38a8795ad7b93cb73a7',1,'w3fi63.f']]], + ['fi636_765',['fi636',['../w3fi63_8f.html#acf6e1d529f2d31927f198d24b8ca610b',1,'w3fi63.f']]], + ['fi637_766',['fi637',['../w3fi63_8f.html#a7c07c9973bb0370c09e56fa6aa00665a',1,'w3fi63.f']]], + ['fi6701_767',['fi6701',['../w3fi67_8f.html#af1838e0792e8dacd4ba70b0b844065c6',1,'w3fi67.f']]], + ['fi6702_768',['fi6702',['../w3fi67_8f.html#ab4efc955f13221a830e6c653fbe8326b',1,'w3fi67.f']]], + ['fi6703_769',['fi6703',['../w3fi67_8f.html#a85264d1d80f2dcd1c5aef6998179ed21',1,'w3fi67.f']]], + ['fi6704_770',['fi6704',['../w3fi67_8f.html#ad13befc6a11f1be63345c169e4e2c21a',1,'w3fi67.f']]], + ['fi6705_771',['fi6705',['../w3fi67_8f.html#ac00ebd799c167d32ad1e8d2ccf77d8ed',1,'w3fi67.f']]], + ['fi6706_772',['fi6706',['../w3fi67_8f.html#aa8975059a9c80ae0909d0942907c5b04',1,'w3fi67.f']]], + ['fi6707_773',['fi6707',['../w3fi67_8f.html#a0ba8ee313bbaa81c2d31552c8ba447dd',1,'w3fi67.f']]], + ['fi6708_774',['fi6708',['../w3fi67_8f.html#afc00645e835f1bb662852727afb41980',1,'w3fi67.f']]], + ['fi6709_775',['fi6709',['../w3fi67_8f.html#a450eb49ae26957e0bcadb573ffbcbab2',1,'w3fi67.f']]], + ['fi6710_776',['fi6710',['../w3fi67_8f.html#a2f44d69247df49460acaabe30f7cabb9',1,'w3fi67.f']]], + ['fi7501_777',['fi7501',['../w3fi75_8f.html#a76d712772f7a7b26ca1bba569d377e14',1,'w3fi75.f']]], + ['fi7502_778',['fi7502',['../w3fi75_8f.html#acafb610fbee0d6e272301e3277cf4d32',1,'w3fi75.f']]], + ['fi7503_779',['fi7503',['../w3fi75_8f.html#a96ec02cf0c85d44fc9f0fffff0ef038c',1,'w3fi75.f']]], + ['fi7505_780',['fi7505',['../w3fi75_8f.html#ad8add9d378e5f476eb9a03253aac0673',1,'w3fi75.f']]], + ['fi7513_781',['fi7513',['../w3fi75_8f.html#a36ae6b4d235133cbe224771791cc78a1',1,'w3fi75.f']]], + ['fi7516_782',['fi7516',['../w3fi75_8f.html#a2594a5111d3b15a124e611eee1152fb7',1,'w3fi75.f']]], + ['fi7517_783',['fi7517',['../w3fi75_8f.html#ae605cd757c3b135016711cb96e8ddb12',1,'w3fi75.f']]], + ['fi7518_784',['fi7518',['../w3fi75_8f.html#abdf0aa822fec98a9c20620ea1e170b7a',1,'w3fi75.f']]], + ['fi7801_785',['fi7801',['../w3fi78_8f.html#a78a1ba5576bfc184dbcde9db7647f2c0',1,'w3fi78.f']]], + ['fi7802_786',['fi7802',['../w3fi78_8f.html#afe2cebe5fb34bedc4e028fcaeec3eb0b',1,'w3fi78.f']]], + ['fi7803_787',['fi7803',['../w3fi78_8f.html#abd85631fd2ddaae2c69a597dada4bad5',1,'w3fi78.f']]], + ['fi7804_788',['fi7804',['../w3fi78_8f.html#adde456d0a3cdfb2ada7e27dac62ff5b4',1,'w3fi78.f']]], + ['fi7805_789',['fi7805',['../w3fi78_8f.html#aef0cfcae2b4b6aecddae061ef55c23f7',1,'w3fi78.f']]], + ['fi7806_790',['fi7806',['../w3fi78_8f.html#a759ea3357b94bf332300d7ae6b6e073e',1,'w3fi78.f']]], + ['fi7807_791',['fi7807',['../w3fi78_8f.html#ac6daf60e47a8949569927e2dbe795dc7',1,'w3fi78.f']]], + ['fi7808_792',['fi7808',['../w3fi78_8f.html#aa9b1b7dfb8dd609828a6e0db3271351f',1,'w3fi78.f']]], + ['fi7809_793',['fi7809',['../w3fi78_8f.html#aa30ef437f8f02bfaf3482c3c496d4af5',1,'w3fi78.f']]], + ['fi7810_794',['fi7810',['../w3fi78_8f.html#a1c0312bb81a0d948725334348ba1cbc0',1,'w3fi78.f']]], + ['fi8501_795',['fi8501',['../w3fi85_8f.html#a2dfac12c57c3882ab71df73ae85329ef',1,'w3fi85.f']]], + ['fi8502_796',['fi8502',['../w3fi85_8f.html#aa2db7280cff113d09e4ade7687aaca1a',1,'w3fi85.f']]], + ['fi8503_797',['fi8503',['../w3fi85_8f.html#a65ffb3c26f568c33248204db13547c2f',1,'w3fi85.f']]], + ['fi8505_798',['fi8505',['../w3fi85_8f.html#a52f6aae9ed57d3745d0e142b54366427',1,'w3fi85.f']]], + ['fi8506_799',['fi8506',['../w3fi85_8f.html#a909b8c9399363ed4f51c78bedb57f3cd',1,'w3fi85.f']]], + ['fi8508_800',['fi8508',['../w3fi85_8f.html#a97892186cc13a9f697d5cc447131db26',1,'w3fi85.f']]], + ['fi8509_801',['fi8509',['../w3fi85_8f.html#a43fe930255ffb0865c2329031d294786',1,'w3fi85.f']]], + ['fi8511_802',['fi8511',['../w3fi85_8f.html#ae5983e91fa36267f15a462c84a649de3',1,'w3fi85.f']]], + ['fi8512_803',['fi8512',['../w3fi85_8f.html#ab388b83b7f0918bbae5097408882c6b9',1,'w3fi85.f']]], + ['fi8513_804',['fi8513',['../w3fi85_8f.html#a17405ce8ebd7d06c0bedf0bea6ae2105',1,'w3fi85.f']]], + ['fi8801_805',['fi8801',['../w3fi88_8f.html#ae5d0192919fea00763c2ea1490bff16a',1,'w3fi88.f']]], + ['fi8802_806',['fi8802',['../w3fi88_8f.html#a7829bc0e44ec367834a1a6d83377d428',1,'w3fi88.f']]], + ['fi8803_807',['fi8803',['../w3fi88_8f.html#a228b9ca88ab5e42aa00c6df379ecd470',1,'w3fi88.f']]], + ['fi8804_808',['fi8804',['../w3fi88_8f.html#a94b6d994b2df117c1395048caea2f86b',1,'w3fi88.f']]], + ['fi8805_809',['fi8805',['../w3fi88_8f.html#a45180c8723bc0f7b3eaff47b7fda7ed8',1,'w3fi88.f']]], + ['fi8806_810',['fi8806',['../w3fi88_8f.html#a119b554db1325ff6b2d3742797f107dd',1,'w3fi88.f']]], + ['fi8807_811',['fi8807',['../w3fi88_8f.html#aa56d7f5f943a7bf774c2e9ddc144595f',1,'w3fi88.f']]], + ['fi8808_812',['fi8808',['../w3fi88_8f.html#a2a7856fc62e88d8fa8670e58c4082293',1,'w3fi88.f']]], + ['fi8809_813',['fi8809',['../w3fi88_8f.html#a334e81d3c01ac71a02ef5425671e7bf0',1,'w3fi88.f']]], + ['fi8810_814',['fi8810',['../w3fi88_8f.html#adad8332e2168ab134f2c6f879f133a5f',1,'w3fi88.f']]], + ['fi8811_815',['fi8811',['../w3fi88_8f.html#a12b020b46772271cab997bb781bda9c1',1,'w3fi88.f']]], + ['fparsei_816',['fparsei',['../fparsei_8f.html#a36e302a33bf921be9c7990e94ccc1a1f',1,'fparsei.f']]], + ['fparser_817',['fparser',['../fparser_8f.html#afd0eece805c9f9aa1afa5b5496298aa5',1,'fparser.f']]] +]; diff --git a/ver-2.10.0/search/functions_5.html b/ver-2.10.0/search/functions_5.html new file mode 100644 index 00000000..61b920db --- /dev/null +++ b/ver-2.10.0/search/functions_5.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_5.js b/ver-2.10.0/search/functions_5.js new file mode 100644 index 00000000..71250ed0 --- /dev/null +++ b/ver-2.10.0/search/functions_5.js @@ -0,0 +1,30 @@ +var searchData= +[ + ['gbyte_818',['gbyte',['../gbyte_8f.html#ad73b69048043b0e9876125b1d839e5c6',1,'gbyte.f']]], + ['gbytec_819',['gbytec',['../gbytec_8f.html#adcae5457ea7270b3b95a379fec9233d7',1,'gbytec.f']]], + ['gbytes_820',['gbytes',['../gbytes_8f.html#ac957b0c87f1261d8460c52bfec7d0308',1,'gbytes.f']]], + ['gbytesc_821',['gbytesc',['../gbytesc_8f.html#a8fd2d6beeef9feaf3ef1e927f66678db',1,'gbytesc.f']]], + ['getgb_822',['getgb',['../getgb_8f.html#ab1cec03904b6e6c41840726cd53a69ce',1,'getgb.f']]], + ['getgb1_823',['getgb1',['../getgb1_8f.html#a124fccd25cd6967ce2b5ba8629e3707c',1,'getgb1.f']]], + ['getgb1r_824',['getgb1r',['../getgb1r_8f.html#a38f437c2ae06e0aecb78f8841749a09d',1,'getgb1r.f']]], + ['getgb1re_825',['getgb1re',['../getgb1re_8f.html#a964db1a320f7b795dd353fbd292c06d7',1,'getgb1re.f']]], + ['getgb1s_826',['getgb1s',['../getgb1s_8f.html#a112566bbdfcf96f3ce3f7c5e2ba8618f',1,'getgb1s.f']]], + ['getgbe_827',['getgbe',['../getgbe_8f.html#a947b6d97db47adbcce8dde953f7e5de2',1,'getgbe.f']]], + ['getgbeh_828',['getgbeh',['../getgbeh_8f.html#ae52a0759ee42423a1ad4d714665cdb64',1,'getgbeh.f']]], + ['getgbem_829',['getgbem',['../getgbem_8f.html#a1b647652df8027c1858a12f78234d246',1,'getgbem.f']]], + ['getgbemh_830',['getgbemh',['../getgbemh_8f.html#af515ecda0ec8361b15a4596b5773bd5f',1,'getgbemh.f']]], + ['getgbemn_831',['getgbemn',['../getgbemn_8f.html#aa8900c58b55dacd248734fa3e97c1482',1,'getgbemn.f']]], + ['getgbemp_832',['getgbemp',['../getgbemp_8f.html#a3703b88e4d6f0e0dc3a8643d7662137c',1,'getgbemp.f']]], + ['getgbens_833',['getgbens',['../getgbens_8f.html#a0ab50ed386ca101b034a86b960de28b4',1,'getgbens.f']]], + ['getgbep_834',['getgbep',['../getgbep_8f.html#a0f50efcce1cf858f28518c9f3dd19b40',1,'getgbep.f']]], + ['getgbex_835',['getgbex',['../getgbex_8f.html#a2dec8fa1731d77d4d81cd9609f04f8f5',1,'getgbex.f']]], + ['getgbexm_836',['getgbexm',['../getgbexm_8f.html#ab15467040c53a0346d4857a0496c4762',1,'getgbexm.f']]], + ['getgbh_837',['getgbh',['../getgbh_8f.html#ad15e85bb8f0d1057394c1732840fa128',1,'getgbh.f']]], + ['getgbm_838',['getgbm',['../getgbm_8f.html#ac004e0201adb9928c5fada5c7372fd78',1,'getgbm.f']]], + ['getgbmh_839',['getgbmh',['../getgbmh_8f.html#ac4c2d81dcaf427548139d55ca7041022',1,'getgbmh.f']]], + ['getgbmp_840',['getgbmp',['../getgbmp_8f.html#a3dce03b33b45a2c4f9c859774615cb5a',1,'getgbmp.f']]], + ['getgbp_841',['getgbp',['../getgbp_8f.html#afc5ba2c9bbd49e77d7a725bf08bcccfd',1,'getgbp.f']]], + ['getgi_842',['getgi',['../getgi_8f.html#aa6b511267e410648a9961a1aa2e4d27f',1,'getgi.f']]], + ['getgir_843',['getgir',['../getgir_8f.html#abcd2305cabdf6bb6a000fbb948c608a1',1,'getgir.f']]], + ['gtbits_844',['gtbits',['../gtbits_8f.html#a31c0ebc8937002fb7b104298f8c439ec',1,'gtbits.f']]] +]; diff --git a/ver-2.10.0/search/functions_6.html b/ver-2.10.0/search/functions_6.html new file mode 100644 index 00000000..dc70a4a0 --- /dev/null +++ b/ver-2.10.0/search/functions_6.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_6.js b/ver-2.10.0/search/functions_6.js new file mode 100644 index 00000000..f150796b --- /dev/null +++ b/ver-2.10.0/search/functions_6.js @@ -0,0 +1,14 @@ +var searchData= +[ + ['i01o29_845',['i01o29',['../iw3unp29_8f.html#a0d3c45449c312f0e99cdb92777a3220a',1,'iw3unp29.f']]], + ['i02o29_846',['i02o29',['../iw3unp29_8f.html#ae9e0c357df4d0c782d851fdd8ce09e14',1,'iw3unp29.f']]], + ['i03o29_847',['i03o29',['../iw3unp29_8f.html#af0213dc1cf8d73c372bcacc88c16fdf9',1,'iw3unp29.f']]], + ['i05o29_848',['i05o29',['../iw3unp29_8f.html#a89e6f36d2a7dae698c0dff8a77b078a2',1,'iw3unp29.f']]], + ['idsdef_849',['idsdef',['../idsdef_8f.html#a55d6afd1ffb535e0b76701cd33c997e3',1,'idsdef.f']]], + ['instrument_850',['instrument',['../instrument_8f.html#a1bf5314dfe3e0adf03773a63dadf6173',1,'instrument.f']]], + ['isrchne_851',['isrchne',['../isrchne_8f.html#aa2ad73a774eaa79cc4134b5a30210c19',1,'isrchne.f']]], + ['iw3jdn_852',['iw3jdn',['../iw3jdn_8f.html#accbe8d5a05413129a72efa183f1fa3b6',1,'iw3jdn.f']]], + ['iw3mat_853',['iw3mat',['../iw3mat_8f.html#a2fba35a09957d0d2a2e37b8c63e9ef4f',1,'iw3mat.f']]], + ['iw3unp29_854',['iw3unp29',['../iw3unp29_8f.html#a1de5e205645a3843697845185ffaaeb1',1,'iw3unp29.f']]], + ['ixgb_855',['ixgb',['../ixgb_8f.html#a21b5f70c2205bfb68df79fbb83928066',1,'ixgb.f']]] +]; diff --git a/ver-2.10.0/search/functions_7.html b/ver-2.10.0/search/functions_7.html new file mode 100644 index 00000000..7de31067 --- /dev/null +++ b/ver-2.10.0/search/functions_7.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_7.js b/ver-2.10.0/search/functions_7.js new file mode 100644 index 00000000..0a1d12ec --- /dev/null +++ b/ver-2.10.0/search/functions_7.js @@ -0,0 +1,7 @@ +var searchData= +[ + ['lengds_856',['lengds',['../lengds_8f.html#a53ab57aefe7c9277606708b4c8af7b00',1,'lengds.f']]], + ['line01_857',['line01',['../w3fp06_8f.html#a771b5aa20028a43dd4e5fed735c85797',1,'w3fp06.f']]], + ['line02_858',['line02',['../w3fp06_8f.html#a69e9f6991efd633d1734e87d0c0cf6f1',1,'w3fp06.f']]], + ['line03_859',['line03',['../w3fp06_8f.html#a07285bde2b2eda3dea091bbb82ab27ee',1,'w3fp06.f']]] +]; diff --git a/ver-2.10.0/search/functions_8.html b/ver-2.10.0/search/functions_8.html new file mode 100644 index 00000000..7422be24 --- /dev/null +++ b/ver-2.10.0/search/functions_8.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_8.js b/ver-2.10.0/search/functions_8.js new file mode 100644 index 00000000..bb90232f --- /dev/null +++ b/ver-2.10.0/search/functions_8.js @@ -0,0 +1,11 @@ +var searchData= +[ + ['makwmo_860',['makwmo',['../makwmo_8f.html#a8fd8c7e636856ca63ccdd4a0d786636d',1,'makwmo.f']]], + ['misc01_861',['misc01',['../w3miscan_8f.html#afdde0d874410648935ffd0d1c5457321',1,'w3miscan.f']]], + ['misc04_862',['misc04',['../w3miscan_8f.html#acde6036e077def96f8071397d2eec3f5',1,'w3miscan.f']]], + ['misc05_863',['misc05',['../w3miscan_8f.html#a7ee0202db29014a39612fd133a9ca421',1,'w3miscan.f']]], + ['misc06_864',['misc06',['../w3miscan_8f.html#aded626863c4df7539accbced4b6ab799',1,'w3miscan.f']]], + ['misc10_865',['misc10',['../w3miscan_8f.html#adda71e84fc0a136a1b9de35eb6c02d19',1,'w3miscan.f']]], + ['mkfldsep_866',['mkfldsep',['../mkfldsep_8f.html#ac36c3aa46eee1a7f5ce77daa4c3fc045',1,'mkfldsep.f']]], + ['mova2i_867',['mova2i',['../mova2i_8f.html#aed1be7b63ac5c89c04f701e75bb4fbe0',1,'mova2i.f']]] +]; diff --git a/ver-2.10.0/search/functions_9.html b/ver-2.10.0/search/functions_9.html new file mode 100644 index 00000000..befd4faa --- /dev/null +++ b/ver-2.10.0/search/functions_9.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_9.js b/ver-2.10.0/search/functions_9.js new file mode 100644 index 00000000..54872ec9 --- /dev/null +++ b/ver-2.10.0/search/functions_9.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['orders_868',['orders',['../orders_8f.html#a311c2453b613d259dc8e998f6d6aa944',1,'orders.f']]] +]; diff --git a/ver-2.10.0/search/functions_a.html b/ver-2.10.0/search/functions_a.html new file mode 100644 index 00000000..a81e9633 --- /dev/null +++ b/ver-2.10.0/search/functions_a.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_a.js b/ver-2.10.0/search/functions_a.js new file mode 100644 index 00000000..f0a1e781 --- /dev/null +++ b/ver-2.10.0/search/functions_a.js @@ -0,0 +1,12 @@ +var searchData= +[ + ['pdsens_869',['pdsens',['../pdsens_8f.html#ac0ab2fe3df3fc664f2c413214700206e',1,'pdsens.f']]], + ['pdseup_870',['pdseup',['../pdseup_8f.html#a62cf775ad87c64a28b7e395792eabfca',1,'pdseup.f']]], + ['print_5ftiming_871',['print_timing',['../summary_8c.html#a375531ea214cead1fa2bdee20bcc2dd0',1,'summary.c']]], + ['putgb_872',['putgb',['../putgb_8f.html#aa61b5b2b00eb09531ef126983ad1d724',1,'putgb.f']]], + ['putgbe_873',['putgbe',['../putgbe_8f.html#aff43ef1fa54eed421433340d5954fcfe',1,'putgbe.f']]], + ['putgben_874',['putgben',['../putgben_8f.html#a094e5a410a4e995f25665a750ac2bc8c',1,'putgben.f']]], + ['putgbens_875',['putgbens',['../putgbens_8f.html#a1a125225f33ac856c34ce692adeef0b2',1,'putgbens.f']]], + ['putgbex_876',['putgbex',['../putgbex_8f.html#a64977c953757490ae3b8b72a5fd7c4cb',1,'putgbex.f']]], + ['putgbn_877',['putgbn',['../putgbn_8f.html#ad639ec06d322cda9f568c75b98aacc67',1,'putgbn.f']]] +]; diff --git a/ver-2.10.0/search/functions_b.html b/ver-2.10.0/search/functions_b.html new file mode 100644 index 00000000..345265d6 --- /dev/null +++ b/ver-2.10.0/search/functions_b.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_b.js b/ver-2.10.0/search/functions_b.js new file mode 100644 index 00000000..1ce11a91 --- /dev/null +++ b/ver-2.10.0/search/functions_b.js @@ -0,0 +1,6 @@ +var searchData= +[ + ['q9e3i6_878',['q9e3i6',['../w3ai00_8f.html#a080e60503e36be98db3d35c5e508dbde',1,'w3ai00.f']]], + ['q9ei32_879',['q9ei32',['../w3ai00_8f.html#aa9b74cf19854cae0066bd5d905a65873',1,'w3ai00.f']]], + ['q9ie32_880',['q9ie32',['../q9ie32_8f.html#a7cfc294cd548b96adbe4ccd72fc656c1',1,'q9ie32.f']]] +]; diff --git a/ver-2.10.0/search/functions_c.html b/ver-2.10.0/search/functions_c.html new file mode 100644 index 00000000..858bfd6c --- /dev/null +++ b/ver-2.10.0/search/functions_c.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_c.js b/ver-2.10.0/search/functions_c.js new file mode 100644 index 00000000..c79a3020 --- /dev/null +++ b/ver-2.10.0/search/functions_c.js @@ -0,0 +1,13 @@ +var searchData= +[ + ['r01o29_881',['r01o29',['../iw3unp29_8f.html#af252340bc4d8811a4d6e799bdf1c3790',1,'iw3unp29.f']]], + ['r63w72_882',['r63w72',['../r63w72_8f.html#a071601493ea893c59ed2b8fac3cf9116',1,'r63w72.f']]], + ['random_5fgauss_5ff_883',['random_gauss_f',['../namespacemersenne__twister.html#acd01aa05ecfbe1c3283dc3552fc9a437',1,'mersenne_twister']]], + ['random_5findex_5ff_884',['random_index_f',['../namespacemersenne__twister.html#acc59b5b06bcd98e292ffeaeae88c9c5e',1,'mersenne_twister']]], + ['random_5fnumber_5ff_885',['random_number_f',['../namespacemersenne__twister.html#a72d5b1cd21e6af407325bb8b0e18481a',1,'mersenne_twister']]], + ['random_5fseed_886',['random_seed',['../namespacemersenne__twister.html#ab5807578f927f719be280774b17803ad',1,'mersenne_twister']]], + ['resource_887',['resource',['../summary_8c.html#a585b71c74faea63d161810774ef8da9e',1,'summary.c']]], + ['risc02_888',['risc02',['../w3miscan_8f.html#a6edc5e68c541091294d41f99e804a05e',1,'w3miscan.f']]], + ['risc02xx_889',['risc02xx',['../w3miscan_8f.html#a4b77772e4547b0f74a9b1c669a839be6',1,'w3miscan.f']]], + ['risc03_890',['risc03',['../w3miscan_8f.html#ac30ceca6f563c3f755520f227e068930',1,'w3miscan.f']]] +]; diff --git a/ver-2.10.0/search/functions_d.html b/ver-2.10.0/search/functions_d.html new file mode 100644 index 00000000..2f09f51b --- /dev/null +++ b/ver-2.10.0/search/functions_d.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_d.js b/ver-2.10.0/search/functions_d.js new file mode 100644 index 00000000..40a56b8d --- /dev/null +++ b/ver-2.10.0/search/functions_d.js @@ -0,0 +1,12 @@ +var searchData= +[ + ['s06o29_891',['s06o29',['../iw3unp29_8f.html#a2d15cb33d16ceab9921e8add94c30a42',1,'iw3unp29.f']]], + ['sbyte_892',['sbyte',['../sbyte_8f.html#afbbfa5a4daed1898e1235a221dcf54b2',1,'sbyte.f']]], + ['sbytec_893',['sbytec',['../sbytec_8f.html#aa252e1e9e9f8808f95473792d319231b',1,'sbytec.f']]], + ['sbytesc_894',['sbytesc',['../sbytesc_8f.html#aa527f56385adc86efba0d8605f251088',1,'sbytesc.f']]], + ['setcl_895',['setcl',['../w3fp06_8f.html#a67cf94ad0864f312b980ca2315e729e2',1,'w3fp06.f']]], + ['skgb_896',['skgb',['../skgb_8f.html#a7654c30923c8fa28091b5cb300c93311',1,'skgb.f']]], + ['start_5f_897',['start_',['../summary_8c.html#ad890855d9ece9845912ab1f12f8ee31e',1,'summary.c']]], + ['start_5ftimer_898',['start_timer',['../summary_8c.html#a9078a5949f4d6fe30ed2a5bf7c0cf4d7',1,'summary.c']]], + ['summary_5f_899',['summary_',['../summary_8c.html#a60f2dd974b43d33df8d7a6b4c2a47110',1,'summary.c']]] +]; diff --git a/ver-2.10.0/search/functions_e.html b/ver-2.10.0/search/functions_e.html new file mode 100644 index 00000000..ee5afa65 --- /dev/null +++ b/ver-2.10.0/search/functions_e.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_e.js b/ver-2.10.0/search/functions_e.js new file mode 100644 index 00000000..ea0ead34 --- /dev/null +++ b/ver-2.10.0/search/functions_e.js @@ -0,0 +1,12 @@ +var searchData= +[ + ['unpk7701_900',['unpk7701',['../w3unpk77_8f.html#ab50a57de79ddc4377c2c17512e58c6ea',1,'w3unpk77.f']]], + ['unpk7702_901',['unpk7702',['../w3unpk77_8f.html#affac66f51c4a903f7e20d643da19f4df',1,'w3unpk77.f']]], + ['unpk7703_902',['unpk7703',['../w3unpk77_8f.html#ab7a2a42f29d7122f4273548568b0168a',1,'w3unpk77.f']]], + ['unpk7704_903',['unpk7704',['../w3unpk77_8f.html#a9589ef1331e503fdbdc2ff306ae60143',1,'w3unpk77.f']]], + ['unpk7705_904',['unpk7705',['../w3unpk77_8f.html#a83668f95551d6806db9d28f6ce577f22',1,'w3unpk77.f']]], + ['unpk7706_905',['unpk7706',['../w3unpk77_8f.html#a4196e848ecd6558e30a6c0617a35737c',1,'w3unpk77.f']]], + ['unpk7707_906',['unpk7707',['../w3unpk77_8f.html#a87aaaaef2fb86ea98c45d5c206961033',1,'w3unpk77.f']]], + ['unpk7708_907',['unpk7708',['../w3unpk77_8f.html#ab038d6f2a6c28d162b38828264552068',1,'w3unpk77.f']]], + ['unpk7709_908',['unpk7709',['../w3unpk77_8f.html#a38fd0aaaeb7ad9a2f9f9453afc11cd1e',1,'w3unpk77.f']]] +]; diff --git a/ver-2.10.0/search/functions_f.html b/ver-2.10.0/search/functions_f.html new file mode 100644 index 00000000..f17c412c --- /dev/null +++ b/ver-2.10.0/search/functions_f.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/functions_f.js b/ver-2.10.0/search/functions_f.js new file mode 100644 index 00000000..b25a4681 --- /dev/null +++ b/ver-2.10.0/search/functions_f.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['value1_909',['value1',['../w3fp06_8f.html#a857d20cd6a97ba1e266d803b2092670c',1,'w3fp06.f']]] +]; diff --git a/ver-2.10.0/search/mag_sel.png b/ver-2.10.0/search/mag_sel.png new file mode 100644 index 00000000..39c0ed52 Binary files /dev/null and b/ver-2.10.0/search/mag_sel.png differ diff --git a/ver-2.10.0/search/namespaces_0.html b/ver-2.10.0/search/namespaces_0.html new file mode 100644 index 00000000..76996d1c --- /dev/null +++ b/ver-2.10.0/search/namespaces_0.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/namespaces_0.js b/ver-2.10.0/search/namespaces_0.js new file mode 100644 index 00000000..1a6d0711 --- /dev/null +++ b/ver-2.10.0/search/namespaces_0.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['args_5fmod_529',['args_mod',['../namespaceargs__mod.html',1,'']]] +]; diff --git a/ver-2.10.0/search/namespaces_1.html b/ver-2.10.0/search/namespaces_1.html new file mode 100644 index 00000000..c69e3662 --- /dev/null +++ b/ver-2.10.0/search/namespaces_1.html @@ -0,0 +1,30 @@ + + + + + + + + + +
    +
    Loading...
    +
    + +
    Searching...
    +
    No Matches
    + +
    + + diff --git a/ver-2.10.0/search/namespaces_1.js b/ver-2.10.0/search/namespaces_1.js new file mode 100644 index 00000000..d29bb8d5 --- /dev/null +++ b/ver-2.10.0/search/namespaces_1.js @@ -0,0 +1,4 @@ +var searchData= +[ + ['mersenne_5ftwister_530',['mersenne_twister',['../namespacemersenne__twister.html',1,'']]] +]; diff --git a/ver-2.10.0/search/nomatches.html b/ver-2.10.0/search/nomatches.html new file mode 100644 index 00000000..43773208 --- /dev/null +++ b/ver-2.10.0/search/nomatches.html @@ -0,0 +1,12 @@ + + + + + + + +
    +
    No Matches
    +
    + + diff --git a/ver-2.10.0/search/search.css b/ver-2.10.0/search/search.css new file mode 100644 index 00000000..3cf9df94 --- /dev/null +++ b/ver-2.10.0/search/search.css @@ -0,0 +1,271 @@ +/*---------------- Search Box */ + +#FSearchBox { + float: left; +} + +#MSearchBox { + white-space : nowrap; + float: none; + margin-top: 8px; + right: 0px; + width: 170px; + height: 24px; + z-index: 102; +} + +#MSearchBox .left +{ + display:block; + position:absolute; + left:10px; + width:20px; + height:19px; + background:url('search_l.png') no-repeat; + background-position:right; +} + +#MSearchSelect { + display:block; + position:absolute; + width:20px; + height:19px; +} + +.left #MSearchSelect { + left:4px; +} + +.right #MSearchSelect { + right:5px; +} + +#MSearchField { + display:block; + position:absolute; + height:19px; + background:url('search_m.png') repeat-x; + border:none; + width:115px; + margin-left:20px; + padding-left:4px; + color: #909090; + outline: none; + font: 9pt Arial, Verdana, sans-serif; + -webkit-border-radius: 0px; +} + +#FSearchBox #MSearchField { + margin-left:15px; +} + +#MSearchBox .right { + display:block; + position:absolute; + right:10px; + top:8px; + width:20px; + height:19px; + background:url('search_r.png') no-repeat; + background-position:left; +} + +#MSearchClose { + display: none; + position: absolute; + top: 4px; + background : none; + border: none; + margin: 0px 4px 0px 0px; + padding: 0px 0px; + outline: none; +} + +.left #MSearchClose { + left: 6px; +} + +.right #MSearchClose { + right: 2px; +} + +.MSearchBoxActive #MSearchField { + color: #000000; +} + +/*---------------- Search filter selection */ + +#MSearchSelectWindow { + display: none; + position: absolute; + left: 0; top: 0; + border: 1px solid #90A5CE; + background-color: #F9FAFC; + z-index: 10001; + padding-top: 4px; + padding-bottom: 4px; + -moz-border-radius: 4px; + -webkit-border-top-left-radius: 4px; + -webkit-border-top-right-radius: 4px; + -webkit-border-bottom-left-radius: 4px; + -webkit-border-bottom-right-radius: 4px; + -webkit-box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.15); +} + +.SelectItem { + font: 8pt Arial, Verdana, sans-serif; + padding-left: 2px; + padding-right: 12px; + border: 0px; +} + +span.SelectionMark { + margin-right: 4px; + font-family: monospace; + outline-style: none; + text-decoration: none; +} + +a.SelectItem { + display: block; + outline-style: none; + color: #000000; + text-decoration: none; + padding-left: 6px; + padding-right: 12px; +} + +a.SelectItem:focus, +a.SelectItem:active { + color: #000000; + outline-style: none; + text-decoration: none; +} + +a.SelectItem:hover { + color: #FFFFFF; + background-color: #3D578C; + outline-style: none; + text-decoration: none; + cursor: pointer; + display: block; +} + +/*---------------- Search results window */ + +iframe#MSearchResults { + width: 60ex; + height: 15em; +} + +#MSearchResultsWindow { + display: none; + position: absolute; + left: 0; top: 0; + border: 1px solid #000; + background-color: #EEF1F7; + z-index:10000; +} + +/* ----------------------------------- */ + + +#SRIndex { + clear:both; + padding-bottom: 15px; +} + +.SREntry { + font-size: 10pt; + padding-left: 1ex; +} + +.SRPage .SREntry { + font-size: 8pt; + padding: 1px 5px; +} + +body.SRPage { + margin: 5px 2px; +} + +.SRChildren { + padding-left: 3ex; padding-bottom: .5em +} + +.SRPage .SRChildren { + display: none; +} + +.SRSymbol { + font-weight: bold; + color: #425E97; + font-family: Arial, Verdana, sans-serif; + text-decoration: none; + outline: none; +} + +a.SRScope { + display: block; + color: #425E97; + font-family: Arial, Verdana, sans-serif; + text-decoration: none; + outline: none; +} + +a.SRSymbol:focus, a.SRSymbol:active, +a.SRScope:focus, a.SRScope:active { + text-decoration: underline; +} + +span.SRScope { + padding-left: 4px; +} + +.SRPage .SRStatus { + padding: 2px 5px; + font-size: 8pt; + font-style: italic; +} + +.SRResult { + display: none; +} + +DIV.searchresults { + margin-left: 10px; + margin-right: 10px; +} + +/*---------------- External search page results */ + +.searchresult { + background-color: #F0F3F8; +} + +.pages b { + color: white; + padding: 5px 5px 3px 5px; + background-image: url("../tab_a.png"); + background-repeat: repeat-x; + text-shadow: 0 1px 1px #000000; +} + +.pages { + line-height: 17px; + margin-left: 4px; + text-decoration: none; +} + +.hl { + font-weight: bold; +} + +#searchresults { + margin-bottom: 20px; +} + +.searchpages { + margin-top: 10px; +} + diff --git a/ver-2.10.0/search/search.js b/ver-2.10.0/search/search.js new file mode 100644 index 00000000..a554ab9c --- /dev/null +++ b/ver-2.10.0/search/search.js @@ -0,0 +1,814 @@ +/* + @licstart The following is the entire license notice for the + JavaScript code in this file. + + Copyright (C) 1997-2017 by Dimitri van Heesch + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + + @licend The above is the entire license notice + for the JavaScript code in this file + */ +function convertToId(search) +{ + var result = ''; + for (i=0;i do a search + { + this.Search(); + } + } + + this.OnSearchSelectKey = function(evt) + { + var e = (evt) ? evt : window.event; // for IE + if (e.keyCode==40 && this.searchIndex0) // Up + { + this.searchIndex--; + this.OnSelectItem(this.searchIndex); + } + else if (e.keyCode==13 || e.keyCode==27) + { + this.OnSelectItem(this.searchIndex); + this.CloseSelectionWindow(); + this.DOMSearchField().focus(); + } + return false; + } + + // --------- Actions + + // Closes the results window. + this.CloseResultsWindow = function() + { + this.DOMPopupSearchResultsWindow().style.display = 'none'; + this.DOMSearchClose().style.display = 'none'; + this.Activate(false); + } + + this.CloseSelectionWindow = function() + { + this.DOMSearchSelectWindow().style.display = 'none'; + } + + // Performs a search. + this.Search = function() + { + this.keyTimeout = 0; + + // strip leading whitespace + var searchValue = this.DOMSearchField().value.replace(/^ +/, ""); + + var code = searchValue.toLowerCase().charCodeAt(0); + var idxChar = searchValue.substr(0, 1).toLowerCase(); + if ( 0xD800 <= code && code <= 0xDBFF && searchValue > 1) // surrogate pair + { + idxChar = searchValue.substr(0, 2); + } + + var resultsPage; + var resultsPageWithSearch; + var hasResultsPage; + + var idx = indexSectionsWithContent[this.searchIndex].indexOf(idxChar); + if (idx!=-1) + { + var hexCode=idx.toString(16); + resultsPage = this.resultsPath + '/' + indexSectionNames[this.searchIndex] + '_' + hexCode + '.html'; + resultsPageWithSearch = resultsPage+'?'+escape(searchValue); + hasResultsPage = true; + } + else // nothing available for this search term + { + resultsPage = this.resultsPath + '/nomatches.html'; + resultsPageWithSearch = resultsPage; + hasResultsPage = false; + } + + window.frames.MSearchResults.location = resultsPageWithSearch; + var domPopupSearchResultsWindow = this.DOMPopupSearchResultsWindow(); + + if (domPopupSearchResultsWindow.style.display!='block') + { + var domSearchBox = this.DOMSearchBox(); + this.DOMSearchClose().style.display = 'inline'; + if (this.insideFrame) + { + var domPopupSearchResults = this.DOMPopupSearchResults(); + domPopupSearchResultsWindow.style.position = 'relative'; + domPopupSearchResultsWindow.style.display = 'block'; + var width = document.body.clientWidth - 8; // the -8 is for IE :-( + domPopupSearchResultsWindow.style.width = width + 'px'; + domPopupSearchResults.style.width = width + 'px'; + } + else + { + var domPopupSearchResults = this.DOMPopupSearchResults(); + var left = getXPos(domSearchBox) + 150; // domSearchBox.offsetWidth; + var top = getYPos(domSearchBox) + 20; // domSearchBox.offsetHeight + 1; + domPopupSearchResultsWindow.style.display = 'block'; + left -= domPopupSearchResults.offsetWidth; + domPopupSearchResultsWindow.style.top = top + 'px'; + domPopupSearchResultsWindow.style.left = left + 'px'; + } + } + + this.lastSearchValue = searchValue; + this.lastResultsPage = resultsPage; + } + + // -------- Activation Functions + + // Activates or deactivates the search panel, resetting things to + // their default values if necessary. + this.Activate = function(isActive) + { + if (isActive || // open it + this.DOMPopupSearchResultsWindow().style.display == 'block' + ) + { + this.DOMSearchBox().className = 'MSearchBoxActive'; + + var searchField = this.DOMSearchField(); + + if (searchField.value == this.searchLabel) // clear "Search" term upon entry + { + searchField.value = ''; + this.searchActive = true; + } + } + else if (!isActive) // directly remove the panel + { + this.DOMSearchBox().className = 'MSearchBoxInactive'; + this.DOMSearchField().value = this.searchLabel; + this.searchActive = false; + this.lastSearchValue = '' + this.lastResultsPage = ''; + } + } +} + +// ----------------------------------------------------------------------- + +// The class that handles everything on the search results page. +function SearchResults(name) +{ + // The number of matches from the last run of . + this.lastMatchCount = 0; + this.lastKey = 0; + this.repeatOn = false; + + // Toggles the visibility of the passed element ID. + this.FindChildElement = function(id) + { + var parentElement = document.getElementById(id); + var element = parentElement.firstChild; + + while (element && element!=parentElement) + { + if (element.nodeName == 'DIV' && element.className == 'SRChildren') + { + return element; + } + + if (element.nodeName == 'DIV' && element.hasChildNodes()) + { + element = element.firstChild; + } + else if (element.nextSibling) + { + element = element.nextSibling; + } + else + { + do + { + element = element.parentNode; + } + while (element && element!=parentElement && !element.nextSibling); + + if (element && element!=parentElement) + { + element = element.nextSibling; + } + } + } + } + + this.Toggle = function(id) + { + var element = this.FindChildElement(id); + if (element) + { + if (element.style.display == 'block') + { + element.style.display = 'none'; + } + else + { + element.style.display = 'block'; + } + } + } + + // Searches for the passed string. If there is no parameter, + // it takes it from the URL query. + // + // Always returns true, since other documents may try to call it + // and that may or may not be possible. + this.Search = function(search) + { + if (!search) // get search word from URL + { + search = window.location.search; + search = search.substring(1); // Remove the leading '?' + search = unescape(search); + } + + search = search.replace(/^ +/, ""); // strip leading spaces + search = search.replace(/ +$/, ""); // strip trailing spaces + search = search.toLowerCase(); + search = convertToId(search); + + var resultRows = document.getElementsByTagName("div"); + var matches = 0; + + var i = 0; + while (i < resultRows.length) + { + var row = resultRows.item(i); + if (row.className == "SRResult") + { + var rowMatchName = row.id.toLowerCase(); + rowMatchName = rowMatchName.replace(/^sr\d*_/, ''); // strip 'sr123_' + + if (search.length<=rowMatchName.length && + rowMatchName.substr(0, search.length)==search) + { + row.style.display = 'block'; + matches++; + } + else + { + row.style.display = 'none'; + } + } + i++; + } + document.getElementById("Searching").style.display='none'; + if (matches == 0) // no results + { + document.getElementById("NoMatches").style.display='block'; + } + else // at least one result + { + document.getElementById("NoMatches").style.display='none'; + } + this.lastMatchCount = matches; + return true; + } + + // return the first item with index index or higher that is visible + this.NavNext = function(index) + { + var focusItem; + while (1) + { + var focusName = 'Item'+index; + focusItem = document.getElementById(focusName); + if (focusItem && focusItem.parentNode.parentNode.style.display=='block') + { + break; + } + else if (!focusItem) // last element + { + break; + } + focusItem=null; + index++; + } + return focusItem; + } + + this.NavPrev = function(index) + { + var focusItem; + while (1) + { + var focusName = 'Item'+index; + focusItem = document.getElementById(focusName); + if (focusItem && focusItem.parentNode.parentNode.style.display=='block') + { + break; + } + else if (!focusItem) // last element + { + break; + } + focusItem=null; + index--; + } + return focusItem; + } + + this.ProcessKeys = function(e) + { + if (e.type == "keydown") + { + this.repeatOn = false; + this.lastKey = e.keyCode; + } + else if (e.type == "keypress") + { + if (!this.repeatOn) + { + if (this.lastKey) this.repeatOn = true; + return false; // ignore first keypress after keydown + } + } + else if (e.type == "keyup") + { + this.lastKey = 0; + this.repeatOn = false; + } + return this.lastKey!=0; + } + + this.Nav = function(evt,itemIndex) + { + var e = (evt) ? evt : window.event; // for IE + if (e.keyCode==13) return true; + if (!this.ProcessKeys(e)) return false; + + if (this.lastKey==38) // Up + { + var newIndex = itemIndex-1; + var focusItem = this.NavPrev(newIndex); + if (focusItem) + { + var child = this.FindChildElement(focusItem.parentNode.parentNode.id); + if (child && child.style.display == 'block') // children visible + { + var n=0; + var tmpElem; + while (1) // search for last child + { + tmpElem = document.getElementById('Item'+newIndex+'_c'+n); + if (tmpElem) + { + focusItem = tmpElem; + } + else // found it! + { + break; + } + n++; + } + } + } + if (focusItem) + { + focusItem.focus(); + } + else // return focus to search field + { + parent.document.getElementById("MSearchField").focus(); + } + } + else if (this.lastKey==40) // Down + { + var newIndex = itemIndex+1; + var focusItem; + var item = document.getElementById('Item'+itemIndex); + var elem = this.FindChildElement(item.parentNode.parentNode.id); + if (elem && elem.style.display == 'block') // children visible + { + focusItem = document.getElementById('Item'+itemIndex+'_c0'); + } + if (!focusItem) focusItem = this.NavNext(newIndex); + if (focusItem) focusItem.focus(); + } + else if (this.lastKey==39) // Right + { + var item = document.getElementById('Item'+itemIndex); + var elem = this.FindChildElement(item.parentNode.parentNode.id); + if (elem) elem.style.display = 'block'; + } + else if (this.lastKey==37) // Left + { + var item = document.getElementById('Item'+itemIndex); + var elem = this.FindChildElement(item.parentNode.parentNode.id); + if (elem) elem.style.display = 'none'; + } + else if (this.lastKey==27) // Escape + { + parent.searchBox.CloseResultsWindow(); + parent.document.getElementById("MSearchField").focus(); + } + else if (this.lastKey==13) // Enter + { + return true; + } + return false; + } + + this.NavChild = function(evt,itemIndex,childIndex) + { + var e = (evt) ? evt : window.event; // for IE + if (e.keyCode==13) return true; + if (!this.ProcessKeys(e)) return false; + + if (this.lastKey==38) // Up + { + if (childIndex>0) + { + var newIndex = childIndex-1; + document.getElementById('Item'+itemIndex+'_c'+newIndex).focus(); + } + else // already at first child, jump to parent + { + document.getElementById('Item'+itemIndex).focus(); + } + } + else if (this.lastKey==40) // Down + { + var newIndex = childIndex+1; + var elem = document.getElementById('Item'+itemIndex+'_c'+newIndex); + if (!elem) // last child, jump to parent next parent + { + elem = this.NavNext(itemIndex+1); + } + if (elem) + { + elem.focus(); + } + } + else if (this.lastKey==27) // Escape + { + parent.searchBox.CloseResultsWindow(); + parent.document.getElementById("MSearchField").focus(); + } + else if (this.lastKey==13) // Enter + { + return true; + } + return false; + } +} + +function setKeyActions(elem,action) +{ + elem.setAttribute('onkeydown',action); + elem.setAttribute('onkeypress',action); + elem.setAttribute('onkeyup',action); +} + +function setClassAttr(elem,attr) +{ + elem.setAttribute('class',attr); + elem.setAttribute('className',attr); +} + +function createResults() +{ + var results = document.getElementById("SRResults"); + for (var e=0; e + + + + + + +NCEPLIBS-w3emc: skgb.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    skgb.f File Reference
    +
    +
    + +

    Search for next grib message. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine skgb (LUGB, ISEEK, MSEEK, LSKIP, LGRIB)
     This subprogram searches a file for the next grib 1 message. More...
     
    +

    Detailed Description

    +

    Search for next grib message.

    +
    Author
    Mark Iredell
    +
    Date
    1993-11-22
    + +

    Definition in file skgb.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ skgb()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine skgb ( LUGB,
     ISEEK,
     MSEEK,
     LSKIP,
     LGRIB 
    )
    +
    + +

    This subprogram searches a file for the next grib 1 message.

    +

    A grib 1 message is identified by its indicator section, i.e. an 8-byte sequence with 'grib' in bytes 1-4 and 1 in byte 8. If found, the length of the message is decoded from bytes 5-7. The search is done over a given section of the file. The search is terminated if an eof or i/o error is encountered.

    +

    Program history log:

      +
    • Mark Iredell 1993-11-22
      • +
    • Mark Iredell 1995-10-31 Add call to baread.
      • +
    • Mark Iredell 1997-03-14 Check for '7777'.
      • +
    • Stephen Gilbert 2001-12-05 Modified to also look for grib2 messages.
      • +
    +
    Parameters
    + + + + + + +
    [in]LUGBInteger logical unit of input grib file.
    [in]ISEEKInteger number of bytes to skip before search.
    [in]MSEEKInteger maximum number of bytes to search.
    [out]LSKIPInteger number of bytes to skip before message.
    [out]LGRIBInteger number of bytes in message (0 if not found).
    +
    +
    +
    Author
    Mark Iredell
    +
    Date
    1993-11-22
    + +

    Definition at line 27 of file skgb.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/skgb_8f.js b/ver-2.10.0/skgb_8f.js new file mode 100644 index 00000000..3004b89e --- /dev/null +++ b/ver-2.10.0/skgb_8f.js @@ -0,0 +1,4 @@ +var skgb_8f = +[ + [ "skgb", "skgb_8f.html#a7654c30923c8fa28091b5cb300c93311", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/skgb_8f_source.html b/ver-2.10.0/skgb_8f_source.html new file mode 100644 index 00000000..10ead0ea --- /dev/null +++ b/ver-2.10.0/skgb_8f_source.html @@ -0,0 +1,170 @@ + + + + + + + +NCEPLIBS-w3emc: skgb.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    skgb.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Search for next grib message.
    +
    3 C> @author Mark Iredell @date 1993-11-22
    +
    4 
    +
    5 C> This subprogram searches a file for the next grib 1 message.
    +
    6 C> A grib 1 message is identified by its indicator section, i.e.
    +
    7 C> an 8-byte sequence with 'grib' in bytes 1-4 and 1 in byte 8.
    +
    8 C> If found, the length of the message is decoded from bytes 5-7.
    +
    9 C> The search is done over a given section of the file.
    +
    10 C> The search is terminated if an eof or i/o error is encountered.
    +
    11 C>
    +
    12 C> Program history log:
    +
    13 C> - Mark Iredell 1993-11-22
    +
    14 C> - Mark Iredell 1995-10-31 Add call to baread.
    +
    15 C> - Mark Iredell 1997-03-14 Check for '7777'.
    +
    16 C> - Stephen Gilbert 2001-12-05 Modified to also look for grib2 messages.
    +
    17 C>
    +
    18 C> @param[in] LUGB Integer logical unit of input grib file.
    +
    19 C> @param[in] ISEEK Integer number of bytes to skip before search.
    +
    20 C> @param[in] MSEEK Integer maximum number of bytes to search.
    +
    21 C> @param[out] LSKIP Integer number of bytes to skip before message.
    +
    22 C> @param[out] LGRIB Integer number of bytes in message (0 if not found).
    +
    23 C>
    +
    24 C> @author Mark Iredell @date 1993-11-22
    +
    25 C-----------------------------------------------------------------------
    +
    26  SUBROUTINE skgb(LUGB,ISEEK,MSEEK,LSKIP,LGRIB)
    +
    27  parameter(lseek=128)
    +
    28  CHARACTER Z(LSEEK)
    +
    29  CHARACTER Z4(4)
    +
    30 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    31  lgrib=0
    +
    32  ks=iseek
    +
    33  kn=min(lseek,mseek)
    +
    34  kz=lseek
    +
    35 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    36 C LOOP UNTIL GRIB MESSAGE IS FOUND
    +
    37  dowhile(lgrib.EQ.0.AND.kn.GE.8.AND.kz.EQ.lseek)
    +
    38 C READ PARTIAL SECTION
    +
    39  CALL baread(lugb,ks,kn,kz,z)
    +
    40  km=kz-8+1
    +
    41  k=0
    +
    42 C LOOK FOR 'GRIB...1' IN PARTIAL SECTION
    +
    43  dowhile(lgrib.EQ.0.AND.k.LT.km)
    +
    44  CALL gbytec(z,i4,(k+0)*8,4*8)
    +
    45  CALL gbytec(z,i1,(k+7)*8,1*8)
    +
    46  IF(i4.EQ.1196575042.AND.(i1.EQ.1.OR.i1.EQ.2)) THEN
    +
    47 C LOOK FOR '7777' AT END OF GRIB MESSAGE
    +
    48  IF (i1.EQ.1) CALL gbytec(z,kg,(k+4)*8,3*8)
    +
    49  IF (i1.EQ.2) CALL gbytec(z,kg,(k+12)*8,4*8)
    +
    50  CALL baread(lugb,ks+k+kg-4,4,k4,z4)
    +
    51  IF(k4.EQ.4) THEN
    +
    52  CALL gbytec(z4,i4,0,4*8)
    +
    53  IF(i4.EQ.926365495) THEN
    +
    54 C GRIB MESSAGE FOUND
    +
    55  lskip=ks+k
    +
    56  lgrib=kg
    +
    57  ENDIF
    +
    58  ENDIF
    +
    59  ENDIF
    +
    60  k=k+1
    +
    61  ENDDO
    +
    62  ks=ks+km
    +
    63  kn=min(lseek,iseek+mseek-ks)
    +
    64  ENDDO
    +
    65 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    66  RETURN
    +
    67  END
    +
    +
    +
    skgb
    subroutine skgb(LUGB, ISEEK, MSEEK, LSKIP, LGRIB)
    This subprogram searches a file for the next grib 1 message.
    Definition: skgb.f:27
    +
    gbytec
    subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
    Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
    Definition: gbytec.f:14
    + + + + diff --git a/ver-2.10.0/splitbar.png b/ver-2.10.0/splitbar.png new file mode 100644 index 00000000..fe895f2c Binary files /dev/null and b/ver-2.10.0/splitbar.png differ diff --git a/ver-2.10.0/summary_8c.html b/ver-2.10.0/summary_8c.html new file mode 100644 index 00000000..0d121eeb --- /dev/null +++ b/ver-2.10.0/summary_8c.html @@ -0,0 +1,839 @@ + + + + + + + +NCEPLIBS-w3emc: summary.c File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions | +Variables
    +
    +
    summary.c File Reference
    +
    +
    + +

    Make a system call to return various useful parameters. +More...

    +
    #include <stdio.h>
    +#include <stdlib.h>
    +#include <math.h>
    +#include <string.h>
    +#include <sys/types.h>
    +#include <sys/stat.h>
    +#include <sys/time.h>
    +#include <sys/times.h>
    +#include <sys/utsname.h>
    +
    +

    Go to the source code of this file.

    + + + + + + + + + + + + + + + + + + + + +

    +Functions

    int bucket (int lng)
     
    void cputim (double *usr, double *sys)
     
    void elapse (double *timer)
     
    void end_timer (struct time_data *time)
     
    void print_timing (char *string, struct time_data *time)
     
    void resource ()
     
    void start_ ()
     
    void start_timer (struct time_data *time)
     
    void summary_ (int *returnVal)
     
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

    +Variables

    +double cpu_comm
     
    +double f_bytes
     
    +double final_wall
     
    +static FILE * fp = NULL
     
    +struct time_data MPI_Abort_data
     
    +struct time_data MPI_Address_data
     
    +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_Attr_delete_data
     
    +struct time_data MPI_Attr_get_data
     
    +struct time_data MPI_Attr_put_data
     
    +struct time_data MPI_Barrier_data
     
    +struct time_data MPI_Bcast_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_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_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_Dims_create_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_Errhandler_set_data
     
    +struct time_data MPI_Error_class_data
     
    +struct time_data MPI_Error_string_data
     
    +struct time_data MPI_Gather_data
     
    +struct time_data MPI_Gatherv_data
     
    +struct time_data MPI_Get_count_data
     
    +struct time_data MPI_Get_elements_data
     
    +struct time_data MPI_Get_processor_name_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_count_data
     
    +struct time_data MPI_Graph_neighbors_data
     
    +struct time_data MPI_Graphdims_get_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_range_excl_data
     
    +struct time_data MPI_Group_range_incl_data
     
    +struct time_data MPI_Group_rank_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_Ibsend_data
     
    +struct time_data MPI_Initialized_data
     
    +struct time_data MPI_Intercomm_create_data
     
    +struct time_data MPI_Intercomm_merge_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_Keyval_create_data
     
    +struct time_data MPI_Keyval_free_data
     
    +struct time_data MPI_Op_create_data
     
    +struct time_data MPI_Op_free_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_Recv_init_data
     
    +struct time_data MPI_Reduce_data
     
    +struct time_data MPI_Reduce_scatter_data
     
    +struct time_data MPI_Request_free_data
     
    +struct time_data MPI_Rsend_data
     
    +struct time_data MPI_Rsend_init_data
     
    +struct time_data MPI_Scan_data
     
    +struct time_data MPI_Scatter_data
     
    +struct time_data MPI_Scatterv_data
     
    +struct time_data MPI_Send_data
     
    +struct time_data MPI_Send_init_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_cancelled_data
     
    +struct time_data MPI_Test_data
     
    +struct time_data MPI_Testall_data
     
    +struct time_data MPI_Testany_data
     
    +struct time_data MPI_Testsome_data
     
    +struct time_data MPI_Topo_test_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_Wtick_data
     
    +struct time_data MPI_Wtime_data
     
    +int msglen
     
    +int mypid
     
    +int numtask
     
    +int procid_0
     
    +int profile
     
    +double start_wall
     
    +double tbytes
     
    +double tcpu
     
    +double tot_wall
     
    +int trace_flag
     
    +double twall
     
    +double wall_comm
     
    +

    Detailed Description

    +

    Make a system call to return various useful parameters.

    +

    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()
    +
    Author
    Jim Tuccillo
    +
    Date
    August 1999
    + +

    Definition in file summary.c.

    +

    Function Documentation

    + +

    ◆ bucket()

    + +
    +
    + + + + + + + + +
    int bucket (int lng)
    +
    +
    Parameters
    + + +
    lng
    +
    +
    +
    Author
    Jim Tuccillo
    +
    Date
    August 1999
    + +

    Definition at line 196 of file summary.c.

    + +
    +
    + +

    ◆ cputim()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    void cputim (double * usr,
    double * sys 
    )
    +
    +
    Parameters
    + + + +
    usr
    sys
    +
    +
    +
    Author
    Jim Tuccillo
    +
    Date
    August 1999
    + +

    Definition at line 234 of file summary.c.

    + +
    +
    + +

    ◆ elapse()

    + +
    +
    + + + + + + + + +
    void elapse (double * timer)
    +
    +
    Parameters
    + + +
    timer
    +
    +
    +
    Author
    Jim Tuccillo
    +
    Date
    August 1999
    + +

    Definition at line 211 of file summary.c.

    + +
    +
    + +

    ◆ end_timer()

    + +
    +
    + + + + + + + + +
    void end_timer (struct time_data * time)
    +
    +
    Parameters
    + + +
    time
    +
    +
    +
    Author
    Jim Tuccillo
    +
    Date
    August 1999
    + +

    Definition at line 279 of file summary.c.

    + +
    +
    + +

    ◆ print_timing()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    void print_timing (char * string,
    struct time_data * time 
    )
    +
    +
    Parameters
    + + + +
    string
    time
    +
    +
    +
    Author
    Jim Tuccillo
    +
    Date
    August 1999
    + +

    Definition at line 381 of file summary.c.

    + +
    +
    + +

    ◆ resource()

    + +
    +
    + + + + + + + +
    void resource ()
    +
    +
    Author
    Jim Tuccillo
    +
    Date
    August 1999
    + +

    Definition at line 299 of file summary.c.

    + +
    +
    + +

    ◆ start_()

    + +
    +
    + + + + + + + +
    void start_ ()
    +
    +
    Author
    Jim Tuccillo
    +
    Date
    August 1999
    + +

    Definition at line 458 of file summary.c.

    + +
    +
    + +

    ◆ start_timer()

    + +
    +
    + + + + + + + + +
    void start_timer (struct time_data * time)
    +
    +
    Parameters
    + + +
    time
    +
    +
    +
    Author
    Jim Tuccillo
    +
    Date
    August 1999
    + +

    Definition at line 260 of file summary.c.

    + +
    +
    + +

    ◆ summary_()

    + +
    +
    + + + + + + + + +
    void summary_ (int * returnVal)
    +
    +
    Parameters
    + + +
    returnVal
    +
    +
    +
    Author
    Jim Tuccillo
    +
    Date
    August 1999
    + +

    Definition at line 437 of file summary.c.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/summary_8c.js b/ver-2.10.0/summary_8c.js new file mode 100644 index 00000000..96c72d7c --- /dev/null +++ b/ver-2.10.0/summary_8c.js @@ -0,0 +1,153 @@ +var summary_8c = +[ + [ "bucket", "summary_8c.html#ac30f918e4632256526a027a73c95da78", null ], + [ "cputim", "summary_8c.html#a85f50c91b93171e345aa393946e62aa9", null ], + [ "elapse", "summary_8c.html#a5c5678e05ce08da171d237db078d2c30", null ], + [ "end_timer", "summary_8c.html#a91f9293b85b800dfb07ec0ef110e4c22", null ], + [ "print_timing", "summary_8c.html#a375531ea214cead1fa2bdee20bcc2dd0", null ], + [ "resource", "summary_8c.html#a585b71c74faea63d161810774ef8da9e", null ], + [ "start_", "summary_8c.html#ad890855d9ece9845912ab1f12f8ee31e", null ], + [ "start_timer", "summary_8c.html#a9078a5949f4d6fe30ed2a5bf7c0cf4d7", null ], + [ "summary_", "summary_8c.html#a60f2dd974b43d33df8d7a6b4c2a47110", null ], + [ "cpu_comm", "summary_8c.html#a9f59baa0114b00d5aa7a2816956e72cd", null ], + [ "f_bytes", "summary_8c.html#a0d299f4055cfd86606b089e19be86621", null ], + [ "final_wall", "summary_8c.html#abfb08950cf0e1a2e18dd0e2f814d2628", null ], + [ "fp", "summary_8c.html#aa065f30aa9f5f9a42132c82c787ee70b", null ], + [ "MPI_Abort_data", "summary_8c.html#a332b1d3c4af749906617bb41764246de", null ], + [ "MPI_Address_data", "summary_8c.html#a67e785f2dd7e8ea603021417f97dcb7c", null ], + [ "MPI_Allgather_data", "summary_8c.html#a4d94fd6b8925abf20dec9d4b3a456f15", null ], + [ "MPI_Allgatherv_data", "summary_8c.html#ab00ad145263477c95172947b29f1c968", null ], + [ "MPI_Allreduce_data", "summary_8c.html#afbbbe5ad84b18c8c4da164591de9f239", null ], + [ "MPI_Alltoall_data", "summary_8c.html#a3ad334b34de6b33e80f0df352228b745", null ], + [ "MPI_Alltoallv_data", "summary_8c.html#a9cf3ff9bf9134241c2aef429c1546107", null ], + [ "MPI_Attr_delete_data", "summary_8c.html#a6d0dcf8f28b8ad13c7c11ff5c0b13df9", null ], + [ "MPI_Attr_get_data", "summary_8c.html#ae3c22dce32faa30047ddc9e0e19a8033", null ], + [ "MPI_Attr_put_data", "summary_8c.html#a424a5e562902c316c88909a26acb2c61", null ], + [ "MPI_Barrier_data", "summary_8c.html#a304efc367f6903d35848e20233315218", null ], + [ "MPI_Bcast_data", "summary_8c.html#a6f6fd8f50986414c088aced1a2673f7c", null ], + [ "MPI_Bsend_data", "summary_8c.html#a574692b8069ffc0a2f6f20bd471130bd", null ], + [ "MPI_Bsend_init_data", "summary_8c.html#a8032faf2beae02017ddbf2580ca03e01", null ], + [ "MPI_Buffer_attach_data", "summary_8c.html#a23dd794cefb7971ff0ca30772a34431b", null ], + [ "MPI_Buffer_detach_data", "summary_8c.html#aa18cd3eba4355ba908e0832354e71807", null ], + [ "MPI_Cancel_data", "summary_8c.html#a88fa76175a8290858e0bcb3f1958d82d", null ], + [ "MPI_Cart_coords_data", "summary_8c.html#a6cd6e07cefa9e1534636ff7e7911e49d", null ], + [ "MPI_Cart_create_data", "summary_8c.html#aa4c0c0f68d1493772573327bf11f206b", null ], + [ "MPI_Cart_get_data", "summary_8c.html#ab98d375a77c3980c418cc26cc9baef27", null ], + [ "MPI_Cart_map_data", "summary_8c.html#a103ed1c4797d36d7418f3e8a3fc8dffe", null ], + [ "MPI_Cart_rank_data", "summary_8c.html#ad3cf0f50569c5c2db65c6313c823df89", null ], + [ "MPI_Cart_shift_data", "summary_8c.html#ad42b6bd039b57665a8987db1ed619976", null ], + [ "MPI_Cart_sub_data", "summary_8c.html#a8e437726cd46292cc3d35e9d27a225e2", null ], + [ "MPI_Cartdim_get_data", "summary_8c.html#ac6d9a870d61e535eb3a6fa851bdd6b01", null ], + [ "MPI_Comm_compare_data", "summary_8c.html#a0ac76d4f1d76d40d499700499781885b", null ], + [ "MPI_Comm_create_data", "summary_8c.html#ac8c4cb4aff5ebc789ac24463a1f94dc7", null ], + [ "MPI_Comm_dup_data", "summary_8c.html#a793ab58960f1a8ffd5db6d1bc1e907e5", null ], + [ "MPI_Comm_free_data", "summary_8c.html#a26c99f29011e8cdf3258177c223de426", null ], + [ "MPI_Comm_group_data", "summary_8c.html#a5e6a1e9100ac23cb6f3fa698ad79799f", null ], + [ "MPI_Comm_rank_data", "summary_8c.html#ad9fc0acf7146d802d8a9755f57e57ba2", null ], + [ "MPI_Comm_remote_group_data", "summary_8c.html#a7bf19ae5fce740bae9e4c99c7fc3bb22", null ], + [ "MPI_Comm_remote_size_data", "summary_8c.html#a7bec6e7e8062862594eb54d2925c8850", null ], + [ "MPI_Comm_size_data", "summary_8c.html#af9996e5e0f28de18e22169e4653dc35e", null ], + [ "MPI_Comm_split_data", "summary_8c.html#aac8feac9a6eb9aae1ce4cf03c0aa3fae", null ], + [ "MPI_Comm_test_inter_data", "summary_8c.html#ae4c632bdefe7eca1cb99d80728957551", null ], + [ "MPI_Dims_create_data", "summary_8c.html#a37fe0b295099c3b2c7e191b9c0bce462", null ], + [ "MPI_Errhandler_create_data", "summary_8c.html#aec8001a11cec57890a1cde3384d58f4f", null ], + [ "MPI_Errhandler_free_data", "summary_8c.html#a5c53ec2b21790bdeb3bcdeec9a5d32b0", null ], + [ "MPI_Errhandler_get_data", "summary_8c.html#a124310bdb5f17de6f56ccc25194dede0", null ], + [ "MPI_Errhandler_set_data", "summary_8c.html#a8c68a5508755545d18df4e0275e15b9b", null ], + [ "MPI_Error_class_data", "summary_8c.html#aca6c82c918a287dea09fa62f09704cb2", null ], + [ "MPI_Error_string_data", "summary_8c.html#a77aa528389f4aabc677b37c69ed2d273", null ], + [ "MPI_Gather_data", "summary_8c.html#a2a8359613c949a5a3f6455f561d4c5ad", null ], + [ "MPI_Gatherv_data", "summary_8c.html#a2245ce70794b38eeb74b9bb980d4e443", null ], + [ "MPI_Get_count_data", "summary_8c.html#a3e65cb73000c63acc54dc632d0f7c8e0", null ], + [ "MPI_Get_elements_data", "summary_8c.html#a966379facb3b4a533100776877c26a85", null ], + [ "MPI_Get_processor_name_data", "summary_8c.html#a13ee506c2a8d4c6a1c9bb2ca6af24338", null ], + [ "MPI_Graph_create_data", "summary_8c.html#aff520cb6940df03a10a8783171ebf6fa", null ], + [ "MPI_Graph_get_data", "summary_8c.html#ac57d55f49a196adf709b8990b2aa7ae8", null ], + [ "MPI_Graph_map_data", "summary_8c.html#a1da536176214b2e7b5ccaab09c3da934", null ], + [ "MPI_Graph_neighbors_count_data", "summary_8c.html#a31331609bb19c361321575e990585798", null ], + [ "MPI_Graph_neighbors_data", "summary_8c.html#a34f9930772a2a2f51d1fb599fada8097", null ], + [ "MPI_Graphdims_get_data", "summary_8c.html#afd5df26a7cddbeda2510eeb1ea2377bb", null ], + [ "MPI_Group_compare_data", "summary_8c.html#ad8f5d780aba02e250048879053bff1ce", null ], + [ "MPI_Group_difference_data", "summary_8c.html#a538189ebb31693d5ad6f7ba1f3f6d80e", null ], + [ "MPI_Group_excl_data", "summary_8c.html#a9c034ede980053b065250459a44a8739", null ], + [ "MPI_Group_free_data", "summary_8c.html#ac7b0b714c8d1b65637246f1041a1dfd3", null ], + [ "MPI_Group_incl_data", "summary_8c.html#a165395c8ebe7c4039f84bbbe969e2c44", null ], + [ "MPI_Group_intersection_data", "summary_8c.html#a709e2b3208f9fced286cbf14fe8dcc09", null ], + [ "MPI_Group_range_excl_data", "summary_8c.html#a1708f19bbcbee673142de58879a995a9", null ], + [ "MPI_Group_range_incl_data", "summary_8c.html#aa283f1f1288f0c09f4297c174953e774", null ], + [ "MPI_Group_rank_data", "summary_8c.html#ad622acacb3e78e6f5835627d98a0a62f", null ], + [ "MPI_Group_size_data", "summary_8c.html#ae80e64cd7b00ae6444c0b35e94d74e4d", null ], + [ "MPI_Group_translate_ranks_data", "summary_8c.html#aaa4ff1a21cce32e8e59fa19b895472d6", null ], + [ "MPI_Group_union_data", "summary_8c.html#a430c901b4584328d0cd8c616afd77e6c", null ], + [ "MPI_Ibsend_data", "summary_8c.html#ac93eaa6232d01d87c1157661779b826c", null ], + [ "MPI_Initialized_data", "summary_8c.html#a552fe939a67643f7c430c5372bcf1201", null ], + [ "MPI_Intercomm_create_data", "summary_8c.html#a9ed990b4797de73eb6d75d76cde88c86", null ], + [ "MPI_Intercomm_merge_data", "summary_8c.html#a744258e78f5ea78f646751f699250ea7", null ], + [ "MPI_Iprobe_data", "summary_8c.html#a8cce40fe10eac5a02f682f049899c542", null ], + [ "MPI_Irecv_data", "summary_8c.html#ab0b8c97f0ff9cc5995904191c48d3e7f", null ], + [ "MPI_Irsend_data", "summary_8c.html#a705bece7100f009b8e11a2211b113a9b", null ], + [ "MPI_Isend_data", "summary_8c.html#a5032732c2a1862bbc57f96af8a977ab9", null ], + [ "MPI_Issend_data", "summary_8c.html#a5365870332fef1d02410663a44f58f1c", null ], + [ "MPI_Keyval_create_data", "summary_8c.html#aed5835480e81f2df4f37804613b1e74b", null ], + [ "MPI_Keyval_free_data", "summary_8c.html#abfa16073834655419a410f518aba2f49", null ], + [ "MPI_Op_create_data", "summary_8c.html#ae11dfdf520e707e22d8bdb2ee1ad8afa", null ], + [ "MPI_Op_free_data", "summary_8c.html#aeca74a0a3f19313c8d9d81f55d674dbf", null ], + [ "MPI_Pack_data", "summary_8c.html#a0681b3770e0eb8056e2ed3e35310da4a", null ], + [ "MPI_Pack_size_data", "summary_8c.html#ae75041f363da67739c69c176a00b5e84", null ], + [ "MPI_Probe_data", "summary_8c.html#aec220c18dc943150e7776e8cdcf4910b", null ], + [ "MPI_Recv_data", "summary_8c.html#abac1fae2799629450e7f59c6de8bb1af", null ], + [ "MPI_Recv_init_data", "summary_8c.html#aa1c573c70b697b92861ec8d0fd96035f", null ], + [ "MPI_Reduce_data", "summary_8c.html#a8866d80f4e23bcb3ed0937542d0ddd9d", null ], + [ "MPI_Reduce_scatter_data", "summary_8c.html#a19d4b62d0047d54a3296076522d40f6e", null ], + [ "MPI_Request_free_data", "summary_8c.html#adbc2b296851c0570648f3fea735c0ff5", null ], + [ "MPI_Rsend_data", "summary_8c.html#a529e42f6f92b1ebac2ad14371f8edc85", null ], + [ "MPI_Rsend_init_data", "summary_8c.html#a1c5e2b28e66709fe08d97343a92d4826", null ], + [ "MPI_Scan_data", "summary_8c.html#a826c278d990ab9b300161cfbe7896703", null ], + [ "MPI_Scatter_data", "summary_8c.html#adae61454a87dda528e91d4d7134dc762", null ], + [ "MPI_Scatterv_data", "summary_8c.html#ae7645302ac7ec28341f115080d5f9307", null ], + [ "MPI_Send_data", "summary_8c.html#aaae0564624fb5baf2cc1218575247be0", null ], + [ "MPI_Send_init_data", "summary_8c.html#a8dce0c8af1194fad38fde639bdc4c906", null ], + [ "MPI_Sendrecv_data", "summary_8c.html#ae63a8d07f2d480ae45ce9d0e723fc7ee", null ], + [ "MPI_Sendrecv_replace_data", "summary_8c.html#a92f552c67909fb4d2179d40efeaa4874", null ], + [ "MPI_Ssend_data", "summary_8c.html#ac6f6c8dc0ea2891f749832ba21d44a2d", null ], + [ "MPI_Ssend_init_data", "summary_8c.html#aa3dc17da4681ab6f806ce43e400ce9de", null ], + [ "MPI_Start_data", "summary_8c.html#a609972981d9e0d89a9818d67c43ec47e", null ], + [ "MPI_Startall_data", "summary_8c.html#a52c7f23b6a85a53fa92d4f75b84363ca", null ], + [ "MPI_Test_cancelled_data", "summary_8c.html#aa478ea147dd03240882bdeb14f4a9754", null ], + [ "MPI_Test_data", "summary_8c.html#a45599b5df94f2e1582f50a84e22824ed", null ], + [ "MPI_Testall_data", "summary_8c.html#af03e5dedf4289fadf0d22132f7008d88", null ], + [ "MPI_Testany_data", "summary_8c.html#ad93d61f023cd9a2ef33494420e220571", null ], + [ "MPI_Testsome_data", "summary_8c.html#a8d62e6e10c4660c07db3d9ab31d4d04b", null ], + [ "MPI_Topo_test_data", "summary_8c.html#ac9786807efe83a04234fde1ffb1a866c", null ], + [ "MPI_Type_commit_data", "summary_8c.html#ae6d8c5b4eff4b959c8ec57d833f1e75e", null ], + [ "MPI_Type_contiguous_data", "summary_8c.html#a2cdf05b0a53642321b7107358118bd0d", null ], + [ "MPI_Type_extent_data", "summary_8c.html#a144e9a3ce7f907c1f5a909030aa1d23e", null ], + [ "MPI_Type_free_data", "summary_8c.html#a7cd23e366bcf87578b65731fb6b90ed8", null ], + [ "MPI_Type_hindexed_data", "summary_8c.html#ae3c3d4113fce5c68b5e64ad5940d72b1", null ], + [ "MPI_Type_hvector_data", "summary_8c.html#a0a36e75197127097bdffaa9bb9689768", null ], + [ "MPI_Type_indexed_data", "summary_8c.html#a6a2564455d5080402cf42c4b49ee68af", null ], + [ "MPI_Type_lb_data", "summary_8c.html#a0b30c3f65ce506a2a04098e0d2c31c64", null ], + [ "MPI_Type_size_data", "summary_8c.html#a01ef0e511f889598d8bea5fcccd9e474", null ], + [ "MPI_Type_struct_data", "summary_8c.html#a67a621ea35ad8ab625a6087006bc6341", null ], + [ "MPI_Type_ub_data", "summary_8c.html#ae37b64c61bd2e4ef3922f5f7fe18c19d", null ], + [ "MPI_Type_vector_data", "summary_8c.html#a2c6b7c1f73844eae1ecd931d1bfc55c3", null ], + [ "MPI_Unpack_data", "summary_8c.html#ae6a525ec5e3a9b10083c5f6fa543532e", null ], + [ "MPI_Wait_data", "summary_8c.html#a3e0c85a19f4c1d2a25f45c50e2f36563", null ], + [ "MPI_Waitall_data", "summary_8c.html#a64e80bb7555f90e7fdf6060f18d78042", null ], + [ "MPI_Waitany_data", "summary_8c.html#a32d9b2f126d7ea1c9dfbd07a564b1f27", null ], + [ "MPI_Waitsome_data", "summary_8c.html#a013eb31a0d2f7caf88a59e53b4dbb10c", null ], + [ "MPI_Wtick_data", "summary_8c.html#aadf7be3d57d51f602268076851eee7d9", null ], + [ "MPI_Wtime_data", "summary_8c.html#a73575684d3072d0f7b21c43c0d7f7ba9", null ], + [ "msglen", "summary_8c.html#a118cad54a817ac93b88012250dd6ce16", null ], + [ "mypid", "summary_8c.html#a5ec9634520c3df4561d5e9a5dfbdf20a", null ], + [ "numtask", "summary_8c.html#ab094a15c7ca29970bd5abe5794d92532", null ], + [ "procid_0", "summary_8c.html#a389c7c1d3463a433be1d5311eb945fc7", null ], + [ "profile", "summary_8c.html#a41cdb4a229a3d71837d607124f8a07a4", null ], + [ "start_wall", "summary_8c.html#aefd87183e71a7d074a6a3e87faa4868f", null ], + [ "tbytes", "summary_8c.html#ae0276ef6a367bbc96a3d4e441243f971", null ], + [ "tcpu", "summary_8c.html#a4a88193fca9ebe61ea6eab56cd9befc9", null ], + [ "tot_wall", "summary_8c.html#a2f75be153f43f026a70f3df9b651ce3b", null ], + [ "trace_flag", "summary_8c.html#a4d9ac415b892403cd9d81603c304a35d", null ], + [ "twall", "summary_8c.html#aae7b07a620912f0a0bc33705383c85ef", null ], + [ "wall_comm", "summary_8c.html#a6f189801f4fd3bbe4dd5e4e119b42546", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/summary_8c_source.html b/ver-2.10.0/summary_8c_source.html new file mode 100644 index 00000000..85551ab2 --- /dev/null +++ b/ver-2.10.0/summary_8c_source.html @@ -0,0 +1,520 @@ + + + + + + + +NCEPLIBS-w3emc: summary.c Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    summary.c
    +
    +
    +Go to the documentation of this file.
    1 
    +
    23 #include <stdio.h>
    +
    24 #include <stdlib.h>
    +
    25 #include <math.h>
    +
    26 #include <string.h>
    +
    27 #include <sys/types.h>
    +
    28 #include <sys/stat.h>
    +
    29 #include <sys/time.h>
    +
    30 #include <sys/times.h>
    +
    31 #include <sys/utsname.h>
    +
    32 #ifdef _AIX
    +
    33 #include <sys/proc.h>
    +
    34 #endif
    +
    35 #ifdef __linux__
    +
    36 #include <errno.h>
    +
    37 #include <sys/resource.h>
    +
    38 #endif
    +
    39 
    +
    40 static FILE *fp = NULL;
    +
    41 int numtask, mypid;
    +
    42 int procid_0;
    +
    43 int profile, msglen;
    +
    44 int trace_flag;
    +
    45 double tcpu, twall, tbytes, f_bytes;
    +
    46 double tot_wall, final_wall, start_wall;
    +
    47 double cpu_comm, wall_comm;
    +
    48 #ifdef _AIX
    +
    49 extern double rtc ();
    +
    50 #endif
    +
    51 struct time_data {
    +
    52  double s_cpu;
    +
    53  double s_wall;
    +
    54  double f_cpu;
    +
    55  double f_wall;
    +
    56  double c_cpu;
    +
    57  double c_wall;
    +
    58  double c_bytes;
    +
    59  int c_calls;
    +
    60  int c_buckets[32];
    +
    61  float c_sum[32];
    +
    62  double b_cpu[32];
    +
    63  double b_wall[32];
    +
    64 };
    +
    65 
    +
    66 struct time_data MPI_Allgather_data;
    +
    67 struct time_data MPI_Allgatherv_data;
    +
    68 struct time_data MPI_Allreduce_data;
    +
    69 struct time_data MPI_Alltoall_data;
    +
    70 struct time_data MPI_Alltoallv_data;
    +
    71 struct time_data MPI_Barrier_data;
    +
    72 struct time_data MPI_Bcast_data;
    +
    73 struct time_data MPI_Gather_data;
    +
    74 struct time_data MPI_Gatherv_data;
    +
    75 struct time_data MPI_Op_create_data;
    +
    76 struct time_data MPI_Op_free_data;
    +
    77 struct time_data MPI_Reduce_scatter_data;
    +
    78 struct time_data MPI_Reduce_data;
    +
    79 struct time_data MPI_Scan_data;
    +
    80 struct time_data MPI_Scatter_data;
    +
    81 struct time_data MPI_Scatterv_data;
    +
    82 struct time_data MPI_Attr_delete_data;
    +
    83 struct time_data MPI_Attr_get_data;
    +
    84 struct time_data MPI_Attr_put_data;
    +
    85 struct time_data MPI_Comm_compare_data;
    +
    86 struct time_data MPI_Comm_create_data;
    +
    87 struct time_data MPI_Comm_dup_data;
    +
    88 struct time_data MPI_Comm_free_data;
    +
    89 struct time_data MPI_Comm_group_data;
    +
    90 struct time_data MPI_Comm_rank_data;
    +
    91 struct time_data MPI_Comm_remote_group_data;
    +
    92 struct time_data MPI_Comm_remote_size_data;
    +
    93 struct time_data MPI_Comm_size_data;
    +
    94 struct time_data MPI_Comm_split_data;
    +
    95 struct time_data MPI_Comm_test_inter_data;
    +
    96 struct time_data MPI_Group_compare_data;
    +
    97 struct time_data MPI_Group_difference_data;
    +
    98 struct time_data MPI_Group_excl_data;
    +
    99 struct time_data MPI_Group_free_data;
    +
    100 struct time_data MPI_Group_incl_data;
    +
    101 struct time_data MPI_Group_intersection_data;
    +
    102 struct time_data MPI_Group_rank_data;
    +
    103 struct time_data MPI_Group_range_excl_data;
    +
    104 struct time_data MPI_Group_range_incl_data;
    +
    105 struct time_data MPI_Group_size_data;
    +
    106 struct time_data MPI_Group_translate_ranks_data;
    +
    107 struct time_data MPI_Group_union_data;
    +
    108 struct time_data MPI_Intercomm_create_data;
    +
    109 struct time_data MPI_Intercomm_merge_data;
    +
    110 struct time_data MPI_Keyval_create_data;
    +
    111 struct time_data MPI_Keyval_free_data;
    +
    112 struct time_data MPI_Abort_data;
    +
    113 struct time_data MPI_Error_class_data;
    +
    114 struct time_data MPI_Errhandler_create_data;
    +
    115 struct time_data MPI_Errhandler_free_data;
    +
    116 struct time_data MPI_Errhandler_get_data;
    +
    117 struct time_data MPI_Error_string_data;
    +
    118 struct time_data MPI_Errhandler_set_data;
    +
    119 struct time_data MPI_Get_processor_name_data;
    +
    120 struct time_data MPI_Initialized_data;
    +
    121 struct time_data MPI_Wtick_data;
    +
    122 struct time_data MPI_Wtime_data;
    +
    123 struct time_data MPI_Address_data;
    +
    124 struct time_data MPI_Bsend_data;
    +
    125 struct time_data MPI_Bsend_init_data;
    +
    126 struct time_data MPI_Buffer_attach_data;
    +
    127 struct time_data MPI_Buffer_detach_data;
    +
    128 struct time_data MPI_Cancel_data;
    +
    129 struct time_data MPI_Request_free_data;
    +
    130 struct time_data MPI_Recv_init_data;
    +
    131 struct time_data MPI_Send_init_data;
    +
    132 struct time_data MPI_Get_elements_data;
    +
    133 struct time_data MPI_Get_count_data;
    +
    134 struct time_data MPI_Ibsend_data;
    +
    135 struct time_data MPI_Iprobe_data;
    +
    136 struct time_data MPI_Irecv_data;
    +
    137 struct time_data MPI_Irsend_data;
    +
    138 struct time_data MPI_Isend_data;
    +
    139 struct time_data MPI_Issend_data;
    +
    140 struct time_data MPI_Pack_data;
    +
    141 struct time_data MPI_Pack_size_data;
    +
    142 struct time_data MPI_Probe_data;
    +
    143 struct time_data MPI_Recv_data;
    +
    144 struct time_data MPI_Rsend_data;
    +
    145 struct time_data MPI_Rsend_init_data;
    +
    146 struct time_data MPI_Send_data;
    +
    147 struct time_data MPI_Sendrecv_data;
    +
    148 struct time_data MPI_Sendrecv_replace_data;
    +
    149 struct time_data MPI_Ssend_data;
    +
    150 struct time_data MPI_Ssend_init_data;
    +
    151 struct time_data MPI_Start_data;
    +
    152 struct time_data MPI_Startall_data;
    +
    153 struct time_data MPI_Test_data;
    +
    154 struct time_data MPI_Testall_data;
    +
    155 struct time_data MPI_Testany_data;
    +
    156 struct time_data MPI_Test_cancelled_data;
    +
    157 struct time_data MPI_Testsome_data;
    +
    158 struct time_data MPI_Type_commit_data;
    +
    159 struct time_data MPI_Type_contiguous_data;
    +
    160 struct time_data MPI_Type_extent_data;
    +
    161 struct time_data MPI_Type_free_data;
    +
    162 struct time_data MPI_Type_hindexed_data;
    +
    163 struct time_data MPI_Type_hvector_data;
    +
    164 struct time_data MPI_Type_indexed_data;
    +
    165 struct time_data MPI_Type_lb_data;
    +
    166 struct time_data MPI_Type_size_data;
    +
    167 struct time_data MPI_Type_struct_data;
    +
    168 struct time_data MPI_Type_ub_data;
    +
    169 struct time_data MPI_Type_vector_data;
    +
    170 struct time_data MPI_Unpack_data;
    +
    171 struct time_data MPI_Wait_data;
    +
    172 struct time_data MPI_Waitall_data;
    +
    173 struct time_data MPI_Waitany_data;
    +
    174 struct time_data MPI_Waitsome_data;
    +
    175 struct time_data MPI_Cart_coords_data;
    +
    176 struct time_data MPI_Cart_create_data;
    +
    177 struct time_data MPI_Cart_get_data;
    +
    178 struct time_data MPI_Cart_map_data;
    +
    179 struct time_data MPI_Cart_rank_data;
    +
    180 struct time_data MPI_Cart_shift_data;
    +
    181 struct time_data MPI_Cart_sub_data;
    +
    182 struct time_data MPI_Cartdim_get_data;
    +
    183 struct time_data MPI_Dims_create_data;
    +
    184 struct time_data MPI_Graph_create_data;
    +
    185 struct time_data MPI_Graph_get_data;
    +
    186 struct time_data MPI_Graph_map_data;
    +
    187 struct time_data MPI_Graph_neighbors_data;
    +
    188 struct time_data MPI_Graph_neighbors_count_data;
    +
    189 struct time_data MPI_Graphdims_get_data;
    +
    190 struct time_data MPI_Topo_test_data;
    +
    191 
    +
    196 int bucket (lng)
    +
    197 int lng;
    +
    198 {
    +
    199  int i, j;
    +
    200  if (lng <= 0) {return(0);}
    +
    201  for (i=1, j=--lng; j>0; ++i) {
    +
    202  j = j>>1;
    +
    203  }
    +
    204  return (i);
    +
    205 }
    +
    206 
    +
    211 void elapse (timer)
    +
    212 double *timer;
    +
    213 {
    +
    214 #ifdef _AIX
    +
    215  *timer = rtc();
    +
    216 #endif
    +
    217 #ifdef __linux__
    +
    218  struct timeval st;
    +
    219  if (gettimeofday (&st, NULL) == -1) {
    +
    220  fprintf (stderr,
    +
    221  "elapse: gettimeofday: %s.\n",
    +
    222  strerror (errno));
    +
    223  *timer = 0.;
    +
    224  }
    +
    225  *timer = ((double) st.tv_sec) + 1.e-6 * ((double) st.tv_usec);
    +
    226 #endif
    +
    227 }
    +
    228 
    +
    234 void cputim (usr, sys)
    +
    235 double *usr;
    +
    236 double *sys;
    +
    237 {
    +
    238  double real;
    +
    239  typedef struct { int tms_utime;
    +
    240  int tms_stime;
    +
    241  int tms_cutime;
    +
    242  int tms_cstime; } tms;
    +
    243 
    +
    244  struct tms Time_buffer;
    +
    245  int ret;
    +
    246 
    +
    247  ret = times (&Time_buffer);
    +
    248 
    +
    249  real = ((double) ret) * 0.01;
    +
    250 
    +
    251  *usr = ((double) Time_buffer.tms_utime) * 0.01;
    +
    252  *sys = ((double) Time_buffer.tms_stime) * 0.01;
    +
    253  return;
    +
    254 }
    +
    255 
    +
    260 void start_timer (time)
    +
    261 struct time_data *time;
    +
    262 {
    +
    263  double user, sys;
    +
    264  double wall;
    +
    265 
    +
    266  cputim (&user, &sys);
    +
    267  elapse (&wall);
    +
    268  time->s_cpu = user + sys;
    +
    269  time->s_wall = wall;
    +
    270 
    +
    271  return;
    +
    272 }
    +
    273 
    +
    279 void end_timer (time)
    +
    280 struct time_data *time;
    +
    281 {
    +
    282  double user, sys;
    +
    283  double wall;
    +
    284 
    +
    285  cputim (&user, &sys);
    +
    286  elapse (&wall);
    +
    287  time->f_cpu = user + sys;
    +
    288  time->f_wall = wall;
    +
    289  time->c_cpu += time->f_cpu - time->s_cpu;
    +
    290  time->c_wall += time->f_wall - time->s_wall;
    +
    291 
    +
    292  return;
    +
    293 }
    +
    294 
    +
    299 void resource ()
    +
    300 
    +
    301 {
    +
    302  double usr, sys;
    +
    303  long data[14];
    +
    304 #ifdef _AIX
    +
    305  typedef struct {
    +
    306  int tv_sec; /* seconds */
    +
    307  int tv_usec; /* microseconds */
    +
    308  } timeval;
    +
    309 #endif
    +
    310  double user, system;
    +
    311  int ret;
    +
    312 
    +
    313  struct rusage RU;
    +
    314  ret = getrusage (0, &RU);
    +
    315 
    +
    316  if (ret != 0) {
    +
    317  printf ("getrusage FAILED!!!\n");
    +
    318  printf ("ret = %d\n", ret);
    +
    319  return;
    +
    320  }
    +
    321 
    +
    322  user = ((double) RU.ru_utime.tv_sec) + (((double) RU.ru_utime.tv_usec) * ((double) 0.000001));
    +
    323  system = ((double) RU.ru_stime.tv_sec) + (((double) RU.ru_stime.tv_usec) * ((double) 0.000001));
    +
    324 
    +
    325  printf("*****************RESOURCE STATISTICS*******************************\n");
    +
    326  printf("The total amount of wall time = %f\n", tot_wall);
    +
    327  printf("The total amount of time in user mode = %f\n", user);
    +
    328  printf("The total amount of time in sys mode = %f\n", system);
    +
    329 #ifdef _AIX
    +
    330  printf("The maximum resident set size (KB) = %d\n", RU.ru_maxrss);
    +
    331  printf("Average shared memory use in text segment (KB*sec) = %d\n", RU.ru_ixrss);
    +
    332  printf("Average unshared memory use in data segment (KB*sec) = %d\n", RU.ru_idrss);
    +
    333  printf("Average unshared memory use in stack segment(KB*sec) = %d\n", RU.ru_isrss);
    +
    334  printf("Number of page faults without I/O activity = %d\n", RU.ru_minflt);
    +
    335  printf("Number of page faults with I/O activity = %d\n", RU.ru_majflt);
    +
    336  printf("Number of times process was swapped out = %d\n", RU.ru_nswap);
    +
    337  printf("Number of times filesystem performed INPUT = %d\n", RU.ru_inblock);
    +
    338  printf("Number of times filesystem performed OUTPUT = %d\n", RU.ru_oublock);
    +
    339  printf("Number of IPC messages sent = %d\n", RU.ru_msgsnd);
    +
    340  printf("Number of IPC messages received = %d\n", RU.ru_msgrcv);
    +
    341  printf("Number of Signals delivered = %d\n", RU.ru_nsignals);
    +
    342  printf("Number of Voluntary Context Switches = %d\n", RU.ru_nvcsw);
    +
    343  printf("Number of InVoluntary Context Switches = %d\n", RU.ru_nivcsw);
    +
    344 #endif
    +
    345 #ifdef __linux__
    +
    346  printf ("The maximum resident set size (KB) = %ld\n", RU.ru_maxrss);
    +
    347  printf ("Number of page faults without I/O activity = %ld\n", RU.ru_minflt);
    +
    348  printf ("Number of page faults with I/O activity = %ld\n", RU.ru_majflt);
    +
    349  printf ("Number of times filesystem performed INPUT = %ld\n", RU.ru_inblock);
    +
    350  printf ("Number of times filesystem performed OUTPUT = %ld\n", RU.ru_oublock);
    +
    351  printf ("Number of Voluntary Context Switches = %ld\n", RU.ru_nvcsw);
    +
    352  printf ("Number of InVoluntary Context Switches = %ld\n", RU.ru_nivcsw);
    +
    353 #endif
    +
    354  printf("*****************END OF RESOURCE STATISTICS*************************\n\n");
    +
    355 
    +
    356  usr = user;
    +
    357  sys = system;
    +
    358  data[0] = RU.ru_maxrss;
    +
    359  data[1] = RU.ru_ixrss;
    +
    360  data[2] = RU.ru_idrss;
    +
    361  data[3] = RU.ru_isrss;
    +
    362  data[4] = RU.ru_minflt;
    +
    363  data[5] = RU.ru_majflt;
    +
    364  data[6] = RU.ru_nswap;
    +
    365  data[7] = RU.ru_inblock;
    +
    366  data[8] = RU.ru_oublock;
    +
    367  data[9] = RU.ru_msgsnd;
    +
    368  data[10] = RU.ru_msgrcv;
    +
    369  data[11] = RU.ru_nsignals;
    +
    370  data[12] = RU.ru_nvcsw;
    +
    371  data[13] = RU.ru_nivcsw;
    +
    372  return;
    +
    373 }
    +
    374 
    +
    381 void print_timing (string, time)
    +
    382 char *string;
    +
    383 struct time_data *time;
    +
    384 {
    +
    385  if (time->c_calls > 0) {
    +
    386  fprintf (fp, "Information for %s: AVG. Length = %13.2f, CALLS = %d, WALL = %13.3f, CPU = %13.3f \n",
    +
    387  string, (double) (time->c_bytes) / (double) time->c_calls, time->c_calls,
    +
    388  time->c_wall, time->c_cpu);
    +
    389  }
    +
    390 
    +
    391  if (time->c_wall > 0.001 ) {
    +
    392  fprintf (fp, " %s: Total BYTES = %g, BW = %8.3f MBYTES/WALL SEC., BW = %8.3f MBYTES/CPU SEC.\n",
    +
    393  string, time->c_bytes,
    +
    394  ((double) time->c_bytes * 0.000001)/time->c_wall,
    +
    395  ((double) time->c_bytes * 0.000001)/time->c_cpu);
    +
    396  }
    +
    397 
    +
    398  twall += time->c_wall;
    +
    399  tcpu += time->c_cpu;
    +
    400  tbytes += time->c_bytes * 0.000001;
    +
    401 
    +
    402  /* Print the distribution of the message lengths */
    +
    403  if (time->c_calls > 0) {
    +
    404  int i, j1, j2;
    +
    405 
    +
    406  j1 = 0; j2 = 0;
    +
    407  fprintf (fp, " AVG. Length # of Calls MB/WALL Sec. MB/CPU Sec. WALL Secs. CPU Secs. \n");
    +
    408  if (time->c_buckets[0] >0) {
    +
    409  fprintf (fp, " %13.2f %13d %13.3f %13.3f %13.4f %13.4f \n",
    +
    410  time->c_sum[0]/(float)time->c_buckets[0], time->c_buckets[0],
    +
    411  ((double) time->c_sum[0] * 0.000001)/time->b_wall[0],
    +
    412  ((double) time->c_sum[0] * 0.000001)/time->b_cpu[0],
    +
    413  time->b_wall[0], time->b_cpu[0]);
    +
    414  }
    +
    415  time->c_buckets[3] = time->c_buckets[1] + time->c_buckets[2] + time->c_buckets[3];
    +
    416  j1 = 1; j2 = 4;
    +
    417  for (i =3; i < 31; ++i) {
    +
    418  if (time->c_buckets[i] > 0) {
    +
    419  fprintf (fp, " %13.2f %13d %13.3f %13.3f %13.4f %13.4f \n",
    +
    420  time->c_sum[i]/(float)time->c_buckets[i], time->c_buckets[i],
    +
    421  ((double) time->c_sum[i] * 0.000001)/time->b_wall[i],
    +
    422  ((double) time->c_sum[i] * 0.000001)/time->b_cpu[i],
    +
    423  time->b_wall[i], time->b_cpu[i]);
    +
    424  }
    +
    425  j1 = j2 +1;
    +
    426  j2 = j2 + j2;
    +
    427  }
    +
    428 
    +
    429  fprintf (fp, "\n");
    +
    430  }
    +
    431 }
    +
    432 
    +
    437 void summary_ (int *returnVal)
    +
    438 {
    +
    439  double temp, temp1;
    +
    440  char trace_file[255], processor[8];
    +
    441 
    +
    442 /*
    +
    443  MPI_Finalize - prototyping replacement for MPI_Finalize
    +
    444 */
    +
    445  elapse(&final_wall);
    +
    446  tot_wall = final_wall - start_wall;
    +
    447 
    +
    448  resource();
    +
    449 
    +
    450  if (fp) fclose (fp);
    +
    451  return;
    +
    452 }
    +
    453 
    +
    458 void start_ ()
    +
    459 {
    +
    460  int stateid;
    +
    461  int Argc;
    +
    462  char **Argv;
    +
    463 
    +
    464  char *answer;
    +
    465 
    +
    466  trace_flag=1;
    +
    467 
    +
    468  profile = 0;
    +
    469  elapse (&start_wall);
    +
    470  return;
    +
    471 }
    +
    +
    +
    end_timer
    void end_timer(struct time_data *time)
    Definition: summary.c:279
    +
    cputim
    void cputim(double *usr, double *sys)
    Definition: summary.c:234
    +
    bucket
    int bucket(int lng)
    Definition: summary.c:196
    +
    summary_
    void summary_(int *returnVal)
    Definition: summary.c:437
    +
    elapse
    void elapse(double *timer)
    Definition: summary.c:211
    +
    resource
    void resource()
    Definition: summary.c:299
    +
    start_
    void start_()
    Definition: summary.c:458
    +
    start_timer
    void start_timer(struct time_data *time)
    Definition: summary.c:260
    +
    print_timing
    void print_timing(char *string, struct time_data *time)
    Definition: summary.c:381
    + + + + diff --git a/ver-2.10.0/sync_off.png b/ver-2.10.0/sync_off.png new file mode 100644 index 00000000..3b443fc6 Binary files /dev/null and b/ver-2.10.0/sync_off.png differ diff --git a/ver-2.10.0/sync_on.png b/ver-2.10.0/sync_on.png new file mode 100644 index 00000000..e08320fb Binary files /dev/null and b/ver-2.10.0/sync_on.png differ diff --git a/ver-2.10.0/tab_a.png b/ver-2.10.0/tab_a.png new file mode 100644 index 00000000..3b725c41 Binary files /dev/null and b/ver-2.10.0/tab_a.png differ diff --git a/ver-2.10.0/tab_b.png b/ver-2.10.0/tab_b.png new file mode 100644 index 00000000..e2b4a863 Binary files /dev/null and b/ver-2.10.0/tab_b.png differ diff --git a/ver-2.10.0/tab_h.png b/ver-2.10.0/tab_h.png new file mode 100644 index 00000000..fd5cb705 Binary files /dev/null and b/ver-2.10.0/tab_h.png differ diff --git a/ver-2.10.0/tab_s.png b/ver-2.10.0/tab_s.png new file mode 100644 index 00000000..ab478c95 Binary files /dev/null and b/ver-2.10.0/tab_s.png differ diff --git a/ver-2.10.0/tabs.css b/ver-2.10.0/tabs.css new file mode 100644 index 00000000..7d45d36c --- /dev/null +++ b/ver-2.10.0/tabs.css @@ -0,0 +1 @@ +.sm{position:relative;z-index:9999}.sm,.sm ul,.sm li{display:block;list-style:none;margin:0;padding:0;line-height:normal;direction:ltr;text-align:left;-webkit-tap-highlight-color:rgba(0,0,0,0)}.sm-rtl,.sm-rtl ul,.sm-rtl li{direction:rtl;text-align:right}.sm>li>h1,.sm>li>h2,.sm>li>h3,.sm>li>h4,.sm>li>h5,.sm>li>h6{margin:0;padding:0}.sm ul{display:none}.sm li,.sm a{position:relative}.sm a{display:block}.sm a.disabled{cursor:not-allowed}.sm:after{content:"\00a0";display:block;height:0;font:0px/0 serif;clear:both;visibility:hidden;overflow:hidden}.sm,.sm *,.sm *:before,.sm *:after{-moz-box-sizing:border-box;-webkit-box-sizing:border-box;box-sizing:border-box}.sm-dox{background-image:url("tab_b.png")}.sm-dox a,.sm-dox a:focus,.sm-dox a:hover,.sm-dox a:active{padding:0px 12px;padding-right:43px;font-family:"Lucida Grande","Geneva","Helvetica",Arial,sans-serif;font-size:13px;font-weight:bold;line-height:36px;text-decoration:none;text-shadow:0px 1px 1px rgba(255,255,255,0.9);color:#283A5D;outline:none}.sm-dox a:hover{background-image:url("tab_a.png");background-repeat:repeat-x;color:#fff;text-shadow:0px 1px 1px #000}.sm-dox a.current{color:#D23600}.sm-dox a.disabled{color:#bbb}.sm-dox a span.sub-arrow{position:absolute;top:50%;margin-top:-14px;left:auto;right:3px;width:28px;height:28px;overflow:hidden;font:bold 12px/28px monospace !important;text-align:center;text-shadow:none;background:rgba(255,255,255,0.5);border-radius:5px}.sm-dox a.highlighted span.sub-arrow:before{display:block;content:'-'}.sm-dox>li:first-child>a,.sm-dox>li:first-child>:not(ul) a{border-radius:5px 5px 0 0}.sm-dox>li:last-child>a,.sm-dox>li:last-child>*:not(ul) a,.sm-dox>li:last-child>ul,.sm-dox>li:last-child>ul>li:last-child>a,.sm-dox>li:last-child>ul>li:last-child>*:not(ul) a,.sm-dox>li:last-child>ul>li:last-child>ul,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>a,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>*:not(ul) a,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>ul,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>a,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>*:not(ul) a,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>ul,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>a,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>*:not(ul) a,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>ul{border-radius:0 0 5px 5px}.sm-dox>li:last-child>a.highlighted,.sm-dox>li:last-child>*:not(ul) a.highlighted,.sm-dox>li:last-child>ul>li:last-child>a.highlighted,.sm-dox>li:last-child>ul>li:last-child>*:not(ul) a.highlighted,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>a.highlighted,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>*:not(ul) a.highlighted,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>a.highlighted,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>*:not(ul) a.highlighted,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>a.highlighted,.sm-dox>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>ul>li:last-child>*:not(ul) a.highlighted{border-radius:0}.sm-dox ul{background:rgba(162,162,162,0.1)}.sm-dox ul a,.sm-dox ul a:focus,.sm-dox ul a:hover,.sm-dox ul a:active{font-size:12px;border-left:8px solid transparent;line-height:36px;text-shadow:none;background-color:white;background-image:none}.sm-dox ul a:hover{background-image:url("tab_a.png");background-repeat:repeat-x;color:#fff;text-shadow:0px 1px 1px #000}.sm-dox ul ul a,.sm-dox ul ul a:hover,.sm-dox ul ul a:focus,.sm-dox ul ul a:active{border-left:16px solid transparent}.sm-dox ul ul ul a,.sm-dox ul ul ul a:hover,.sm-dox ul ul ul a:focus,.sm-dox ul ul ul a:active{border-left:24px solid transparent}.sm-dox ul ul ul ul a,.sm-dox ul ul ul ul a:hover,.sm-dox ul ul ul ul a:focus,.sm-dox ul ul ul ul a:active{border-left:32px solid transparent}.sm-dox ul ul ul ul ul a,.sm-dox ul ul ul ul ul a:hover,.sm-dox ul ul ul ul ul a:focus,.sm-dox ul ul ul ul ul a:active{border-left:40px solid transparent}@media (min-width: 768px){.sm-dox ul{position:absolute;width:12em}.sm-dox li{float:left}.sm-dox.sm-rtl li{float:right}.sm-dox ul li,.sm-dox.sm-rtl ul li,.sm-dox.sm-vertical li{float:none}.sm-dox a{white-space:nowrap}.sm-dox ul a,.sm-dox.sm-vertical a{white-space:normal}.sm-dox .sm-nowrap>li>a,.sm-dox .sm-nowrap>li>:not(ul) a{white-space:nowrap}.sm-dox{padding:0 10px;background-image:url("tab_b.png");line-height:36px}.sm-dox a span.sub-arrow{top:50%;margin-top:-2px;right:12px;width:0;height:0;border-width:4px;border-style:solid dashed dashed dashed;border-color:#283A5D transparent transparent transparent;background:transparent;border-radius:0}.sm-dox a,.sm-dox a:focus,.sm-dox a:active,.sm-dox a:hover,.sm-dox a.highlighted{padding:0px 12px;background-image:url("tab_s.png");background-repeat:no-repeat;background-position:right;border-radius:0 !important}.sm-dox a:hover{background-image:url("tab_a.png");background-repeat:repeat-x;color:#fff;text-shadow:0px 1px 1px #000}.sm-dox a:hover span.sub-arrow{border-color:#fff transparent transparent transparent}.sm-dox a.has-submenu{padding-right:24px}.sm-dox li{border-top:0}.sm-dox>li>ul:before,.sm-dox>li>ul:after{content:'';position:absolute;top:-18px;left:30px;width:0;height:0;overflow:hidden;border-width:9px;border-style:dashed dashed solid dashed;border-color:transparent transparent #bbb transparent}.sm-dox>li>ul:after{top:-16px;left:31px;border-width:8px;border-color:transparent transparent #fff transparent}.sm-dox ul{border:1px solid #bbb;padding:5px 0;background:#fff;border-radius:5px !important;box-shadow:0 5px 9px rgba(0,0,0,0.2)}.sm-dox ul a span.sub-arrow{right:8px;top:50%;margin-top:-5px;border-width:5px;border-color:transparent transparent transparent #555;border-style:dashed dashed dashed solid}.sm-dox ul a,.sm-dox ul a:hover,.sm-dox ul a:focus,.sm-dox ul a:active,.sm-dox ul a.highlighted{color:#555;background-image:none;border:0 !important;color:#555;background-image:none}.sm-dox ul a:hover{background-image:url("tab_a.png");background-repeat:repeat-x;color:#fff;text-shadow:0px 1px 1px #000}.sm-dox ul a:hover span.sub-arrow{border-color:transparent transparent transparent #fff}.sm-dox span.scroll-up,.sm-dox span.scroll-down{position:absolute;display:none;visibility:hidden;overflow:hidden;background:#fff;height:36px}.sm-dox span.scroll-up:hover,.sm-dox span.scroll-down:hover{background:#eee}.sm-dox span.scroll-up:hover span.scroll-up-arrow,.sm-dox span.scroll-up:hover span.scroll-down-arrow{border-color:transparent transparent #D23600 transparent}.sm-dox span.scroll-down:hover span.scroll-down-arrow{border-color:#D23600 transparent transparent transparent}.sm-dox span.scroll-up-arrow,.sm-dox span.scroll-down-arrow{position:absolute;top:0;left:50%;margin-left:-6px;width:0;height:0;overflow:hidden;border-width:6px;border-style:dashed dashed solid dashed;border-color:transparent transparent #555 transparent}.sm-dox span.scroll-down-arrow{top:8px;border-style:solid dashed dashed dashed;border-color:#555 transparent transparent transparent}.sm-dox.sm-rtl a.has-submenu{padding-right:12px;padding-left:24px}.sm-dox.sm-rtl a span.sub-arrow{right:auto;left:12px}.sm-dox.sm-rtl.sm-vertical a.has-submenu{padding:10px 20px}.sm-dox.sm-rtl.sm-vertical a span.sub-arrow{right:auto;left:8px;border-style:dashed solid dashed dashed;border-color:transparent #555 transparent transparent}.sm-dox.sm-rtl>li>ul:before{left:auto;right:30px}.sm-dox.sm-rtl>li>ul:after{left:auto;right:31px}.sm-dox.sm-rtl ul a.has-submenu{padding:10px 20px !important}.sm-dox.sm-rtl ul a span.sub-arrow{right:auto;left:8px;border-style:dashed solid dashed dashed;border-color:transparent #555 transparent transparent}.sm-dox.sm-vertical{padding:10px 0;border-radius:5px}.sm-dox.sm-vertical a{padding:10px 20px}.sm-dox.sm-vertical a:hover,.sm-dox.sm-vertical a:focus,.sm-dox.sm-vertical a:active,.sm-dox.sm-vertical a.highlighted{background:#fff}.sm-dox.sm-vertical a.disabled{background-image:url("tab_b.png")}.sm-dox.sm-vertical a span.sub-arrow{right:8px;top:50%;margin-top:-5px;border-width:5px;border-style:dashed dashed dashed solid;border-color:transparent transparent transparent #555}.sm-dox.sm-vertical>li>ul:before,.sm-dox.sm-vertical>li>ul:after{display:none}.sm-dox.sm-vertical ul a{padding:10px 20px}.sm-dox.sm-vertical ul a:hover,.sm-dox.sm-vertical ul a:focus,.sm-dox.sm-vertical ul a:active,.sm-dox.sm-vertical ul a.highlighted{background:#eee}.sm-dox.sm-vertical ul a.disabled{background:#fff}} diff --git a/ver-2.10.0/w3ai00_8f.html b/ver-2.10.0/w3ai00_8f.html new file mode 100644 index 00000000..2d0e94cd --- /dev/null +++ b/ver-2.10.0/w3ai00_8f.html @@ -0,0 +1,332 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai00.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ai00.f File Reference
    +
    +
    + +

    Real array to 16 bit packed format. +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + + + +

    +Functions/Subroutines

    subroutine q9e3i6 (A, B, N, ISTAT)
     Convert ieee 32 bit task 754 floating point numbers to ibm370 64 bit floating point numbers. More...
     
    subroutine q9ei32 (A, B, N, ISTAT)
     Convert IEEE 32 bit task 754 floating point numbers to IBM370 32 bit floating point numbers. More...
     
    subroutine w3ai00 (REAL8, PACK, LABEL)
     Converts IEEE floating point numbers to 16 bit packed office note 84 format. More...
     
    +

    Detailed Description

    +

    Real array to 16 bit packed format.

    +
    Author
    Ralph Jones
    +
    Date
    1985-07-31
    + +

    Definition in file w3ai00.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ q9e3i6()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine q9e3i6 (integer(4), dimension(n) A,
    integer(4), dimension(2,n) B,
     N,
     ISTAT 
    )
    +
    + +

    Convert ieee 32 bit task 754 floating point numbers to ibm370 64 bit floating point numbers.

    +

    Program history log:

      +
    • Ralph Jones 1992-08-02
      • +
    • Ralph Jones 1995-11-15 Add save statement.
      • +
    +
    Parameters
    + + + + + +
    [in]AReal*4 array of IEEE 32 bit floating point numbers.
    [in]NNumber of words to convert to IBM370 64 bit F.P.
    [out]BReal*8 array of IBM370 64 bit floating point numbers.
    [out]ISTAT
      +
    • 0 All numbers converted.
      • +
    • -1 N is less than one.
      • +
    • +K K infinity or nan numbers were found.
      • +
    +
    +
    +
    +
    Note
    See IEEE task 754 standard floating point arithmetic for more information about IEEE F.P.
    +
    Author
    Ralph Jones
    +
    Date
    1992-08-02
    + +

    Definition at line 367 of file w3ai00.f.

    + +
    +
    + +

    ◆ q9ei32()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine q9ei32 (integer(4), dimension(*) A,
    integer(4), dimension(*) B,
     N,
     ISTAT 
    )
    +
    + +

    Convert IEEE 32 bit task 754 floating point numbers to IBM370 32 bit floating point numbers.

    +

    Program history log:

      +
    • Ralph Jones 1990-06-04 Convert to sun fortran 1.3.
      • +
    • Ralph Jones 1990-07-14 Change ishft to lshift or lrshft.
      • +
    • Ralph Jones 1991-03-28 Change to silicongraphics 3.3 fortran 77.
      • +
    • Ralph Jones 1992-07-20 Change to ibm aix xl fortran.
      • +
    • Ralph Jones 1995-11-15 Add save statement.
      • +
    • Stepen Gilbert 1998-11-18 Specified 4-byte Integer values.
      • +
    +
    Parameters
    + + + + + +
    [in]A- Real*4 array of IEEE 32 bit floating point numbers.
    [in]N- Number of words to convert to IBM370 32 bit F.P.
    [out]B- Real*4 array of IBM370 32 bit floating point numbers.
    [out]ISTAT
      +
    • 0: All numbers converted.
      • +
    • -1: N is less than one.
      • +
    • +K: K infinity or nan numbers were found.
      • +
    +
    +
    +
    +
    Note
    See IEEE task 754 standard floating point arithmetic for more information about IEEE F.P.
    +
    Author
    Ralph Jones
    +
    Date
    1990-06-04
    + +

    Definition at line 271 of file w3ai00.f.

    + +
    +
    + +

    ◆ w3ai00()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ai00 (real, dimension(*) REAL8,
    integer(8), dimension(*) PACK,
    integer(8), dimension(6) LABEL 
    )
    +
    + +

    Converts IEEE floating point numbers to 16 bit packed office note 84 format.

    +

    The floating point number are converted to 16 bit signed scaled integers.

    +

    Program history log:

      +
    • Ralph Jones 1989-10-20 Convert cyber 205 version of w3ai00 to cray.
      • +
    • Ralph Jones 1990-03-18 Change to use cray integer*2 packer.
      • +
    • Ralph Jones 1990-10-11 Special version to pack grids larger than 32743 words. Will do old and new version.
      • +
    • Ralph Jones 1991-02-16 Changes so equivalence of pack and real8 arrays will work.
      • +
    • Ralph Jones 1993-06-10 Changes for array size (512,512) 262144 words.
      • +
    • Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
      • +
    • Stephen Gilbert 1998-11-18 Changed to pack IEEE values for the IBM SP
      • +
    +
    Parameters
    + + + + +
    [in]REAL8Array of cray floating point numbers.
    [in]LABELSix 8-byte integer words. Must have first 8 of 12 32 bit word office note 84 label. word 6 must have in bits 31-00 the number of real words in array real8 if j is greater than 32743. j in bits 15-0 of the 4th id word is set zero.
    [out]PACKPacked output array of integer words of size 6 + (j+3)/4 , j = no. points in label (from word 4 bits 15-00). Label will be copied to pack words 1-4.
      +
    • Pack will contain the following in words 5-6:
        +
      • word 5 bits 63-48 Number of bytes in whole record. will not be correct if j > 32743.
        • +
      • word 5 bits 47-32 Exclusive-or checksum by 16 bit words of whole array pack excluding checksum itself.
        • +
      • word 5 bits 31-00 Center value a = mean of max and min values. converted to ibm 32 floating point number.
        • +
      • word 6 bits 63-48 Zero.
        • +
      • word 6 bits 47-32 16 bit shift value n. the least integer such that abs(x-a)/2**n lt 1 for all x in real8. limited to +-127.
        • +
      • word 6 bits 31-00 Number of words in real8 if > 32743, right adjusted if <= 32743 set zero.
        • +
      +
      • +
    +
    +
    +
    +
    Note
    Pack and label may be equivalenced. n, the number of points in a grid is now in 32 bit id word 12.
    +
    Author
    Ralph Jones
    +
    Date
    1985-07-31
    + +

    Definition at line 40 of file w3ai00.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ai00_8f.js b/ver-2.10.0/w3ai00_8f.js new file mode 100644 index 00000000..ac93df34 --- /dev/null +++ b/ver-2.10.0/w3ai00_8f.js @@ -0,0 +1,6 @@ +var w3ai00_8f = +[ + [ "q9e3i6", "w3ai00_8f.html#a080e60503e36be98db3d35c5e508dbde", null ], + [ "q9ei32", "w3ai00_8f.html#aa9b74cf19854cae0066bd5d905a65873", null ], + [ "w3ai00", "w3ai00_8f.html#a076bf45857d517709ef249c89a0791e5", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ai00_8f_source.html b/ver-2.10.0/w3ai00_8f_source.html new file mode 100644 index 00000000..c3307a7b --- /dev/null +++ b/ver-2.10.0/w3ai00_8f_source.html @@ -0,0 +1,551 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai00.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ai00.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Real array to 16 bit packed format.
    +
    3 C> @author Ralph Jones @date 1985-07-31
    +
    4 
    +
    5 C> Converts IEEE floating point numbers to 16 bit
    +
    6 C> packed office note 84 format. The floating point number are
    +
    7 C> converted to 16 bit signed scaled integers.
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - Ralph Jones 1989-10-20 Convert cyber 205 version of w3ai00 to cray.
    +
    11 C> - Ralph Jones 1990-03-18 Change to use cray integer*2 packer.
    +
    12 C> - Ralph Jones 1990-10-11 Special version to pack grids larger than
    +
    13 C> 32743 words. Will do old and new version.
    +
    14 C> - Ralph Jones 1991-02-16 Changes so equivalence of pack and real8
    +
    15 C> arrays will work.
    +
    16 C> - Ralph Jones 1993-06-10 Changes for array size (512,512) 262144 words.
    +
    17 C> - Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
    +
    18 C> - Stephen Gilbert 1998-11-18 Changed to pack IEEE values for the IBM SP
    +
    19 C>
    +
    20 C> @param[in] REAL8 Array of cray floating point numbers.
    +
    21 C> @param[in] LABEL Six 8-byte integer words. Must have first 8 of 12 32 bit
    +
    22 C> word office note 84 label. word 6 must have in bits 31-00 the number of
    +
    23 C> real words in array real8 if j is greater than 32743.
    +
    24 C> j in bits 15-0 of the 4th id word is set zero.
    +
    25 C> @param[out] PACK Packed output array of integer words of size 6 + (j+3)/4 ,
    +
    26 C> j = no. points in label (from word 4 bits 15-00). Label will be copied to pack words 1-4.
    +
    27 C> - Pack will contain the following in words 5-6:
    +
    28 C> - word 5 bits 63-48 Number of bytes in whole record. will not be correct if j > 32743.
    +
    29 C> - word 5 bits 47-32 Exclusive-or checksum by 16 bit words of whole array pack excluding checksum itself.
    +
    30 C> - word 5 bits 31-00 Center value a = mean of max and min values. converted to ibm 32 floating point number.
    +
    31 C> - word 6 bits 63-48 Zero.
    +
    32 C> - word 6 bits 47-32 16 bit shift value n. the least integer such that abs(x-a)/2**n lt 1 for all x in real8. limited to +-127.
    +
    33 C> - word 6 bits 31-00 Number of words in real8 if > 32743, right adjusted if <= 32743 set zero.
    +
    34 C>
    +
    35 C> @note Pack and label may be equivalenced. n, the number of points
    +
    36 C> in a grid is now in 32 bit id word 12.
    +
    37 C>
    +
    38 C> @author Ralph Jones @date 1985-07-31
    +
    39  SUBROUTINE w3ai00(REAL8,PACK,LABEL)
    +
    40 C
    +
    41  REAL REAL8(*)
    +
    42  REAL XX(262144)
    +
    43 C
    +
    44  INTEGER(8) KK(262144)
    +
    45  INTEGER(8) LABEL(6)
    +
    46  INTEGER(8) PACK(*)
    +
    47  INTEGER(8) TPACK(6)
    +
    48  INTEGER(8) MASK16,MASK32,MASKN,IBYTES,IXOR
    +
    49  INTEGER(8) IB,N
    +
    50  REAL(8) B
    +
    51  REAL(4) X,A
    +
    52  real(4) rtemp(2)
    +
    53  integer(8) irtemp
    +
    54  equivalence(irtemp,rtemp(1))
    +
    55 C
    +
    56  SAVE
    +
    57 C
    +
    58  equivalence(b,ib)
    +
    59 C
    +
    60  DATA mask16/z'000000000000FFFF'/
    +
    61  DATA mask32/z'00000000FFFFFFFF'/
    +
    62  DATA maskn /z'0000FFFF00000000'/
    +
    63 C
    +
    64 C TRANSFER LABEL DATA TO WORDS 1-4. GET WORD COUNT, COMPUTE BYTES.
    +
    65 C
    +
    66  DO 10 i = 1,4
    +
    67  tpack(i) = label(i)
    +
    68  10 CONTINUE
    +
    69 C
    +
    70  tpack(5) = 0
    +
    71  tpack(6) = 0
    +
    72 C
    +
    73 C GET J, THE NUMBER OF WORDS IN A GRID, IF ZERO GET THE
    +
    74 C GET J FROM OFFICE NOTE 84 ID WORD 12.
    +
    75 C
    +
    76  j = iand(mask16,tpack(4))
    +
    77  IF (j.EQ.0) THEN
    +
    78  tpack(6) = label(6)
    +
    79  j = iand(mask32,tpack(6))
    +
    80  IF (j.EQ.0) THEN
    +
    81  print *,' W3AI00: ERROR, NO. OF WORDS IN GRID = 0'
    +
    82  RETURN
    +
    83  ENDIF
    +
    84  IF (j.GT.262144) THEN
    +
    85  print *,' W3AI00: ERROR, NO. OF WORDS IN GRID = ',j
    +
    86  print *,' THERE IS A LIMIT OF 262144 WORDS.'
    +
    87  RETURN
    +
    88  ENDIF
    +
    89  ENDIF
    +
    90  m = j + 24
    +
    91 C
    +
    92 C COMPUTE THE NUMBER OF 64 BIT INTEGER CRAY WORDS NEEDED FOR
    +
    93 C PACKED DATA.
    +
    94 C
    +
    95  IF (mod(m,4).NE.0) THEN
    +
    96  iword = (m + 3) / 4
    +
    97  ELSE
    +
    98  iword = m / 4
    +
    99  ENDIF
    +
    100 C
    +
    101  ibytes = m + m
    +
    102 C
    +
    103 C STORE NUMBER OF BYTES IN RECORD IN BITS 63-48 OF WORD 5.
    +
    104 C BITS ARE NUMBERED LEFT TO RIGHT 63 T0 00
    +
    105 C
    +
    106  tpack(5) = ishft(ibytes,48_8)
    +
    107 C
    +
    108 C FIND MAX, MIN OF DATA, COMPUTE A AND N.
    +
    109 C
    +
    110  rmax = real8(1)
    +
    111  rmin = rmax
    +
    112  DO 20 i = 2,j
    +
    113  rmax = amax1(rmax,real8(i))
    +
    114  rmin = amin1(rmin,real8(i))
    +
    115  20 CONTINUE
    +
    116 C
    +
    117  a = 0.5 * (rmax + rmin)
    +
    118  x = rmax - a
    +
    119  IF (rmax.NE.rmin) THEN
    +
    120 C CALL USDCTI(X,B,1,1,ISTAT)
    +
    121  CALL q9e3i6(x,b,1,istat)
    +
    122  IF (istat.NE.0) print *,' W3AI00-USDCTI OVERFLOW ERROR 1'
    +
    123  n = iand(ishft(ib,-56_8),127_8)
    +
    124  n = 4 * (n - 64)
    +
    125  IF (btest(ib,55_8)) GO TO 30
    +
    126  n = n - 1
    +
    127  IF (btest(ib,54_8)) GO TO 30
    +
    128  n = n - 1
    +
    129  IF (btest(ib,53_8)) GO TO 30
    +
    130  n = n - 1
    +
    131  30 CONTINUE
    +
    132  n = max(-127_8,min(127_8,n))
    +
    133  ELSE
    +
    134 C
    +
    135 C FIELD IS ZERO OR A CONSTANT
    +
    136 C
    +
    137  n = 0
    +
    138  ENDIF
    +
    139 C
    +
    140 C CONVERT AVERAGE VALUE FROM IEEE F.P. TO IBM370 32 BIT
    +
    141 C STORE IBM370 32 BIT F.P. AVG. VALUE IN BITS 31 - 00 OF WORD 5.
    +
    142 C
    +
    143 C CALL USSCTI(A,TPACK(5),5,1,ISTAT)
    +
    144  CALL q9ei32(a,rtemp(2),1,istat)
    +
    145  IF (istat.NE.0) print *,' W3AI00-USDCTI OVERFLOW ERROR 2'
    +
    146  tpack(5)=ior(tpack(5),irtemp)
    +
    147 C
    +
    148 C STORE SCALING VALUE N IN BITS 47 - 32 OF WORD 6.
    +
    149 C
    +
    150  tpack(6) = ior(iand(maskn,ishft(n,32_8)),tpack(6))
    +
    151 C
    +
    152 C NOW PACK UP THE DATA, AND SCALE IT TO FIT AN INTEGER*2 WORD
    +
    153 C
    +
    154  twon = 2.0 ** (15 - n)
    +
    155  DO 40 i = 1,j
    +
    156  xx(i) = (real8(i) - a) * twon
    +
    157  kk(i) = xx(i) + sign(0.5,xx(i))
    +
    158  IF (kk(i).GE.(-32767)) THEN
    +
    159  kk(i) = min(32767_8,kk(i))
    +
    160  ELSE
    +
    161  kk(i) = -32767
    +
    162  ENDIF
    +
    163  kk(i) = iand(kk(i),mask16)
    +
    164  40 CONTINUE
    +
    165 C
    +
    166 C SHIFT THE INTEGER*2 DATA TO FIT 4 IN A 64 BIT WORD
    +
    167 C
    +
    168  lim = (j / 4 ) * 4
    +
    169  irem = j - lim
    +
    170  DO 50 i = 1,lim,4
    +
    171  kk(i) = ishft(kk(i), 48_8)
    +
    172  kk(i+1) = ishft(kk(i+1),32_8)
    +
    173  kk(i+2) = ishft(kk(i+2),16_8)
    +
    174  50 CONTINUE
    +
    175 C
    +
    176 C SHIFT THE REMAINING 1, 2, OR 3 INTEGER*2 WORDS
    +
    177 C
    +
    178  IF (irem.EQ.1) THEN
    +
    179  kk(lim+1) = ishft(kk(lim+1),48_8)
    +
    180  ENDIF
    +
    181 C
    +
    182  IF (irem.EQ.2) THEN
    +
    183  kk(lim+1) = ishft(kk(lim+1),48_8)
    +
    184  kk(lim+2) = ishft(kk(lim+2),32_8)
    +
    185  ENDIF
    +
    186 C
    +
    187  IF (irem.EQ.3) THEN
    +
    188  kk(lim+1) = ishft(kk(lim+1),48_8)
    +
    189  kk(lim+2) = ishft(kk(lim+2),32_8)
    +
    190  kk(lim+3) = ishft(kk(lim+3),16_8)
    +
    191  ENDIF
    +
    192 C
    +
    193 C PACK THE DATA BY USE OF IOR FOUR TO A WORD
    +
    194 C
    +
    195  ii = 7
    +
    196  DO 60 i = 1,lim,4
    +
    197  pack(ii) = ior(ior(ior(kk(i),kk(i+1)),kk(i+2)),kk(i+3))
    +
    198  ii = ii + 1
    +
    199  60 CONTINUE
    +
    200 C
    +
    201 C PACK THE LAST 1, 2, OR 3 INTEGER*2 WORDS
    +
    202 C
    +
    203  IF (irem.EQ.1) THEN
    +
    204  pack(iword) = kk(lim+1)
    +
    205  ENDIF
    +
    206 C
    +
    207  IF (irem.EQ.2) THEN
    +
    208  pack(iword) = ior(kk(i),kk(i+1))
    +
    209  ENDIF
    +
    210 C
    +
    211  IF (irem.EQ.3) THEN
    +
    212  pack(iword) = ior(ior(kk(i),kk(i+1)),kk(i+2))
    +
    213  ENDIF
    +
    214 C
    +
    215 C MOVE LABEL FROM TEMPORARY ARRAY TO PACK
    +
    216 C
    +
    217  DO 70 i = 1,6
    +
    218  pack(i) = tpack(i)
    +
    219  70 CONTINUE
    +
    220 C
    +
    221 C COMPUTE CHECKSUM AND STORE
    +
    222 C
    +
    223  ixor = 0
    +
    224 C
    +
    225 C COMPUTES A 64 BIT CHECKSUM 1ST
    +
    226 C
    +
    227  DO 80 i = 1,iword
    +
    228  ixor = ieor(ixor,pack(i))
    +
    229  80 CONTINUE
    +
    230 C
    +
    231 C COMPUTES A 32 BIT CHECKSUM 2ND
    +
    232 C
    +
    233  ixor = ieor(ishft(ixor,-32_8),iand(ixor,mask32))
    +
    234 C
    +
    235 C COMPUTES A 16 BIT CHECKSUM 3RD
    +
    236 C
    +
    237  ixor = ieor(ishft(ixor,-16_8),iand(ixor,mask16))
    +
    238 C
    +
    239 C STORE 16 BIT CHECK SUM OF RECORD IN BITS 47-32 OF WORD 5.
    +
    240 C
    +
    241  pack(5) = ior(ishft(ixor,32_8),pack(5))
    +
    242 C
    +
    243  RETURN
    +
    244  END
    +
    245 
    +
    246 
    +
    247 C> Convert IEEE 32 bit task 754 floating point numbers
    +
    248 C> to IBM370 32 bit floating point numbers.
    +
    249 C>
    +
    250 C> Program history log:
    +
    251 C> - Ralph Jones 1990-06-04 Convert to sun fortran 1.3.
    +
    252 C> - Ralph Jones 1990-07-14 Change ishft to lshift or lrshft.
    +
    253 C> - Ralph Jones 1991-03-28 Change to silicongraphics 3.3 fortran 77.
    +
    254 C> - Ralph Jones 1992-07-20 Change to ibm aix xl fortran.
    +
    255 C> - Ralph Jones 1995-11-15 Add save statement.
    +
    256 C> - Stepen Gilbert 1998-11-18 Specified 4-byte Integer values.
    +
    257 C>
    +
    258 C> @param[in] A - Real*4 array of IEEE 32 bit floating point numbers.
    +
    259 C> @param[in] N - Number of words to convert to IBM370 32 bit F.P.
    +
    260 C> @param[out] B - Real*4 array of IBM370 32 bit floating point numbers.
    +
    261 C> @param[out] ISTAT:
    +
    262 C> - 0: All numbers converted.
    +
    263 C> - -1: N is less than one.
    +
    264 C> - +K: K infinity or nan numbers were found.
    +
    265 C>
    +
    266 C> @note See IEEE task 754 standard floating point arithmetic for
    +
    267 C> more information about IEEE F.P.
    +
    268 C>
    +
    269 C> @author Ralph Jones @date 1990-06-04
    +
    270  SUBROUTINE q9ei32(A,B,N,ISTAT)
    +
    271 C
    +
    272  INTEGER(4) A(*)
    +
    273  INTEGER(4) B(*)
    +
    274  INTEGER(4) SIGN,MASKFR,IBIT8,MASKSN,ITEMP,IBMEXP,IBX7
    +
    275  INTEGER(4) ISIGN
    +
    276 C
    +
    277  SAVE
    +
    278 C
    +
    279  DATA maskfr/z'00FFFFFF'/
    +
    280  DATA ibit8 /z'00800000'/
    +
    281  DATA masksn/z'7FFFFFFF'/
    +
    282  DATA sign /z'80000000'/
    +
    283 C
    +
    284  IF (n.LT.1) THEN
    +
    285  istat = -1
    +
    286  RETURN
    +
    287  ENDIF
    +
    288 C
    +
    289  istat = 0
    +
    290 C
    +
    291  DO 30 i = 1,n
    +
    292 C
    +
    293 C SIGN BIT OFF
    +
    294 C
    +
    295  isign = 0
    +
    296  itemp = a(i)
    +
    297 C
    +
    298 C TEST SIGN BIT
    +
    299 C
    +
    300  IF (itemp.EQ.0) GO TO 20
    +
    301 C
    +
    302  IF (itemp.LT.0) THEN
    +
    303 C
    +
    304 C SIGN BIT ON
    +
    305 C
    +
    306  isign = sign
    +
    307 C
    +
    308 C TURN SIGN BIT OFF
    +
    309 C
    +
    310  itemp = iand(itemp,masksn)
    +
    311 C
    +
    312  END IF
    +
    313 C
    +
    314  ibmexp = ishft(itemp,-23_4)
    +
    315 C
    +
    316 C TEST FOR INDIFINITE OR NAN NUMBER
    +
    317 C
    +
    318  IF (ibmexp.EQ.255) GO TO 10
    +
    319 C
    +
    320 C TEST FOR ZERO EXPONENT AND FRACTION (UNDERFLOW)
    +
    321 C
    +
    322  IF (ibmexp.EQ.0) GO TO 20
    +
    323  ibmexp = ibmexp + 133
    +
    324  ibx7 = iand(3_4,ibmexp)
    +
    325  ibmexp = ieor(ibmexp,ibx7)
    +
    326  ibx7 = ieor(3_4,ibx7)
    +
    327  itemp = ior(itemp,ibit8)
    +
    328  itemp = ior(ishft(ibmexp,22_4),ishft(iand(itemp,maskfr),
    +
    329  & -ibx7))
    +
    330  b(i) = ior(itemp,isign)
    +
    331  GO TO 30
    +
    332 C
    +
    333  10 CONTINUE
    +
    334 C
    +
    335 C ADD 1 TO ISTAT FOR INDEFINITE OR NAN NUMBER
    +
    336 C
    +
    337  istat = istat + 1
    +
    338 C
    +
    339  20 CONTINUE
    +
    340  b(i) = 0
    +
    341 C
    +
    342  30 CONTINUE
    +
    343 C
    +
    344  RETURN
    +
    345  END
    +
    346 
    +
    347 C> Convert ieee 32 bit task 754 floating point numbers
    +
    348 C> to ibm370 64 bit floating point numbers.
    +
    349 C>
    +
    350 C> Program history log:
    +
    351 C> - Ralph Jones 1992-08-02
    +
    352 C> - Ralph Jones 1995-11-15 Add save statement.
    +
    353 C>
    +
    354 C> @param[in] A Real*4 array of IEEE 32 bit floating point numbers.
    +
    355 C> @param[in] N Number of words to convert to IBM370 64 bit F.P.
    +
    356 C> @param[out] B Real*8 array of IBM370 64 bit floating point numbers.
    +
    357 C> @param[out] ISTAT
    +
    358 C> - 0 All numbers converted.
    +
    359 C> - -1 N is less than one.
    +
    360 C> - +K K infinity or nan numbers were found.
    +
    361 C>
    +
    362 C> @note See IEEE task 754 standard floating point arithmetic for
    +
    363 C> more information about IEEE F.P.
    +
    364 C>
    +
    365 C> @author Ralph Jones @date 1992-08-02
    +
    366  SUBROUTINE q9e3i6(A,B,N,ISTAT)
    +
    367 
    +
    368 C
    +
    369  INTEGER(4) A(N)
    +
    370  INTEGER(4) B(2,N)
    +
    371  INTEGER(4) SIGN,MASKFR,IBIT8,MASKSN,ITEMP,IEEEXP
    +
    372  INTEGER(4) IBMEXP,IBX7,JTEMP,ISIGN
    +
    373 C
    +
    374  SAVE
    +
    375 C
    +
    376  DATA maskfr/z'00FFFFFF'/
    +
    377  DATA ibit8 /z'00800000'/
    +
    378  DATA masksn/z'7FFFFFFF'/
    +
    379  DATA sign /z'80000000'/
    +
    380 C
    +
    381  IF (n.LT.1) THEN
    +
    382  istat = -1
    +
    383  RETURN
    +
    384  ENDIF
    +
    385 C
    +
    386  istat = 0
    +
    387 C
    +
    388  DO 30 i = 1,n
    +
    389  isign = 0
    +
    390  itemp = a(i)
    +
    391 C
    +
    392 C TEST SIGN BIT
    +
    393 C
    +
    394  IF (itemp.EQ.0) GO TO 20
    +
    395 C
    +
    396 C TEST FOR NEGATIVE NUMBERS
    +
    397 C
    +
    398  IF (itemp.LT.0) THEN
    +
    399 C
    +
    400 C SIGN BIT ON
    +
    401 C
    +
    402  isign = sign
    +
    403 C
    +
    404 C TURN SIGN BIT OFF
    +
    405 C
    +
    406  itemp = iand(itemp,masksn)
    +
    407 C
    +
    408  END IF
    +
    409 C
    +
    410 C GET IEEE EXPONENT
    +
    411 C
    +
    412  ieeexp = ishft(itemp,-23_4)
    +
    413 C
    +
    414 C TEST FOR INDIFINITE OR NAN NUMBER
    +
    415 C
    +
    416  IF (ieeexp.EQ.255) GO TO 10
    +
    417 C
    +
    418 C TEST FOR ZERO EXPONENT AND FRACTION (UNDERFLOW)
    +
    419 C CONVERT IEEE EXPONENT (BASE 2) TO IBM EXPONENT
    +
    420 C (BASE 16)
    +
    421 C
    +
    422  IF (ieeexp.EQ.0) GO TO 20
    +
    423  ibmexp = ieeexp + 133
    +
    424  ibx7 = iand(3_4,ibmexp)
    +
    425  ibmexp = ieor(ibmexp,ibx7)
    +
    426  ibx7 = ieor(3_4,ibx7)
    +
    427  itemp = ior(itemp,ibit8)
    +
    428  jtemp = ior(ishft(ibmexp,22_4),ishft(iand(itemp,maskfr),
    +
    429  & -ibx7))
    +
    430  b(1,i) = ior(jtemp,isign)
    +
    431  b(2,i) = 0
    +
    432  IF (ibx7.GT.0) b(2,i) = ishft(itemp,32_4-ibx7)
    +
    433  GO TO 30
    +
    434 C
    +
    435  10 CONTINUE
    +
    436 C ADD 1 TO ISTAT FOR INDEFINITE OR NAN NUMBER
    +
    437 C
    +
    438  istat = istat + 1
    +
    439 C
    +
    440  20 CONTINUE
    +
    441  b(1,i) = 0
    +
    442  b(2,i) = 0
    +
    443 C
    +
    444  30 CONTINUE
    +
    445 C
    +
    446  RETURN
    +
    447  END
    +
    +
    +
    q9e3i6
    subroutine q9e3i6(A, B, N, ISTAT)
    Convert ieee 32 bit task 754 floating point numbers to ibm370 64 bit floating point numbers.
    Definition: w3ai00.f:367
    +
    w3ai00
    subroutine w3ai00(REAL8, PACK, LABEL)
    Converts IEEE floating point numbers to 16 bit packed office note 84 format.
    Definition: w3ai00.f:40
    +
    q9ei32
    subroutine q9ei32(A, B, N, ISTAT)
    Convert IEEE 32 bit task 754 floating point numbers to IBM370 32 bit floating point numbers.
    Definition: w3ai00.f:271
    + + + + diff --git a/ver-2.10.0/w3ai01_8f.html b/ver-2.10.0/w3ai01_8f.html new file mode 100644 index 00000000..6c4464a4 --- /dev/null +++ b/ver-2.10.0/w3ai01_8f.html @@ -0,0 +1,181 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai01.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ai01.f File Reference
    +
    +
    + +

    Unpack record into IEEE F.P. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ai01 (PACK, REAL8, LABEL)
     Unpacks a record in office note 84 format and convert the packed data to ieee real floating point numbers. More...
     
    +

    Detailed Description

    +

    Unpack record into IEEE F.P.

    +
    Author
    Ralph Jones
    +
    Date
    1989-10-17
    + +

    Definition in file w3ai01.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ai01()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ai01 (integer(8), dimension(*) PACK,
    real, dimension(*) REAL8,
    integer(8), dimension(6) LABEL 
    )
    +
    + +

    Unpacks a record in office note 84 format and convert the packed data to ieee real floating point numbers.

    +

    The office note 84 data is bit for bit the same on the nas-9050 and the cray.

    +

    Program history log:

      +
    • Ralph Jones 1989-10-20
      • +
    • Ralph Jones 1990-02-02 Change to cray function for integer*2, f.p.
      • +
    • Ralph Jones 1990-10-11 Special version of w3ai01 to unpack records packed by big version of w3ai00. Will do old and new version.
      • +
    • Ralph Jones 1991-03-19 Make special version of w3ai01 to unpack big records the operational version.
      • +
    • Ralph Jones 1993-06-10 Increace array size to 262144 words.
      • +
    • Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
      • +
    • Stephen Gilbert 1998-11-17 Changed to unpack into IEEE reals for the IBM SP.
      • +
    +
    Parameters
    + + + + +
    [in]PACKInteger array with data in office note 84 format to be unpacked.
    [out]REAL8Real array of n words. where n is given in word 6 of pack. Word 6 of pack must contain center and scaling values.
    [out]LABELSix word integer label copied from pack, 12 office note 84 32 bit id's that are stored into six 64-bit words.
    +
    +
    +
    Note
    Label and pack may be equivalenced.
    +
    Author
    Ralph Jones
    +
    Date
    1989-10-17
    + +

    Definition at line 32 of file w3ai01.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ai01_8f.js b/ver-2.10.0/w3ai01_8f.js new file mode 100644 index 00000000..56216060 --- /dev/null +++ b/ver-2.10.0/w3ai01_8f.js @@ -0,0 +1,4 @@ +var w3ai01_8f = +[ + [ "w3ai01", "w3ai01_8f.html#a222326720cc27c198b6808bd3f601e4a", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ai01_8f_source.html b/ver-2.10.0/w3ai01_8f_source.html new file mode 100644 index 00000000..9bc7133a --- /dev/null +++ b/ver-2.10.0/w3ai01_8f_source.html @@ -0,0 +1,201 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai01.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ai01.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Unpack record into IEEE F.P.
    +
    3 C> @author Ralph Jones @date 1989-10-17
    +
    4 
    +
    5 C> Unpacks a record in office note 84 format and convert the
    +
    6 C> packed data to ieee real floating point numbers. The
    +
    7 C> office note 84 data is bit for bit the same on the nas-9050 and
    +
    8 C> the cray.
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - Ralph Jones 1989-10-20
    +
    12 C> - Ralph Jones 1990-02-02 Change to cray function for integer*2, f.p.
    +
    13 C> - Ralph Jones 1990-10-11 Special version of w3ai01 to unpack records
    +
    14 c> packed by big version of w3ai00. Will do old and new version.
    +
    15 C> - Ralph Jones 1991-03-19 Make special version of w3ai01 to unpack
    +
    16 c> big records the operational version.
    +
    17 C> - Ralph Jones 1993-06-10 Increace array size to 262144 words.
    +
    18 C> - Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
    +
    19 C> - Stephen Gilbert 1998-11-17 Changed to unpack into IEEE reals for the IBM SP.
    +
    20 C>
    +
    21 C> @param[in] PACK Integer array with data in office note 84 format to be unpacked.
    +
    22 C> @param[out] REAL8 Real array of n words. where n is given in word 6 of pack.
    +
    23 c> Word 6 of pack must contain center and scaling values.
    +
    24 C> @param[out] LABEL Six word integer label copied from pack,
    +
    25 c> 12 office note 84 32 bit id's that are stored into six 64-bit words.
    +
    26 C>
    +
    27 C> @note Label and pack may be equivalenced.
    +
    28 C>
    +
    29 C> @author Ralph Jones @date 1989-10-17
    +
    30 
    +
    31  SUBROUTINE w3ai01(PACK,REAL8,LABEL)
    +
    32 C
    +
    33  REAL REAL8(*)
    +
    34 C
    +
    35  INTEGER(2) ITEMP(262144)
    +
    36  INTEGER(8) LABEL(6)
    +
    37  INTEGER(8) PACK(*)
    +
    38  INTEGER(8) MASK16
    +
    39  INTEGER(8) MASK32
    +
    40  integer(2) i2(4)
    +
    41  real(4) rtemp(2)
    +
    42  integer(8) ktemp,jtemp(65536)
    +
    43  equivalence(ktemp,rtemp(1),i2(1))
    +
    44  equivalence(itemp(1),jtemp(1))
    +
    45 C
    +
    46  SAVE
    +
    47 C
    +
    48  DATA mask16/z'000000000000FFFF'/
    +
    49  DATA mask32/z'00000000FFFFFFFF'/
    +
    50 C
    +
    51 C MOVE OFFICE NOTE 84 12 32 BIT ID'S INTO LABEL
    +
    52 C
    +
    53  DO 10 i = 1,6
    +
    54  label(i) = pack(i)
    +
    55  10 CONTINUE
    +
    56 C
    +
    57 C GET WORD COUNT, AVERAGE VALUE, SCALING FACTOR, J, A , N.
    +
    58 C
    +
    59  j = iand(label(4),mask16)
    +
    60  IF (j.EQ.0) THEN
    +
    61  j = iand(label(6),mask32)
    +
    62  IF (j.EQ.0) THEN
    +
    63  print *,' W3AI01 ERROR, NUMBER OF WORDS IN GRID IS 0'
    +
    64  RETURN
    +
    65  ENDIF
    +
    66  IF (j.GT.262144) THEN
    +
    67  print *,' W3AI01 ERROR, NUMBER OF WORDS IN GRID IS ',j
    +
    68  print *,' THERE IS A LIMIT OF 262144'
    +
    69  RETURN
    +
    70  ENDIF
    +
    71  ENDIF
    +
    72 C
    +
    73 C CONVERT IBM 32 BIT MEAN VALUE TO IEEE F.P. NUMBER
    +
    74 C
    +
    75 C CALL USSCTC(LABEL(5),5,A,1)
    +
    76  ktemp=label(5)
    +
    77  call q9ie32(rtemp(2),rtemp(1),1,istat)
    +
    78  a=rtemp(1)
    +
    79 C
    +
    80 C GET SCALING VALUE N, CAN BE NEGATIVE (INTEGER*2 TWO'S COMPL.)
    +
    81 C
    +
    82 C CALL USICTC(LABEL(6),3,N,1,2)
    +
    83  ktemp=label(6)
    +
    84  n=i2(2)
    +
    85 C
    +
    86  twon = 2.0 ** (n - 15)
    +
    87 C
    +
    88 C UNPACK, CONVERT TO REAL 64 BIT FLOATING POINT DATA
    +
    89 C
    +
    90 C CALL USICTC(PACK(7),1,ITEMP,J,2)
    +
    91  jtemp(1:65536)=pack(7:65542)
    +
    92 C
    +
    93  DO 20 i = 1,j
    +
    94  real8(i) = float(itemp(i)) * twon + a
    +
    95  20 CONTINUE
    +
    96 C
    +
    97  RETURN
    +
    98  END
    +
    +
    +
    w3ai01
    subroutine w3ai01(PACK, REAL8, LABEL)
    Unpacks a record in office note 84 format and convert the packed data to ieee real floating point num...
    Definition: w3ai01.f:32
    +
    q9ie32
    subroutine q9ie32(A, B, N, ISTAT)
    Convert ibm370 32 bit floating point numbers to ieee 32 bit task 754 floating point numbers.
    Definition: q9ie32.f:28
    + + + + diff --git a/ver-2.10.0/w3ai08_8f.html b/ver-2.10.0/w3ai08_8f.html new file mode 100644 index 00000000..4b021a57 --- /dev/null +++ b/ver-2.10.0/w3ai08_8f.html @@ -0,0 +1,1350 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai08.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ai08.f File Reference
    +
    +
    + +

    Unpack grib field to grib grid. +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

    +Functions/Subroutines

    subroutine ai081 (MSGA, KPTR, KPDS, KRET)
     Find 'grib; characters and set pointers to the next byte following 'grib'. More...
     
    subroutine ai082 (MSGA, KPTR, KPDS, KRET)
     Extract information from the product description sec, and generate label information to permit storage in office note 84 format. More...
     
    subroutine ai082a (MSGA, KPTR, KPDS, KRET)
     Extract information from the product description section (version 1). More...
     
    subroutine ai083 (MSGA, KPTR, KPDS, KGDS, KRET)
     Extract information on unlisted grid to allow conversion to office note 84 format. More...
     
    subroutine ai084 (MSGA, KPTR, KPDS, KGDS, KBMS, KRET)
     If bit map sec is available in grib message,extract for program use, otherwise generate an appropriate bit map. More...
     
    subroutine ai085 (MSGA, KPTR, KPDS, KBMS, DATA, KRET)
     Extract grib data and place into output arry in proper position. More...
     
    subroutine ai085a (MSGA, KPTR, KPDS, KBMS, DATA, KRET)
     Extract grib data (version 1) and place into proper position in output array. More...
     
    subroutine ai087 (, J, KPDS, KGDS, KRET)
     To test when gds is available to see if size mismatch on existing grids (by center) is indicated. More...
     
    subroutine w3ai08 (MSGA, KPDS, KGDS, KBMS, DATA, KPTR, KRET)
     Unpack a grib field to the exact grid specified in the message, isolate the bit map and make the values of the product description sec (pds) and the grid description sec (gds) available in return arrays. More...
     
    +

    Detailed Description

    +

    Unpack grib field to grib grid.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-01-20
    + +

    Definition in file w3ai08.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ ai081()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine ai081 (character*1, dimension(*) MSGA,
    integer, dimension(*) KPTR,
    integer, dimension(*) KPDS,
    integer KRET 
    )
    +
    + +

    Find 'grib; characters and set pointers to the next byte following 'grib'.

    +

    If they exist extract counts from gds and bms. Extract count from bds. determine if sum of counts actually places terminator '7777' at the correct location.

    +

    Program history log:

      +
    • Bill Cavanaugh 1988-01-20
      • +
    • Ralph Jones 1990-09-01 Change's for ansi fortran.
      • +
    • Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + +
    [in]msgagrib field - "grib" thru "7777".``
    [in,out]kptrarray containing storage for following parameters.
      +
    • 1: Unused.
      • +
    • 2: Unused.
      • +
    • 3: Length of pds.
      • +
    • 4: Length of gds.
      • +
    • 5: Length of bms.
      • +
    • 6: Length of bds.
      • +
    • 7: Value of current byte.
      • +
    • 8: Unused.
      • +
    • 9: Grib start byte.
      • +
    • 10: Grib/grid element count.
      • +
    +
    [out]kpds- array containing pds elements..
      +
    • 1: Id of center.
      • +
    • 2: Model identification.
      • +
    • 3: Grid identification.
      • +
    • 4: Gds/bms flag.
      • +
    • 5: Indicator of parameter.
      • +
    • 6: Type of level.
      • +
    • 7: Height/pressure , etc of level.
      • +
    • 8: Year of century.
      • +
    • 9: Month of year.
      • +
    • 10: Day of month.
      • +
    • 11: Hour of day.
      • +
    • 12: Minute of hour.
      • +
    • 13: Indicator of forecast time unit.
      • +
    • 14: Time range 1.
      • +
    • 15: Time range 2.
      • +
    • 16: Time range flag.
      • +
    • 17: Number included in average.
      • +
    • 18: Version nr of grib specification.
      • +
    +
    [out]kretError return.
    +
    +
    +
    Note
    Error returns.
      +
    • kret = 1: No 'grib'.
      • +
    • kret = 2: No '7777' or mislocated (by counts).
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-01-20
    + +

    Definition at line 569 of file w3ai08.f.

    + +
    +
    + +

    ◆ ai082()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine ai082 (character*1, dimension(*) MSGA,
    integer, dimension(*) KPTR,
    integer, dimension(*) KPDS,
    integer KRET 
    )
    +
    + +

    Extract information from the product description sec, and generate label information to permit storage in office note 84 format.

    +

    Program history log:

      +
    • Bill Cavanaugh 1988-01-20
      • +
    • Ralph Jones 1990-09-01 Change's for ansi fortran.
      • +
    • Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
      • +
    • Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
      • +
    +
    Parameters
    + + + + + +
    [in]msgaArray containing grib message.
    [in,out]kptrArray containing storage for following parameters.
      +
    • 1: Unused.
      • +
    • 2: Unused.
      • +
    • 3: Length of pds.
      • +
    • 4: Length of gds.
      • +
    • 5: Length of bms.
      • +
    • 6: Length of pds.
      • +
    • 7: Value of current byte.
      • +
    • 8: Unused.
      • +
    • 9: Grib start byte nr.
      • +
    • 10: Grib/grid element count.
      • +
    +
    [out]kpdsArray containing pds elements.
      +
    • 1: Id of center.
      • +
    • 2: Model identification.
      • +
    • 3: Grid identification.
      • +
    • 4: Gds/bms flag.
      • +
    • 5: Indicator of parameter.
      • +
    • 6: Type of level.
      • +
    • 7: Height/pressure, etc of level.
      • +
    • 8: Year of century.
      • +
    • 9: Month of year.
      • +
    • 10: Day of month.
      • +
    • 11: Hour of day.
      • +
    • 12: Minute of hour.
      • +
    • 13: Indicator of forecast time unit.
      • +
    • 14: Time range 1.
      • +
    • 15: Time range 2.
      • +
    • 16: Time range flag.
      • +
    • 17: Number included in average.
      • +
    • 18: Version number of grib spefication.
      • +
    • 19: Version nr of parameter table.
      • +
    • 20: Total length of grib message (including section 0).
      • +
    +
    [out]kreterror return.
    +
    +
    +
    Note
    error return:
      +
    • = 0 - no errors
      • +
    • = 8 - temp gds indicated, but no gds
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-01-20
    + +

    Definition at line 749 of file w3ai08.f.

    + +
    +
    + +

    ◆ ai082a()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine ai082a (character*1, dimension(*) MSGA,
    integer, dimension(*) KPTR,
    integer, dimension(*) KPDS,
    integer KRET 
    )
    +
    + +

    Extract information from the product description section (version 1).

    +

    Program history log:

      +
    • Bill Cavanaugh 1989-11-20
      • +
    • Ralph Jones 1990-09-01 Change's for ansi fortran.
      • +
    • Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
      • +
    • Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
      • +
    +
    Parameters
    + + + + + +
    [in]MSGAArray containing grib message.
    [in,out]KPTRArray containing storage for following parameters.
      +
    • 1: Unused.
      • +
    • 2: Unused.
      • +
    • 3: Length of pds.
      • +
    • 4: Length of gds.
      • +
    • 5: Length of bms.
      • +
    • 6: Length of pds.
      • +
    • 7: Value of current byte.
      • +
    • 8: Unused.
      • +
    • 9: Grib start byte nr.
      • +
    • 10: Grib/grid element count.
      • +
    +
    [out]KPDSArray containing pds elements.
      +
    • 1: Id of center
      • +
    • 2: Model identi.fication
      • +
    • 3: Grid identification.
      • +
    • 4: Gds/bms flag.
      • +
    • 5: Indicator of. parameter
      • +
    • 6: Type of level.
      • +
    • 7: Height/pressu.re , etc of level
      • +
    • 8: Year (including century).
      • +
    • 9: Month of year.
      • +
    • 10: Day of month..
      • +
    • 11: Hour of day.
      • +
    • 12: Minute of hour.
      • +
    • 13: Indicator of forecast time unit.
      • +
    • 14: Time range 1.
      • +
    • 15: Time range 2.
      • +
    • 16: Time range flag.
      • +
    • 17: Number included in average.
      • +
    • 18: Version nr of grib specification.
      • +
    • 19: Version nr of parameter table.
      • +
    • 20: Total byte count for source message.
      • +
    +
    [out]KRETError return.
    +
    +
    +
    Note
    Source pds structure (version 1).
      +
    • 1-3: Length of pds section in bytes.
      • +
    • 4: Parameter table version no. for international exchange (crrently no. 1).
      • +
    • 5: Center id.
      • +
    • 6: Model id.
      • +
    • 7: Grid id.
      • +
    • 8: Flag for gds/bms.
      • +
    • 9: Indicator for parameter.
      • +
    • 10: Indicator for type of level.
      • +
    • 11-12: Height, pressure of level.
      • +
    • 13: Year of century.
      • +
    • 14: Month.
      • +
    • 15: Day.
      • +
    • 16: Hour.
      • +
    • 17: Minute.
      • +
    • 18: Forecast time unit.
      • +
    • 19: P1 - pd of time.
      • +
    • 20: P2 - pd of time.
      • +
    • 21: Time range indicator.
      • +
    • 22-23: Number in average.
      • +
    • 24: Number misg from averages.
      • +
    • 25: Century.
      • +
    • 26: Indicator of parameter in locally re-defined parameter table..
      • +
    • 27-28: Units decimal scale factor (d).
      • +
    • 29-40: Reserved: need not be present.
      • +
    • 41-NN: National use.
      • +
    • Error return:
        +
      • = 0 - No errors.
        • +
      • = 8 - Temp gds indicated, but no gds.
        • +
      +
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-01-20
    + +

    Definition at line 935 of file w3ai08.f.

    + +
    +
    + +

    ◆ ai083()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine ai083 (character*1, dimension(*) MSGA,
    integer, dimension(*) KPTR,
    integer, dimension(*) KPDS,
    integer, dimension(*) KGDS,
    integer KRET 
    )
    +
    + +

    Extract information on unlisted grid to allow conversion to office note 84 format.

    +

    Program history log:

      +
    • Bill Cavanaugh 1988-01-20
      • +
    • Bill Cavanaugh 1989-03-16 Added mercator & lambert conformal processing.
      • +
    • Bill Cavanaugh 1989-07-12 Corrected change entered 89-03-16 reordering processing for lambert conformal and mercator grids.
      • +
    • Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + + +
    [in]MSGAArray containing grib message.
    [in,out]KPTRArray containing storage for following parameters.
      +
    • 1): Unused.
      • +
    • 2): Unused.
      • +
    • 3): Length of pds.
      • +
    • 4): Length of gds.
      • +
    • 5): Length of bms.
      • +
    • 6): Length of bds.
      • +
    • 7): Value of current byte.
      • +
    • 8): Unused.
      • +
    • 9): Grib start byte nr.
      • +
    • 0): Grib/grid element count.
      • +
    +
    [in]KPDSArray containing pds elements.
      +
    • 1): Id of center.
      • +
    • 2): Model identification.
      • +
    • 3): Grid identification.
      • +
    • 4): Gds/bms flag.
      • +
    • 5): Indicator of parameter.
      • +
    • 6): Type of level.
      • +
    • 7): Height/pressure , etc of level.
      • +
    • 8): Year of century.
      • +
    • 9): Month of year.
      • +
    • 10: Day of month.
      • +
    • 11: Hour of day.
      • +
    • 12: Minute of hour.
      • +
    • 13: Indicator of forecast time unit.
      • +
    • 14: Time range 1.
      • +
    • 15: Time range 2.
      • +
    • 16: Time range flag.
      • +
    • 17: Number included in average.
      • +
    • 18: Version nr of grib specification.
      • +
    +
    [out]KGDSArray containing gds elements..
      +
    • 1): Data representation type.
      • +
    • Latitude/Longitude grids
        +
      • 2): N(i) nr points on latitude circle.
        • +
      • 3): N(j) nr points on longitude meridian.
        • +
      • 4): La(1) latitude of origin.
        • +
      • 5): Lo(1) longitude of origin.
        • +
      • 6): Resolution flag.
        • +
      • 7): La(2) latitude of extreme point.
        • +
      • 8): Lo(2) longitude of extreme point.
        • +
      • 9): Di longitudinal direction of increment.
        • +
      • 10: Dj latitudinal direction of increment.
        • +
      • 11: Scanning mode flag.
        • +
      +
      • +
    • Polar stereographic grids.
        +
      • 2): N(i) nr points along lat circle.
        • +
      • 3): N(j) nr points along lon circle.
        • +
      • 4): La(1) latitude of origin.
        • +
      • 5): Lo(1) longitude of origin.
        • +
      • 6): Reserved.
        • +
      • 7): Lov grid orientation.
        • +
      • 8): Dx - x direction increment.
        • +
      • 9): Dy - y direction increment.
        • +
      • 10: Projection center flag.
        • +
      • 11: Scanning mode.
        • +
      +
      • +
    • Spherical harmonic coefficients.
        +
      • 2): J pentagonal resolution parameter.
        • +
      • 3): K pentagonal resolution parameter.
        • +
      • 4): M pentagonal resolution parameter.
        • +
      • 5): Representation type.
        • +
      • 6): Coefficient storage mode.
        • +
      +
      • +
    • Mercator grids.
        +
      • 2): N(i) nr points on latitude circle.
        • +
      • 3): N(j) nr points on longitude meridian.
        • +
      • 4): La(1) latitude of origin.
        • +
      • 5): Lo(1) longitude of origin.
        • +
      • 6): Resolution flag.
        • +
      • 7): La(2) latitude of last grid point.
        • +
      • 8): Lo(2) longitude of last grid point.
        • +
      • 9): Longit dir increment.
        • +
      • 10: Latit dir increment.
        • +
      • 11: Scanning mode flag.
        • +
      • 12: Latitude intersection.
        • +
      +
      • +
    • Lambert conformal grids.
        +
      • 2): Nx nr points along x-axis.
        • +
      • 3): Ny nr points along y-axis.
        • +
      • 4): La1 lat of origin (lower left).
        • +
      • 5): Lo1 lon of origin (lower left).
        • +
      • 6): Reserved.
        • +
      • 7): Lov - orientation of grid.
        • +
      • 8): Dx - x-dir increment.
        • +
      • 9): Dy - y-dir increment.
        • +
      • 10: Projection center flag.
        • +
      • 11: Scanning mode flag.
        • +
      • 12: Latin 1 - first lat from pole of secant cone inter.
        • +
      • 13: Latin 2 - second lat from pole of secant cone inter.
        • +
      +
      • +
    +
    [out]KRETError return.
    +
    +
    +
    Note
    KRET
      +
    • = 0
      • +
    • = 4 - DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-01-20
    + +

    Definition at line 1158 of file w3ai08.f.

    + +
    +
    + +

    ◆ ai084()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine ai084 (character*1, dimension(*) MSGA,
    integer, dimension(10) KPTR,
    integer, dimension(20) KPDS,
    integer, dimension(13) KGDS,
    logical, dimension(*) KBMS,
    integer KRET 
    )
    +
    + +

    If bit map sec is available in grib message,extract for program use, otherwise generate an appropriate bit map.

    +

    Program history log:

      +
    • Bill Cavanaugh 1988-01-20
      • +
    • Bill Cavanaugh 1989-02-24 Increment of position in bit map when bit map was included was handled improperly. corrected this data.
      • +
    • Bill Cavanaugh 1989-07-12 Altered method of calculating nr of bits in a bit map contained in grib message.
      • +
    • Bill Cavanaugh 1990-05-07 Brings all u.s. grids to revised values as of dec 89.
      • +
    • William Bostelman 1990-07-15 Modiifed to test the grib bds byte size to determine what ecmwf grid array size is to be specified.
      • +
    • Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
      • +
    • Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
      • +
    +
    Parameters
    + + + + + + + +
    [in]MSGABUFR message.
    [in,out]KPTRArray containing storage for following parameters.
      +
    • 1: Unused.
      • +
    • 2: Unused.
      • +
    • 3: Length of pds.
      • +
    • 4: Length of gds.
      • +
    • 5: Length of bms.
      • +
    • 6: Length of bds.
      • +
    • 7: Value of current byte.
      • +
    • 8: Unused.
      • +
    • 9: Grib start byte nr.
      • +
    • 10: Grib/grid element count.
      • +
    +
    [in]KPDSARRAY CONTAINING PDS ELEMENTS.
      +
    • 1: Id of center.
      • +
    • 2: Model identification.
      • +
    • 3: Grid identification.
      • +
    • 4: Gds/bms flag.
      • +
    • 5: Indicator of parameter.
      • +
    • 6: Type of level.
      • +
    • 7: Height/pressure , etc of level.
      • +
    • 8: Year of century.
      • +
    • 9: Month of year.
      • +
    • 10: Day of month.
      • +
    • 11: Hour of day.
      • +
    • 12: Minute of hour.
      • +
    • 13: Indicator of forecast time unit.
      • +
    • 14: Time range 1.
      • +
    • 15: Time range 2.
      • +
    • 16: Time range flag.
      • +
    • 17: Number included in average.
      • +
    • 18: Version nr of grib specification.
      • +
    +
    [out]kgdsarray containing gds elements.
      +
    • 1: data representation type
      • +
    • Latitude/longitude grids
        +
      • 2: n(i) nr points on latitude circle
        • +
      • 3: n(j) nr points on longitude meridian
        • +
      • 4: la(1) latitude of origin
        • +
      • 5: lo(1) longitude of origin
        • +
      • 6: resolution flag
        • +
      • 7: la(2) latitude of extreme point
        • +
      • 8: lo(2) longitude of extreme point
        • +
      • 9: di longitudinal direction of increment
        • +
      • 10: dj latitundinal direction of increment
        • +
      • 11: scanning mode flag
        • +
      +
      • +
    • Polar stereographic grids
        +
      • 2: n(i) nr points along lat circle
        • +
      • 3: n(j) nr points along lon circle
        • +
      • 4: la(1) latitude of origin
        • +
      • 5: lo(1) longitude of origin
        • +
      • 6: reserved
        • +
      • 7: lov grid orientation
        • +
      • 8: dx - x direction increment
        • +
      • 9: dy - y direction increment
        • +
      • 10: projection center flag
        • +
      • 11: scanning mode
        • +
      +
      • +
    • Spherical harmonic coefficients
        +
      • 2: j pentagonal resolution parameter
        • +
      • 3: k pentagonal resolution parameter
        • +
      • 4: m pentagonal resolution parameter
        • +
      • 5: representation type
        • +
      • 6: coefficient storage mode
        • +
      +
      • +
    • Mercator grids
        +
      • 2: n(i) nr points on latitude circle
        • +
      • 3: n(j) nr points on longitude meridian
        • +
      • 4: la(1) latitude of origin
        • +
      • 5: lo(1) longitude of origin
        • +
      • 6: resolution flag
        • +
      • 7: la(2) latitude of last grid point
        • +
      • 8: lo(2) longitude of last grid point
        • +
      • 9: longit dir increment
        • +
      • 10: latit dir increment
        • +
      • 11: scanning mode flag
        • +
      • 12: latitude intersection
        • +
      +
      • +
    • Lambert conformal grids
        +
      • 2: nx nr points along x-axis
        • +
      • 3: ny nr points along y-axis
        • +
      • 4: la1 lat of origin (lower left)
        • +
      • 5: lo1 lon of origin (lower left)
        • +
      • 6: reserved
        • +
      • 7: lov - orientation of grid
        • +
      • 8: dx - x-dir increment
        • +
      • 9: dy - y-dir increment
        • +
      • 10: projection center flag
        • +
      • 11: scanning mode flag
        • +
      • 12: latin 1 - first lat from pole of secant cone inter
        • +
      • 13: latin 2 - second lat from pole of secant cone inter
        • +
      +
      • +
    +
    [out]KBMSBitmap describing location of output elements..
    [out]KRETError return.
    +
    +
    +
    Note
    KRET
      +
    • = 0 - No error.
      • +
    • = 5 - Grid not avail for center indicated.
      • +
    • = 10 - Incorrect center indicator.
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-01-20
    + +

    Definition at line 1615 of file w3ai08.f.

    + +
    +
    + +

    ◆ ai085()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine ai085 (character*1, dimension(*) MSGA,
    integer, dimension(*) KPTR,
    integer, dimension(*) KPDS,
    logical, dimension(*) KBMS,
    real, dimension(*) DATA,
     KRET 
    )
    +
    + +

    Extract grib data and place into output arry in proper position.

    +

    Program history log:

      +
    • Bill Cavanaugh 1988-01-20
      • +
    • Ralph Jones 1990-09-01 Change's for ansi fortran.
      • +
    • Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
      • +
    • Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
      • +
    +
    Parameters
    + + + + + + + +
    [in]MSGAArray containing grib message.
    [in,out]KPTRArray containing storage for following parameters.
      +
    • 1: Unused.
      • +
    • 2: Unused.
      • +
    • 3: Length of pds.
      • +
    • 4: Length of gds.
      • +
    • 5: Length of bms.
      • +
    • 6: Length of bds.
      • +
    • 7: Value of current byte.
      • +
    • 8: Unused.
      • +
    • 9: Grib start byte nr.
      • +
    • 10: Grib/grid element count.
      • +
    +
    [in]KPDSArray containing pds elements.
      +
    • 1: Id of center.
      • +
    • 2: Model identification.
      • +
    • 3: Grid identification.
      • +
    • 4: Gds/bms flag.
      • +
    • 5: Indicator of parameter.
      • +
    • 6: Type of level.
      • +
    • 7: Height/pressure , etc of level.
      • +
    • 8: Year of century.
      • +
    • 9: Month of year.
      • +
    • 10: Day of month.
      • +
    • 11: Hour of day.
      • +
    • 12: Minute of hour.
      • +
    • 13: Indicator of forecast time unit.
      • +
    • 14: Time range 1.
      • +
    • 15: Time range 2.
      • +
    • 16: Time range flag.
      • +
    • 17: Number included in average.
      • +
    • 18: Version nr of grib specification.
      • +
    +
    [in]KBMSBitmap describing location of output elements.
    [out]DATAReal array of gridded elements in grib message.
    [out]KRETError return.
    +
    +
    +
    Note
    Error return.
      +
    • 3 = Unpacked field is larger than 32768.
      • +
    • 6 = Does not match nr of entries for this grib/grid.
      • +
    • 7 = Number of bits in fill too large.
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-01-20
    + +

    Definition at line 2067 of file w3ai08.f.

    + +
    +
    + +

    ◆ ai085a()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine ai085a (character*1, dimension(*) MSGA,
    integer, dimension(*) KPTR,
    integer, dimension(*) KPDS,
    logical, dimension(*) KBMS,
    real, dimension(*) DATA,
     KRET 
    )
    +
    + +

    Extract grib data (version 1) and place into proper position in output array.

    +

    Program history log:

      +
    • Bill Cavanaugh 1989-11-20
      • +
    • Ralph Jones 1990-09-01 Change's for ansi fortran.
      • +
    • Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
      • +
    • Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
      • +
    +
    Parameters
    + + + + + + + +
    [in]MSGAArray containing grib message.
    [in,out]KPTRArray containing storage for following parameters.
      +
    • 1:Unused.
      • +
    • 2:Unused.
      • +
    • 3:Length of pds.
      • +
    • 4:Length of gds.
      • +
    • 5:Length of bms.
      • +
    • 6:Length of bds.
      • +
    • 7:Value of current byte.
      • +
    • 8:Unused.
      • +
    • 9:Grib start byte nr.
      • +
    • 10:Grib/grid element count.
      • +
    +
    [in]KPDSArray containing pds elements. (version 1)
      +
    • 1: Id of center.
      • +
    • 2: Model identification.
      • +
    • 3: Grid identification.
      • +
    • 4: Gds/bms flag.
      • +
    • 5: Indicator of parameter.
      • +
    • 6: Type of level.
      • +
    • 7: Height/pressure , etc of level.
      • +
    • 8: Year including century.
      • +
    • 9: Month of year.
      • +
    • 10: Day of month.
      • +
    • 11: Hour of day.
      • +
    • 12: Minute of hour.
      • +
    • 13: Indicator of forecast time unit.
      • +
    • 14: Time range 1.
      • +
    • 15: Time range 2.
      • +
    • 16: Time range flag.
      • +
    • 17: Number included in average.
      • +
    • 18: Version nr of grib specification.
      • +
    • 19: Version nr of parameter table.
      • +
    • 20: Total length of grib message (including section 0).
      • +
    +
    [in]KBMSBitmap describing location of output elements.
    [out]DATAReal array of gridded elements in grib message.
    [out]KRETError return.
    +
    +
    +
    Note
    Structure of binary data section (version 1)
      +
    • 1-3: LENGTH OF SECTION
      • +
    • 4: PACKING FLAGS
      • +
    • 5-6: SCALE FACTOR
      • +
    • 7-10: REFERENCE VALUE
      • +
    • 11: NUMBER OF BIT FOR EACH VALUE
      • +
    • 12s-N: DATA
      • +
    +
    +
    +Error return:
      +
    • 3 = Unpacked field is larger than 32768.
      • +
    • 6 = Does not match nr of entries for this grib/grid.
      • +
    • 7 = Number of bits in fill too large.
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1989-11-20
    + +

    Definition at line 2362 of file w3ai08.f.

    + +
    +
    + +

    ◆ ai087()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine ai087 (integer J,
    integer, dimension(20) KPDS,
    integer, dimension(13) KGDS,
     KRET 
    )
    +
    + +

    To test when gds is available to see if size mismatch on existing grids (by center) is indicated.

    +

    Program history log:

      +
    • Bill Cavanaugh 1988-02-08
      • +
    • Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
      • +
    • Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
      • +
    +
    Parameters
    + + + + + +
    [in]JSize for indicated grid.
    [in]KPDS
    [in]KGDS
    [out]KRETError return.
    +
    +
    +
    Note
    KRET = 9 - GDS indicates size mismatch with std grid.
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-02-08
    + +

    Definition at line 2630 of file w3ai08.f.

    + +
    +
    + +

    ◆ w3ai08()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ai08 (character*1, dimension(*) MSGA,
    integer, dimension(*) KPDS,
    integer, dimension(*) KGDS,
    logical, dimension(*) KBMS,
    real, dimension(*) DATA,
    integer, dimension(*) KPTR,
     KRET 
    )
    +
    + +

    Unpack a grib field to the exact grid specified in the message, isolate the bit map and make the values of the product description sec (pds) and the grid description sec (gds) available in return arrays.

    +

    Program history log:

      +
    • Bill Cavanaugh 1988-01-20
      • +
    • Bill Cavanaugh 1990-05-11 To assure that all u.s. grids in the grib decoder comply with size changes in the december 1989 revisions.
      • +
    • Bill Cavanaugh 1990-05-24 Corrects searching an improper location for grib version number in grib messages.
      • +
    • William Bostelman 1990-07-15 Modiifed sub. ai084 so that it will test the grib bds byte size to determine what ecmwf grid array size is to be specified.
      • +
    • Ralph Jones 1990-09-14 Change's for ansi fortran, and pds version 1.
      • +
    • Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
      • +
    • Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
      • +
    • Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
      • +
    +
    Parameters
    + + + +
    [in]msgagrib field - "grib" thru "7777" char*1
    [out]dataarray containing data elements
    +
    +
    +
    Note
    (version 0):
      +
    • 1: id of center
      • +
    • 2: model identification
      • +
    • 3: grid identification
      • +
    • 4: gds/bms flag
      • +
    • 5: indicator of parameter
      • +
    • 6: type of level
      • +
    • 7: height/pressure , etc of level
      • +
    • 8: year including century
      • +
    • 9: month of year
      • +
    • 10: day of month
      • +
    • 11: hour of day
      • +
    • 12: minute of hour
      • +
    • 13: indicator of forecast time unit
      • +
    • 14: time range 1
      • +
    • 15: time range 2
      • +
    • 16: time range flag
      • +
    • 17: number included in average
      • +
    • 18: grib specification edition number
      • +
    +
    +
    Parameters
    + + + + + + +
    [out]kpdsarray containing pds elements. (version 1)
      +
    • 1: id of center
      • +
    • 2: model identification
      • +
    • 3: grid identification
      • +
    • 4: gds/bms flag
      • +
    • 5: indicator of parameter
      • +
    • 6: type of level
      • +
    • 7: height/pressure , etc of level
      • +
    • 8: year including century
      • +
    • 9: month of year
      • +
    • 10: day of month
      • +
    • 11: hour of day
      • +
    • 12: minute of hour
      • +
    • 13: indicator of forecast time unit
      • +
    • 14: time range 1
      • +
    • 15: time range 2
      • +
    • 16: time range flag
      • +
    • 17: number included in average
      • +
    • 18: version nr of grib specification
      • +
    • 19: version nr of parameter table
      • +
    • 20: total length of grib message (including section 0)
      • +
    +
    [out]kgdsarray containing gds elements.
      +
    • 1: data representation type
      • +
    • Latitude/longitude grids
        +
      • 2: n(i) nr points on latitude circle
        • +
      • 3: n(j) nr points on longitude meridian
        • +
      • 4: la(1) latitude of origin
        • +
      • 5: lo(1) longitude of origin
        • +
      • 6: resolution flag
        • +
      • 7: la(2) latitude of extreme point
        • +
      • 8: lo(2) longitude of extreme point
        • +
      • 9: di longitudinal direction of increment
        • +
      • 10: dj latitundinal direction of increment
        • +
      • 11: scanning mode flag
        • +
      +
      • +
    • Polar stereographic grids
        +
      • 2: n(i) nr points along lat circle
        • +
      • 3: n(j) nr points along lon circle
        • +
      • 4: la(1) latitude of origin
        • +
      • 5: lo(1) longitude of origin
        • +
      • 6: reserved
        • +
      • 7: lov grid orientation
        • +
      • 8: dx - x direction increment
        • +
      • 9: dy - y direction increment
        • +
      • 10: projection center flag
        • +
      • 11: scanning mode
        • +
      +
      • +
    • Spherical harmonic coefficients
        +
      • 2: j pentagonal resolution parameter
        • +
      • 3: k pentagonal resolution parameter
        • +
      • 4: m pentagonal resolution parameter
        • +
      • 5: representation type
        • +
      • 6: coefficient storage mode
        • +
      +
      • +
    • Mercator grids
        +
      • 2: n(i) nr points on latitude circle
        • +
      • 3: n(j) nr points on longitude meridian
        • +
      • 4: la(1) latitude of origin
        • +
      • 5: lo(1) longitude of origin
        • +
      • 6: resolution flag
        • +
      • 7: la(2) latitude of last grid point
        • +
      • 8: lo(2) longitude of last grid point
        • +
      • 9: longit dir increment
        • +
      • 10: latit dir increment
        • +
      • 11: scanning mode flag
        • +
      • 12: latitude intersection
        • +
      +
      • +
    • Lambert conformal grids
        +
      • 2: nx nr points along x-axis
        • +
      • 3: ny nr points along y-axis
        • +
      • 4: la1 lat of origin (lower left)
        • +
      • 5: lo1 lon of origin (lower left)
        • +
      • 6: reserved
        • +
      • 7: lov - orientation of grid
        • +
      • 8: dx - x-dir increment
        • +
      • 9: dy - y-dir increment
        • +
      • 10: projection center flag
        • +
      • 11: scanning mode flag
        • +
      • 12: latin 1 - first lat from pole of secant cone inter
        • +
      • 13: latin 2 - second lat from pole of secant cone inter
        • +
      +
      • +
    +
    [out]kbms- bitmap describing location of output elements.
    [out]kptr- array containing storage for following parameters
      +
    • 1: unused
      • +
    • 2: unused
      • +
    • 3: length of pds
      • +
    • 4: length of gds
      • +
    • 5: length of bms
      • +
    • 6: length of bds
      • +
    • 7: value of current byte
      • +
    • 8: unused
      • +
    • 9: grib start byte nr
      • +
    • 10: grib/grid element count
      • +
    +
    [out]kretflag indicating quality of completion
    +
    +
    +
    Note
    values for return flag (kret)
      +
    • kret = 0 - normal return, no errors
        +
      • = 1 - 'grib' not found in first 100 chars
        • +
      • = 2 - '7777' not in correct location
        • +
      • = 3 - unpacked field is larger than 32768
        • +
      • = 4 - gds/ grid not one of currently accepted values
        • +
      • = 5 - grid not currently avail for center indicated
        • +
      • = 8 - temp gds indicated, but gds flag is off
        • +
      • = 9 - gds indicates size mismatch with std grid
        • +
      • = 10 - incorrect center indicator
        • +
      +
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-01-20
    + +

    Definition at line 148 of file w3ai08.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ai08_8f.js b/ver-2.10.0/w3ai08_8f.js new file mode 100644 index 00000000..2a95a5e2 --- /dev/null +++ b/ver-2.10.0/w3ai08_8f.js @@ -0,0 +1,12 @@ +var w3ai08_8f = +[ + [ "ai081", "w3ai08_8f.html#a441b7146a653d41877d19a7cd64efb7c", null ], + [ "ai082", "w3ai08_8f.html#afa6093fcf5580f32f3ff8be92af6b0e3", null ], + [ "ai082a", "w3ai08_8f.html#a720103ce8519bc682230c8757c6fb8e9", null ], + [ "ai083", "w3ai08_8f.html#a7031bf0f0b33cba1e5c2334224e735a1", null ], + [ "ai084", "w3ai08_8f.html#a1ac753d2f7d6ce69d4e1412af879b7b9", null ], + [ "ai085", "w3ai08_8f.html#a220caa94dfc83c8a73d224245c9469da", null ], + [ "ai085a", "w3ai08_8f.html#a7ecf84941a754cb8d8a328c77f038de0", null ], + [ "ai087", "w3ai08_8f.html#ac73cef7b08d3fbe6549b6db66ae7b49f", null ], + [ "w3ai08", "w3ai08_8f.html#a8ca96c27a72b383415773ff07d2027dd", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ai08_8f_source.html b/ver-2.10.0/w3ai08_8f_source.html new file mode 100644 index 00000000..5767f4a4 --- /dev/null +++ b/ver-2.10.0/w3ai08_8f_source.html @@ -0,0 +1,2882 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai08.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ai08.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Unpack grib field to grib grid.
    +
    3 C> @author Bill Cavanaugh @date 1988-01-20
    +
    4 
    +
    5 C> Unpack a grib field to the exact grid specified in the
    +
    6 C> message, isolate the bit map and make the values of the product
    +
    7 C> description sec (pds) and the grid description sec (gds)
    +
    8 C> available in return arrays.
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - Bill Cavanaugh 1988-01-20
    +
    12 C> - Bill Cavanaugh 1990-05-11 To assure that all u.s. grids in the grib decoder
    +
    13 C> comply with size changes in the december 1989 revisions.
    +
    14 C> - Bill Cavanaugh 1990-05-24 Corrects searching an improper location for grib
    +
    15 c> version number in grib messages.
    +
    16 C> - William Bostelman 1990-07-15 Modiifed sub. ai084 so that it will test
    +
    17 C> the grib bds byte size to determine what ecmwf grid array size is
    +
    18 C> to be specified.
    +
    19 C> - Ralph Jones 1990-09-14 Change's for ansi fortran, and pds version 1.
    +
    20 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    21 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    22 C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
    +
    23 C>
    +
    24 C> @param[in] msga grib field - "grib" thru "7777" char*1
    +
    25 C> @param[out] data array containing data elements
    +
    26 C> @note (version 0):
    +
    27 C> - 1: id of center
    +
    28 C> - 2: model identification
    +
    29 C> - 3: grid identification
    +
    30 C> - 4: gds/bms flag
    +
    31 C> - 5: indicator of parameter
    +
    32 C> - 6: type of level
    +
    33 C> - 7: height/pressure , etc of level
    +
    34 C> - 8: year including century
    +
    35 C> - 9: month of year
    +
    36 C> - 10: day of month
    +
    37 C> - 11: hour of day
    +
    38 C> - 12: minute of hour
    +
    39 C> - 13: indicator of forecast time unit
    +
    40 C> - 14: time range 1
    +
    41 C> - 15: time range 2
    +
    42 C> - 16: time range flag
    +
    43 C> - 17: number included in average
    +
    44 C> - 18: grib specification edition number
    +
    45 C> @param[out] kpds array containing pds elements. (version 1)
    +
    46 C> - 1: id of center
    +
    47 C> - 2: model identification
    +
    48 C> - 3: grid identification
    +
    49 C> - 4: gds/bms flag
    +
    50 C> - 5: indicator of parameter
    +
    51 C> - 6: type of level
    +
    52 C> - 7: height/pressure , etc of level
    +
    53 C> - 8: year including century
    +
    54 C> - 9: month of year
    +
    55 C> - 10: day of month
    +
    56 C> - 11: hour of day
    +
    57 C> - 12: minute of hour
    +
    58 C> - 13: indicator of forecast time unit
    +
    59 C> - 14: time range 1
    +
    60 C> - 15: time range 2
    +
    61 C> - 16: time range flag
    +
    62 C> - 17: number included in average
    +
    63 C> - 18: version nr of grib specification
    +
    64 C> - 19: version nr of parameter table
    +
    65 C> - 20: total length of grib message (including section 0)
    +
    66 C> @param[out] kgds array containing gds elements.
    +
    67 C> - 1: data representation type
    +
    68 C> - Latitude/longitude grids
    +
    69 C> - 2: n(i) nr points on latitude circle
    +
    70 C> - 3: n(j) nr points on longitude meridian
    +
    71 C> - 4: la(1) latitude of origin
    +
    72 C> - 5: lo(1) longitude of origin
    +
    73 C> - 6: resolution flag
    +
    74 C> - 7: la(2) latitude of extreme point
    +
    75 C> - 8: lo(2) longitude of extreme point
    +
    76 C> - 9: di longitudinal direction of increment
    +
    77 C> - 10: dj latitundinal direction of increment
    +
    78 C> - 11: scanning mode flag
    +
    79 C> - Polar stereographic grids
    +
    80 C> - 2: n(i) nr points along lat circle
    +
    81 C> - 3: n(j) nr points along lon circle
    +
    82 C> - 4: la(1) latitude of origin
    +
    83 C> - 5: lo(1) longitude of origin
    +
    84 C> - 6: reserved
    +
    85 C> - 7: lov grid orientation
    +
    86 C> - 8: dx - x direction increment
    +
    87 C> - 9: dy - y direction increment
    +
    88 C> - 10: projection center flag
    +
    89 C> - 11: scanning mode
    +
    90 C> - Spherical harmonic coefficients
    +
    91 C> - 2: j pentagonal resolution parameter
    +
    92 C> - 3: k pentagonal resolution parameter
    +
    93 C> - 4: m pentagonal resolution parameter
    +
    94 C> - 5: representation type
    +
    95 C> - 6: coefficient storage mode
    +
    96 C> - Mercator grids
    +
    97 C> - 2: n(i) nr points on latitude circle
    +
    98 C> - 3: n(j) nr points on longitude meridian
    +
    99 C> - 4: la(1) latitude of origin
    +
    100 C> - 5: lo(1) longitude of origin
    +
    101 C> - 6: resolution flag
    +
    102 C> - 7: la(2) latitude of last grid point
    +
    103 C> - 8: lo(2) longitude of last grid point
    +
    104 C> - 9: longit dir increment
    +
    105 C> - 10: latit dir increment
    +
    106 C> - 11: scanning mode flag
    +
    107 C> - 12: latitude intersection
    +
    108 C> - Lambert conformal grids
    +
    109 C> - 2: nx nr points along x-axis
    +
    110 C> - 3: ny nr points along y-axis
    +
    111 C> - 4: la1 lat of origin (lower left)
    +
    112 C> - 5: lo1 lon of origin (lower left)
    +
    113 C> - 6: reserved
    +
    114 C> - 7: lov - orientation of grid
    +
    115 C> - 8: dx - x-dir increment
    +
    116 C> - 9: dy - y-dir increment
    +
    117 C> - 10: projection center flag
    +
    118 C> - 11: scanning mode flag
    +
    119 C> - 12: latin 1 - first lat from pole of secant cone inter
    +
    120 C> - 13: latin 2 - second lat from pole of secant cone inter
    +
    121 C> @param[out] kbms - bitmap describing location of output elements.
    +
    122 C> @param[out] kptr - array containing storage for following parameters
    +
    123 C> - 1: unused
    +
    124 C> - 2: unused
    +
    125 C> - 3: length of pds
    +
    126 C> - 4: length of gds
    +
    127 C> - 5: length of bms
    +
    128 C> - 6: length of bds
    +
    129 C> - 7: value of current byte
    +
    130 C> - 8: unused
    +
    131 C> - 9: grib start byte nr
    +
    132 C> - 10: grib/grid element count
    +
    133 C> @param[out] kret flag indicating quality of completion
    +
    134 C>
    +
    135 C> @note values for return flag (kret)
    +
    136 C> - kret = 0 - normal return, no errors
    +
    137 C> - = 1 - 'grib' not found in first 100 chars
    +
    138 C> - = 2 - '7777' not in correct location
    +
    139 C> - = 3 - unpacked field is larger than 32768
    +
    140 C> - = 4 - gds/ grid not one of currently accepted values
    +
    141 C> - = 5 - grid not currently avail for center indicated
    +
    142 C> - = 8 - temp gds indicated, but gds flag is off
    +
    143 C> - = 9 - gds indicates size mismatch with std grid
    +
    144 C> - = 10 - incorrect center indicator
    +
    145 C>
    +
    146 C> @author Bill Cavanaugh @date 1988-01-20
    +
    147  SUBROUTINE w3ai08(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET)
    +
    148 C 4 AUG 1988
    +
    149 C W3AI08
    +
    150 C
    +
    151 C
    +
    152 C GRIB UNPACKING ROUTINE
    +
    153 C
    +
    154 C
    +
    155 C THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID
    +
    156 C TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE
    +
    157 C VALUES OF THE PRODUCT DEFINITION SEC (PDS) AND THE GRID
    +
    158 C DESCRIPTION SEC (GDS) AVAILABLE IN RETURN ARRAYS.
    +
    159 C SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT
    +
    160 C INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN
    +
    161 C GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE
    +
    162 C DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER.
    +
    163 C
    +
    164 C THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS:
    +
    165 C
    +
    166 C CALL W3AI08(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET)
    +
    167 C
    +
    168 C INPUT:
    +
    169 C
    +
    170 C MSGA = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS
    +
    171 C "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES.
    +
    172 C
    +
    173 C OUTPUT:
    +
    174 C
    +
    175 C KPDS(100) INTEGER
    +
    176 C ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT
    +
    177 C DEFINITION SEC .
    +
    178 C (VERSION 0)
    +
    179 C KPDS(1) - ID OF CENTER
    +
    180 C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1)
    +
    181 C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2)
    +
    182 C KPDS(4) - GDS/BMS FLAG
    +
    183 C BIT DEFINITION
    +
    184 C 25 0 - GDS OMITTED
    +
    185 C 1 - GDS INCLUDED
    +
    186 C 26 0 - BMS OMITTED
    +
    187 C 1 - BMS INCLUDED
    +
    188 C NOTE:- LEFTMOST BIT = 1,
    +
    189 C RIGHTMOST BIT = 32
    +
    190 C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5)
    +
    191 C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7)
    +
    192 C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL
    +
    193 C KPDS(8) - YEAR OF CENTURY
    +
    194 C KPDS(9) - MONTH OF YEAR
    +
    195 C KPDS(10) - DAY OF MONTH
    +
    196 C KPDS(11) - HOUR OF DAY
    +
    197 C KPDS(12) - MINUTE OF HOUR
    +
    198 C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB"
    +
    199 C TABLE 8)
    +
    200 C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A)
    +
    201 C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A)
    +
    202 C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A)
    +
    203 C KPDS(17) - NUMBER INCLUDED IN AVERAGE
    +
    204 C KPDS(18) - VERSION NR OF GRIB SPECIFICATION
    +
    205 C
    +
    206 C (VERSION 1)
    +
    207 C KPDS(1) - ID OF CENTER
    +
    208 C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1)
    +
    209 C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2)
    +
    210 C KPDS(4) - GDS/BMS FLAG
    +
    211 C BIT DEFINITION
    +
    212 C 25 0 - GDS OMITTED
    +
    213 C 1 - GDS INCLUDED
    +
    214 C 26 0 - BMS OMITTED
    +
    215 C 1 - BMS INCLUDED
    +
    216 C NOTE:- LEFTMOST BIT = 1,
    +
    217 C RIGHTMOST BIT = 32
    +
    218 C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5)
    +
    219 C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7)
    +
    220 C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL
    +
    221 C KPDS(8) - YEAR INCLUDING CENTURY
    +
    222 C KPDS(9) - MONTH OF YEAR
    +
    223 C KPDS(10) - DAY OF MONTH
    +
    224 C KPDS(11) - HOUR OF DAY
    +
    225 C KPDS(12) - MINUTE OF HOUR
    +
    226 C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB"
    +
    227 C TABLE 8)
    +
    228 C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A)
    +
    229 C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A)
    +
    230 C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A)
    +
    231 C KPDS(17) - NUMBER INCLUDED IN AVERAGE
    +
    232 C KPDS(18) - VERSION NR OF GRIB SPECIFICATION
    +
    233 C KPDS(19) - VERSION NR OF PARAMETER TABLE
    +
    234 C KPDS(20) - TOTAL LENGTH 0F GRIB MESSAGE
    +
    235 C (INCLUDING SECTION 0)
    +
    236 C KGDS(13) INTEGER
    +
    237 C ARRAY CONTAINING GDS ELEMENTS.
    +
    238 C
    +
    239 C KGDS(1) - DATA REPRESENTATION TYPE
    +
    240 C
    +
    241 C LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10)
    +
    242 C KGDS(2) - N(I) NUMBER OF POINTS ON LATITUDE
    +
    243 C CIRCLE
    +
    244 C KGDS(3) - N(J) NUMBER OF POINTS ON LONGITUDE
    +
    245 C CIRCLE
    +
    246 C KGDS(4) - LA(1) LATITUDE OF ORIGIN
    +
    247 C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
    +
    248 C KGDS(6) - RESOLUTION FLAG
    +
    249 C BIT MEANING
    +
    250 C 25 0 - DIRECTION INCREMENTS NOT
    +
    251 C GIVEN
    +
    252 C 1 - DIRECTION INCREMENTS GIVEN
    +
    253 C KGDS(7) - LA(2) LATITUDE OF EXTREME POINT
    +
    254 C KGDS(8) - LO(2) LONGITUDE OF EXTREME POINT
    +
    255 C KGDS(9) - DI LONGITUDINAL DIRECTION INCREMENT
    +
    256 C KGDS(10) - REGULAR LAT/LON GRID
    +
    257 C DJ - LATITUDINAL DIRECTION
    +
    258 C INCREMENT
    +
    259 C GAUSSIAN GRID
    +
    260 C N - NUMBER OF LATITUDE CIRCLES
    +
    261 C BETWEEN A POLE AND THE EQUATOR
    +
    262 C KGDS(11) - SCANNING MODE FLAG
    +
    263 C BIT MEANING
    +
    264 C 25 0 - POINTS ALONG A LATITUDE
    +
    265 C SCAN FROM WEST TO EAST
    +
    266 C 1 - POINTS ALONG A LATITUDE
    +
    267 C SCAN FROM EAST TO WEST
    +
    268 C 26 0 - POINTS ALONG A MERIDIAN
    +
    269 C SCAN FROM NORTH TO SOUTH
    +
    270 C 1 - POINTS ALONG A MERIDIAN
    +
    271 C SCAN FROM SOUTH TO NORTH
    +
    272 C 27 0 - POINTS SCAN FIRST ALONG
    +
    273 C CIRCLES OF LATITUDE, THEN
    +
    274 C ALONG MERIDIANS
    +
    275 C (FORTRAN: (I,J))
    +
    276 C 1 - POINTS SCAN FIRST ALONG
    +
    277 C MERIDIANS THEN ALONG
    +
    278 C CIRCLES OF LATITUDE
    +
    279 C (FORTRAN: (J,I))
    +
    280 C
    +
    281 C POLAR STEREOGRAPHIC GRIDS (SEE GRIB TABLE 12)
    +
    282 C KGDS(2) - N(I) NR POINTS ALONG LAT CIRCLE
    +
    283 C KGDS(3) - N(J) NR POINTS ALONG LON CIRCLE
    +
    284 C KGDS(4) - LA(1) LATITUDE OF ORIGIN
    +
    285 C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
    +
    286 C KGDS(6) - RESERVED
    +
    287 C KGDS(7) - LOV GRID ORIENTATION
    +
    288 C KGDS(8) - DX - X DIRECTION INCREMENT
    +
    289 C KGDS(9) - DY - Y DIRECTION INCREMENT
    +
    290 C KGDS(10) - PROJECTION CENTER FLAG
    +
    291 C KGDS(11) - SCANNING MODE
    +
    292 C
    +
    293 C SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14)
    +
    294 C KGDS(2) - J PENTAGONAL RESOLUTION PARAMETER
    +
    295 C KGDS(3) - K PENTAGONAL RESOLUTION PARAMETER
    +
    296 C KGDS(4) - M PENTAGONAL RESOLUTION PARAMETER
    +
    297 C KGDS(5) - REPRESENTATION TYPE
    +
    298 C KGDS(6) - COEFFICIENT STORAGE MODE
    +
    299 C
    +
    300 C MERCATOR GRIDS
    +
    301 C KGDS(2) - N(I) NR POINTS ON LATITUDE CIRCLE
    +
    302 C KGDS(3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
    +
    303 C KGDS(4) - LA(1) LATITUDE OF ORIGIN
    +
    304 C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
    +
    305 C KGDS(6) - RESOLUTION FLAG
    +
    306 C KGDS(7) - LA(2) LATITUDE OF LAST GRID POINT
    +
    307 C KGDS(8) - LO(2) LONGITUDE OF LAST GRID POINT
    +
    308 C KGDS(9) - LONGIT DIR INCREMENT
    +
    309 C KGDS(10) - LATIT DIR INCREMENT
    +
    310 C KGDS(11) - SCANNING MODE FLAG
    +
    311 C KGDS(12) - LATITUDE INTERSECTION
    +
    312 C LAMBERT CONFORMAL GRIDS
    +
    313 C KGDS(2) - NX NR POINTS ALONG X-AXIS
    +
    314 C KGDS(3) - NY NR POINTS ALONG Y-AXIS
    +
    315 C KGDS(4) - LA1 LAT OF ORIGIN (LOWER LEFT)
    +
    316 C KGDS(5) - LO1 LON OF ORIGIN (LOWER LEFT)
    +
    317 C KGDS(6) - RESERVED
    +
    318 C KGDS(7) - LOV - ORIENTATION OF GRID
    +
    319 C KGDS(8) - DX - X-DIR INCREMENT
    +
    320 C KGDS(9) - DY - Y-DIR INCREMENT
    +
    321 C KGDS(10) - PROJECTION CENTER FLAG
    +
    322 C KGDS(11) - SCANNING MODE FLAG
    +
    323 C KGDS(12) - LATIN 1 - FIRST LAT FROM POLE OF
    +
    324 C SECANT CONE INTERSECTION
    +
    325 C KGDS(13) - LATIN 2 - SECOND LAT FROM POLE OF
    +
    326 C SECANT CONE INTERSECTION
    +
    327 C
    +
    328 C LBMS(32768) LOGICAL
    +
    329 C ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE
    +
    330 C PLACEMENT OF DATA IN THE OUTPUT ARRAY. IF A
    +
    331 C BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE,
    +
    332 C ONE WILL BE GENERATED AUTOMATICALLY BY THE
    +
    333 C UNPACKING ROUTINE.
    +
    334 C
    +
    335 C
    +
    336 C DATA(32768) REAL
    +
    337 C THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS.
    +
    338 C
    +
    339 C NOTE:- 32768 IS MAXIMUN FIELD SIZE ALLOWABLE
    +
    340 C
    +
    341 C KPTR(10) INTEGER
    +
    342 C ARRAY CONTAINING STORAGE FOR THE FOLLOWING
    +
    343 C PARAMETERS.
    +
    344 C
    +
    345 C (1) - UNUSED
    +
    346 C (2) - UNUSED
    +
    347 C (3) - LENGTH OF PDS (IN BYTES)
    +
    348 C (4) - LENGTH OF GDS (IN BYTES)
    +
    349 C (5) - LENGTH OF BMS (IN BYTES)
    +
    350 C (6) - LENGTH OF BDS (IN BYTES)
    +
    351 C (7) - USED BY UNPACKING ROUTINE
    +
    352 C (8) - NUMBER OF DATA POINTS FOR GRID
    +
    353 C (9) - "GRIB" CHARACTERS START IN BYTE NUMBER
    +
    354 C (10) - USED BY UNPACKING ROUTINE
    +
    355 C
    +
    356 C
    +
    357 C KRET INTEGER
    +
    358 C THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR.
    +
    359 C
    +
    360 C 0 - NO ERRORS DETECTED.
    +
    361 C
    +
    362 C 1 - 'GRIB' NOT FOUND IN FIRST 100
    +
    363 C CHARACTERS.
    +
    364 C
    +
    365 C 2 - '7777' NOT FOUND, EITHER MISSING OR
    +
    366 C TOTAL OF SEC COUNTS OF INDIVIDUAL
    +
    367 C SEC'S IS INCORRECT.
    +
    368 C
    +
    369 C 3 - UNPACKED FIELD IS LARGER THAN 32768.
    +
    370 C
    +
    371 C 4 - IN GDS, DATA REPRESENTATION TYPE
    +
    372 C NOT ONE OF THE CURRENTLY ACCEPTABLE
    +
    373 C VALUES. SEE "GRIB" TABLE 9. VALUE
    +
    374 C OF INCORRECT TYPE RETURNED IN KGDS(1).
    +
    375 C
    +
    376 C 5 - GRID INDICATED IN KPDS(3) IS NOT
    +
    377 C AVAILABLE FOR THE CENTER INDICATED IN
    +
    378 C KPDS(1) AND NO GDS SENT.
    +
    379 C
    +
    380 C 7 - VERSION INDICATED IN KPDS(18) HAS NOT
    +
    381 C YET BEEN INCLUDED IN THE DECODER.
    +
    382 C
    +
    383 C 8 - GRID IDENTIFICATION = 255 (NOT STANDARD
    +
    384 C GRID) BUT FLAG INDICATING PRESENCE OF
    +
    385 C GDS IS TURNED OFF. NO METHOD OF
    +
    386 C GENERATING PROPER GRID.
    +
    387 C
    +
    388 C 9 - PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT
    +
    389 C MATCH STANDARD NUMBER OF POINTS FOR THIS
    +
    390 C GRID (FOR OTHER THAN SPECTRALS). THIS
    +
    391 C WILL OCCUR ONLY IF THE GRID.
    +
    392 C IDENTIFICATION, KPDS(3), AND A
    +
    393 C TRANSMITTED GDS ARE INCONSISTENT.
    +
    394 C
    +
    395 C 10 - CENTER INDICATOR WAS NOT ONE INDICATED
    +
    396 C IN "GRIB" TABLE 1. PLEASE CONTACT AD
    +
    397 C PRODUCTION MANAGEMENT BRANCH (W/NMC42)
    +
    398 C IF THIS ERROR IS ENCOUNTERED.
    +
    399 C
    +
    400 C
    +
    401 C
    +
    402 C LIST OF TEXT MESSAGES FROM CODE
    +
    403 C
    +
    404 C
    +
    405 C W3AI08/AI082
    +
    406 C
    +
    407 C 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY
    +
    408 C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    +
    409 C (W/NMC42)'
    +
    410 C
    +
    411 C 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY
    +
    412 C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    +
    413 C (W/NMC42)'
    +
    414 C
    +
    415 C 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL
    +
    416 C OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION,
    +
    417 C PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
    +
    418 C
    +
    419 C 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY
    +
    420 C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    +
    421 C (W/NMC42)'
    +
    422 C
    +
    423 C
    +
    424 C W3AI08/AI083
    +
    425 C
    +
    426 C 'POLAR STEREO PROCESSING NOT AVAILABLE' *
    +
    427 C
    +
    428 C W3AI08/AI084
    +
    429 C
    +
    430 C 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL
    +
    431 C COEFFICIENTS'
    +
    432 C
    +
    433 C
    +
    434 C W3AI08/AI087
    +
    435 C
    +
    436 C 'NO CURRENT LISTING OF FNOC GRIDS' *
    +
    437 C
    +
    438 C
    +
    439 C * WILL BE AVAILABLE IN NEXT UPDATE
    +
    440 C ***************************************************************
    +
    441 C
    +
    442 C INCOMING MESSAGE HOLDER
    +
    443  CHARACTER*1 MSGA(*)
    +
    444 C BIT MAP
    +
    445  LOGICAL KBMS(*)
    +
    446 C
    +
    447 C ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS)
    +
    448  INTEGER KPDS(*)
    +
    449 C ELEMENTS OF GRID DESCRIPTION SEC (PDS)
    +
    450  INTEGER KGDS(*)
    +
    451 C
    +
    452 C CONTAINER FOR GRIB GRID
    +
    453  REAL DATA(*)
    +
    454 C
    +
    455 C ARRAY OF POINTERS AND COUNTERS
    +
    456  INTEGER KPTR(*)
    +
    457 C
    +
    458 C *****************************************************************
    +
    459 C 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE
    +
    460 C FIND 'GRIB' CHARACTERS
    +
    461 C 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE
    +
    462 C IF '7777' IS IN PROPER PLACE.
    +
    463 C 3.0 PARSE PRODUCT DEFINITION SECTION.
    +
    464 C 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED)
    +
    465 C 5.0 PARSE BIT MAP SEC (IF INCLUDED)
    +
    466 C 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID
    +
    467 C DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT
    +
    468 C DATA AND PLACE INTO PROPER ARRAY.
    +
    469 C *******************************************************************
    +
    470 C
    +
    471 C MAIN DRIVER
    +
    472 C
    +
    473 C *******************************************************************
    +
    474  kptr(10) = 0
    +
    475 C SEE IF PROPER 'GRIB' KEY EXISTS, THEN
    +
    476 C USING SEC COUNTS, DETERMINE IF '7777'
    +
    477 C IS IN THE PROPER LOCATION
    +
    478 C
    +
    479  CALL ai081(msga,kptr,kpds,kret)
    +
    480  IF (kret.NE.0) GO TO 900
    +
    481 C
    +
    482 C PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION
    +
    483 C
    +
    484  IF (kpds(18).EQ.0) THEN
    +
    485  CALL ai082(msga,kptr,kpds,kret)
    +
    486  ELSE IF (kpds(18).EQ.1) THEN
    +
    487  CALL ai082a(msga,kptr,kpds,kret)
    +
    488  ELSE
    +
    489  print *,'GRIB EDITION',kpds(18),' NOT PROGRAMMED FOR'
    +
    490  kret = 7
    +
    491  GO TO 900
    +
    492  END IF
    +
    493  IF (kret.NE.0) GO TO 900
    +
    494 C
    +
    495 C EXTRACT NEW GRID DESCRIPTION
    +
    496 C
    +
    497  CALL ai083(msga,kptr,kpds,kgds,kret)
    +
    498  IF (kret.NE.0) GO TO 900
    +
    499 C
    +
    500 C EXTRACT OR GENERATE BIT MAP
    +
    501 C
    +
    502  CALL ai084(msga,kptr,kpds,kgds,kbms,kret)
    +
    503  IF (kret.NE.0) GO TO 900
    +
    504 C
    +
    505 C USING INFORMATION FROM PDS, BMS AND BIT DATA SEC ,
    +
    506 C EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES.
    +
    507 C
    +
    508  IF (kpds(18).EQ.0) THEN
    +
    509  CALL ai085(msga,kptr,kpds,kbms,DATA,kret)
    +
    510  ELSE IF (kpds(18).EQ.1) THEN
    +
    511  CALL ai085a(msga,kptr,kpds,kbms,DATA,kret)
    +
    512  ELSE
    +
    513  print *,'AI085 NOT PROGRAMMED FOR VERSION NR',kpds(18)
    +
    514  kret = 7
    +
    515  END IF
    +
    516 C
    +
    517  900 RETURN
    +
    518  END
    +
    519 
    +
    520 C>Find 'grib; characters and set pointers to the next
    +
    521 C>byte following 'grib'. If they exist extract counts from gds and
    +
    522 C>bms. Extract count from bds. determine if sum of counts actually
    +
    523 C>places terminator '7777' at the correct location.
    +
    524 C>
    +
    525 C> Program history log:
    +
    526 C> - Bill Cavanaugh 1988-01-20
    +
    527 C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
    +
    528 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    529 C>
    +
    530 C> @param[in] msga grib field - "grib" thru "7777".``
    +
    531 C> @param[inout] kptr array containing storage for following parameters.
    +
    532 C> - 1: Unused.
    +
    533 C> - 2: Unused.
    +
    534 C> - 3: Length of pds.
    +
    535 C> - 4: Length of gds.
    +
    536 C> - 5: Length of bms.
    +
    537 C> - 6: Length of bds.
    +
    538 C> - 7: Value of current byte.
    +
    539 C> - 8: Unused.
    +
    540 C> - 9: Grib start byte.
    +
    541 C> - 10: Grib/grid element count.
    +
    542 C> @param[out] kpds - array containing pds elements..
    +
    543 C> - 1: Id of center.
    +
    544 C> - 2: Model identification.
    +
    545 C> - 3: Grid identification.
    +
    546 C> - 4: Gds/bms flag.
    +
    547 C> - 5: Indicator of parameter.
    +
    548 C> - 6: Type of level.
    +
    549 C> - 7: Height/pressure , etc of level.
    +
    550 C> - 8: Year of century.
    +
    551 C> - 9: Month of year.
    +
    552 C> - 10: Day of month.
    +
    553 C> - 11: Hour of day.
    +
    554 C> - 12: Minute of hour.
    +
    555 C> - 13: Indicator of forecast time unit.
    +
    556 C> - 14: Time range 1.
    +
    557 C> - 15: Time range 2.
    +
    558 C> - 16: Time range flag.
    +
    559 C> - 17: Number included in average.
    +
    560 C> - 18: Version nr of grib specification.
    +
    561 C> @param[out] kret Error return.
    +
    562 C>
    +
    563 C> @note Error returns.
    +
    564 C> - kret = 1: No 'grib'.
    +
    565 C> - kret = 2: No '7777' or mislocated (by counts).
    +
    566 C>
    +
    567 C> @author Bill Cavanaugh @date 1988-01-20
    +
    568  SUBROUTINE ai081(MSGA,KPTR,KPDS,KRET)
    +
    569 
    +
    570 C
    +
    571 C INCOMING MESSAGE HOLDER
    +
    572  CHARACTER*1 MSGA(*)
    +
    573 C ARRAY OF POINTERS AND COUNTERS
    +
    574  INTEGER KPTR(*)
    +
    575 C PRODUCT DESCRIPTION SECTION DATA.
    +
    576  INTEGER KPDS(*)
    +
    577 C
    +
    578  INTEGER KRET
    +
    579 C
    +
    580 C DATA MASK40/Z00000040/
    +
    581 C DATA MASK80/Z00000080/
    +
    582 C
    +
    583  DATA mask40/64/
    +
    584  DATA mask80/128/
    +
    585 C
    +
    586 C ******************************************************************
    +
    587  kret = 0
    +
    588 C ------------------- FIND 'GRIB' KEY
    +
    589  DO 100 i = 1, 105
    +
    590  IF (mova2i(msga(i )).NE.71) GO TO 100
    +
    591  IF (mova2i(msga(i+1)).NE.82) GO TO 100
    +
    592  IF (mova2i(msga(i+2)).NE.73) GO TO 100
    +
    593  IF (mova2i(msga(i+3)).NE.66) GO TO 100
    +
    594  kptr(9) = i
    +
    595  GO TO 200
    +
    596  100 CONTINUE
    +
    597  kret = 1
    +
    598  RETURN
    +
    599 C
    +
    600  200 CONTINUE
    +
    601  is = kptr(9)
    +
    602 C ------------------- HAVE 'GRIB' KEY
    +
    603  kcnt = 0
    +
    604 C --------------- EXTRACT COUNT FROM PDS OR GRIB
    +
    605  iss = is + 4
    +
    606  DO 300 i = 0, 2
    +
    607  kcnt = kcnt * 256 + mova2i(msga(i+iss))
    +
    608  300 CONTINUE
    +
    609 C
    +
    610 C TEST FOR VERSION NUMBER OF PDS 0 OR 1
    +
    611 C
    +
    612  IF (kcnt.EQ.24) THEN
    +
    613  kptr(3) = kcnt
    +
    614  igribl = 4
    +
    615 C
    +
    616 C --------------- EDITION NR OF GRIB SPECIFICATION, VERSION 0
    +
    617 C
    +
    618  kpds(18) = mova2i(msga(iss + 3))
    +
    619  ELSE
    +
    620  igribl = 8
    +
    621  iss = is + igribl
    +
    622 C --------------- EDITION NR OF GRIB SPECIFICATION, VERSION 1
    +
    623  kpds(18) = mova2i(msga(is + 7))
    +
    624 C
    +
    625 C --------------- PARAMETER TABLE VERSION NUMBER FOR INTERNATIONAL
    +
    626 C EXCHANGE (CURRENTLY NO. 1)
    +
    627 C
    +
    628  kpds(19) = mova2i(msga(iss + 3))
    +
    629 C
    +
    630 C ---------------- SAVE TOTAL LENGTH OF MESSAGE (INCLUDING SECTION 0)
    +
    631 C
    +
    632  kpds(20) = kcnt
    +
    633 C
    +
    634 C --------------- EXTRACT COUNT FROM PDS VERSION 1
    +
    635 C
    +
    636  kcnt = 0
    +
    637  DO 400 i = 0, 2
    +
    638  kcnt = kcnt * 256 + mova2i(msga(i+iss))
    +
    639  400 CONTINUE
    +
    640  kptr(3) = kcnt
    +
    641  ENDIF
    +
    642 C
    +
    643 C --------------- GET GDS, BMS INDICATOR
    +
    644 C
    +
    645  kpds(4) = mova2i(msga(iss+7))
    +
    646 C
    +
    647 C READY FOR NEXT SECTION
    +
    648 C
    +
    649  kptr(4) = 0
    +
    650  kptr(5) = 0
    +
    651  IF (iand(kpds(4),mask80).EQ.0) GO TO 600
    +
    652 C
    +
    653 C --------------- EXTRACT COUNT FROM GDS
    +
    654 C
    +
    655  iss = kptr(3) + is + igribl
    +
    656  kcnt = 0
    +
    657  DO 500 i = 0, 2
    +
    658  kcnt = kcnt * 256 + mova2i(msga(i+iss))
    +
    659  500 CONTINUE
    +
    660  kptr(4) = kcnt
    +
    661  600 CONTINUE
    +
    662  IF (iand(kpds(4),mask40).EQ.0) GO TO 800
    +
    663 C
    +
    664 C ---------------- EXTRACT COUNT FROM BMS
    +
    665 C
    +
    666  iss = kptr(3) + kptr(4) + is + igribl
    +
    667  kcnt = 0
    +
    668  DO 700 i = 0, 2
    +
    669  kcnt = kcnt * 256 + mova2i(msga(i+iss))
    +
    670  700 CONTINUE
    +
    671  kptr(5) = kcnt
    +
    672 C
    +
    673 C --------------- EXTRACT COUNT FROM BDS
    +
    674 C
    +
    675  800 CONTINUE
    +
    676  kcnt = 0
    +
    677  iss = kptr(3) + kptr(4) + kptr(5) + is + igribl
    +
    678  DO 900 i = 0, 2
    +
    679  kcnt = kcnt * 256 + mova2i(msga(i+iss))
    +
    680  900 CONTINUE
    +
    681  kptr(6) = kcnt
    +
    682 C
    +
    683 C --------------- TEST FOR '7777'
    +
    684 C
    +
    685  iss = kptr(3) + kptr(4) + kptr(5) + kptr(6) + is + igribl
    +
    686  kret = 0
    +
    687  DO 1000 i = 0, 3
    +
    688  IF (mova2i(msga(i+iss)).EQ.55) THEN
    +
    689  GO TO 1000
    +
    690  ELSE
    +
    691  kret = 2
    +
    692  RETURN
    +
    693  END IF
    +
    694  1000 CONTINUE
    +
    695  RETURN
    +
    696  END
    +
    697 
    +
    698 C> Extract information from the product description
    +
    699 C> sec, and generate label information to permit storage
    +
    700 C> in office note 84 format.
    +
    701 C>
    +
    702 C> Program history log:
    +
    703 C> - Bill Cavanaugh 1988-01-20
    +
    704 C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
    +
    705 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    706 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    707 C>
    +
    708 C> @param[in] msga Array containing grib message.
    +
    709 C> @param[inout] kptr Array containing storage for following parameters.
    +
    710 C> - 1: Unused.
    +
    711 C> - 2: Unused.
    +
    712 C> - 3: Length of pds.
    +
    713 C> - 4: Length of gds.
    +
    714 C> - 5: Length of bms.
    +
    715 C> - 6: Length of pds.
    +
    716 C> - 7: Value of current byte.
    +
    717 C> - 8: Unused.
    +
    718 C> - 9: Grib start byte nr.
    +
    719 C> - 10: Grib/grid element count.
    +
    720 C> @param[out] kpds Array containing pds elements.
    +
    721 C> - 1: Id of center.
    +
    722 C> - 2: Model identification.
    +
    723 C> - 3: Grid identification.
    +
    724 C> - 4: Gds/bms flag.
    +
    725 C> - 5: Indicator of parameter.
    +
    726 C> - 6: Type of level.
    +
    727 C> - 7: Height/pressure, etc of level.
    +
    728 C> - 8: Year of century.
    +
    729 C> - 9: Month of year.
    +
    730 C> - 10: Day of month.
    +
    731 C> - 11: Hour of day.
    +
    732 C> - 12: Minute of hour.
    +
    733 C> - 13: Indicator of forecast time unit.
    +
    734 C> - 14: Time range 1.
    +
    735 C> - 15: Time range 2.
    +
    736 C> - 16: Time range flag.
    +
    737 C> - 17: Number included in average.
    +
    738 C> - 18: Version number of grib spefication.
    +
    739 C> - 19: Version nr of parameter table.
    +
    740 C> - 20: Total length of grib message (including section 0).
    +
    741 C> @param[out] kret error return.
    +
    742 C>
    +
    743 C> @note error return:
    +
    744 C> - = 0 - no errors
    +
    745 C> - = 8 - temp gds indicated, but no gds
    +
    746 C>
    +
    747 C> @author Bill Cavanaugh @date 1988-01-20
    +
    748  SUBROUTINE ai082(MSGA,KPTR,KPDS,KRET)
    +
    749 C
    +
    750 C INCOMING MESSAGE HOLDER
    +
    751  CHARACTER*1 MSGA(*)
    +
    752 C
    +
    753 C ARRAY OF POINTERS AND COUNTERS
    +
    754  INTEGER KPTR(*)
    +
    755 C PRODUCT DESCRIPTION SECTION ENTRIES
    +
    756  INTEGER KPDS(*)
    +
    757 C
    +
    758  INTEGER KRET
    +
    759 C
    +
    760 C -------------------- COLLECT PDS VALUES
    +
    761 C KPDS(1) - ID OF CENTER
    +
    762 C KPDS(2) - MODEL IDENTIFICATION
    +
    763 C KPDS(3) - GRID IDENTIFICATION
    +
    764 C KPDS(4) - GDS/BMS FLAG
    +
    765 C KPDS(5) - INDICATOR OF PARAMETER
    +
    766 C ----------- KPDS(6) - TYPE OF LEVEL
    +
    767  is = kptr(9)
    +
    768  iss = is + 8
    +
    769  DO 200 i = 0, 5
    +
    770  kpds(i+1) = mova2i(msga(i+iss))
    +
    771  200 CONTINUE
    +
    772  IF (kpds(3).NE.255) GO TO 250
    +
    773  IF (iand(kpds(4),128).NE.0) GO TO 250
    +
    774  kret = 8
    +
    775  RETURN
    +
    776  250 CONTINUE
    +
    777  iss = is + 14
    +
    778  kpds(7) = 0
    +
    779  DO 300 i = 0, 1
    +
    780  kpds(7) = kpds(7) * 256 + mova2i(msga(i+iss))
    +
    781  300 CONTINUE
    +
    782 C ----------- KPDS(8) - YEAR OF CENTURY
    +
    783 C KPDS(9) - MONTH OF YEAR
    +
    784 C KPDS(10) - DAY OF MONTH
    +
    785 C KPDS(11) - HOUR OF DAY
    +
    786 C KPDS(12) - MINUTE OF HOUR
    +
    787 C KPDS(13) - INDICATOR OF FORECAST TIME UNIT
    +
    788 C KPDS(14) - TIME RANGE 1
    +
    789 C KPDS(15) - TIME RANGE 2
    +
    790 C ----------- KPDS(16) - TIME RANGE FLAG
    +
    791 C
    +
    792  iss = is + 16
    +
    793  DO 400 i = 0, 7
    +
    794  kpds(i+8) = mova2i(msga(i+iss))
    +
    795  400 CONTINUE
    +
    796 C ----------- KPDS(17) - NUMBER INCLUDED IN AVERAGE
    +
    797  iss = is + 25
    +
    798  kpds(17) = 0
    +
    799  DO 500 i = 0, 1
    +
    800  kpds(17) = kpds(17) * 256 + mova2i(msga(i+iss))
    +
    801  500 CONTINUE
    +
    802 C -----------SKIP OVER SOURCE BYTE 24
    +
    803 C ----------- TEST FOR NEW GRID
    +
    804  IF (iand(kpds(4),128).NE.0) THEN
    +
    805  IF (iand(kpds(4),64).NE.0) THEN
    +
    806  IF (kpds(3).NE.255) THEN
    +
    807  IF (kpds(1).EQ.7) THEN
    +
    808  IF (kpds(3).GE.21.AND.kpds(3).LE.26) THEN
    +
    809  ELSE IF (kpds(3).EQ.50) THEN
    +
    810  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
    +
    811  ELSE IF (kpds(3).EQ.70) THEN
    +
    812  ELSE IF (kpds(3).GE.85.AND.kpds(3).LE.86) THEN
    +
    813  ELSE IF (kpds(3).GE.100.AND.kpds(3).LE.103) THEN
    +
    814  ELSE IF (kpds(3).GE.201.AND.kpds(3).LE.214) THEN
    +
    815  ELSE
    +
    816  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    817  * ' NMC'
    +
    818  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    819  print *,' PRODUCTION MANAGEMENT BRANCH'
    +
    820  print *,' W/NMC42)'
    +
    821  END IF
    +
    822  ELSE IF (kpds(1).EQ.98) THEN
    +
    823  IF (kpds(3).GE.1.AND.kpds(3).LE.16) THEN
    +
    824  ELSE
    +
    825  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    826  * ' ECMWF'
    +
    827  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    828  print *,' PRODUCTION MANAGEMENT BRANCH'
    +
    829  print *,' W/NMC42)'
    +
    830  END IF
    +
    831  ELSE IF (kpds(1).EQ.74) THEN
    +
    832  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
    +
    833  ELSE IF (kpds(3).GE.21.AND.kpds(3).LE.26)THEN
    +
    834  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
    +
    835  ELSE IF (kpds(3).EQ.70) THEN
    +
    836  ELSE
    +
    837  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    838  * ' U.K. MET OFFICE, BRACKNELL'
    +
    839  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    840  print *,' PRODUCTION MANAGEMENT BRANCH'
    +
    841  print *,' W/NMC42)'
    +
    842  END IF
    +
    843  ELSE IF (kpds(1).EQ.58) THEN
    +
    844  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
    +
    845  ELSE
    +
    846  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    847  * ' FNOC,'
    +
    848  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    849  print *,' PRODUCTION MANAGEMENT BRANCH'
    +
    850  print *,' W/NMC42)'
    +
    851  END IF
    +
    852  END IF
    +
    853  END IF
    +
    854  END IF
    +
    855  END IF
    +
    856  RETURN
    +
    857  END
    +
    858 
    +
    859 C> Extract information from the product description section (version 1).
    +
    860 C>
    +
    861 C> Program history log:
    +
    862 C> - Bill Cavanaugh 1989-11-20
    +
    863 C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
    +
    864 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    865 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    866 C>
    +
    867 C> @param[in] MSGA Array containing grib message.
    +
    868 C> @param[inout] KPTR Array containing storage for following parameters.
    +
    869 C> - 1: Unused.
    +
    870 C> - 2: Unused.
    +
    871 C> - 3: Length of pds.
    +
    872 C> - 4: Length of gds.
    +
    873 C> - 5: Length of bms.
    +
    874 C> - 6: Length of pds.
    +
    875 C> - 7: Value of current byte.
    +
    876 C> - 8: Unused.
    +
    877 C> - 9: Grib start byte nr.
    +
    878 C> - 10: Grib/grid element count.
    +
    879 C>
    +
    880 C> @param[out] KPDS Array containing pds elements.
    +
    881 C> - 1: Id of center
    +
    882 C> - 2: Model identi.fication
    +
    883 C> - 3: Grid identification.
    +
    884 C> - 4: Gds/bms flag.
    +
    885 C> - 5: Indicator of. parameter
    +
    886 C> - 6: Type of level.
    +
    887 C> - 7: Height/pressu.re , etc of level
    +
    888 C> - 8: Year (including century).
    +
    889 C> - 9: Month of year.
    +
    890 C> - 10: Day of month..
    +
    891 C> - 11: Hour of day.
    +
    892 C> - 12: Minute of hour.
    +
    893 C> - 13: Indicator of forecast time unit.
    +
    894 C> - 14: Time range 1.
    +
    895 C> - 15: Time range 2.
    +
    896 C> - 16: Time range flag.
    +
    897 C> - 17: Number included in average.
    +
    898 C> - 18: Version nr of grib specification.
    +
    899 C> - 19: Version nr of parameter table.
    +
    900 C> - 20: Total byte count for source message.
    +
    901 C> @param[out] KRET Error return.
    +
    902 C>
    +
    903 C> @note Source pds structure (version 1).
    +
    904 C> - 1-3: Length of pds section in bytes.
    +
    905 C> - 4: Parameter table version no. for international exchange (crrently no. 1).
    +
    906 C> - 5: Center id.
    +
    907 C> - 6: Model id.
    +
    908 C> - 7: Grid id.
    +
    909 C> - 8: Flag for gds/bms.
    +
    910 C> - 9: Indicator for parameter.
    +
    911 C> - 10: Indicator for type of level.
    +
    912 C> - 11-12: Height, pressure of level.
    +
    913 C> - 13: Year of century.
    +
    914 C> - 14: Month.
    +
    915 C> - 15: Day.
    +
    916 C> - 16: Hour.
    +
    917 C> - 17: Minute.
    +
    918 C> - 18: Forecast time unit.
    +
    919 C> - 19: P1 - pd of time.
    +
    920 C> - 20: P2 - pd of time.
    +
    921 C> - 21: Time range indicator.
    +
    922 C> - 22-23: Number in average.
    +
    923 C> - 24: Number misg from averages.
    +
    924 C> - 25: Century.
    +
    925 C> - 26: Indicator of parameter in locally re-defined parameter table..
    +
    926 C> - 27-28: Units decimal scale factor (d).
    +
    927 C> - 29-40: Reserved: need not be present.
    +
    928 C> - 41-NN: National use.
    +
    929 C> - Error return:
    +
    930 C> - = 0 - No errors.
    +
    931 C> - = 8 - Temp gds indicated, but no gds.
    +
    932 C>
    +
    933 C> @author Bill Cavanaugh @date 1988-01-20
    +
    934  SUBROUTINE ai082a(MSGA,KPTR,KPDS,KRET)
    +
    935 C
    +
    936 C INCOMING MESSAGE HOLDER
    +
    937  CHARACTER*1 MSGA(*)
    +
    938 C
    +
    939 C ARRAY OF POINTERS AND COUNTERS
    +
    940  INTEGER KPTR(*)
    +
    941 C PRODUCT DESCRIPTION SECTION ENTRIES
    +
    942  INTEGER KPDS(*)
    +
    943 C
    +
    944  INTEGER KRET
    +
    945 C
    +
    946  is = kptr(9)
    +
    947  igribl = 8
    +
    948 C -------------------- COLLECT PDS VALUES
    +
    949 C KPDS(1) - ID OF CENTER
    +
    950 C KPDS(2) - MODEL IDENTIFICATION
    +
    951 C KPDS(3) - GRID IDENTIFICATION
    +
    952 C KPDS(4) - GDS/BMS FLAG
    +
    953 C KPDS(5) - INDICATOR OF PARAMETER
    +
    954 C ----------- KPDS(6) - TYPE OF LEVEL
    +
    955  iss = is + igribl + 4
    +
    956  DO 200 i = 0, 5
    +
    957  kpds(i+1) = mova2i(msga(i+iss))
    +
    958  200 CONTINUE
    +
    959  IF (kpds(3).NE.255) GO TO 250
    +
    960  IF (iand(kpds(4),128).NE.0) GO TO 250
    +
    961  kret = 8
    +
    962  RETURN
    +
    963  250 CONTINUE
    +
    964 C HEIGHT, PRESS OF LEVEL
    +
    965  iss = is + igribl + 10
    +
    966  kpds(7) = 0
    +
    967  DO 300 i = 0, 1
    +
    968  kpds(7) = kpds(7) * 256 + mova2i(msga(i+iss))
    +
    969  300 CONTINUE
    +
    970 C
    +
    971 C ----------- KPDS(8) - YEAR (INCLUDING CENTURY)
    +
    972 C
    +
    973  iss = is + igribl + 12
    +
    974  icen = is + igribl + 24
    +
    975 C
    +
    976  kpds(8) = mova2i(msga(icen)) * 100 + mova2i(msga(iss))
    +
    977 C
    +
    978 C KPDS(9) - MONTH OF YEAR
    +
    979 C KPDS(10) - DAY OF MONTH
    +
    980 C KPDS(11) - HOUR OF DAY
    +
    981 C KPDS(12) - MINUTE OF HOUR
    +
    982 C KPDS(13) - INDICATOR OF FORECAST TIME UNIT
    +
    983 C KPDS(14) - TIME RANGE 1
    +
    984 C KPDS(15) - TIME RANGE 2
    +
    985 C ----------- KPDS(16) - TIME RANGE FLAG
    +
    986 C
    +
    987  iss = is + igribl + 13
    +
    988  DO 400 i = 0, 7
    +
    989  kpds(i+9) = mova2i(msga(i+iss))
    +
    990  400 CONTINUE
    +
    991 C ----------- KPDS(17) - NUMBER INCLUDED IN AVERAGE
    +
    992  iss = is + igribl + 21
    +
    993  kpds(17) = 0
    +
    994  DO 500 i = 0, 1
    +
    995  kpds(17) = kpds(17) * 256 + mova2i(msga(i+iss))
    +
    996  500 CONTINUE
    +
    997 C -----------SKIP OVER SOURCE BYTE 28
    +
    998 C ----------- TEST FOR NEW GRID
    +
    999  IF (iand(kpds(4),128).NE.0) THEN
    +
    1000  IF (iand(kpds(4),64).NE.0) THEN
    +
    1001  IF (kpds(3).NE.255) THEN
    +
    1002  IF (kpds(1).EQ.7) THEN
    +
    1003  IF (kpds(3).GE.21.AND.kpds(3).LE.26)THEN
    +
    1004  ELSE IF (kpds(3).EQ.50) THEN
    +
    1005  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
    +
    1006  ELSE IF (kpds(3).EQ.70) THEN
    +
    1007  ELSE IF (kpds(3).GE.85.AND.kpds(3).LE.86) THEN
    +
    1008  ELSE IF (kpds(3).GE.100.AND.kpds(3).LE.103) THEN
    +
    1009  ELSE IF (kpds(3).GE.201.AND.kpds(3).LE.214) THEN
    +
    1010  ELSE
    +
    1011  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    1012  * ' NMC'
    +
    1013  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    1014  print *,' PRODUCTION MANAGEMENT BRANCH'
    +
    1015  print *,' W/NMC42)'
    +
    1016  END IF
    +
    1017  ELSE IF (kpds(1).EQ.98) THEN
    +
    1018  IF (kpds(3).GE.1.AND.kpds(3).LE.16) THEN
    +
    1019  ELSE
    +
    1020  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    1021  * ' ECMWF'
    +
    1022  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    1023  print *,' PRODUCTION MANAGEMENT BRANCH'
    +
    1024  print *,' W/NMC42)'
    +
    1025  END IF
    +
    1026  ELSE IF (kpds(1).EQ.74) THEN
    +
    1027  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
    +
    1028  ELSE IF (kpds(3).GE.21.AND.kpds(3).LE.26)THEN
    +
    1029  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
    +
    1030  ELSE IF (kpds(3).EQ.70) THEN
    +
    1031  ELSE
    +
    1032  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    1033  * ' U.K. MET OFFICE, BRACKNELL'
    +
    1034  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    1035  print *,' PRODUCTION MANAGEMENT BRANCH'
    +
    1036  print *,' W/NMC42)'
    +
    1037  END IF
    +
    1038  ELSE IF (kpds(1).EQ.58) THEN
    +
    1039  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
    +
    1040  ELSE
    +
    1041  print *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    1042  * ' FNOC,'
    +
    1043  print *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    1044  print *,' PRODUCTION MANAGEMENT BRANCH'
    +
    1045  print *,' W/NMC42)'
    +
    1046  END IF
    +
    1047  END IF
    +
    1048  END IF
    +
    1049  END IF
    +
    1050  END IF
    +
    1051  RETURN
    +
    1052  END
    +
    1053 
    +
    1054 C> Extract information on unlisted grid to allow conversion to office note 84 format.
    +
    1055 C>
    +
    1056 C> Program history log:
    +
    1057 C> - Bill Cavanaugh 1988-01-20
    +
    1058 C> - Bill Cavanaugh 1989-03-16 Added mercator & lambert conformal processing.
    +
    1059 C> - Bill Cavanaugh 1989-07-12 Corrected change entered 89-03-16 reordering
    +
    1060 C> processing for lambert conformal and mercator grids.
    +
    1061 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    1062 C>
    +
    1063 C> @param[in] MSGA Array containing grib message.
    +
    1064 C> @param[inout] KPTR Array containing storage for following parameters.
    +
    1065 C> - 1): Unused.
    +
    1066 C> - 2): Unused.
    +
    1067 C> - 3): Length of pds.
    +
    1068 C> - 4): Length of gds.
    +
    1069 C> - 5): Length of bms.
    +
    1070 C> - 6): Length of bds.
    +
    1071 C> - 7): Value of current byte.
    +
    1072 C> - 8): Unused.
    +
    1073 C> - 9): Grib start byte nr.
    +
    1074 C> - 0): Grib/grid element count.
    +
    1075 C> @param[in] KPDS Array containing pds elements.
    +
    1076 C> - 1): Id of center.
    +
    1077 C> - 2): Model identification.
    +
    1078 C> - 3): Grid identification.
    +
    1079 C> - 4): Gds/bms flag.
    +
    1080 C> - 5): Indicator of parameter.
    +
    1081 C> - 6): Type of level.
    +
    1082 C> - 7): Height/pressure , etc of level.
    +
    1083 C> - 8): Year of century.
    +
    1084 C> - 9): Month of year.
    +
    1085 C> - 10: Day of month.
    +
    1086 C> - 11: Hour of day.
    +
    1087 C> - 12: Minute of hour.
    +
    1088 C> - 13: Indicator of forecast time unit.
    +
    1089 C> - 14: Time range 1.
    +
    1090 C> - 15: Time range 2.
    +
    1091 C> - 16: Time range flag.
    +
    1092 C> - 17: Number included in average.
    +
    1093 C> - 18: Version nr of grib specification.
    +
    1094 C> @param[out] KGDS Array containing gds elements..
    +
    1095 C> - 1): Data representation type.
    +
    1096 C> - Latitude/Longitude grids
    +
    1097 C> - 2): N(i) nr points on latitude circle.
    +
    1098 C> - 3): N(j) nr points on longitude meridian.
    +
    1099 C> - 4): La(1) latitude of origin.
    +
    1100 C> - 5): Lo(1) longitude of origin.
    +
    1101 C> - 6): Resolution flag.
    +
    1102 C> - 7): La(2) latitude of extreme point.
    +
    1103 C> - 8): Lo(2) longitude of extreme point.
    +
    1104 C> - 9): Di longitudinal direction of increment.
    +
    1105 C> - 10: Dj latitudinal direction of increment.
    +
    1106 C> - 11: Scanning mode flag.
    +
    1107 C> - Polar stereographic grids.
    +
    1108 C> - 2): N(i) nr points along lat circle.
    +
    1109 C> - 3): N(j) nr points along lon circle.
    +
    1110 C> - 4): La(1) latitude of origin.
    +
    1111 C> - 5): Lo(1) longitude of origin.
    +
    1112 C> - 6): Reserved.
    +
    1113 C> - 7): Lov grid orientation.
    +
    1114 C> - 8): Dx - x direction increment.
    +
    1115 C> - 9): Dy - y direction increment.
    +
    1116 C> - 10: Projection center flag.
    +
    1117 C> - 11: Scanning mode.
    +
    1118 C> - Spherical harmonic coefficients.
    +
    1119 C> - 2): J pentagonal resolution parameter.
    +
    1120 C> - 3): K pentagonal resolution parameter.
    +
    1121 C> - 4): M pentagonal resolution parameter.
    +
    1122 C> - 5): Representation type.
    +
    1123 C> - 6): Coefficient storage mode.
    +
    1124 C> - Mercator grids.
    +
    1125 C> - 2): N(i) nr points on latitude circle.
    +
    1126 C> - 3): N(j) nr points on longitude meridian.
    +
    1127 C> - 4): La(1) latitude of origin.
    +
    1128 C> - 5): Lo(1) longitude of origin.
    +
    1129 C> - 6): Resolution flag.
    +
    1130 C> - 7): La(2) latitude of last grid point.
    +
    1131 C> - 8): Lo(2) longitude of last grid point.
    +
    1132 C> - 9): Longit dir increment.
    +
    1133 C> - 10: Latit dir increment.
    +
    1134 C> - 11: Scanning mode flag.
    +
    1135 C> - 12: Latitude intersection.
    +
    1136 C> - Lambert conformal grids.
    +
    1137 C> - 2): Nx nr points along x-axis.
    +
    1138 C> - 3): Ny nr points along y-axis.
    +
    1139 C> - 4): La1 lat of origin (lower left).
    +
    1140 C> - 5): Lo1 lon of origin (lower left).
    +
    1141 C> - 6): Reserved.
    +
    1142 C> - 7): Lov - orientation of grid.
    +
    1143 C> - 8): Dx - x-dir increment.
    +
    1144 C> - 9): Dy - y-dir increment.
    +
    1145 C> - 10: Projection center flag.
    +
    1146 C> - 11: Scanning mode flag.
    +
    1147 C> - 12: Latin 1 - first lat from pole of secant cone inter.
    +
    1148 C> - 13: Latin 2 - second lat from pole of secant cone inter.
    +
    1149 C> @param[out] KRET Error return.
    +
    1150 C>
    +
    1151 C> @note KRET
    +
    1152 C> - = 0
    +
    1153 C> - = 4 - DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE
    +
    1154 C>
    +
    1155 C> @author Bill Cavanaugh @date 1988-01-20
    +
    1156 
    +
    1157  SUBROUTINE ai083(MSGA,KPTR,KPDS,KGDS,KRET)
    +
    1158 C ************************************************************
    +
    1159 C INCOMING MESSAGE HOLDER
    +
    1160  CHARACTER*1 MSGA(*)
    +
    1161 C
    +
    1162 C ARRAY GDS ELEMENTS
    +
    1163  INTEGER KGDS(*)
    +
    1164 C ARRAY OF POINTERS AND COUNTERS
    +
    1165  INTEGER KPTR(*)
    +
    1166 C ARRAY OF PDS ELEMENTS
    +
    1167  INTEGER KPDS(*)
    +
    1168 C
    +
    1169  INTEGER KRET
    +
    1170 C
    +
    1171 C DATA MSK80 /Z00000080/
    +
    1172 C
    +
    1173  DATA msk80 /128/
    +
    1174 C ********************************************************
    +
    1175 C IF FLAG IN PDS INDICATE THAT THERE IS NO GDS ,
    +
    1176 C RETURN IMMEDIATELY
    +
    1177 C ************************************************************
    +
    1178  IF (iand(kpds(4),msk80).EQ.0) GO TO 900
    +
    1179 C ------------------- BYTE 1-3 COUNT
    +
    1180  is = kptr(9)
    +
    1181  IF (kpds(18).EQ.0) THEN
    +
    1182  igribl = 4
    +
    1183  ELSE
    +
    1184  igribl = 8
    +
    1185  ENDIF
    +
    1186  iss = is + kptr(3) + igribl
    +
    1187 C ------------------- BYTE 4 NUMBER OF UNUSED BITS AT END OF SEC
    +
    1188 C ------------------- BYTE 5 RESERVED
    +
    1189 C ------------------- BYTE 6 DATA REPRESENTATION TYPE
    +
    1190  kgds(1) = mova2i(msga(iss+5))
    +
    1191 C ------------------- DIVERT TO PROCESS CORRECT TYPE
    +
    1192  IF (kgds(1).EQ.0) THEN
    +
    1193  GO TO 1000
    +
    1194  ELSE IF (kgds(1).EQ.1) THEN
    +
    1195  GO TO 4000
    +
    1196  ELSE IF (kgds(1).EQ.2.OR.kgds(1).EQ.5) THEN
    +
    1197  GO TO 2000
    +
    1198  ELSE IF (kgds(1).EQ.3) THEN
    +
    1199  GO TO 5000
    +
    1200  ELSE IF (kgds(1).EQ.4) THEN
    +
    1201  GO TO 1000
    +
    1202  ELSE IF (kgds(1).EQ.50) THEN
    +
    1203  GO TO 3000
    +
    1204  ELSE
    +
    1205 C MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE
    +
    1206  kret = 4
    +
    1207  GO TO 900
    +
    1208  END IF
    +
    1209 C
    +
    1210 C ------------------- LATITUDE/LONGITUDE GRIDS
    +
    1211 C
    +
    1212 C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE
    +
    1213  1000 kgds(2) = 0
    +
    1214  DO 1005 i = 0, 1
    +
    1215  kgds(2) = kgds(2) * 256 + mova2i(msga(i+iss+6))
    +
    1216  1005 CONTINUE
    +
    1217 C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
    +
    1218  kgds(3) = 0
    +
    1219  DO 1010 i = 0, 1
    +
    1220  kgds(3) = kgds(3) * 256 + mova2i(msga(i+iss+8))
    +
    1221  1010 CONTINUE
    +
    1222 C ------------------- BYTE 11-13 LATITUE OF ORIGIN
    +
    1223  kgds(4) = 0
    +
    1224  DO 1020 i = 0, 2
    +
    1225  kgds(4) = kgds(4) * 256 + mova2i(msga(i+iss+10))
    +
    1226  1020 CONTINUE
    +
    1227  IF (iand(kgds(4),8388608).NE.0) THEN
    +
    1228  kgds(4) = iand(kgds(4),8388607) * (-1)
    +
    1229  END IF
    +
    1230 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
    +
    1231  kgds(5) = 0
    +
    1232  DO 1030 i = 0, 2
    +
    1233  kgds(5) = kgds(5) * 256 + mova2i(msga(i+iss+13))
    +
    1234  1030 CONTINUE
    +
    1235  IF (iand(kgds(5),8388608).NE.0) THEN
    +
    1236  kgds(5) = - iand(kgds(5),8388607)
    +
    1237  END IF
    +
    1238 C ------------------- BYTE 17 RESOLUTION FLAG
    +
    1239  kgds(6) = mova2i(msga(iss+16))
    +
    1240 C ------------------- BYTE 18-20 LATITUDE OF LAST GRID POINT
    +
    1241  kgds(7) = 0
    +
    1242  DO 1040 i = 0, 2
    +
    1243  kgds(7) = kgds(7) * 256 + mova2i(msga(i+iss+17))
    +
    1244  1040 CONTINUE
    +
    1245  IF (iand(kgds(7),8388608).NE.0) THEN
    +
    1246  kgds(7) = - iand(kgds(7),8388607)
    +
    1247  END IF
    +
    1248 C ------------------- BYTE 21-23 LONGITUDE OF LAST GRID POINT
    +
    1249  kgds(8) = 0
    +
    1250  DO 1050 i = 0, 2
    +
    1251  kgds(8) = kgds(8) * 256 + mova2i(msga(i+iss+20))
    +
    1252  1050 CONTINUE
    +
    1253  IF (iand(kgds(8),8388608).NE.0) THEN
    +
    1254  kgds(8) = - iand(kgds(8),8388607)
    +
    1255  END IF
    +
    1256 C ------------------- BYTE 24-25 LATITUDINAL DIR INCREMENT
    +
    1257  kgds(9) = 0
    +
    1258  DO 1060 i = 0, 1
    +
    1259  kgds(9) = kgds(9) * 256 + mova2i(msga(i+iss+23))
    +
    1260  1060 CONTINUE
    +
    1261 C ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID
    +
    1262 C HAVE LONGIT DIR INCREMENT
    +
    1263 C ELSE IF GAUSSIAN GRID
    +
    1264 C HAVE NR OF LAT CIRCLES
    +
    1265 C BETWEEN POLE AND EQUATOR
    +
    1266  kgds(10) = 0
    +
    1267  DO 1070 i = 0, 1
    +
    1268  kgds(10) = kgds(10) * 256 + mova2i(msga(i+iss+25))
    +
    1269  1070 CONTINUE
    +
    1270 C ------------------- BYTE 28 SCANNING MODE FLAGS
    +
    1271  kgds(11) = mova2i(msga(iss+27))
    +
    1272 C ------------------- BYTE 29-32 RESERVED
    +
    1273 C -------------------
    +
    1274  GO TO 900
    +
    1275 C -------------------
    +
    1276 C ' POLAR STEREO PROCESSING '
    +
    1277 C
    +
    1278 C ------------------- BYTE 7-8 NR OF POINTS ALONG X=AXIS
    +
    1279  2000 kgds(2) = 0
    +
    1280  DO 2005 i = 0, 1
    +
    1281  kgds(2) = kgds(2) * 256 + mova2i(msga(i+iss+6))
    +
    1282  2005 CONTINUE
    +
    1283 C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
    +
    1284  kgds(3) = 0
    +
    1285  DO 2010 i = 0, 1
    +
    1286  kgds(3) = kgds(3) * 256 + mova2i(msga(i+iss+8))
    +
    1287  2010 CONTINUE
    +
    1288 C ------------------- BYTE 11-13 LATITUDE OF ORIGIN
    +
    1289  kgds(4) = 0
    +
    1290  DO 2020 i = 0, 2
    +
    1291  kgds(4) = kgds(4) * 256 + mova2i(msga(i+iss+10))
    +
    1292  2020 CONTINUE
    +
    1293  IF (iand(kgds(4),8388608).NE.0) THEN
    +
    1294  kgds(4) = - iand(kgds(4),8388607)
    +
    1295  END IF
    +
    1296 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
    +
    1297  kgds(5) = 0
    +
    1298  DO 2030 i = 0, 2
    +
    1299  kgds(5) = kgds(5) * 256 + mova2i(msga(i+iss+13))
    +
    1300  2030 CONTINUE
    +
    1301  IF (iand(kgds(5),8388608).NE.0) THEN
    +
    1302  kgds(5) = - iand(kgds(5),8388607)
    +
    1303  END IF
    +
    1304 C ------------------- BYTE 17 RESERVED
    +
    1305  kgds(6) = mova2i(msga(iss+16))
    +
    1306 C ------------------- BYTE 18-20 LOV ORIENTATION OF THE GRID
    +
    1307  kgds(7) = 0
    +
    1308  DO 2040 i = 0, 2
    +
    1309  kgds(7) = kgds(7) * 256 + mova2i(msga(i+iss+17))
    +
    1310  2040 CONTINUE
    +
    1311  IF (iand(kgds(7),8388608).NE.0) THEN
    +
    1312  kgds(7) = - iand(kgds(7),8388607)
    +
    1313  END IF
    +
    1314 C ------------------- BYTE 21-23 DX - THE X DIRECTION INCREMENT
    +
    1315  kgds(8) = 0
    +
    1316  DO 2050 i = 0, 2
    +
    1317  kgds(8) = kgds(8) * 256 + mova2i(msga(i+iss+20))
    +
    1318  2050 CONTINUE
    +
    1319  IF (iand(kgds(8),8388608).NE.0) THEN
    +
    1320  kgds(8) = - iand(kgds(8),8388607)
    +
    1321  END IF
    +
    1322 C ------------------- BYTE 24-26 DY - THE Y DIRECTION INCREMENT
    +
    1323  kgds(9) = 0
    +
    1324  DO 2060 i = 0, 2
    +
    1325  kgds(9) = kgds(9) * 256 + mova2i(msga(i+iss+23))
    +
    1326  2060 CONTINUE
    +
    1327  IF (iand(kgds(9),8388608).NE.0) THEN
    +
    1328  kgds(9) = - iand(kgds(9),8388607)
    +
    1329  END IF
    +
    1330 C ------------------- BYTE 27 PROJECTION CENTER FLAG
    +
    1331  kgds(10) = mova2i(msga(iss+26))
    +
    1332 C ------------------- BYTE 28 SCANNING MODE
    +
    1333  kgds(11) = mova2i(msga(iss+27))
    +
    1334 C ------------------- BYTE 29-32 RESERVED
    +
    1335 C -------------------
    +
    1336  GO TO 900
    +
    1337 C
    +
    1338 C ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF.
    +
    1339 C
    +
    1340 C ------------------- BYTE 7-8 J PENTAGONAL RESOLUTION PARAMETER
    +
    1341  3000 kgds(2) = 0
    +
    1342  DO 3010 i = 0, 1
    +
    1343  kgds(2) = kgds(2) * 256 + mova2i(msga(i+iss+6))
    +
    1344  3010 CONTINUE
    +
    1345 C ------------------- BYTE 9-10 K PENTAGONAL RESOLUTION PARAMETER
    +
    1346  kgds(3) = 0
    +
    1347  DO 3020 i = 0, 1
    +
    1348  kgds(3) = kgds(3) * 256 + mova2i(msga(i+iss+8))
    +
    1349  3020 CONTINUE
    +
    1350 C ------------------- BYTE 11-12 M PENTAGONAL RESOLUTION PARAMETER
    +
    1351  kgds(4) = 0
    +
    1352  DO 3030 i = 0, 1
    +
    1353  kgds(4) = kgds(4) * 256 + mova2i(msga(i+iss+10))
    +
    1354  3030 CONTINUE
    +
    1355 C ------------------- BYTE 13 REPRESENTATION TYPE
    +
    1356  kgds(5) = mova2i(msga(iss+12))
    +
    1357 C ------------------- BYTE 14 COEFFICIENT STORAGE MODE
    +
    1358  kgds(6) = mova2i(msga(iss+13))
    +
    1359 C ------------------- EMPTY FIELDS - BYTES 15 - 32
    +
    1360  kret = 0
    +
    1361  GO TO 900
    +
    1362 C ------------------- PROCESS MERCATOR GRIDS
    +
    1363 C
    +
    1364 C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE
    +
    1365  4000 kgds(2) = 0
    +
    1366  DO 4005 i = 0, 1
    +
    1367  kgds(2) = kgds(2) * 256 + mova2i(msga(i+iss+6))
    +
    1368  4005 CONTINUE
    +
    1369 C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
    +
    1370  kgds(3) = 0
    +
    1371  DO 4010 i = 0, 1
    +
    1372  kgds(3) = kgds(3) * 256 + mova2i(msga(i+iss+8))
    +
    1373  4010 CONTINUE
    +
    1374 C ------------------- BYTE 11-13 LATITUE OF ORIGIN
    +
    1375  kgds(4) = 0
    +
    1376  DO 4020 i = 0, 2
    +
    1377  kgds(4) = kgds(4) * 256 + mova2i(msga(i+iss+10))
    +
    1378  4020 CONTINUE
    +
    1379  IF (iand(kgds(4),8388608).NE.0) THEN
    +
    1380  kgds(4) = - iand(kgds(4),8388607)
    +
    1381  END IF
    +
    1382 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
    +
    1383  kgds(5) = 0
    +
    1384  DO 4030 i = 0, 2
    +
    1385  kgds(5) = kgds(5) * 256 + mova2i(msga(i+iss+13))
    +
    1386  4030 CONTINUE
    +
    1387  IF (iand(kgds(5),8388608).NE.0) THEN
    +
    1388  kgds(5) = - iand(kgds(5),8388607)
    +
    1389  END IF
    +
    1390 C ------------------- BYTE 17 RESOLUTION FLAG
    +
    1391  kgds(6) = mova2i(msga(iss+16))
    +
    1392 C ------------------- BYTE 18-20 LATITUDE OF EXTREME POINT
    +
    1393  kgds(7) = 0
    +
    1394  DO 4040 i = 0, 2
    +
    1395  kgds(7) = kgds(7) * 256 + mova2i(msga(i+iss+17))
    +
    1396  4040 CONTINUE
    +
    1397  IF (iand(kgds(7),8388608).NE.0) THEN
    +
    1398  kgds(7) = - iand(kgds(7),8388607)
    +
    1399  END IF
    +
    1400 C ------------------- BYTE 21-23 LONGITUDE OF EXTREME POINT
    +
    1401  kgds(8) = 0
    +
    1402  DO 4050 i = 0, 2
    +
    1403  kgds(8) = kgds(8) * 256 + mova2i(msga(i+iss+20))
    +
    1404  4050 CONTINUE
    +
    1405  IF (iand(kgds(8),8388608).NE.0) THEN
    +
    1406  kgds(8) = - iand(kgds(8),8388607)
    +
    1407  END IF
    +
    1408 C ------------------- BYTE 24-25 LONGITUDE DIR INCREMENT
    +
    1409  kgds(9) = 0
    +
    1410  DO 4070 i = 0, 1
    +
    1411  kgds(9) = kgds(9) * 256 + mova2i(msga(i+iss+23))
    +
    1412  4070 CONTINUE
    +
    1413  IF (iand(kgds(9),8388608).NE.0) THEN
    +
    1414  kgds(9) = - iand(kgds(9),32768)
    +
    1415  END IF
    +
    1416 C ------------------- BYTE 26-27 LATIT DIR INCREMENT
    +
    1417  kgds(10) = 0
    +
    1418  DO 4080 i = 0, 1
    +
    1419  kgds(10) = kgds(10) * 256 + mova2i(msga(i+iss+25))
    +
    1420  4080 CONTINUE
    +
    1421  IF (iand(kgds(10),8388608).NE.0) THEN
    +
    1422  kgds(10) = - iand(kgds(10),32768)
    +
    1423  END IF
    +
    1424 C ------------------- BYTE 28 SCANNING MODE FLAGS
    +
    1425  kgds(11) = mova2i(msga(iss+27))
    +
    1426 C ------------------- BYTE 29-31 INTERSECTION LATITUDE
    +
    1427  kgds(12) = 0
    +
    1428  DO 4060 i = 0, 2
    +
    1429  kgds(12)= kgds(12) * 256 + mova2i(msga(i+iss+28))
    +
    1430  4060 CONTINUE
    +
    1431 C ------------------- BYTE 32 RESERVED
    +
    1432 C -------------------
    +
    1433  GO TO 900
    +
    1434 C ------------------- PROCESS LAMBERT CONFORMAL
    +
    1435 C
    +
    1436 C ------------------- BYTE 7-8 NR OF POINTS ALONG X-AXIS
    +
    1437  5000 kgds(2) = 0
    +
    1438  DO 5005 i = 0, 1
    +
    1439  kgds(2) = kgds(2) * 256 + mova2i(msga(i+iss+6))
    +
    1440  5005 CONTINUE
    +
    1441 C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
    +
    1442  kgds(3) = 0
    +
    1443  DO 5010 i = 0, 1
    +
    1444  kgds(3) = kgds(3) * 256 + mova2i(msga(i+iss+8))
    +
    1445  5010 CONTINUE
    +
    1446 C ------------------- BYTE 11-13 LATITUDE OF ORIGIN
    +
    1447  kgds(4) = 0
    +
    1448  DO 5020 i = 0, 2
    +
    1449  kgds(4) = kgds(4) * 256 + mova2i(msga(i+iss+10))
    +
    1450  5020 CONTINUE
    +
    1451  IF (iand(kgds(4),8388608).NE.0) THEN
    +
    1452  kgds(4) = - iand(kgds(4),8388607)
    +
    1453  END IF
    +
    1454 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN (LOWER LEFT)
    +
    1455  kgds(5) = 0
    +
    1456  DO 5030 i = 0, 2
    +
    1457  kgds(5) = kgds(5) * 256 + mova2i(msga(i+iss+13))
    +
    1458  5030 CONTINUE
    +
    1459  IF (iand(kgds(5),8388608).NE.0) THEN
    +
    1460  kgds(5) = - iand(kgds(5),8388607)
    +
    1461  END IF
    +
    1462 C ------------------- BYTE 17 RESERVED
    +
    1463 C KGDS(6) =
    +
    1464 C ------------------- BYTE 18-20 LOV -ORIENTATION OF GRID
    +
    1465  kgds(7) = 0
    +
    1466  DO 5040 i = 0, 2
    +
    1467  kgds(7) = kgds(7) * 256 + mova2i(msga(i+iss+17))
    +
    1468  5040 CONTINUE
    +
    1469  IF (iand(kgds(7),8388608).NE.0) THEN
    +
    1470  kgds(7) = - iand(kgds(7),8388607)
    +
    1471  END IF
    +
    1472 C ------------------- BYTE 21-23 DX - X-DIR INCREMENT
    +
    1473  kgds(8) = 0
    +
    1474  DO 5060 i = 0, 2
    +
    1475  kgds(8) = kgds(8) * 256 + mova2i(msga(i+iss+20))
    +
    1476  5060 CONTINUE
    +
    1477 C ------------------- BYTE 24-26 DY - Y-DIR INCREMENT
    +
    1478  kgds(9) = 0
    +
    1479  DO 5070 i = 0, 2
    +
    1480  kgds(9) = kgds(9) * 256 + mova2i(msga(i+iss+23))
    +
    1481  5070 CONTINUE
    +
    1482 C ------------------- BYTE 27 PROJECTION CENTER FLAG
    +
    1483  kgds(10) = mova2i(msga(iss+26))
    +
    1484 C ------------------- BYTE 28 SCANNING MODE
    +
    1485  kgds(11) = mova2i(msga(iss+27))
    +
    1486 C ------------------- BYTE 29-31 LATIN1 - 1ST LAT FROM POLE
    +
    1487  kgds(12) = 0
    +
    1488  DO 5050 i = 0, 2
    +
    1489  kgds(12)= kgds(12)* 256 + mova2i(msga(i+iss+28))
    +
    1490  5050 CONTINUE
    +
    1491  IF (iand(kgds(12),8388608).NE.0) THEN
    +
    1492  kgds(12) = - iand(kgds(12),8388607)
    +
    1493  END IF
    +
    1494 C ------------------- BYTE 32-34 LATIN2 - 2ND LAT FROM POLE
    +
    1495  kgds(13) = 0
    +
    1496  DO 5055 i = 0, 2
    +
    1497  kgds(13)= kgds(13)* 256 + mova2i(msga(i+iss+31))
    +
    1498  5055 CONTINUE
    +
    1499  IF (iand(kgds(13),8388608).NE.0) THEN
    +
    1500  kgds(13) = - iand(kgds(13),8388607)
    +
    1501  END IF
    +
    1502 C -------------------
    +
    1503  900 CONTINUE
    +
    1504  RETURN
    +
    1505  END
    +
    1506 
    +
    1507 C> If bit map sec is available in grib message,extract
    +
    1508 C> for program use, otherwise generate an appropriate bit map.
    +
    1509 C>
    +
    1510 C> Program history log:
    +
    1511 C> - Bill Cavanaugh 1988-01-20
    +
    1512 C> - Bill Cavanaugh 1989-02-24 Increment of position in bit map when bit map was included was handled improperly. corrected this data.
    +
    1513 C> - Bill Cavanaugh 1989-07-12 Altered method of calculating nr of bits in a bit map contained in grib message.
    +
    1514 C> - Bill Cavanaugh 1990-05-07 Brings all u.s. grids to revised values as of dec 89.
    +
    1515 C> - William Bostelman 1990-07-15 Modiifed to test the grib bds byte size to determine what ecmwf grid array size is to be specified.
    +
    1516 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    1517 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    1518 C>
    +
    1519 C> @param[in] MSGA BUFR message.
    +
    1520 C> @param[inout] KPTR Array containing storage for following parameters.
    +
    1521 C> - 1: Unused.
    +
    1522 C> - 2: Unused.
    +
    1523 C> - 3: Length of pds.
    +
    1524 C> - 4: Length of gds.
    +
    1525 C> - 5: Length of bms.
    +
    1526 C> - 6: Length of bds.
    +
    1527 C> - 7: Value of current byte.
    +
    1528 C> - 8: Unused.
    +
    1529 C> - 9: Grib start byte nr.
    +
    1530 C> - 10: Grib/grid element count.
    +
    1531 C> @param[in] KPDS ARRAY CONTAINING PDS ELEMENTS.
    +
    1532 C> - 1: Id of center.
    +
    1533 C> - 2: Model identification.
    +
    1534 C> - 3: Grid identification.
    +
    1535 C> - 4: Gds/bms flag.
    +
    1536 C> - 5: Indicator of parameter.
    +
    1537 C> - 6: Type of level.
    +
    1538 C> - 7: Height/pressure , etc of level.
    +
    1539 C> - 8: Year of century.
    +
    1540 C> - 9: Month of year.
    +
    1541 C> - 10: Day of month.
    +
    1542 C> - 11: Hour of day.
    +
    1543 C> - 12: Minute of hour.
    +
    1544 C> - 13: Indicator of forecast time unit.
    +
    1545 C> - 14: Time range 1.
    +
    1546 C> - 15: Time range 2.
    +
    1547 C> - 16: Time range flag.
    +
    1548 C> - 17: Number included in average.
    +
    1549 C> - 18: Version nr of grib specification.
    +
    1550 C> @param[out] kgds array containing gds elements.
    +
    1551 C> - 1: data representation type
    +
    1552 C> - Latitude/longitude grids
    +
    1553 C> - 2: n(i) nr points on latitude circle
    +
    1554 C> - 3: n(j) nr points on longitude meridian
    +
    1555 C> - 4: la(1) latitude of origin
    +
    1556 C> - 5: lo(1) longitude of origin
    +
    1557 C> - 6: resolution flag
    +
    1558 C> - 7: la(2) latitude of extreme point
    +
    1559 C> - 8: lo(2) longitude of extreme point
    +
    1560 C> - 9: di longitudinal direction of increment
    +
    1561 C> - 10: dj latitundinal direction of increment
    +
    1562 C> - 11: scanning mode flag
    +
    1563 C> - Polar stereographic grids
    +
    1564 C> - 2: n(i) nr points along lat circle
    +
    1565 C> - 3: n(j) nr points along lon circle
    +
    1566 C> - 4: la(1) latitude of origin
    +
    1567 C> - 5: lo(1) longitude of origin
    +
    1568 C> - 6: reserved
    +
    1569 C> - 7: lov grid orientation
    +
    1570 C> - 8: dx - x direction increment
    +
    1571 C> - 9: dy - y direction increment
    +
    1572 C> - 10: projection center flag
    +
    1573 C> - 11: scanning mode
    +
    1574 C> - Spherical harmonic coefficients
    +
    1575 C> - 2: j pentagonal resolution parameter
    +
    1576 C> - 3: k pentagonal resolution parameter
    +
    1577 C> - 4: m pentagonal resolution parameter
    +
    1578 C> - 5: representation type
    +
    1579 C> - 6: coefficient storage mode
    +
    1580 C> - Mercator grids
    +
    1581 C> - 2: n(i) nr points on latitude circle
    +
    1582 C> - 3: n(j) nr points on longitude meridian
    +
    1583 C> - 4: la(1) latitude of origin
    +
    1584 C> - 5: lo(1) longitude of origin
    +
    1585 C> - 6: resolution flag
    +
    1586 C> - 7: la(2) latitude of last grid point
    +
    1587 C> - 8: lo(2) longitude of last grid point
    +
    1588 C> - 9: longit dir increment
    +
    1589 C> - 10: latit dir increment
    +
    1590 C> - 11: scanning mode flag
    +
    1591 C> - 12: latitude intersection
    +
    1592 C> - Lambert conformal grids
    +
    1593 C> - 2: nx nr points along x-axis
    +
    1594 C> - 3: ny nr points along y-axis
    +
    1595 C> - 4: la1 lat of origin (lower left)
    +
    1596 C> - 5: lo1 lon of origin (lower left)
    +
    1597 C> - 6: reserved
    +
    1598 C> - 7: lov - orientation of grid
    +
    1599 C> - 8: dx - x-dir increment
    +
    1600 C> - 9: dy - y-dir increment
    +
    1601 C> - 10: projection center flag
    +
    1602 C> - 11: scanning mode flag
    +
    1603 C> - 12: latin 1 - first lat from pole of secant cone inter
    +
    1604 C> - 13: latin 2 - second lat from pole of secant cone inter
    +
    1605 C> @param[out] KBMS Bitmap describing location of output elements..
    +
    1606 C> @param[out] KRET Error return.
    +
    1607 C>
    +
    1608 C> @note KRET
    +
    1609 C> - = 0 - No error.
    +
    1610 C> - = 5 - Grid not avail for center indicated.
    +
    1611 C> - = 10 - Incorrect center indicator.
    +
    1612 C>
    +
    1613 C> @author Bill Cavanaugh @date 1988-01-20
    +
    1614  SUBROUTINE ai084(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
    +
    1615 C
    +
    1616 C INCOMING MESSAGE HOLDER
    +
    1617  CHARACTER*1 MSGA(*)
    +
    1618 C
    +
    1619 C BIT MAP
    +
    1620  LOGICAL KBMS(*)
    +
    1621 C
    +
    1622 C ARRAY OF POINTERS AND COUNTERS
    +
    1623  INTEGER KPTR(10)
    +
    1624 C ARRAY OF POINTERS AND COUNTERS
    +
    1625  INTEGER KPDS(20)
    +
    1626  INTEGER KGDS(13)
    +
    1627 C
    +
    1628  INTEGER KRET
    +
    1629  INTEGER MASK(8)
    +
    1630 C ----------------------GRID 21 AND GRID 22 ARE THE SAME
    +
    1631  LOGICAL GRD21( 1369)
    +
    1632 C ----------------------GRID 23 AND GRID 24 ARE THE SAME
    +
    1633  LOGICAL GRD23( 1369)
    +
    1634  LOGICAL GRD25( 1368)
    +
    1635  LOGICAL GRD26( 1368)
    +
    1636 C ----------------------GRID 27 AND GRID 28 ARE THE SAME
    +
    1637 C ----------------------GRID 29 AND GRID 30 ARE THE SAME
    +
    1638 C ----------------------GRID 33 AND GRID 34 ARE THE SAME
    +
    1639  LOGICAL GRD50(1188)
    +
    1640 C -----------------------GRID 61 AND GRID 62 ARE THE SAME
    +
    1641  LOGICAL GRD61( 4186)
    +
    1642 C -----------------------GRID 63 AND GRID 64 ARE THE SAME
    +
    1643  LOGICAL GRD63( 4186)
    +
    1644 C
    +
    1645  DATA grd21 /1333*.true.,36*.false./
    +
    1646  DATA grd23 /.true.,36*.false.,1332*.true./
    +
    1647  DATA grd25 /1297*.true.,71*.false./
    +
    1648  DATA grd26 /.true.,71*.false.,1296*.true./
    +
    1649  DATA grd50/
    +
    1650 C LINE 1-4
    +
    1651  & 7*.false.,22*.true.,14*.false.,22*.true.,
    +
    1652  & 14*.false.,22*.true.,14*.false.,22*.true.,7*.false.,
    +
    1653 C LINE 5-8
    +
    1654  & 6*.false.,24*.true.,12*.false.,24*.true.,
    +
    1655  & 12*.false.,24*.true.,12*.false.,24*.true.,6*.false.,
    +
    1656 C LINE 9-12
    +
    1657  & 5*.false.,26*.true.,10*.false.,26*.true.,
    +
    1658  & 10*.false.,26*.true.,10*.false.,26*.true.,5*.false.,
    +
    1659 C LINE 13-16
    +
    1660  & 4*.false.,28*.true., 8*.false.,28*.true.,
    +
    1661  & 8*.false.,28*.true., 8*.false.,28*.true.,4*.false.,
    +
    1662 C LINE 17-20
    +
    1663  & 3*.false.,30*.true., 6*.false.,30*.true.,
    +
    1664  & 6*.false.,30*.true., 6*.false.,30*.true.,3*.false.,
    +
    1665 C LINE 21-24
    +
    1666  & 2*.false.,32*.true., 4*.false.,32*.true.,
    +
    1667  & 4*.false.,32*.true., 4*.false.,32*.true.,2*.false.,
    +
    1668 C LINE 25-28
    +
    1669  & .false.,34*.true., 2*.false.,34*.true.,
    +
    1670  & 2*.false.,34*.true., 2*.false.,34*.true., .false.,
    +
    1671 C LINE 29-33
    +
    1672  & 180*.true./
    +
    1673  DATA grd61 /4096*.true.,90*.false./
    +
    1674  DATA grd63 /.true.,90*.false.,4095*.true./
    +
    1675  DATA mask /128,64,32,16,8,4,2,1/
    +
    1676 C DATA MSK40 /Z00000040/
    +
    1677  DATA msk40 /64/
    +
    1678 C
    +
    1679  is = kptr(9)
    +
    1680  IF (kpds(18).EQ.0) THEN
    +
    1681  igribl = 4
    +
    1682  ELSE
    +
    1683  igribl = 8
    +
    1684  ENDIF
    +
    1685  iss = is + kptr(3) + kptr(4) + igribl
    +
    1686 C **********************************************************
    +
    1687 C IF THE FLAG IN PDS INDICATES THAT THERE IS NO BMS,
    +
    1688 C SET BIT MAP WITH ALL BITS ON
    +
    1689 C ELSE
    +
    1690 C RECOVER BIT MAP
    +
    1691 C THEN RETURN
    +
    1692 C **********************************************************
    +
    1693 C ---------------- NON-STANDARD GRID
    +
    1694  IF (kpds(3).EQ.255) THEN
    +
    1695  j = kgds(2) * kgds(3)
    +
    1696  kptr(10) = j
    +
    1697  DO 600 i = 1, j
    +
    1698  kbms(i) = .true.
    +
    1699  600 CONTINUE
    +
    1700  END IF
    +
    1701  IF (iand(kpds(4),msk40).EQ.0)THEN
    +
    1702 C PRINT *,' NO BIT MAP',MSK40,KPDS(4)
    +
    1703  GO TO 400
    +
    1704  ELSE
    +
    1705  print *,' HAVE A BIT MAP'
    +
    1706  END IF
    +
    1707 C ---------------- FLAG INDICATING PRESENCE OF BIT MAP IS ON
    +
    1708  IF (kgds(1).EQ.50) THEN
    +
    1709  print *,' W3AI08/AI084 WARNING - BIT MAP MAY NOT BE',
    +
    1710  * ' ASSOCIATED WITH SPHERICAL COEFFICIENTS'
    +
    1711  RETURN
    +
    1712  ENDIF
    +
    1713 C GET NUMBER OF UNUSED BITS
    +
    1714  iubits = mova2i(msga(iss+3))
    +
    1715 C SEE IF BIT MAP IS CONTAINED
    +
    1716  kflag = 0
    +
    1717  DO 150 i = 0, 1
    +
    1718  kflag = kflag * 256 + mova2i(msga(i+iss+4))
    +
    1719  150 CONTINUE
    +
    1720  print *,'KFLAG=',kflag
    +
    1721 C ----------------- IF KFLAG = 0 PICK UP NEW BIT MAP
    +
    1722 C ELSE
    +
    1723 C ------------------ USE PREDEFINED BIT MAP
    +
    1724  maxbyt = kptr(5) - 6
    +
    1725  IF (kflag.EQ.0) THEN
    +
    1726 C ------------------ UTILIZE BIT MAP FROM MESSAGE
    +
    1727  ii = 1
    +
    1728  DO 300 i = 1, maxbyt
    +
    1729  kcnt = mova2i(msga(i+iss+6))
    +
    1730  DO 200 k = 1, 8
    +
    1731  IF (iand(kcnt,mask(k)).NE.0) THEN
    +
    1732  kbms(ii) = .true.
    +
    1733  ELSE
    +
    1734  kbms(ii) = .false.
    +
    1735  END IF
    +
    1736  ii = ii + 1
    +
    1737  200 CONTINUE
    +
    1738  300 CONTINUE
    +
    1739  kptr(10) = 8 * (kptr(5) - 6) - iubits
    +
    1740  GO TO 900
    +
    1741  ELSE
    +
    1742  print *,'KFLAG SAYS USE STD BIT MAP',kflag
    +
    1743  END IF
    +
    1744 C ---------------------- PREDEFINED BIT MAP IS INDICATED
    +
    1745 C IF GRID NUMBER DOES NOT MATCH AN
    +
    1746 C EXISTING GRID, SET KRET TO 5 AND
    +
    1747 C ---------------------- RETURN.
    +
    1748  400 CONTINUE
    +
    1749  kret = 0
    +
    1750 C ---------------------- ECMWF MAP GRIDS
    +
    1751  IF (kpds(1).EQ.98) THEN
    +
    1752  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
    +
    1753  j = 1073
    +
    1754 C*** TEST FOR FULL HEMISPHERIC GRID ****
    +
    1755  IF (kptr(6) .GT. 2158) j= 1369
    +
    1756 C*** *** **** *** ***
    +
    1757  kptr(10) = j
    +
    1758  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1759  DO 1000 i = 1, j
    +
    1760  kbms(i) = .true.
    +
    1761  1000 CONTINUE
    +
    1762  ELSE IF (kpds(3).GE.13.AND.kpds(3).LE.16) THEN
    +
    1763  j = 361
    +
    1764  kptr(10) = j
    +
    1765  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1766  DO 1013 i = 1, j
    +
    1767  kbms(i) = .true.
    +
    1768  1013 CONTINUE
    +
    1769  ELSE
    +
    1770  kret = 5
    +
    1771  RETURN
    +
    1772  END IF
    +
    1773 C ---------------------- U.K. MET OFFICE BRACKNELL
    +
    1774  ELSE IF (kpds(1).EQ.74) THEN
    +
    1775  IF (kpds(3).EQ.21.OR.kpds(3).EQ.22) THEN
    +
    1776 C ----- INT'L GRIDS 21, 22 - MAP SIZE 1369
    +
    1777  j = 1369
    +
    1778  kptr(10) = j
    +
    1779  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1780  DO 3021 i = 1, 1369
    +
    1781  kbms(i) = grd21(i)
    +
    1782  3021 CONTINUE
    +
    1783  ELSE IF (kpds(3).EQ.23.OR.kpds(3).EQ.24) THEN
    +
    1784 C ----- INT'L GRIDS 23, 24 - MAP SIZE 1369
    +
    1785  j = 1369
    +
    1786  kptr(10) = j
    +
    1787  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1788  DO 3023 i = 1, 1369
    +
    1789  kbms(i) = grd23(i)
    +
    1790  3023 CONTINUE
    +
    1791  ELSE IF (kpds(3).EQ.25) THEN
    +
    1792 C ----- INT'L GRID 25 - MAP SIZE 1368
    +
    1793  j = 1368
    +
    1794  kptr(10) = j
    +
    1795  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1796  DO 3025 i = 1, 1368
    +
    1797  kbms(i) = grd25(i)
    +
    1798  3025 CONTINUE
    +
    1799  ELSE IF (kpds(3).EQ.26) THEN
    +
    1800 C ----- INT'L GRID 26 - MAP SIZE 1368
    +
    1801  j = 1368
    +
    1802  kptr(10) = j
    +
    1803  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1804  DO 3026 i = 1, 1368
    +
    1805  kbms(i) = grd26(i)
    +
    1806  3026 CONTINUE
    +
    1807  ELSE IF (kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
    +
    1808 C ----- INT'L GRIDS 61, 62 - MAP SIZE 4186
    +
    1809  j = 4186
    +
    1810  kptr(10) = j
    +
    1811  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1812  DO 3061 i = 1, 4186
    +
    1813  kbms(i) = grd61(i)
    +
    1814  3061 CONTINUE
    +
    1815  ELSE IF (kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
    +
    1816 C ----- INT'L GRIDS 63, 64 - MAP SIZE 4186
    +
    1817  j = 4186
    +
    1818  kptr(10) = j
    +
    1819  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1820  DO 3063 i = 1, 4186
    +
    1821  kbms(i) = grd63(i)
    +
    1822  3063 CONTINUE
    +
    1823  ELSE IF (kpds(3).EQ.70) THEN
    +
    1824 C ----- U.S. GRID 70 - MAP SIZE 16380
    +
    1825  j = 16380
    +
    1826  kptr(10) = j
    +
    1827  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1828  DO 3070 i = 1, j
    +
    1829  kbms(i) = .true.
    +
    1830  3070 CONTINUE
    +
    1831  ELSE
    +
    1832  kret = 5
    +
    1833  RETURN
    +
    1834  END IF
    +
    1835 C ---------------------- FNOC NAVY
    +
    1836  ELSE IF (kpds(1).EQ.58) THEN
    +
    1837  print *,' NO STANDARD FNOC GRID AT THIS TIME'
    +
    1838  RETURN
    +
    1839 C ---------------------- U.S. GRIDS
    +
    1840  ELSE IF (kpds(1).EQ.7) THEN
    +
    1841  IF (kpds(3).EQ.5) THEN
    +
    1842 C ----- U.S. GRID 5 - MAP SIZE 3021
    +
    1843  j = 3021
    +
    1844  kptr(10) = j
    +
    1845  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1846  DO 2005 i = 1, j
    +
    1847  kbms(i) = .true.
    +
    1848  2005 CONTINUE
    +
    1849  ELSE IF (kpds(3).EQ.6) THEN
    +
    1850 C ----- U.S. GRID 6 - MAP SIZE 2385
    +
    1851  j = 2385
    +
    1852  kptr(10) = j
    +
    1853  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1854  DO 2006 i = 1, j
    +
    1855  kbms(i) = .true.
    +
    1856  2006 CONTINUE
    +
    1857  ELSE IF (kpds(3).EQ.21.OR.kpds(3).EQ.22) THEN
    +
    1858 C ----- U.S. GRIDS 21, 22 - MAP SIZE 1369
    +
    1859  j = 1369
    +
    1860  kptr(10) = j
    +
    1861  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1862  DO 2021 i = 1, 1369
    +
    1863  kbms(i) = grd21(i)
    +
    1864  2021 CONTINUE
    +
    1865  ELSE IF (kpds(3).EQ.23.OR.kpds(3).EQ.24) THEN
    +
    1866 C ----- U.S GRIDS 23, 24 - MAP SIZE 1369
    +
    1867  j = 1369
    +
    1868  kptr(10) = j
    +
    1869  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1870  DO 2023 i = 1, 1369
    +
    1871  kbms(i) = grd23(i)
    +
    1872  2023 CONTINUE
    +
    1873  ELSE IF (kpds(3).EQ.25) THEN
    +
    1874 C ----- U.S. GRID 25 - MAP SIZE 1368
    +
    1875  j = 1368
    +
    1876  kptr(10) = j
    +
    1877  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1878  DO 2025 i = 1, 1368
    +
    1879  kbms(i) = grd25(i)
    +
    1880  2025 CONTINUE
    +
    1881  ELSE IF (kpds(3).EQ.26) THEN
    +
    1882 C ----- U.S.GRID 26 - MAP SIZE 1368
    +
    1883  j = 1368
    +
    1884  kptr(10) = j
    +
    1885  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1886  DO 2026 i = 1, 1368
    +
    1887  kbms(i) = grd26(i)
    +
    1888  2026 CONTINUE
    +
    1889  ELSE IF (kpds(3).EQ.27.OR.kpds(3).EQ.28) THEN
    +
    1890 C ----- U.S. GRIDS 27, 28 - MAP SIZE 4225
    +
    1891  j = 4225
    +
    1892  kptr(10) = j
    +
    1893  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1894  DO 2027 i = 1, j
    +
    1895  kbms(i) = .true.
    +
    1896  2027 CONTINUE
    +
    1897  ELSE IF (kpds(3).EQ.29.OR.kpds(3).EQ.30)THEN
    +
    1898 C ----- U.S. GRIDS 29,30 - MAP SIZE 5365
    +
    1899  j = 5365
    +
    1900  kptr(10) = j
    +
    1901  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1902  DO 2029 i = 1, j
    +
    1903  kbms(i) = .true.
    +
    1904  2029 CONTINUE
    +
    1905  ELSE IF (kpds(3).EQ.33.OR.kpds(3).EQ.34) THEN
    +
    1906 C ----- U.S GRID 33, 34 - MAP SIZE 8326 (181 X 46)
    +
    1907  j = 8326
    +
    1908  kptr(10) = j
    +
    1909  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1910  DO 2033 i = 1, j
    +
    1911  kbms(i) = .true.
    +
    1912  2033 CONTINUE
    +
    1913  ELSE IF (kpds(3).EQ.50) THEN
    +
    1914 C ----- U.S. GRID 50 - MAP SIZE 964
    +
    1915  j = 1188
    +
    1916  kptr(10) = j
    +
    1917  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1918  DO 2050 i = 1, 1188
    +
    1919  kbms(i) = grd50(i)
    +
    1920  2050 CONTINUE
    +
    1921  ELSE IF (kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
    +
    1922 C ----- U.S. GRIDS 61, 62 - MAP SIZE 4186
    +
    1923  j = 4186
    +
    1924  kptr(10) = j
    +
    1925  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1926  DO 2061 i = 1, 4186
    +
    1927  kbms(i) = grd61(i)
    +
    1928  2061 CONTINUE
    +
    1929  ELSE IF (kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
    +
    1930 C ----- U.S. GRIDS 63, 64 - MAP SIZE 4186
    +
    1931  j = 4186
    +
    1932  kptr(10) = j
    +
    1933  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1934  DO 2063 i = 1, 4186
    +
    1935  kbms(i) = grd63(i)
    +
    1936  2063 CONTINUE
    +
    1937  ELSE IF (kpds(3).EQ.70) THEN
    +
    1938 C ----- U.S. GRID 70 - MAP SIZE 16380
    +
    1939  j = 16380
    +
    1940  kptr(10) = j
    +
    1941  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1942  DO 2070 i = 1, j
    +
    1943  kbms(i) = .true.
    +
    1944  2070 CONTINUE
    +
    1945  ELSE IF (kpds(3).EQ.85.OR.kpds(3).EQ.86) THEN
    +
    1946 C ----- U.S. GRIDS 85, 86 - MAP SIZE 32400 (360 X 90)
    +
    1947  j = 32400
    +
    1948  kptr(10) = j
    +
    1949  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1950  DO 2085 i = 1, j
    +
    1951  kbms(i) = .true.
    +
    1952  2085 CONTINUE
    +
    1953  ELSE IF (kpds(3).EQ.100) THEN
    +
    1954 C ----- U.S. GRID 100 - MAP SIZE 6889 (83 X 83)
    +
    1955  j = 6889
    +
    1956  kptr(10) = j
    +
    1957  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1958  DO 1100 i = 1, j
    +
    1959  kbms(i) = .true.
    +
    1960  1100 CONTINUE
    +
    1961  ELSE IF (kpds(3).EQ.101) THEN
    +
    1962 C ----- U.S. GRID 101 - MAP SIZE 10283 (113 X 91)
    +
    1963  j = 10283
    +
    1964  kptr(10) = j
    +
    1965  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1966  DO 2101 i = 1, j
    +
    1967  kbms(i) = .true.
    +
    1968  2101 CONTINUE
    +
    1969  ELSE IF (kpds(3).EQ.102) THEN
    +
    1970 C ----- U.S. GRID 102 - MAP SIZE 14375 (115 X 125)
    +
    1971  j = 14375
    +
    1972  kptr(10) = j
    +
    1973  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1974  DO 2102 i = 1, j
    +
    1975  kbms(i) = .true.
    +
    1976  2102 CONTINUE
    +
    1977  ELSE IF (kpds(3).EQ.103) THEN
    +
    1978 C ----- U.S. GRID 103 - MAP SIZE 3640 (65 X 56)
    +
    1979  j = 3640
    +
    1980  kptr(10) = j
    +
    1981  CALL ai087(*900,j,kpds,kgds,kret)
    +
    1982  DO 2103 i = 1, j
    +
    1983  kbms(i) = .true.
    +
    1984  2103 CONTINUE
    +
    1985  ELSE IF (kpds(3).GE.201.AND.kpds(3).LE.214) THEN
    +
    1986  IF (kpds(3).EQ.201) j = 4225
    +
    1987  IF (kpds(3).EQ.202) j = 2795
    +
    1988  IF (kpds(3).EQ.203) j = 1755
    +
    1989  IF (kpds(3).EQ.204) j = 5609
    +
    1990  IF (kpds(3).EQ.205) j = 1755
    +
    1991  IF (kpds(3).EQ.206) j = 2091
    +
    1992  IF (kpds(3).EQ.207) j = 1715
    +
    1993  IF (kpds(3).EQ.208) j = 625
    +
    1994  IF (kpds(3).EQ.209) j = 8181
    +
    1995  IF (kpds(3).EQ.210) j = 625
    +
    1996  IF (kpds(3).EQ.211) j = 2915
    +
    1997  IF (kpds(3).EQ.212) j = 4225
    +
    1998  IF (kpds(3).EQ.213) j = 10965
    +
    1999  IF (kpds(3).EQ.214) j = 6693
    +
    2000  kptr(10) = j
    +
    2001  CALL ai087(*900,j,kpds,kgds,kret)
    +
    2002  DO 2201 i = 1, j
    +
    2003  kbms(i) = .true.
    +
    2004  2201 CONTINUE
    +
    2005  ELSE
    +
    2006  kret = 5
    +
    2007  RETURN
    +
    2008  END IF
    +
    2009  ELSE
    +
    2010  kret = 10
    +
    2011  RETURN
    +
    2012  END IF
    +
    2013  900 CONTINUE
    +
    2014  RETURN
    +
    2015  END
    +
    2016 
    +
    2017 C> Extract grib data and place into output arry in proper position.
    +
    2018 C>
    +
    2019 C> Program history log:
    +
    2020 C> - Bill Cavanaugh 1988-01-20
    +
    2021 C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
    +
    2022 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    2023 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    2024 C>
    +
    2025 C> @param[in] MSGA Array containing grib message.
    +
    2026 C> @param[inout] KPTR Array containing storage for following parameters.
    +
    2027 C> - 1: Unused.
    +
    2028 C> - 2: Unused.
    +
    2029 C> - 3: Length of pds.
    +
    2030 C> - 4: Length of gds.
    +
    2031 C> - 5: Length of bms.
    +
    2032 C> - 6: Length of bds.
    +
    2033 C> - 7: Value of current byte.
    +
    2034 C> - 8: Unused.
    +
    2035 C> - 9: Grib start byte nr.
    +
    2036 C> - 10: Grib/grid element count.
    +
    2037 C> @param[in] KPDS Array containing pds elements.
    +
    2038 C> - 1: Id of center.
    +
    2039 C> - 2: Model identification.
    +
    2040 C> - 3: Grid identification.
    +
    2041 C> - 4: Gds/bms flag.
    +
    2042 C> - 5: Indicator of parameter.
    +
    2043 C> - 6: Type of level.
    +
    2044 C> - 7: Height/pressure , etc of level.
    +
    2045 C> - 8: Year of century.
    +
    2046 C> - 9: Month of year.
    +
    2047 C> - 10: Day of month.
    +
    2048 C> - 11: Hour of day.
    +
    2049 C> - 12: Minute of hour.
    +
    2050 C> - 13: Indicator of forecast time unit.
    +
    2051 C> - 14: Time range 1.
    +
    2052 C> - 15: Time range 2.
    +
    2053 C> - 16: Time range flag.
    +
    2054 C> - 17: Number included in average.
    +
    2055 C> - 18: Version nr of grib specification.
    +
    2056 C> @param[in] KBMS Bitmap describing location of output elements.
    +
    2057 C> @param[out] DATA Real array of gridded elements in grib message.
    +
    2058 C> @param[out] KRET Error return.
    +
    2059 C>
    +
    2060 C> @note Error return.
    +
    2061 C> - 3 = Unpacked field is larger than 32768.
    +
    2062 C> - 6 = Does not match nr of entries for this grib/grid.
    +
    2063 C> - 7 = Number of bits in fill too large.
    +
    2064 C>
    +
    2065 C> @author Bill Cavanaugh @date 1988-01-20
    +
    2066  SUBROUTINE ai085(MSGA,KPTR,KPDS,KBMS,DATA,KRET)
    +
    2067 C *************************************************************
    +
    2068  CHARACTER*1 MSGA(*)
    +
    2069  CHARACTER*1 KREF(8)
    +
    2070  CHARACTER*1 KK(8)
    +
    2071 C
    +
    2072  LOGICAL KBMS(*)
    +
    2073 C
    +
    2074  INTEGER KPDS(*)
    +
    2075  INTEGER KPTR(*)
    +
    2076  INTEGER NRBITS
    +
    2077  INTEGER KSAVE(105000)
    +
    2078  INTEGER KSCALE
    +
    2079 C
    +
    2080  REAL DATA(*)
    +
    2081  REAL REFNCE
    +
    2082  REAL SCALE
    +
    2083  REAL REALKK
    +
    2084 C
    +
    2085  LOGICAL IBM370
    +
    2086 C
    +
    2087  equivalence(refnce,kref(1),iref)
    +
    2088  equivalence(kk(1),realkk,ikk)
    +
    2089 C
    +
    2090 C DATA MSK0F /Z0000000F/
    +
    2091 C DATA MSK80 /Z00000080/
    +
    2092 C DATA MSK40 /Z00000040/
    +
    2093 C
    +
    2094  DATA msk0f /15/
    +
    2095  DATA msk80 /128/
    +
    2096  DATA msk40 /64/
    +
    2097 C
    +
    2098 C *************************************************************
    +
    2099  kret = 0
    +
    2100  is = kptr(9)
    +
    2101  iss = is + kptr(3) + kptr(4) + kptr(5) + 4
    +
    2102 C BYTE 4
    +
    2103  kspl = mova2i(msga(iss+3))
    +
    2104 C POINT TO BYTE 5 OF BDS
    +
    2105 C
    +
    2106 C ------------- GET SCALE FACTOR
    +
    2107 C
    +
    2108  kscale = 0
    +
    2109  DO 100 i = 0, 1
    +
    2110  kscale = kscale * 256 + mova2i(msga(i+iss+4))
    +
    2111  100 CONTINUE
    +
    2112  IF (iand(kscale,32768).NE.0) THEN
    +
    2113  kscale = - iand(kscale,32767)
    +
    2114  END IF
    +
    2115  scale = 2.0**kscale
    +
    2116 C
    +
    2117 C ------------ GET REFERENCE VALUE
    +
    2118 C
    +
    2119  iref = 0
    +
    2120  DO 200 i = 0, 3
    +
    2121  kref(i+1) = msga(i+iss+6)
    +
    2122  200 CONTINUE
    +
    2123 C
    +
    2124 C THE FLOATING POINT NUMBER IN THE REFERENCE VALUE IS AN IBM370
    +
    2125 C 32 BIT NUMBER, IF YOUR COMPUTER IS NOT AN IBM370 OR CLONE
    +
    2126 C SET IBM370 TO .FALSE. SO THE NUMBER IS CONVERTED TO A F.P.
    +
    2127 C NUMBER OF YOUR MACHINE TYPE.
    +
    2128 C
    +
    2129  ibm370 = .false.
    +
    2130 C
    +
    2131  IF (.NOT.ibm370) THEN
    +
    2132  koff = 0
    +
    2133 C GET 1 BIT SIGN
    +
    2134  CALL gbyte(iref,isgn,0,1)
    +
    2135 C GET 7 BIT EXPONENT
    +
    2136  CALL gbyte(iref,iexp,1,7)
    +
    2137 C GET 24 BIT FRACTION
    +
    2138  CALL gbyte(iref,ifr,8,24)
    +
    2139  IF (ifr.EQ.0.OR.iexp.EQ.0) THEN
    +
    2140  refnce = 0.0
    +
    2141  ELSE
    +
    2142  refnce = float(ifr) * 16.0 ** (iexp-64-6)
    +
    2143  IF (isgn.NE.0) refnce = - refnce
    +
    2144  ENDIF
    +
    2145  ENDIF
    +
    2146 C
    +
    2147 C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
    +
    2148 C
    +
    2149  kbits = mova2i(msga(iss+10))
    +
    2150  kentry = kptr(10)
    +
    2151 C
    +
    2152 C ------------- MAX SIZE CHECK
    +
    2153 C
    +
    2154  IF (kentry.GT.105000) THEN
    +
    2155  kret = 3
    +
    2156  RETURN
    +
    2157  END IF
    +
    2158  IF (kbits.EQ.0) THEN
    +
    2159 C
    +
    2160 C -------------------- HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE
    +
    2161 C
    +
    2162  DO 210 i = 1, kentry
    +
    2163  DATA(i) = 0.0
    +
    2164  IF (kbms(i)) THEN
    +
    2165  DATA(i) = refnce
    +
    2166  END IF
    +
    2167  210 CONTINUE
    +
    2168  GO TO 900
    +
    2169  END IF
    +
    2170 C
    +
    2171 C --------------------
    +
    2172 C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
    +
    2173 C ENTRIES.
    +
    2174 C
    +
    2175 C ------------- UNUSED BITS IN DATA AREA
    +
    2176 C
    +
    2177  lessbt = iand(kspl,msk0f)
    +
    2178 C
    +
    2179 C ------------- NUMBER OF BYTES IN DATA AREA
    +
    2180 C
    +
    2181  nrbyte = kptr(6) - 11
    +
    2182 C
    +
    2183 C ------------- TOTAL NR OF USABLE BITS
    +
    2184 C
    +
    2185  nrbits = nrbyte * 8 - lessbt
    +
    2186 C
    +
    2187 C ------------- TOTAL NR OF ENTRIES
    +
    2188 C
    +
    2189  kentry = nrbits / kbits
    +
    2190 C
    +
    2191 C ------------- MAX SIZE CHECK
    +
    2192 C
    +
    2193  IF (kentry.GT.105000) THEN
    +
    2194  kret = 3
    +
    2195  RETURN
    +
    2196  END IF
    +
    2197 C
    +
    2198  ibms = iand(kpds(4),msk40)
    +
    2199 C
    +
    2200 C -------------- CHECK TO SEE IF PROCESSING COEFFICIENTS
    +
    2201 C IF YES,
    +
    2202 C GO AND PROCESS AS SUCH
    +
    2203 C ELSE
    +
    2204 C CONTINUE PROCESSING
    +
    2205 C
    +
    2206  IF (iand(kspl,msk80).EQ.0) THEN
    +
    2207 C
    +
    2208 C ------------- SET POINTERS
    +
    2209 C
    +
    2210 C XMOVEX MOVES THE DATA TO MAKE SURE IT IS ON A INTEGER WORD
    +
    2211 C BOUNDARY, ON SOME COMPUTERS THIS DOES NOT HAVE TO BE DONE.
    +
    2212 C (IBM PC, VAX)
    +
    2213 C
    +
    2214 C CALL XMOVEX(MSGB,MSGA(ISS+11),NRBYTE)
    +
    2215 C ------------- UNPACK ALL FIELDS
    +
    2216  koff = 0
    +
    2217 C
    +
    2218 C THE BIT UNPACKER W3AI41 WILL CONSUME MOST OF THE CPU TIME
    +
    2219 C CONVERTING THE GRIB DATA. FOR THE IBM370 WE HAVE AN
    +
    2220 C ASSEMBLER AND FORTRAN VERSION. THE ASSMBLER VERSION WILL
    +
    2221 C RUN TWO TO THREE TIMES FASTER. THE FORTRAN VERSION IS TO
    +
    2222 C MAKE THE CODE MORE PORTABLE. FOR A VAX OR IBM PC WE HAVE
    +
    2223 C ANOTHER VERSION, IT REVERSED THE ORDER OF THE BYTES IN
    +
    2224 C AN INTEGER WORD. W3AI41 CAN BE REPLACED BY NCAR GBYTES
    +
    2225 C BIT UNPACKER. NCAR HAS A LARGE NUMBER OF VERSIONS OF GBYTES
    +
    2226 C IN FORTRAN AN ASSEMBLER FOR A NUMBER OF DIFFERENT BRANDS OF
    +
    2227 C COMPUTERS. THEY ALSO HAVE A C VERSION.
    +
    2228 C
    +
    2229 C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
    +
    2230 C
    +
    2231 C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
    +
    2232 C INTEGER WORD BOUNDARY
    +
    2233 C
    +
    2234  lll = mod(iss+10,8)
    +
    2235  nnn = 11 - lll
    +
    2236  koff = lll * 8
    +
    2237  CALL gbytes(msga(iss+nnn),ksave,koff,kbits,0,kentry)
    +
    2238 C
    +
    2239 C ------------- CORRECTLY PLACE ALL ENTRIES
    +
    2240 C
    +
    2241  ii = 1
    +
    2242  kentry = kptr(10)
    +
    2243  DO 500 i = 1, kentry
    +
    2244  IF (kbms(i)) THEN
    +
    2245  DATA(i) = refnce + float(ksave(ii)) * scale
    +
    2246  ii = ii + 1
    +
    2247  ELSE
    +
    2248  DATA(i) = 0.0
    +
    2249  END IF
    +
    2250  500 CONTINUE
    +
    2251  GO TO 900
    +
    2252  END IF
    +
    2253 C
    +
    2254 C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS
    +
    2255 C
    +
    2256  ikk = 0
    +
    2257  DO 5500 i = 0, 3
    +
    2258  kk(i+1) = msga(i+iss+11)
    +
    2259  5500 CONTINUE
    +
    2260 C
    +
    2261  IF (.NOT.ibm370) THEN
    +
    2262  koff = 0
    +
    2263 C GET 1 BIT SIGN
    +
    2264  CALL gbyte(ikk,isgn,0,1)
    +
    2265 C GET 7 BIT EXPONENT
    +
    2266  CALL gbyte(ikk,iexp,1,7)
    +
    2267 C GET 24 BIT FRACTION
    +
    2268  CALL gbyte(ikk,ifr,8,24)
    +
    2269  IF (ifr.EQ.0.OR.iexp.EQ.0) THEN
    +
    2270  realkk = 0.0
    +
    2271  ELSE
    +
    2272  realkk = float(ifr) * 16.0 ** (iexp-64-6)
    +
    2273  IF (isgn.NE.0) realkk = - realkk
    +
    2274  ENDIF
    +
    2275  ENDIF
    +
    2276 C
    +
    2277  DATA(1) = realkk
    +
    2278  koff = 0
    +
    2279 C CALL XMOVEX(MSGB,MSGA(ISS+15),NRBYTE)
    +
    2280 C ------------- UNPACK ALL FIELDS
    +
    2281 C
    +
    2282 C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
    +
    2283 C
    +
    2284 C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
    +
    2285 C INTEGER WORD BOUNDARY
    +
    2286 C
    +
    2287  lll = mod(iss+14,8)
    +
    2288  nnn = 15 - lll
    +
    2289  koff = lll * 8
    +
    2290 C
    +
    2291  CALL gbytes(msga(iss+nnn),ksave,koff,kbits,0,kentry)
    +
    2292 C
    +
    2293 C --------------
    +
    2294  DO 6000 i = 1, kentry
    +
    2295  DATA(i+1) = refnce + float(ksave(i)) * scale
    +
    2296  6000 CONTINUE
    +
    2297  900 CONTINUE
    +
    2298  RETURN
    +
    2299  END
    +
    2300 
    +
    2301 
    +
    2302 C> Extract grib data (version 1) and place into proper position in output array.
    +
    2303 C>
    +
    2304 C> Program history log:
    +
    2305 C> - Bill Cavanaugh 1989-11-20
    +
    2306 C> - Ralph Jones 1990-09-01 Change's for ansi fortran.
    +
    2307 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    2308 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    2309 C>
    +
    2310 C> @param[in] MSGA Array containing grib message.
    +
    2311 C> @param[inout] KPTR Array containing storage for following parameters.
    +
    2312 C> - 1:Unused.
    +
    2313 C> - 2:Unused.
    +
    2314 C> - 3:Length of pds.
    +
    2315 C> - 4:Length of gds.
    +
    2316 C> - 5:Length of bms.
    +
    2317 C> - 6:Length of bds.
    +
    2318 C> - 7:Value of current byte.
    +
    2319 C> - 8:Unused.
    +
    2320 C> - 9:Grib start byte nr.
    +
    2321 C> - 10:Grib/grid element count.
    +
    2322 C> @param[in] KPDS Array containing pds elements. (version 1)
    +
    2323 C> - 1: Id of center.
    +
    2324 C> - 2: Model identification.
    +
    2325 C> - 3: Grid identification.
    +
    2326 C> - 4: Gds/bms flag.
    +
    2327 C> - 5: Indicator of parameter.
    +
    2328 C> - 6: Type of level.
    +
    2329 C> - 7: Height/pressure , etc of level.
    +
    2330 C> - 8: Year including century.
    +
    2331 C> - 9: Month of year.
    +
    2332 C> - 10: Day of month.
    +
    2333 C> - 11: Hour of day.
    +
    2334 C> - 12: Minute of hour.
    +
    2335 C> - 13: Indicator of forecast time unit.
    +
    2336 C> - 14: Time range 1.
    +
    2337 C> - 15: Time range 2.
    +
    2338 C> - 16: Time range flag.
    +
    2339 C> - 17: Number included in average.
    +
    2340 C> - 18: Version nr of grib specification.
    +
    2341 C> - 19: Version nr of parameter table.
    +
    2342 C> - 20: Total length of grib message (including section 0).
    +
    2343 C> @param[in] KBMS Bitmap describing location of output elements.
    +
    2344 C> @param[out] DATA Real array of gridded elements in grib message.
    +
    2345 C> @param[out] KRET Error return.
    +
    2346 C>
    +
    2347 C> @note Structure of binary data section (version 1)
    +
    2348 C> - 1-3: LENGTH OF SECTION
    +
    2349 C> - 4: PACKING FLAGS
    +
    2350 C> - 5-6: SCALE FACTOR
    +
    2351 C> - 7-10: REFERENCE VALUE
    +
    2352 C> - 11: NUMBER OF BIT FOR EACH VALUE
    +
    2353 C> - 12s-N: DATA
    +
    2354 C>
    +
    2355 C> @note Error return:
    +
    2356 C> - 3 = Unpacked field is larger than 32768.
    +
    2357 C> - 6 = Does not match nr of entries for this grib/grid.
    +
    2358 C> - 7 = Number of bits in fill too large.
    +
    2359 C>
    +
    2360 C> @author Bill Cavanaugh @date 1989-11-20
    +
    2361  SUBROUTINE ai085a(MSGA,KPTR,KPDS,KBMS,DATA,KRET)
    +
    2362 C *************************************************************
    +
    2363  CHARACTER*1 MSGA(*)
    +
    2364  CHARACTER*1 KREF(8)
    +
    2365  CHARACTER*1 KK(8)
    +
    2366 C
    +
    2367  LOGICAL KBMS(*)
    +
    2368 C
    +
    2369  INTEGER KPDS(*)
    +
    2370  INTEGER KPTR(*)
    +
    2371  INTEGER NRBITS
    +
    2372  INTEGER KSAVE(105000)
    +
    2373  INTEGER KSCALE
    +
    2374 C
    +
    2375  REAL DATA(*)
    +
    2376  REAL REFNCE
    +
    2377  REAL SCALE
    +
    2378  REAL REALKK
    +
    2379 C
    +
    2380  LOGICAL IBM370
    +
    2381 C
    +
    2382  equivalence(refnce,kref(1),iref)
    +
    2383  equivalence(kk(1),realkk,ikk)
    +
    2384 C
    +
    2385 C DATA MSK0F /Z0000000F/
    +
    2386 C DATA MSK40 /Z00000040/
    +
    2387 C DATA MSK80 /Z00000080/
    +
    2388 C
    +
    2389  DATA msk0f /15/
    +
    2390  DATA msk40 /64/
    +
    2391  DATA msk80 /128/
    +
    2392 C
    +
    2393 C *************************************************************
    +
    2394 C
    +
    2395  kret = 0
    +
    2396  is = kptr(9)
    +
    2397  igribl = 8
    +
    2398  iss = is + kptr(3) + kptr(4) + kptr(5) + igribl
    +
    2399 C BYTE 4
    +
    2400  kspl = mova2i(msga(iss+3))
    +
    2401 C
    +
    2402 C ------------- POINT TO BYTE 5 OF BDS
    +
    2403 C
    +
    2404 C ------------- GET SCALE FACTOR
    +
    2405 C
    +
    2406  kscale = 0
    +
    2407  DO 100 i = 0, 1
    +
    2408  kscale = kscale * 256 + mova2i(msga(i+iss+4))
    +
    2409  100 CONTINUE
    +
    2410  IF (iand(kscale,32768).NE.0) THEN
    +
    2411  kscale = - iand(kscale,32767)
    +
    2412  END IF
    +
    2413  scale = 2.0**kscale
    +
    2414 C
    +
    2415 C -------------------- DECIMAL SCALE EXPONENT
    +
    2416 C
    +
    2417  idec = is + igribl + 26
    +
    2418  jscale = 0
    +
    2419  DO 150 i = 0, 1
    +
    2420  jscale = jscale * 256 + mova2i(msga(i+idec))
    +
    2421  150 CONTINUE
    +
    2422 C IF HIGH ORDER BIT IS ON, HAVE NEGATIVE EXPONENT
    +
    2423  IF (iand(jscale,32768).NE.0) THEN
    +
    2424  jscale = - iand(jscale,32767)
    +
    2425  END IF
    +
    2426  ascale = 10.0 ** jscale
    +
    2427 C
    +
    2428 C ------------ GET REFERENCE VALUE
    +
    2429 C
    +
    2430  iref = 0
    +
    2431  DO 200 i = 0, 3
    +
    2432  kref(i+1) = msga(i+iss+6)
    +
    2433  200 CONTINUE
    +
    2434 C
    +
    2435 C THE FLOATING POINT NUMBER IN THE REFERENCE VALUE IS AN IBM370
    +
    2436 C 32 BIT NUMBER, IF YOUR COMPUTER IS NOT AN IBM370 OR CLONE
    +
    2437 C SET IBM370 TO .FALSE. SO THE NUMBER IS CONVERTED TO A F.P.
    +
    2438 C NUMBER OF YOUR MACHINE TYPE.
    +
    2439 C
    +
    2440  ibm370 = .false.
    +
    2441 C
    +
    2442  IF (.NOT.ibm370) THEN
    +
    2443  koff = 0
    +
    2444 C GET 1 BIT SIGN
    +
    2445  CALL gbyte(iref,isgn,0,1)
    +
    2446 C GET 7 BIT EXPONENT
    +
    2447  CALL gbyte(iref,iexp,1,7)
    +
    2448 C GET 24 BIT FRACTION
    +
    2449  CALL gbyte(iref,ifr,8,24)
    +
    2450  IF (ifr.EQ.0.OR.iexp.EQ.0) THEN
    +
    2451  refnce = 0.0
    +
    2452  ELSE
    +
    2453  refnce = float(ifr) * 16.0 ** (iexp-64-6)
    +
    2454  IF (isgn.NE.0) refnce = - refnce
    +
    2455  ENDIF
    +
    2456  ENDIF
    +
    2457 C
    +
    2458 C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
    +
    2459 C
    +
    2460  kbits = mova2i(msga(iss+10))
    +
    2461  kentry = kptr(10)
    +
    2462 C
    +
    2463 C ------------- MAX SIZE CHECK
    +
    2464 C
    +
    2465  IF (kentry.GT.105000) THEN
    +
    2466  kret = 3
    +
    2467  RETURN
    +
    2468  END IF
    +
    2469 C
    +
    2470  IF (kbits.EQ.0) THEN
    +
    2471 C
    +
    2472 C -------------------- HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE
    +
    2473 C
    +
    2474  DO 210 i = 1, kentry
    +
    2475  DATA(i) = 0.0
    +
    2476  IF (kbms(i)) THEN
    +
    2477  DATA(i) = refnce
    +
    2478  END IF
    +
    2479  210 CONTINUE
    +
    2480  GO TO 900
    +
    2481  END IF
    +
    2482 C
    +
    2483 C --------------------
    +
    2484 C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
    +
    2485 C ENTRIES.
    +
    2486 C
    +
    2487 C ------------- UNUSED BITS IN DATA AREA
    +
    2488 C
    +
    2489  lessbt = iand(kspl,msk0f)
    +
    2490 C
    +
    2491 C ------------- NUMBER OF BYTES IN DATA AREA
    +
    2492 C
    +
    2493  nrbyte = kptr(6) - 11
    +
    2494 C
    +
    2495 C ------------- TOTAL NR OF USABLE BITS
    +
    2496 C
    +
    2497  nrbits = nrbyte * 8 - lessbt
    +
    2498 C
    +
    2499 C ------------- TOTAL NR OF ENTRIES
    +
    2500 C
    +
    2501  kentry = nrbits / kbits
    +
    2502 C
    +
    2503 C ------------- MAX SIZE CHECK
    +
    2504 C
    +
    2505  IF (kentry.GT.105000) THEN
    +
    2506  kret = 3
    +
    2507  RETURN
    +
    2508  END IF
    +
    2509  ibms = iand(kpds(4),msk40)
    +
    2510 C
    +
    2511 C -------------- CHECK TO SEE IF PROCESSING COEFFICIENTS
    +
    2512 C IF YES,
    +
    2513 C GO AND PROCESS AS SUCH
    +
    2514 C ELSE
    +
    2515 C CONTINUE PROCESSING
    +
    2516  IF (iand(kspl,msk80).EQ.0) THEN
    +
    2517 C
    +
    2518 C ------------- SET POINTERS
    +
    2519 C
    +
    2520 C REPLACE XMOVEX AND W3AI41 WITH GBYTES
    +
    2521 C CALL XMOVEX(MSGB,MSGA(ISS+11),NRBYTE)
    +
    2522 C
    +
    2523 C ------------- UNPACK ALL FIELDS
    +
    2524 C
    +
    2525  koff = 0
    +
    2526 C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
    +
    2527 C
    +
    2528 C THE BIT UNPACKER W3AI41 WILL CONSUME MOST OF THE CPU TIME
    +
    2529 C CONVERTING THE GRIB DATA. FOR THE IBM370 WE HAVE AN
    +
    2530 C ASSEMBLER AND FORTRAN VERSION. THE ASSMBLER VERSION WILL
    +
    2531 C RUN TWO TO THREE TIMES FASTER. THE FORTRAN VERSION IS TO
    +
    2532 C MAKE THE CODE MORE PORTABLE. FOR A VAX OR IBM PC WE HAVE
    +
    2533 C ANOTHER VERSION, IT REVERSED THE ORDER OF THE BYTES IN
    +
    2534 C AN INTEGER WORD. W3AI41 CAN BE REPLACED BY NCAR GBYTES
    +
    2535 C BIT UNPACKER. NCAR HAS A LARGE NUMBER OF VERSIONS OF GBYTES
    +
    2536 C IN FORTRAN AND ASSEMBLER FOR A NUMBER OF DIFFERENT BRANDS OF
    +
    2537 C COMPUTERS. THEY ALSO HAVE A C VERSION.
    +
    2538 C
    +
    2539 C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
    +
    2540 C INTEGER WORD BOUNDARY
    +
    2541 C
    +
    2542  lll = mod(iss+10,8)
    +
    2543  nnn = 11 - lll
    +
    2544  koff = lll * 8
    +
    2545 C
    +
    2546  CALL gbytes(msga(iss+nnn),ksave,koff,kbits,0,kentry)
    +
    2547 C
    +
    2548 C ------------- CORRECTLY PLACE ALL ENTRIES
    +
    2549 C
    +
    2550  ii = 1
    +
    2551  kentry = kptr(10)
    +
    2552  DO 500 i = 1, kentry
    +
    2553  IF (kbms(i)) THEN
    +
    2554 C MUST INCLUDE DECIMAL SCALE
    +
    2555  DATA(i) = (refnce + float(ksave(ii)) * scale) / ascale
    +
    2556  ii = ii + 1
    +
    2557  ELSE
    +
    2558  DATA(i) = 0.0
    +
    2559  END IF
    +
    2560  500 CONTINUE
    +
    2561  GO TO 900
    +
    2562  END IF
    +
    2563 C
    +
    2564 C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS
    +
    2565 C
    +
    2566  ikk = 0
    +
    2567  DO 5500 i = 0, 3
    +
    2568  kk(i+1) = msga(i+iss+11)
    +
    2569  5500 CONTINUE
    +
    2570 C
    +
    2571  IF (.NOT.ibm370) THEN
    +
    2572  koff = 0
    +
    2573 C GET 1 BIT SIGN
    +
    2574  CALL gbyte(ikk,isgn,0,1)
    +
    2575 C GET 7 BIT EXPONENT
    +
    2576  CALL gbyte(ikk,iexp,1,7)
    +
    2577 C GET 24 BIT FRACTION
    +
    2578  CALL gbyte(ikk,ifr,8,24)
    +
    2579  IF (ifr.EQ.0.OR.iexp.EQ.0) THEN
    +
    2580  realkk = 0.0
    +
    2581  ELSE
    +
    2582  realkk = float(ifr) * 16.0 ** (iexp-64-6)
    +
    2583  IF (isgn.NE.0) realkk = - realkk
    +
    2584  ENDIF
    +
    2585  ENDIF
    +
    2586 C
    +
    2587  DATA(1) = realkk
    +
    2588  koff = 0
    +
    2589 C CALL XMOVEX(MSGB,MSGA(ISS+15),NRBYTE)
    +
    2590 C
    +
    2591 C ------------- UNPACK ALL FIELDS
    +
    2592 C
    +
    2593 C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
    +
    2594 C --------------
    +
    2595 C
    +
    2596 C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
    +
    2597 C INTEGER WORD BOUNDARY
    +
    2598 C
    +
    2599  lll = mod(iss+14,8)
    +
    2600  nnn = 15 - lll
    +
    2601  koff = lll * 8
    +
    2602 C
    +
    2603  CALL gbytes(msga(iss+nnn),ksave,koff,kbits,0,kentry)
    +
    2604 C
    +
    2605  DO 6000 i = 1, kentry
    +
    2606  DATA(i+1) = refnce + float(ksave(i)) * scale
    +
    2607  6000 CONTINUE
    +
    2608  900 CONTINUE
    +
    2609  RETURN
    +
    2610  END
    +
    2611 
    +
    2612 C> To test when gds is available to see if size mismatch
    +
    2613 C> on existing grids (by center) is indicated.
    +
    2614 C>
    +
    2615 C> Program history log:
    +
    2616 C> - Bill Cavanaugh 1988-02-08
    +
    2617 C> - Ralph Jones 1990-09-23 Change's for cray cft77 fortran.
    +
    2618 C> - Ralph Jones 1990-12-05 Change's for grib nov. 21,1990.
    +
    2619 C>
    +
    2620 C> @param[in] J Size for indicated grid.
    +
    2621 C> @param[in] KPDS
    +
    2622 C> @param[in] KGDS
    +
    2623 C> @param[out] KRET Error return.
    +
    2624 C>
    +
    2625 C> @note KRET = 9 - GDS indicates size mismatch with std grid.
    +
    2626 C>
    +
    2627 C> @author Bill Cavanaugh @date 1988-02-08
    +
    2628 C$$$
    +
    2629  SUBROUTINE ai087(*,J,KPDS,KGDS,KRET)
    +
    2630  INTEGER KPDS(20)
    +
    2631  INTEGER KGDS(13)
    +
    2632  INTEGER J
    +
    2633  INTEGER I
    +
    2634 C ---------------------------------------
    +
    2635 C ---------------------------------------
    +
    2636 C IF GDS NOT INDICATED, RETURN
    +
    2637 C ----------------------------------------
    +
    2638  IF (iand(kpds(4),128).EQ.0) RETURN
    +
    2639 C ---------------------------------------
    +
    2640 C GDS IS INDICATED, PROCEED WITH TESTING
    +
    2641 C ---------------------------------------
    +
    2642  i = kgds(2) * kgds(3)
    +
    2643 C ---------------------------------------
    +
    2644 C TEST ECMWF CONTENT
    +
    2645 C ---------------------------------------
    +
    2646  IF (kpds(1).EQ.98) THEN
    +
    2647  kret = 9
    +
    2648  IF (kpds(3).GE.1.AND.kpds(3).LE.16) THEN
    +
    2649  IF (i.NE.j) THEN
    +
    2650  RETURN 1
    +
    2651  END IF
    +
    2652  ELSE
    +
    2653  kret = 5
    +
    2654  RETURN 1
    +
    2655  END IF
    +
    2656 C ---------------------------------------
    +
    2657 C U.K. MET OFFICE, BRACKNELL
    +
    2658 C ---------------------------------------
    +
    2659  ELSE IF (kpds(1).EQ.74) THEN
    +
    2660  kret = 9
    +
    2661  IF (kpds(3).GE.21.AND.kpds(3).LE.24) THEN
    +
    2662  IF (i.NE.j) THEN
    +
    2663  RETURN 1
    +
    2664  END IF
    +
    2665  ELSE IF (kpds(3).EQ.25.OR.kpds(3).EQ.26) THEN
    +
    2666  IF (i.NE.j) THEN
    +
    2667  RETURN 1
    +
    2668  END IF
    +
    2669  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
    +
    2670  IF (i.NE.j) THEN
    +
    2671  RETURN 1
    +
    2672  END IF
    +
    2673  ELSE IF (kpds(3).EQ.70) THEN
    +
    2674  IF (i.NE.j) THEN
    +
    2675  RETURN 1
    +
    2676  END IF
    +
    2677  ELSE
    +
    2678  kret = 5
    +
    2679  RETURN 1
    +
    2680  END IF
    +
    2681 C ---------------------------------------
    +
    2682 C NAVY - FNOC
    +
    2683 C ---------------------------------------
    +
    2684  ELSE IF (kpds(1).EQ.58) THEN
    +
    2685  print *,' NO CURRENT LISTING OF NAVY GRIDS'
    +
    2686  RETURN 1
    +
    2687 C ---------------------------------------
    +
    2688 C U.S. GRIDS
    +
    2689 C ---------------------------------------
    +
    2690  ELSE IF (kpds(1).EQ.7) THEN
    +
    2691  kret = 9
    +
    2692  IF (kpds(3).EQ.5) THEN
    +
    2693  IF (i.NE.j) THEN
    +
    2694  RETURN 1
    +
    2695  END IF
    +
    2696  ELSE IF (kpds(3).EQ.6) THEN
    +
    2697  IF (i.NE.j) THEN
    +
    2698  RETURN 1
    +
    2699  END IF
    +
    2700  ELSE IF (kpds(3).GE.21.AND.kpds(3).LE.24) THEN
    +
    2701  IF (i.NE.j) THEN
    +
    2702  RETURN 1
    +
    2703  END IF
    +
    2704  ELSE IF (kpds(3).EQ.25.OR.kpds(3).EQ.26) THEN
    +
    2705  IF (i.NE.j) THEN
    +
    2706  RETURN 1
    +
    2707  END IF
    +
    2708  ELSE IF (kpds(3).EQ.27.OR.kpds(3).EQ.28) THEN
    +
    2709  IF (i.NE.j) THEN
    +
    2710  RETURN 1
    +
    2711  END IF
    +
    2712  ELSE IF (kpds(3).EQ.29.OR.kpds(3).EQ.30) THEN
    +
    2713  IF (i.NE.j) THEN
    +
    2714  RETURN 1
    +
    2715  END IF
    +
    2716  ELSE IF (kpds(3).EQ.33.OR.kpds(3).EQ.34) THEN
    +
    2717  IF (i.NE.j) THEN
    +
    2718  RETURN 1
    +
    2719  END IF
    +
    2720  ELSE IF (kpds(3).EQ.50) THEN
    +
    2721  IF (i.NE.j) THEN
    +
    2722  RETURN 1
    +
    2723  END IF
    +
    2724  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
    +
    2725  IF (i.NE.j) THEN
    +
    2726  RETURN 1
    +
    2727  END IF
    +
    2728  ELSE IF (kpds(3).EQ.70) THEN
    +
    2729  IF (i.NE.j) THEN
    +
    2730  RETURN 1
    +
    2731  END IF
    +
    2732  ELSE IF (kpds(3).EQ.85.OR.kpds(3).EQ.86) THEN
    +
    2733  IF (i.NE.j) THEN
    +
    2734  RETURN 1
    +
    2735  END IF
    +
    2736  ELSE IF (kpds(3).EQ.100) THEN
    +
    2737  IF (i.NE.j) THEN
    +
    2738  RETURN 1
    +
    2739  END IF
    +
    2740  ELSE IF (kpds(3).EQ.101) THEN
    +
    2741  IF (i.NE.j) THEN
    +
    2742  RETURN 1
    +
    2743  END IF
    +
    2744  ELSE IF (kpds(3).EQ.102) THEN
    +
    2745  IF (i.NE.j) THEN
    +
    2746  RETURN 1
    +
    2747  END IF
    +
    2748  ELSE IF (kpds(3).EQ.103) THEN
    +
    2749  IF (i.NE.j) THEN
    +
    2750  RETURN 1
    +
    2751  END IF
    +
    2752  ELSE IF (kpds(3).GE.201.AND.kpds(3).LE.214) THEN
    +
    2753  IF (i.NE.j) THEN
    +
    2754  RETURN 1
    +
    2755  END IF
    +
    2756  ELSE
    +
    2757  kret = 5
    +
    2758  RETURN 1
    +
    2759  END IF
    +
    2760  ELSE
    +
    2761  kret = 10
    +
    2762  RETURN 1
    +
    2763  END IF
    +
    2764 C ------------------------------------
    +
    2765 C NORMAL EXIT
    +
    2766 C ------------------------------------
    +
    2767  kret = 0
    +
    2768  RETURN
    +
    2769  END
    +
    +
    +
    ai087
    subroutine ai087(, J, KPDS, KGDS, KRET)
    To test when gds is available to see if size mismatch on existing grids (by center) is indicated.
    Definition: w3ai08.f:2630
    +
    gbytes
    subroutine gbytes(IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
    Program history log:
    Definition: gbytes.f:26
    +
    ai081
    subroutine ai081(MSGA, KPTR, KPDS, KRET)
    Find 'grib; characters and set pointers to the next byte following 'grib'.
    Definition: w3ai08.f:569
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    ai082
    subroutine ai082(MSGA, KPTR, KPDS, KRET)
    Extract information from the product description sec, and generate label information to permit storag...
    Definition: w3ai08.f:749
    +
    w3ai08
    subroutine w3ai08(MSGA, KPDS, KGDS, KBMS, DATA, KPTR, KRET)
    Unpack a grib field to the exact grid specified in the message, isolate the bit map and make the valu...
    Definition: w3ai08.f:148
    +
    ai083
    subroutine ai083(MSGA, KPTR, KPDS, KGDS, KRET)
    Extract information on unlisted grid to allow conversion to office note 84 format.
    Definition: w3ai08.f:1158
    +
    ai085
    subroutine ai085(MSGA, KPTR, KPDS, KBMS, DATA, KRET)
    Extract grib data and place into output arry in proper position.
    Definition: w3ai08.f:2067
    +
    ai082a
    subroutine ai082a(MSGA, KPTR, KPDS, KRET)
    Extract information from the product description section (version 1).
    Definition: w3ai08.f:935
    +
    gbyte
    subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
    This is the fortran version of gbyte.
    Definition: gbyte.f:27
    +
    ai084
    subroutine ai084(MSGA, KPTR, KPDS, KGDS, KBMS, KRET)
    If bit map sec is available in grib message,extract for program use, otherwise generate an appropriat...
    Definition: w3ai08.f:1615
    +
    ai085a
    subroutine ai085a(MSGA, KPTR, KPDS, KBMS, DATA, KRET)
    Extract grib data (version 1) and place into proper position in output array.
    Definition: w3ai08.f:2362
    + + + + diff --git a/ver-2.10.0/w3ai15_8f.html b/ver-2.10.0/w3ai15_8f.html new file mode 100644 index 00000000..1f194e8e --- /dev/null +++ b/ver-2.10.0/w3ai15_8f.html @@ -0,0 +1,198 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai15.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ai15.f File Reference
    +
    +
    + +

    Converts a set of binary numbers to an equivalent set of ascii number fields in core. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ai15 (NBUFA, NBUFB, N1, N2, MINUS)
     Converts a set of binary numbers to an equivalent set of ascii number fields in core. More...
     
    +

    Detailed Description

    +

    Converts a set of binary numbers to an equivalent set of ascii number fields in core.

    +
    Author
    R. Allard
    +
    Date
    1974-01
    + +

    Definition in file w3ai15.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ai15()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ai15 (integer, dimension(*) NBUFA,
    integer, dimension(*) NBUFB,
     N1,
     N2,
    character*1 MINUS 
    )
    +
    + +

    Converts a set of binary numbers to an equivalent set of ascii number fields in core.

    +

    This is an alternate procedure to the use of the 360/195 version of encode.

    +

    Program history log:

      +
    • R. Allard 1974-01-15
      • +
    • Ralph Jones 1989-02-06 Change from assembler to fortran this subroutine should be rewritten in intel 8088 assembly language.
      • +
    • Ralph Jones 1990-08-13 Change to cray cft77 fortran.
      • +
    • Boi Vuong 2012-11-05 Change variable zero fill for little-endian.
      • +
    +
    Parameters
    + + + + + + +
    [in]NBUFAInput array (integer*4).
    [in]N1Number of integers in nbufa to be converted.
    [in]N2Desired character width of ascii number field.
    [in]MINUSCharacter to be inserted in the high order position of a negative number field.
    [out]NBUFBOutput array (integer*4).
    +
    +
    +
    Note
    If n2 is greater than 4, allow two words (eight characters) in the nbufb array for each ascii number field. A number field is left adjusted with blank fill to the right if needed. Likewise, if n2 is less than 4, the result is left adjusted with blank fill to the right.
    +
    +N2 can be specified in the range 1-8. An eight digit positive integer can be converted or a seven digit negative integer and a sign. Zero fill is used for high order positions in a number field. The user should be aware that w3ai15 does not verify that the value of n2 is in the correct range.
    +
    +The minus sign can be inserted as a literal in the call sequence or defined in a data statement. 1h- and 1h+ are the two most likely negative signs. Unfortunately the ascii plus character is the negative sign required in most transmissions. The minus sign will always be in the high order position of a negative number field.
    +
    +If a number contains more digits than the n2 specification allows, the excess high order digits are lost.
    +
    Author
    R. Allard
    +
    Date
    1974-01
    + +

    Definition at line 48 of file w3ai15.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ai15_8f.js b/ver-2.10.0/w3ai15_8f.js new file mode 100644 index 00000000..93c3356f --- /dev/null +++ b/ver-2.10.0/w3ai15_8f.js @@ -0,0 +1,4 @@ +var w3ai15_8f = +[ + [ "w3ai15", "w3ai15_8f.html#acb162c72ac381b1874762eff242118d5", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ai15_8f_source.html b/ver-2.10.0/w3ai15_8f_source.html new file mode 100644 index 00000000..876a7651 --- /dev/null +++ b/ver-2.10.0/w3ai15_8f_source.html @@ -0,0 +1,220 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai15.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ai15.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Converts a set of binary numbers to an equivalent set
    +
    3 C> of ascii number fields in core.
    +
    4 C> @author R. Allard @date 1974-01
    +
    5 
    +
    6 C> Converts a set of binary numbers to an equivalent set
    +
    7 C> of ascii number fields in core. This is an alternate procedure
    +
    8 C> to the use of the 360/195 version of encode.
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - R. Allard 1974-01-15
    +
    12 C> - Ralph Jones 1989-02-06 Change from assembler to fortran
    +
    13 C> this subroutine should be rewritten in intel 8088 assembly language.
    +
    14 C> - Ralph Jones 1990-08-13 Change to cray cft77 fortran.
    +
    15 C> - Boi Vuong 2012-11-05 Change variable zero fill for little-endian.
    +
    16 C>
    +
    17 C> @param[in] NBUFA Input array (integer*4).
    +
    18 C> @param[in] N1 Number of integers in nbufa to be converted.
    +
    19 C> @param[in] N2 Desired character width of ascii number field.
    +
    20 C> @param[in] MINUS Character to be inserted in the high order position
    +
    21 C> of a negative number field.
    +
    22 C> @param[out] NBUFB Output array (integer*4).
    +
    23 C>
    +
    24 C> @note If n2 is greater than 4, allow two words (eight characters)
    +
    25 C> in the nbufb array for each ascii number field. A number field
    +
    26 C> is left adjusted with blank fill to the right if needed.
    +
    27 C> Likewise, if n2 is less than 4, the result is left adjusted
    +
    28 C> with blank fill to the right.
    +
    29 C>
    +
    30 C> @note N2 can be specified in the range 1-8. An eight digit positive
    +
    31 C> integer can be converted or a seven digit negative integer
    +
    32 C> and a sign. Zero fill is used for high order positions in a
    +
    33 C> number field. The user should be aware that w3ai15 does not
    +
    34 C> verify that the value of n2 is in the correct range.
    +
    35 C>
    +
    36 C> @note The minus sign can be inserted as a literal in the call
    +
    37 C> sequence or defined in a data statement. 1h- and 1h+ are the
    +
    38 C> two most likely negative signs. Unfortunately the ascii plus
    +
    39 C> character is the negative sign required in most transmissions.
    +
    40 C> The minus sign will always be in the high order position of a
    +
    41 C> negative number field.
    +
    42 C>
    +
    43 C> @note If a number contains more digits than the n2 specification
    +
    44 C> allows, the excess high order digits are lost.
    +
    45 C>
    +
    46 C> @author R. Allard @date 1974-01
    +
    47  SUBROUTINE w3ai15 (NBUFA,NBUFB,N1,N2,MINUS)
    +
    48 
    +
    49  INTEGER ATEMP
    +
    50  INTEGER BTEMP
    +
    51  INTEGER IDIV(8)
    +
    52  INTEGER NBUFA(*)
    +
    53  INTEGER NBUFB(*)
    +
    54  INTEGER*8 ZERO(8)
    +
    55 C
    +
    56  CHARACTER*1 BLANK
    +
    57  CHARACTER*1 JTEMP(8)
    +
    58  CHARACTER*1 MINUS
    +
    59  CHARACTER*1 NUM(0:9)
    +
    60 C
    +
    61  LOGICAL ISIGN
    +
    62 C
    +
    63  equivalence(btemp,jtemp(1))
    +
    64 C
    +
    65  DATA blank /' '/
    +
    66  DATA idiv /1,10,100,1000,10000,100000,1000000,10000000/
    +
    67  DATA num /'0','1','2','3','4','5','6','7','8','9'/
    +
    68 C FOR LITTLE_ENDIAN
    +
    69  DATA zero /z'2020202020202030',z'2020202020203030',
    +
    70  & z'2020202020303030',z'2020202030303030',
    +
    71  & z'2020203030303030',z'2020303030303030',
    +
    72  & z'2030303030303030',z'3030303030303030'/
    +
    73 
    +
    74 C FOR BIG_ENDIAN
    +
    75 c DATA ZERO /Z'3020202020202020',Z'3030202020202020',
    +
    76 c & Z'3030302020202020',Z'3030303020202020',
    +
    77 c & Z'3030303030202020',Z'3030303030302020',
    +
    78 c & Z'3030303030303020',Z'3030303030303030'/
    +
    79 C
    +
    80  DO 100 i = 1,n1
    +
    81  IF (nbufa(i).EQ.0) THEN
    +
    82  nbufb(i) = zero(n2)
    +
    83  GO TO 100
    +
    84  ENDIF
    +
    85  atemp = nbufa(i)
    +
    86  isign = .false.
    +
    87  IF (atemp.LT.0) THEN
    +
    88  isign = .true.
    +
    89  atemp = iabs(atemp)
    +
    90  ENDIF
    +
    91  IF (.NOT.isign) THEN
    +
    92  DO 10 j = 1,8
    +
    93  IF (j.LE.n2) THEN
    +
    94  i1 = mod(atemp/idiv(n2-j+1),10)
    +
    95  jtemp(j) = num(i1)
    +
    96  ELSE
    +
    97  jtemp(j) = blank
    +
    98  ENDIF
    +
    99  10 CONTINUE
    +
    100 
    +
    101  ELSE
    +
    102 
    +
    103  jtemp(1) = minus
    +
    104  DO 20 j = 2,8
    +
    105  IF (j.LE.n2) THEN
    +
    106  i1 = mod(atemp/idiv(n2-j+1),10)
    +
    107  jtemp(j) = num(i1)
    +
    108  ELSE
    +
    109  jtemp(j) = blank
    +
    110  ENDIF
    +
    111  20 CONTINUE
    +
    112  ENDIF
    +
    113 C
    +
    114  nbufb(i) = btemp
    +
    115 C
    +
    116  100 CONTINUE
    +
    117  RETURN
    +
    118  END
    +
    +
    +
    w3ai15
    subroutine w3ai15(NBUFA, NBUFB, N1, N2, MINUS)
    Converts a set of binary numbers to an equivalent set of ascii number fields in core.
    Definition: w3ai15.f:48
    + + + + diff --git a/ver-2.10.0/w3ai18_8f.html b/ver-2.10.0/w3ai18_8f.html new file mode 100644 index 00000000..e9c212c0 --- /dev/null +++ b/ver-2.10.0/w3ai18_8f.html @@ -0,0 +1,213 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai18.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ai18.f File Reference
    +
    +
    + +

    Line builder subroutine. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ai18 (ITEM, I1, I2, LINE, L, K, N)
     Build a line of information composed of user specified character strings. More...
     
    +

    Detailed Description

    +

    Line builder subroutine.

    +
    Author
    Robert Allard
    +
    Date
    1974-02-01
    + +

    Definition in file w3ai18.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ai18()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ai18 (character * (*) ITEM,
     I1,
     I2,
    character * (*) LINE,
     L,
     K,
     N 
    )
    +
    + +

    Build a line of information composed of user specified character strings.

    +

    Program history log:

      +
    • Robert Allard 1974-02-02
      • +
    • Ralph Jones 1984-07-05 Recompile
      • +
    • Ralph Jones 1996-08-06 Convert from ibm370 assembler to fortran for the cray, workstations, and pc's.
      • +
    +
    Parameters
    + + + + + + + + +
    [in]ITEMCharacter string to be added to line array.
    [in]I1Number of character strings to be added to line array.
    [in]I2Number of characters per string to add to line.
    [in]LCharacter length of line to be built (2.le.l.le.256).
    [in]KNumber of blkank characters to precede a character string (0.le.k.le.256).
    [in,out]N(in) Pointer set equal to 0 when beginning a line. (out) Character count, error indicator.
    [out]LINEArray in which character string are placed while building aline; must be of type integer.
    +
    +
    +

    Exit states:

      +
    • N = -1 Character string will not fit in the line array; otherwise, each time a chacter string is added to the line, n is incremented by (i2 + k).
      • +
    +
    Note
    Each character string included in the item array must start on a full word boundary and be equal in length. Each successive string must start on the nest fullword boundary following the end of the previous string. On a cray this is 8.
    +
    +The dimensions of the item array should be at least the value of (i1*(i2+j))/4, where the integer j is in the range 0.le.j.le.3 and the sum (i2+j) is 4 or a multiple of 4. On a cray this is 8 or a multiple of 8. On a cray (i1*(i2+j))/8, range is 0.le.j.le.7
    +
    +The maximum dimension of line is 64 word or 256 bytes. On a cray it is 32 words or 256 bytes.
    +
    +The user should set n = 0 each time a line is stated to tell w3ai18 to fill the line array with blank characters. Each time a character string is added to the line, the variable (n) is incremented by (i2 + k). If a character string will not fit in the line array, w3ai18 sets n = -1 and returns to the user. The user will not be able to program a recovery procedure for the line being full if more than one character string is in the item array.
    +
    Author
    Robert Allard
    +
    Date
    1974-02-01
    + +

    Definition at line 56 of file w3ai18.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ai18_8f.js b/ver-2.10.0/w3ai18_8f.js new file mode 100644 index 00000000..287ff2f0 --- /dev/null +++ b/ver-2.10.0/w3ai18_8f.js @@ -0,0 +1,4 @@ +var w3ai18_8f = +[ + [ "w3ai18", "w3ai18_8f.html#ae424dd6b4902f8abc7a21f878eea26f5", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ai18_8f_source.html b/ver-2.10.0/w3ai18_8f_source.html new file mode 100644 index 00000000..5843b8e3 --- /dev/null +++ b/ver-2.10.0/w3ai18_8f_source.html @@ -0,0 +1,206 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai18.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ai18.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Line builder subroutine.
    +
    3 C> @author Robert Allard @date 1974-02-01
    +
    4 
    +
    5 C> Build a line of information composed of user specified
    +
    6 C> character strings.
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - Robert Allard 1974-02-02
    +
    10 C> - Ralph Jones 1984-07-05 Recompile
    +
    11 C> - Ralph Jones 1996-08-06 Convert from ibm370 assembler to fortran
    +
    12 C> for the cray, workstations, and pc's.
    +
    13 C>
    +
    14 C> @param[in] ITEM Character string to be added to line array.
    +
    15 C> @param[in] I1 Number of character strings to be added to line array.
    +
    16 C> @param[in] I2 Number of characters per string to add to line.
    +
    17 C> @param[in] L Character length of line to be built (2.le.l.le.256).
    +
    18 C> @param[in] K Number of blkank characters to precede a character
    +
    19 C> string (0.le.k.le.256).
    +
    20 C> @param[inout] N (in) Pointer set equal to 0 when beginning a line.
    +
    21 C> (out) Character count, error indicator.
    +
    22 C> @param[out] LINE Array in which character string are placed while
    +
    23 C> building aline; must be of type integer.
    +
    24 C>
    +
    25 C> Exit states:
    +
    26 C> - N = -1 Character string will not fit in the line array;
    +
    27 C> otherwise, each time a chacter string is added
    +
    28 C> to the line, n is incremented by (i2 + k).
    +
    29 C>
    +
    30 C> @note Each character string included in the item array must
    +
    31 C> start on a full word boundary and be equal in length.
    +
    32 C> Each successive string must start on the nest fullword
    +
    33 C> boundary following the end of the previous string.
    +
    34 C> On a cray this is 8.
    +
    35 C>
    +
    36 C> @note The dimensions of the item array should be at least the
    +
    37 C> value of (i1*(i2+j))/4, where the integer j is in the
    +
    38 C> range 0.le.j.le.3 and the sum (i2+j) is 4 or a multiple
    +
    39 C> of 4. On a cray this is 8 or a multiple of 8. On a cray
    +
    40 C> (i1*(i2+j))/8, range is 0.le.j.le.7
    +
    41 C>
    +
    42 C> @note The maximum dimension of line is 64 word or 256 bytes.
    +
    43 C> On a cray it is 32 words or 256 bytes.
    +
    44 C>
    +
    45 C> @note The user should set n = 0 each time a line is stated to
    +
    46 C> tell w3ai18 to fill the line array with blank characters.
    +
    47 C> Each time a character string is added to the line, the
    +
    48 C> variable (n) is incremented by (i2 + k). If a character
    +
    49 C> string will not fit in the line array, w3ai18 sets n = -1
    +
    50 C> and returns to the user. The user will not be able to
    +
    51 C> program a recovery procedure for the line being full if
    +
    52 C> more than one character string is in the item array.
    +
    53 C>
    +
    54 C> @author Robert Allard @date 1974-02-01
    +
    55  SUBROUTINE w3ai18(ITEM,I1,I2,LINE,L,K,N)
    +
    56 C
    +
    57  CHARACTER * (*) LINE
    +
    58  CHARACTER * (*) ITEM
    +
    59 C
    +
    60  SAVE
    +
    61 C
    +
    62 C TEST WORD LENGTH, LW WILL BE 4 OR 8 BYTES
    +
    63 C
    +
    64  CALL w3fi01(lw)
    +
    65 C
    +
    66 C BAIL OUT IF NEGATIVE
    +
    67 C
    +
    68  IF (n.LT.0) RETURN
    +
    69 C
    +
    70 C FILL LINE WITH BLANK CHAACTERS
    +
    71 C
    +
    72  IF (n.EQ.0) THEN
    +
    73  DO i = 1,l
    +
    74  line(i:i) = ' '
    +
    75  END DO
    +
    76  END IF
    +
    77  IF (i1.EQ.1) THEN
    +
    78  j = 0
    +
    79  IF ((i2+k+n).GT.l) GO TO 200
    +
    80  line(k+n+1:k+n+i2) = item(1:i2)
    +
    81  n = i2+k+n
    +
    82  RETURN
    +
    83  ELSE
    +
    84  jj = mod(i2, lw)
    +
    85  IF (jj.EQ.0) THEN
    +
    86  j = 0
    +
    87  ELSE
    +
    88  j = lw - jj
    +
    89  END IF
    +
    90  IF ((i2+k+n).GT.l) GO TO 200
    +
    91  line(k+n+1:k+n+i2) = item(1:i2)
    +
    92  n = i2+k+n
    +
    93  DO i = 1,i1-1
    +
    94  IF ((i2+k+n).GT.l) GO TO 200
    +
    95  line(k+n+1:k+n+i2) = item((i2+j)*i+1:(i2+j)*i+i2)
    +
    96  n = i2+k+n
    +
    97  END DO
    +
    98  RETURN
    +
    99  END IF
    +
    100  200 CONTINUE
    +
    101  n = -1
    +
    102  RETURN
    +
    103  END
    +
    +
    +
    w3ai18
    subroutine w3ai18(ITEM, I1, I2, LINE, L, K, N)
    Build a line of information composed of user specified character strings.
    Definition: w3ai18.f:56
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    + + + + diff --git a/ver-2.10.0/w3ai19_8f.html b/ver-2.10.0/w3ai19_8f.html new file mode 100644 index 00000000..2ac90a83 --- /dev/null +++ b/ver-2.10.0/w3ai19_8f.html @@ -0,0 +1,198 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai19.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ai19.f File Reference
    +
    +
    + +

    Blocker Subroutine. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ai19 (LINE, L, NBLK, N, NEXT)
     Fills a record block with logical records or lines of information. More...
     
    +

    Detailed Description

    +

    Blocker Subroutine.

    +
    Author
    Robert Allard
    +
    Date
    1997-04-15
    + +

    Definition in file w3ai19.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ai19()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ai19 (character * 1, dimension(*) LINE,
    integer L,
    character * 1, dimension(*) NBLK,
    integer N,
    integer NEXT 
    )
    +
    + +

    Fills a record block with logical records or lines of information.

    +

    Program history log:

      +
    • Robeert Allard 1974-02-01
      • +
    • Ralph Jones 1990-09-15 Convert from ibm370 assembler to microsoft fortran 5.0.
      • +
    • Ralph Jones 1990-10-07 Convert to sun fortran 1.3.
      • +
    • Ralph Jones 1991-07-20 Convert to silicongraphics 3.3 fortran 77.
      • +
    • Ralph Jones 1993-03-29 Add save statement.
      • +
    • Ralph Jones 1994-04-22 Add xmovex and xstore to move and store character data faster on the cray.
      • +
    • Bob Hollern 1997-04-15 Corrected the problem of iniializing nblk to @'s instead of blanks.
      • +
    +
    Parameters
    + + + + + + +
    [in]LINEArray address of logical record to be blocked.
    [in]LNumber of characters in line to be blocked.
    [in]NMaximum character size of nblk.
    [in,out]NEXT(in) flag, initialized to 0. (out) character count, error indicator.
    [out]NBLKBlock filled with logical records.
    +
    +
    +

    Exit states:

      +
    • NEXT = -1 Line will not fit into remainder of block; otherwise, next is set to (next + l).
      • +
    • NEXT = -2 N is zero or less.
      • +
    • NEXT = -3 L is zero or less.
      • +
    +
    Author
    Robert Allard
    +
    Date
    1997-04-15
    + +

    Definition at line 33 of file w3ai19.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ai19_8f.js b/ver-2.10.0/w3ai19_8f.js new file mode 100644 index 00000000..606fdb07 --- /dev/null +++ b/ver-2.10.0/w3ai19_8f.js @@ -0,0 +1,4 @@ +var w3ai19_8f = +[ + [ "w3ai19", "w3ai19_8f.html#ada69d8346ce6a030bc9f722fb842529c", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ai19_8f_source.html b/ver-2.10.0/w3ai19_8f_source.html new file mode 100644 index 00000000..b84f5715 --- /dev/null +++ b/ver-2.10.0/w3ai19_8f_source.html @@ -0,0 +1,219 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai19.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ai19.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Blocker Subroutine.
    +
    3 C> @author Robert Allard @date 1997-04-15
    +
    4 
    +
    5 C> Fills a record block with logical records or lines of information.
    +
    6 C>
    +
    7 C> Program history log:
    +
    8 C> - Robeert Allard 1974-02-01
    +
    9 C> - Ralph Jones 1990-09-15 Convert from ibm370 assembler to microsoft
    +
    10 C> fortran 5.0.
    +
    11 C> - Ralph Jones 1990-10-07 Convert to sun fortran 1.3.
    +
    12 C> - Ralph Jones 1991-07-20 Convert to silicongraphics 3.3 fortran 77.
    +
    13 C> - Ralph Jones 1993-03-29 Add save statement.
    +
    14 C> - Ralph Jones 1994-04-22 Add xmovex and xstore to move and
    +
    15 C> store character data faster on the cray.
    +
    16 C> - Bob Hollern 1997-04-15 Corrected the problem of iniializing nblk
    +
    17 C> to @'s instead of blanks.
    +
    18 C>
    +
    19 C> @param[in] LINE Array address of logical record to be blocked.
    +
    20 C> @param[in] L Number of characters in line to be blocked.
    +
    21 C> @param[in] N Maximum character size of nblk.
    +
    22 C> @param[inout] NEXT (in) flag, initialized to 0. (out) character count, error indicator.
    +
    23 C> @param[out] NBLK Block filled with logical records.
    +
    24 C>
    +
    25 C> Exit states:
    +
    26 C> - NEXT = -1 Line will not fit into remainder of block;
    +
    27 C> otherwise, next is set to (next + l).
    +
    28 C> - NEXT = -2 N is zero or less.
    +
    29 C> - NEXT = -3 L is zero or less.
    +
    30 C>
    +
    31 C> @author Robert Allard @date 1997-04-15
    +
    32  SUBROUTINE w3ai19(LINE, L, NBLK, N, NEXT)
    +
    33 C
    +
    34 C METHOD:
    +
    35 C
    +
    36 C THE USER MUST SET NEXT = 0 EACH TIME NBLK IS TO BE FILLED WITH
    +
    37 C LOGICAL RECORDS.
    +
    38 C
    +
    39 C W3AI19 WILL THEN MOVE THE LINE OF INFORMATION INTO NBLK, STORE
    +
    40 C BLANK CHARACTERS IN THE REMAINDER OF THE BLOCK, AND SET NEXT = NEXT
    +
    41 C + L.
    +
    42 C
    +
    43 C EACH TIME W3AI19 IS ENTERED, ONE LINE IS BLOCKED AND NEXT INCRE-
    +
    44 C MENTED UNTIL A LINE WILL NOT FIT THE REMAINDER OF THE BLOCK. THEN
    +
    45 C W3AI19 WILL SET NEXT = -1 AS A FLAG FOR THE USER TO DISPOSE OF THE
    +
    46 C BLOCK. THE USER SHOULD BE AWARE THAT THE LAST LOGICAL RECORD WAS NOT
    +
    47 C BLOCKED.
    +
    48 C
    +
    49  INTEGER L
    +
    50  INTEGER N
    +
    51  INTEGER NEXT
    +
    52  INTEGER(8) WBLANK
    +
    53 C
    +
    54  CHARACTER * 1 LINE(*)
    +
    55  CHARACTER * 1 NBLK(*)
    +
    56  CHARACTER * 1 BLANK
    +
    57 C
    +
    58  SAVE
    +
    59 C
    +
    60  DATA wblank/z'2020202020202020'/
    +
    61 C
    +
    62 C TEST VALUE OF NEXT.
    +
    63 C
    +
    64  IF (next.LT.0) THEN
    +
    65  RETURN
    +
    66 C
    +
    67 C TEST N FOR ZERO OR LESS
    +
    68 C
    +
    69  ELSE IF (n.LE.0) THEN
    +
    70  next = -2
    +
    71  RETURN
    +
    72 C
    +
    73 C TEST L FOR ZERO OR LESS
    +
    74 C
    +
    75  ELSE IF (l.LE.0) THEN
    +
    76  next = -3
    +
    77  RETURN
    +
    78 C
    +
    79 C TEST TO SEE IF LINE WILL FIT IN BLOCK.
    +
    80 C
    +
    81  ELSE IF ((l + next).GT.n) THEN
    +
    82  next = -1
    +
    83  RETURN
    +
    84 C
    +
    85 C FILL BLOCK WITH BLANK CHARACTERS IF NEXT EQUAL ZERO.
    +
    86 C BLANK IS EBCDIC BLANK, 40 HEX, OR 64 DECIMAL
    +
    87 C
    +
    88  ELSE IF (next.EQ.0) THEN
    +
    89  CALL w3fi01(lw)
    +
    90  iwords = n / lw
    +
    91  CALL xstore(nblk,wblank,iwords)
    +
    92  IF (mod(n,lw).NE.0) THEN
    +
    93  nwords = iwords * lw
    +
    94  ibytes = n - nwords
    +
    95  DO i = 1,ibytes
    +
    96  nblk(nwords+i) = char(32)
    +
    97  END DO
    +
    98  END IF
    +
    99  END IF
    +
    100 C
    +
    101 C MOVE LINE INTO BLOCK.
    +
    102 C
    +
    103 C DO 20 I = 1,L
    +
    104 C NBLK(I + NEXT) = LINE(I)
    +
    105 C20 CONTINUE
    +
    106  CALL xmovex(nblk(next+1),line,l)
    +
    107 C
    +
    108 C ADJUST VALUE OF NEXT.
    +
    109 C
    +
    110  next = next + l
    +
    111 C
    +
    112  RETURN
    +
    113 C
    +
    114  END
    +
    +
    +
    w3ai19
    subroutine w3ai19(LINE, L, NBLK, N, NEXT)
    Fills a record block with logical records or lines of information.
    Definition: w3ai19.f:33
    +
    xstore
    subroutine xstore(COUT, CON, MWORDS)
    Stores an 8-byte (fullword) value through consecutive storage locations.
    Definition: xstore.f:29
    +
    xmovex
    subroutine xmovex(OUT, IN, IBYTES)
    Definition: xmovex.f:21
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    + + + + diff --git a/ver-2.10.0/w3ai24_8f.html b/ver-2.10.0/w3ai24_8f.html new file mode 100644 index 00000000..981e374e --- /dev/null +++ b/ver-2.10.0/w3ai24_8f.html @@ -0,0 +1,175 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai24.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ai24.f File Reference
    +
    +
    + +

    Test for match of two strings. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    logical function w3ai24 (STRING1, STRING2, LENGTH)
     Test two strings. More...
     
    +

    Detailed Description

    +

    Test for match of two strings.

    +
    Author
    Luke Lin
    +
    Date
    1994-08-31
    + +

    Definition in file w3ai24.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ai24()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    logical function w3ai24 (character*1, dimension(*) STRING1,
    character*1, dimension(*) STRING2,
    integer*4 LENGTH 
    )
    +
    + +

    Test two strings.

    +

    If all equal; Otherwise .false.

    +

    Program history log:

      +
    • Luke Lin 1994-08-31
      • +
    +
    Parameters
    + + + + +
    [in]STRING1Character array to match with string2
    [in]STRING2Character array to match with string1
    [in]LENGTHInteger length of string1 and string2
    +
    +
    +
    Returns
    W3AI24 Logical .true. if s1 and s2 match on all char., logical .false. if not match on any char.
    +
    Author
    Luke Lin
    +
    Date
    1994-08-31
    + +

    Definition at line 18 of file w3ai24.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ai24_8f.js b/ver-2.10.0/w3ai24_8f.js new file mode 100644 index 00000000..cdb47d76 --- /dev/null +++ b/ver-2.10.0/w3ai24_8f.js @@ -0,0 +1,4 @@ +var w3ai24_8f = +[ + [ "w3ai24", "w3ai24_8f.html#a425d9890956ae872557a04b715deb3f2", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ai24_8f_source.html b/ver-2.10.0/w3ai24_8f_source.html new file mode 100644 index 00000000..1d415b8a --- /dev/null +++ b/ver-2.10.0/w3ai24_8f_source.html @@ -0,0 +1,137 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai24.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ai24.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Test for match of two strings.
    +
    3 C> @author Luke Lin @date 1994-08-31
    +
    4 
    +
    5 C> Test two strings. If all equal; Otherwise .false.
    +
    6 C>
    +
    7 C> Program history log:
    +
    8 C> - Luke Lin 1994-08-31
    +
    9 C>
    +
    10 C> @param[in] STRING1 Character array to match with string2
    +
    11 C> @param[in] STRING2 Character array to match with string1
    +
    12 C> @param[in] LENGTH Integer length of string1 and string2
    +
    13 C> @return W3AI24 Logical .true. if s1 and s2 match on all char.,
    +
    14 C> logical .false. if not match on any char.
    +
    15 C>
    +
    16 C> @author Luke Lin @date 1994-08-31
    +
    17  LOGICAL FUNCTION w3ai24(STRING1, STRING2,LENGTH)
    +
    18 C
    +
    19  CHARACTER*1 string1(*)
    +
    20  CHARACTER*1 string2(*)
    +
    21  INTEGER*4 length
    +
    22 C
    +
    23  w3ai24 = .true.
    +
    24 C
    +
    25  DO 10 i = 1,length
    +
    26  IF (string1(i).NE.string2(i)) GO TO 40
    +
    27  10 CONTINUE
    +
    28 C
    +
    29  RETURN
    +
    30 C
    +
    31  40 CONTINUE
    +
    32  w3ai24 = .false.
    +
    33  RETURN
    +
    34 C
    +
    35  END
    +
    +
    +
    w3ai24
    logical function w3ai24(STRING1, STRING2, LENGTH)
    Test two strings.
    Definition: w3ai24.f:18
    + + + + diff --git a/ver-2.10.0/w3ai38_8f.html b/ver-2.10.0/w3ai38_8f.html new file mode 100644 index 00000000..71c4230a --- /dev/null +++ b/ver-2.10.0/w3ai38_8f.html @@ -0,0 +1,173 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai38.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ai38.f File Reference
    +
    +
    + +

    EBCDIC to ASCII. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ai38 (IE, NC)
     Convert EBCDIC to ASCII by character. More...
     
    +

    Detailed Description

    +

    EBCDIC to ASCII.

    +
    Author
    Armand Desmarais
    +
    Date
    1982-11-29
    + +

    Definition in file w3ai38.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ai38()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3ai38 (character*1, dimension(*) IE,
     NC 
    )
    +
    + +

    Convert EBCDIC to ASCII by character.

    +

    This subroutine can be replaced by cray utility subroutine uscctc. See manual sr-2079 page 3-15. cray utility tr can also be used for ASCII, EBCDIC conversion. See manual sr-2079 page 9-35.

    +

    Program history log:

      +
    • Armand Desmarais 1982-11-29
      • +
    • Ralph Jones 1988-03-31 Change logic so it works like a ibm370 translate instruction.
      • +
    • Ralph Jones 1988-08-22 Changes for microsoft fortran 4.10.
      • +
    • Ralph Jones 1988-09-04 Change tables to 128 character set.
      • +
    • Ralph Jones 1990-01-31 Convert to cray cft77 fortran cray does not allow char*1 to be set to hex.
      • +
    • Stephen Gilbert 98-12-21 Replaced Function ICHAR with mova2i.
      • +
    +
    Parameters
    + + + +
    [in,out]IE(in) Character*1 array of EBCDIC data (out) ASCII data
    [in]NCInteger, contains character count to convert.
    +
    +
    +
    Note
    Software version of ibm370 translate instruction, by changing the two tables we could do a 64, 96, 128 ASCII character set, change lower case to upper, etc. aea converts data at a rate of 1.5 million characters per sec. cray utility usccti convert ASCII to IBM EBCDIC cray utility uscctc convert IBM EBCDIC to ASCII they convert data at a rate of 2.1 million characters per sec. cray utility tr will also do a ASCII, EBCDIC conversion. tr convert data at a rate of 5.4 million characters per sec. tr is in library /usr/lib/libcos.a add to segldr card.
    +
    Author
    Armand Desmarais
    +
    Date
    1982-11-29
    + +

    Definition at line 37 of file w3ai38.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ai38_8f.js b/ver-2.10.0/w3ai38_8f.js new file mode 100644 index 00000000..ee2ec90e --- /dev/null +++ b/ver-2.10.0/w3ai38_8f.js @@ -0,0 +1,4 @@ +var w3ai38_8f = +[ + [ "w3ai38", "w3ai38_8f.html#a65ce63976c2011a17a8f44e0d20e074f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ai38_8f_source.html b/ver-2.10.0/w3ai38_8f_source.html new file mode 100644 index 00000000..e035699e --- /dev/null +++ b/ver-2.10.0/w3ai38_8f_source.html @@ -0,0 +1,177 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai38.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ai38.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief EBCDIC to ASCII
    +
    3 C> @author Armand Desmarais @date 1982-11-29
    +
    4 
    +
    5 C> Convert EBCDIC to ASCII by character.
    +
    6 C> This subroutine can be replaced by cray utility subroutine
    +
    7 C> uscctc. See manual sr-2079 page 3-15. cray utility tr
    +
    8 C> can also be used for ASCII, EBCDIC conversion. See manual sr-2079
    +
    9 C> page 9-35.
    +
    10 C>
    +
    11 C> Program history log:
    +
    12 C> - Armand Desmarais 1982-11-29
    +
    13 C> - Ralph Jones 1988-03-31 Change logic so it works like a
    +
    14 C> ibm370 translate instruction.
    +
    15 C> - Ralph Jones 1988-08-22 Changes for microsoft fortran 4.10.
    +
    16 C> - Ralph Jones 1988-09-04 Change tables to 128 character set.
    +
    17 C> - Ralph Jones 1990-01-31 Convert to cray cft77 fortran
    +
    18 C> cray does not allow char*1 to be set to hex.
    +
    19 C> - Stephen Gilbert 98-12-21 Replaced Function ICHAR with mova2i.
    +
    20 C>
    +
    21 C> @param[inout] IE (in) Character*1 array of EBCDIC data (out) ASCII data
    +
    22 C> @param[in] NC Integer, contains character count to convert.
    +
    23 C>
    +
    24 C> @note Software version of ibm370 translate instruction, by
    +
    25 C> changing the two tables we could do a 64, 96, 128 ASCII
    +
    26 C> character set, change lower case to upper, etc.
    +
    27 C> aea converts data at a rate of 1.5 million characters per sec.
    +
    28 C> cray utility usccti convert ASCII to IBM EBCDIC
    +
    29 C> cray utility uscctc convert IBM EBCDIC to ASCII
    +
    30 C> they convert data at a rate of 2.1 million characters per sec.
    +
    31 C> cray utility tr will also do a ASCII, EBCDIC conversion.
    +
    32 C> tr convert data at a rate of 5.4 million characters per sec.
    +
    33 C> tr is in library /usr/lib/libcos.a add to segldr card.
    +
    34 C>
    +
    35 C> @author Armand Desmarais @date 1982-11-29
    +
    36  SUBROUTINE w3ai38 (IE, NC )
    +
    37 C
    +
    38  INTEGER(8) IASCII(32)
    +
    39 C
    +
    40  CHARACTER*1 IE(*)
    +
    41  CHARACTER*1 ASCII(0:255)
    +
    42 C
    +
    43  equivalence(iascii(1),ascii(0))
    +
    44 C
    +
    45 C*** ASCII CONTAINS ASCII CHARACTERS, AS PUNCHED ON IBM029
    +
    46 C
    +
    47  DATA iascii/
    +
    48  & z'000102030009007F',z'0000000B0C0D0E0F',
    +
    49  & z'1011120000000000',z'1819000000000000',
    +
    50  & z'00001C000A001700',z'0000000000050607',
    +
    51  & z'00001600001E0004',z'000000001415001A',
    +
    52  & z'2000600000000000',z'0000602E3C282B00',
    +
    53  & z'2600000000000000',z'000021242A293B5E',
    +
    54  & z'2D2F000000000000',z'00007C2C255F3E3F',
    +
    55  & z'0000000000000000',z'00603A2340273D22',
    +
    56  & z'2061626364656667',z'6869202020202020',
    +
    57  & z'206A6B6C6D6E6F70',z'7172202020202020',
    +
    58  & z'207E737475767778',z'797A2020205B2020',
    +
    59  & z'0000000000000000',z'00000000005D0000',
    +
    60  & z'7B41424344454647',z'4849202020202020',
    +
    61  & z'7D4A4B4C4D4E4F50',z'5152202020202020',
    +
    62  & z'5C20535455565758',z'595A202020202020',
    +
    63  & z'3031323334353637',z'3839202020202020'/
    +
    64 C
    +
    65  IF (nc .LE. 0) RETURN
    +
    66 C
    +
    67 C*** CONVERT STRING ... EBCDIC TO ASCII, NC CHARACTERS
    +
    68 C
    +
    69  DO 20 j = 1, nc
    +
    70  ie(j) = ascii(mova2i(ie(j)))
    +
    71  20 CONTINUE
    +
    72 C
    +
    73  RETURN
    +
    74  END
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    w3ai38
    subroutine w3ai38(IE, NC)
    Convert EBCDIC to ASCII by character.
    Definition: w3ai38.f:37
    + + + + diff --git a/ver-2.10.0/w3ai39_8f.html b/ver-2.10.0/w3ai39_8f.html new file mode 100644 index 00000000..16bc2890 --- /dev/null +++ b/ver-2.10.0/w3ai39_8f.html @@ -0,0 +1,170 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai39.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ai39.f File Reference
    +
    +
    + +

    Translate 'ASCII' field to 'EBCDIC'. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ai39 (NFLD, N)
     translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter, brocken< clear, overcast, bell, ht and vt (for AFOS). More...
     
    +

    Detailed Description

    +

    Translate 'ASCII' field to 'EBCDIC'.

    +
    Author
    Armand Desmarais
    +
    Date
    1993-10-06
    + +

    Definition in file w3ai39.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ai39()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3ai39 (character*1, dimension(*) NFLD,
     N 
    )
    +
    + +

    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter, brocken< clear, overcast, bell, ht and vt (for AFOS).

    +

    space, '6D' to '5E' conversion (hdrology), changers were made to W3AI38 to give reverse table translation

    +

    Program history log:

      +
    • Ralph Jones 1993-10-06 Convert ibm370 assebler version to fortran.
      • +
    • Ralph Jones 1994-04-28 Changes for cray.
      • +
    • Stephen Gilbert 1998-12-21 Replaced Function ICHAR with mova2i.
      • +
    +
    Parameters
    + + + +
    [in,out]NFLDCharacter*1 array of (in) ASCII data (out) EBCDIC data.
    [in]NInteger, contains character count to convert.
    +
    +
    +
    Note
    Software version of IBM370 translate instruction, by changing the table we could do a 64, 96, ASCII character set, change lower case to upper, etc. tr convert data at a rate of 5.4 million characters per sec. tr is in library /usr/lib/libcos.a add to segldr card.
    +
    Author
    Armand Desmarais
    +
    Date
    1993-10-06
    + +

    Definition at line 26 of file w3ai39.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ai39_8f.js b/ver-2.10.0/w3ai39_8f.js new file mode 100644 index 00000000..a2f77677 --- /dev/null +++ b/ver-2.10.0/w3ai39_8f.js @@ -0,0 +1,4 @@ +var w3ai39_8f = +[ + [ "w3ai39", "w3ai39_8f.html#a28ca73de8fec4c73859576d1d2e0a219", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ai39_8f_source.html b/ver-2.10.0/w3ai39_8f_source.html new file mode 100644 index 00000000..4ad8582a --- /dev/null +++ b/ver-2.10.0/w3ai39_8f_source.html @@ -0,0 +1,174 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai39.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ai39.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Translate 'ASCII' field to 'EBCDIC'.
    +
    3 C> @author Armand Desmarais @date 1993-10-06
    +
    4 
    +
    5 C> translate an 'ASCII' field to 'EBCDIC', all alphanumerics,
    +
    6 C> special charcaters, fill scatter, brocken< clear, overcast, bell,
    +
    7 C> ht and vt (for AFOS). space, '6D' to '5E' conversion (hdrology),
    +
    8 C> changers were made to W3AI38 to give reverse table translation
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - Ralph Jones 1993-10-06 Convert ibm370 assebler version to fortran.
    +
    12 C> - Ralph Jones 1994-04-28 Changes for cray.
    +
    13 C> - Stephen Gilbert 1998-12-21 Replaced Function ICHAR with mova2i.
    +
    14 C>
    +
    15 C> @param[inout] NFLD Character*1 array of (in) ASCII data (out) EBCDIC data.
    +
    16 C> @param[in] N Integer, contains character count to convert.
    +
    17 C>
    +
    18 C> @note Software version of IBM370 translate instruction, by
    +
    19 C> changing the table we could do a 64, 96, ASCII
    +
    20 C> character set, change lower case to upper, etc.
    +
    21 C> tr convert data at a rate of 5.4 million characters per sec.
    +
    22 C> tr is in library /usr/lib/libcos.a add to segldr card.
    +
    23 C>
    +
    24 C> @author Armand Desmarais @date 1993-10-06
    +
    25  SUBROUTINE w3ai39 (NFLD, N)
    +
    26 C
    +
    27  INTEGER(8) IEBCDC(32)
    +
    28 C
    +
    29  CHARACTER*1 NFLD(*)
    +
    30  CHARACTER*1 EBCDIC(0:255)
    +
    31 C
    +
    32  SAVE
    +
    33 C
    +
    34  equivalence(iebcdc(1),ebcdic(0))
    +
    35 C
    +
    36 C*** EBCDIC CONTAINS HEX. REPRESENTATION OF EBCDIC CHARACTERS
    +
    37 C
    +
    38 C DATA IEBCDC/
    +
    39 C & X'00010203372D2E2F',X'1605250B0C0D0E0F',
    +
    40 C & X'101112003C3D3226',X'18193F2722003500',
    +
    41 C & X'405A7F7B5B6C507D',X'4D5D5C4E6B604B61',
    +
    42 C & X'F0F1F2F3F4F5F6F7',X'F8F97A5E4C7E6E6F',
    +
    43 C & X'7CC1C2C3C4C5C6C7',X'C8C9D1D2D3D4D5D6',
    +
    44 C & X'D7D8D9E2E3E4E5E6',X'E7E8E9ADE0BD5F6D',
    +
    45 C & X'7981828384858687',X'8889919293949596',
    +
    46 C & X'979899A2A3A4A5A6',X'A7A8A9C06AD0A107',
    +
    47 C & 16*X'4040404040404040'/
    +
    48 C
    +
    49 C THIS TABLE IS THE SAME AS HDS ASSEMBLER VERSION
    +
    50 C
    +
    51  DATA iebcdc/
    +
    52  & z'007D006C000000E0',z'00657C66004C0000',
    +
    53  & z'0000000000000000',z'0000000000005B00',
    +
    54  & z'40D07F7B5000506E',z'4D5D5C4F6B604B61',
    +
    55  & z'F0F1F2F3F4F5F6F7',z'F8F90000007E00C0',
    +
    56  & z'64C1C2C3C4C5C6C7',z'C8C9D1D2D3D4D5D6',
    +
    57  & z'D7D8D9E2E3E4E5E6',z'E7E8E90062636D00',
    +
    58  & z'0000000000000000',z'0000000000000000',
    +
    59  & z'0000000000000000',z'000000000000005F',
    +
    60  & 16 * z'0000000000000000'/
    +
    61 C
    +
    62  IF (n .LE. 0) RETURN
    +
    63 C
    +
    64 C*** CONVERT STRING ... ASCII TO EBCDIC, N CHARACTERS
    +
    65 C
    +
    66  DO 20 j = 1, n
    +
    67  nfld(j) = ebcdic(mova2i(nfld(j)))
    +
    68  20 CONTINUE
    +
    69 C
    +
    70  RETURN
    +
    71  END
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    w3ai39
    subroutine w3ai39(NFLD, N)
    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
    Definition: w3ai39.f:26
    + + + + diff --git a/ver-2.10.0/w3ai40_8f.html b/ver-2.10.0/w3ai40_8f.html new file mode 100644 index 00000000..c4655641 --- /dev/null +++ b/ver-2.10.0/w3ai40_8f.html @@ -0,0 +1,194 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai40.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ai40.f File Reference
    +
    +
    + +

    Constant size binary string packer. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ai40 (KFLD, KOUT, KLEN, KNUM, KOFF)
     Packs constant size binary strings into an array. More...
     
    +

    Detailed Description

    +

    Constant size binary string packer.

    +
    Author
    Robert Allard
    +
    Date
    1980-04-01
    + +

    Definition in file w3ai40.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ai40()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ai40 (integer, dimension(*) KFLD,
    integer, dimension(*) KOUT,
     KLEN,
     KNUM,
     KOFF 
    )
    +
    + +

    Packs constant size binary strings into an array.

    +

    This packing replaces bits in the part of the output array indicated by the offset value. W3AI40 is the reverse of W3AI41. (see W3AI32 to pack variable size binary strings.)

    +

    Program history log:

      +
    • Robert Allard 1980-04-01 Asmembler language version.
      • +
    • Ralph Jones 1984-07-05 Recompiled for nas-9050.
      • +
    • Ralph Jones 1989-11-04 Wrote fortran version of w3ai40 to pack constant size binary strings.
      • +
    • Ralph Jones 1989-11-05 Convert to cray cft77 fortran.
      • +
    • Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
      • +
    +
    Parameters
    + + + + + + +
    [in]KFLDInteger input array of right adjusted strings.
    [in]KLENInteger number of bits per string (0 < klen < 33).
    [in]KNUMInteger number of strings in 'kfld' to pack.
    [in]KOFFInteger number specifying the bit offset of the first output string. the offset value is reset to include the low order bit of the last packed string.
    [out]KOUTInteger output array to hold packed string(s).
    +
    +
    +

    exit states: error - koff < 0 if klen has an illegal value or knum < 1 then kout has no strings stored.

    +
    Note
    This subroutine should be written in assembler language. The fortran version runs two or three times slower than the asembler version. The fortran version can be converted to run on other computers with a few changes. The bit manipulation functions are the same in IBM370 vs fortran 4.1, microsoft fortran 4.10, vax fortran. Most modern fortran compiler have and, or, shift functions. If you are running on a pc, vax and your input was made on a IBM370, apollo sun, h.p.. etc. you may have to add more code to reverse the order of bytes in an integer word. NCAR sbytes() can be used instead of this subroutine. Please use NCAR sbytes() subroutine instead of this subroutine.
    +
    Author
    Robert Allard
    +
    Date
    1980-04-01
    + +

    Definition at line 44 of file w3ai40.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ai40_8f.js b/ver-2.10.0/w3ai40_8f.js new file mode 100644 index 00000000..f70bf2aa --- /dev/null +++ b/ver-2.10.0/w3ai40_8f.js @@ -0,0 +1,4 @@ +var w3ai40_8f = +[ + [ "w3ai40", "w3ai40_8f.html#afecf619ca48a8909617176d5e3b2de84", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ai40_8f_source.html b/ver-2.10.0/w3ai40_8f_source.html new file mode 100644 index 00000000..af863be5 --- /dev/null +++ b/ver-2.10.0/w3ai40_8f_source.html @@ -0,0 +1,191 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai40.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ai40.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Constant size binary string packer.
    +
    3 C> @author Robert Allard @date 1980-04-01
    +
    4 
    +
    5 C> Packs constant size binary strings into an array. This
    +
    6 C> packing replaces bits in the part of the output array indicated
    +
    7 C> by the offset value. W3AI40 is the reverse of W3AI41. (see W3AI32
    +
    8 C> to pack variable size binary strings.)
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - Robert Allard 1980-04-01 Asmembler language version.
    +
    12 C> - Ralph Jones 1984-07-05 Recompiled for nas-9050.
    +
    13 C> - Ralph Jones 1989-11-04 Wrote fortran version of w3ai40 to pack
    +
    14 C> constant size binary strings.
    +
    15 C> - Ralph Jones 1989-11-05 Convert to cray cft77 fortran.
    +
    16 C> - Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
    +
    17 C>
    +
    18 C> @param[in] KFLD Integer input array of right adjusted strings.
    +
    19 C> @param[in] KLEN Integer number of bits per string (0 < klen < 33).
    +
    20 C> @param[in] KNUM Integer number of strings in 'kfld' to pack.
    +
    21 C> @param[in] KOFF Integer number specifying the bit offset of the
    +
    22 C> first output string. the offset value is reset to
    +
    23 C> include the low order bit of the last packed string.
    +
    24 C> @param[out] KOUT Integer output array to hold packed string(s).
    +
    25 C>
    +
    26 C> exit states:
    +
    27 C> error - koff < 0 if klen has an illegal value or knum < 1
    +
    28 C> then kout has no strings stored.
    +
    29 C>
    +
    30 C> @note This subroutine should be written in assembler language.
    +
    31 C> The fortran version runs two or three times slower than the asembler
    +
    32 C> version. The fortran version can be converted to run on other
    +
    33 C> computers with a few changes. The bit manipulation functions are the
    +
    34 C> same in IBM370 vs fortran 4.1, microsoft fortran 4.10, vax fortran.
    +
    35 C> Most modern fortran compiler have and, or, shift functions. If you
    +
    36 C> are running on a pc, vax and your input was made on a IBM370, apollo
    +
    37 C> sun, h.p.. etc. you may have to add more code to reverse the order of
    +
    38 C> bytes in an integer word. NCAR sbytes() can be used instead of this
    +
    39 C> subroutine. Please use NCAR sbytes() subroutine instead of this
    +
    40 C> subroutine.
    +
    41 C>
    +
    42 C> @author Robert Allard @date 1980-04-01
    +
    43  SUBROUTINE w3ai40(KFLD,KOUT,KLEN,KNUM,KOFF)
    +
    44 C
    +
    45  INTEGER KFLD(*)
    +
    46  INTEGER KOUT(*)
    +
    47  INTEGER BIT
    +
    48  INTEGER OFFSET
    +
    49  INTEGER WRD
    +
    50 C
    +
    51  DATA mask /-1/
    +
    52 C
    +
    53  offset = koff
    +
    54  IF (offset.LT.0) RETURN
    +
    55  IF (klen.GT.64.OR.klen.LT.1) THEN
    +
    56  koff = -1
    +
    57  RETURN
    +
    58  ENDIF
    +
    59 C
    +
    60  IF (knum.LT.1) THEN
    +
    61  koff = -1
    +
    62  RETURN
    +
    63  ENDIF
    +
    64 C
    +
    65  jcount = 64 - klen
    +
    66  length = klen
    +
    67  maskwd = ishft(mask,jcount)
    +
    68 C
    +
    69  DO 100 i = 1,knum
    +
    70  wrd = ishft(offset,-6) + 1
    +
    71  bit = mod(offset,64)
    +
    72  mask8 = not(ishft(maskwd,-bit))
    +
    73  offset = offset + length
    +
    74  jtemp = iand(kout(wrd),mask8)
    +
    75  ncount = 64 - bit
    +
    76  IF (ncount.LT.length) THEN
    +
    77  mask9 = not(ishft(maskwd,ncount))
    +
    78  ntemp = iand(kout(wrd+1),mask9)
    +
    79  ENDIF
    +
    80  itemp = ishft(ishft(kfld(i),jcount),-bit)
    +
    81  kout(wrd) = ior(itemp,jtemp)
    +
    82  IF (ncount.LT.length) THEN
    +
    83  itemp = ishft(kfld(i),(jcount+ncount))
    +
    84  kout(wrd+1) = ior(itemp,ntemp)
    +
    85  ENDIF
    +
    86  100 CONTINUE
    +
    87  koff = offset
    +
    88  RETURN
    +
    89  END
    +
    +
    +
    w3ai40
    subroutine w3ai40(KFLD, KOUT, KLEN, KNUM, KOFF)
    Packs constant size binary strings into an array.
    Definition: w3ai40.f:44
    + + + + diff --git a/ver-2.10.0/w3ai41_8f.html b/ver-2.10.0/w3ai41_8f.html new file mode 100644 index 00000000..a5db6fc0 --- /dev/null +++ b/ver-2.10.0/w3ai41_8f.html @@ -0,0 +1,194 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai41.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ai41.f File Reference
    +
    +
    + +

    Constant size binary string unpacker. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ai41 (KFLD, KOUT, KLEN, KNUM, KOFF)
     Unpack consecutive binary strings of the same size from one user supplied array and store them in the same order right aligned in another array. More...
     
    +

    Detailed Description

    +

    Constant size binary string unpacker.

    +
    Author
    Robert Allard
    +
    Date
    1980-04-01
    + +

    Definition in file w3ai41.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ai41()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ai41 (integer, dimension(*) KFLD,
    integer, dimension(*) KOUT,
     KLEN,
     KNUM,
     KOFF 
    )
    +
    + +

    Unpack consecutive binary strings of the same size from one user supplied array and store them in the same order right aligned in another array.

    +

    W3AI41() is the reverse of W3AI40().

    +

    Program history log:

      +
    • Robert Allard 1980-04-01 R.ALLARD (ORIGINAL AUTHOR) ASMEMBLER LANGUAGE VERSION.
      • +
    • Ralph Jones 1984-07-05 Recompiled for NAS-9050
      • +
    • Ralph Jones 1988-07-05 Wrote fortran version of w3ai41 to unpack variable size binary strings, added code to reverse orfer of bytes.
      • +
    • Ralph Jones 1989-11-04 Convert to craf CFT77 FORTRAN
      • +
    • Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
      • +
    +
    Parameters
    + + + + + + +
    [in]KFLDInteger array contining binary string(s).
    [in]KLENInteger number of bits per string (0 < klen < 65).
    [in]KNUMInteger number of strings to unpack. this value must not exceed the dimension of 'kout'.
    [in]KOFFInteger number specifying the bit offset of the first string 'kfld'. the offset value is reset to include the low order bit of the last string unpacked ('koff' > 0 ).
    [out]KOUTInteger*4 array holding unpacked string(s).
    +
    +
    +

    Exit states: error - 'koff' < 0 if 'klen' has an illegal value or 'knum' < 1 then 'kout' has no strings stored.

    +
    Note
    This subroutine should be written in assembler language. The fortran version runs two or three times slower than the asembler version. The fortran version can be converted to run on other computers with a few changes. The bit manipulation functions are the same in IBM370 vs fortran 4.1, microsoft fortran 4.10, vax fortran. Most modern fortran compiler have and, or, shift functions. If you are running on a pc, vax and your input was made on a IBM370, apollo sun, h.p.. etc. you may have to add more code to reverse the order o bytes in an integer word. NCAR gbytes() can be used instead of this subroutine.
    +
    Author
    Robert Allard
    +
    Date
    1980-04-01
    + +

    Definition at line 44 of file w3ai41.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ai41_8f.js b/ver-2.10.0/w3ai41_8f.js new file mode 100644 index 00000000..65d7b9c7 --- /dev/null +++ b/ver-2.10.0/w3ai41_8f.js @@ -0,0 +1,4 @@ +var w3ai41_8f = +[ + [ "w3ai41", "w3ai41_8f.html#a07de865f47db3f841722760476742c04", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ai41_8f_source.html b/ver-2.10.0/w3ai41_8f_source.html new file mode 100644 index 00000000..0923bc1a --- /dev/null +++ b/ver-2.10.0/w3ai41_8f_source.html @@ -0,0 +1,180 @@ + + + + + + + +NCEPLIBS-w3emc: w3ai41.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ai41.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Constant size binary string unpacker.
    +
    3 C> @author Robert Allard @date 1980-04-01
    +
    4 
    +
    5 C> Unpack consecutive binary strings of the same size from
    +
    6 C> one user supplied array and store them in the same order right
    +
    7 C> aligned in another array. W3AI41() is the reverse of W3AI40().
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - Robert Allard 1980-04-01 R.ALLARD (ORIGINAL AUTHOR) ASMEMBLER LANGUAGE VERSION.
    +
    11 C> - Ralph Jones 1984-07-05 Recompiled for NAS-9050
    +
    12 C> - Ralph Jones 1988-07-05 Wrote fortran version of w3ai41 to unpack
    +
    13 C> variable size binary strings, added code to reverse orfer of bytes.
    +
    14 C> - Ralph Jones 1989-11-04 Convert to craf CFT77 FORTRAN
    +
    15 C> - Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
    +
    16 C>
    +
    17 C> @param[in] KFLD Integer array contining binary string(s).
    +
    18 C> @param[in] KLEN Integer number of bits per string (0 < klen < 65).
    +
    19 C> @param[in] KNUM Integer number of strings to unpack. this value must
    +
    20 C> not exceed the dimension of 'kout'.
    +
    21 C> @param[in] KOFF Integer number specifying the bit offset of the
    +
    22 C> first string 'kfld'. the offset value is reset to
    +
    23 C> include the low order bit of the last string unpacked
    +
    24 C> ('koff' > 0 ).
    +
    25 C> @param[out] KOUT Integer*4 array holding unpacked string(s).
    +
    26 C>
    +
    27 C> Exit states:
    +
    28 C> error - 'koff' < 0 if 'klen' has an illegal value or 'knum' < 1
    +
    29 C> then 'kout' has no strings stored.
    +
    30 C>
    +
    31 C> @note This subroutine should be written in assembler language.
    +
    32 C> The fortran version runs two or three times slower than the asembler
    +
    33 C> version. The fortran version can be converted to run on other
    +
    34 C> computers with a few changes. The bit manipulation functions are the
    +
    35 C> same in IBM370 vs fortran 4.1, microsoft fortran 4.10, vax fortran.
    +
    36 C> Most modern fortran compiler have and, or, shift functions. If you
    +
    37 C> are running on a pc, vax and your input was made on a IBM370, apollo
    +
    38 C> sun, h.p.. etc. you may have to add more code to reverse the order o
    +
    39 C> bytes in an integer word. NCAR gbytes() can be used instead of this
    +
    40 C> subroutine.
    +
    41 C>
    +
    42 C> @author Robert Allard @date 1980-04-01
    +
    43  SUBROUTINE w3ai41(KFLD,KOUT,KLEN,KNUM,KOFF)
    +
    44 C
    +
    45  INTEGER KFLD(*)
    +
    46  INTEGER KOUT(*)
    +
    47  INTEGER BITSET
    +
    48  INTEGER OFFSET
    +
    49  INTEGER WRDSET
    +
    50 C
    +
    51  offset = koff
    +
    52  IF (offset.LT.0) RETURN
    +
    53  IF (klen.GT.64.OR.klen.LT.1) THEN
    +
    54  koff = -1
    +
    55  RETURN
    +
    56  ENDIF
    +
    57 C
    +
    58  IF (knum.LT.1) THEN
    +
    59  koff = -1
    +
    60  RETURN
    +
    61  ENDIF
    +
    62 C
    +
    63  jcount = klen - 64
    +
    64  length = klen
    +
    65 C
    +
    66  DO 100 i = 1,knum
    +
    67  wrdset = ishft(offset,-6)
    +
    68  bitset = mod(offset,64)
    +
    69  itemp = kfld(wrdset+1)
    +
    70  ntemp = kfld(wrdset+2)
    +
    71  itemp = ishft(itemp,bitset)
    +
    72  ntemp = ishft(ntemp,bitset-64)
    +
    73  kout(i) = ishft(ior(itemp,ntemp),jcount)
    +
    74  offset = offset + length
    +
    75  100 CONTINUE
    +
    76  koff = offset
    +
    77  RETURN
    +
    78  END
    +
    +
    +
    w3ai41
    subroutine w3ai41(KFLD, KOUT, KLEN, KNUM, KOFF)
    Unpack consecutive binary strings of the same size from one user supplied array and store them in the...
    Definition: w3ai41.f:44
    + + + + diff --git a/ver-2.10.0/w3aq15_8f.html b/ver-2.10.0/w3aq15_8f.html new file mode 100644 index 00000000..3b4096ea --- /dev/null +++ b/ver-2.10.0/w3aq15_8f.html @@ -0,0 +1,167 @@ + + + + + + + +NCEPLIBS-w3emc: w3aq15.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3aq15.f File Reference
    +
    +
    + +

    GMT time packer. +More...

    + +

    Go to the source code of this file.

    + + + + +

    +Functions/Subroutines

    subroutine w3aq15 (ITIME, QDESCR)
     
    +

    Detailed Description

    +

    GMT time packer.

    +
    Author
    B. Struble
    +
    Date
    1983-12-12
    + +

    Definition in file w3aq15.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3aq15()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3aq15 (integer ITIME,
    character * 80 QDESCR 
    )
    +
    +
    Note
    Convert 32 or 64 bit binary time (GMT) into a 16 bit string and store these 4 packed decimal numbers into bytes 39 and 40 of the output array.
    +

    Program history log:

      +
    • B. Struble 1983-12-12
      • +
    • Ralph Jones 1984-07-06 Change to ibm assembler v 02.
      • +
    • Ralph Jones 1995-10-16 Change to fortran for cray and 32 bit workstations.
      • +
    +
    Parameters
    + + + +
    [in]ITIMEInteger word containing time in binary.
    [out]QDESCRArray containing transmission queue descriptor Time will be placed in 39 and 40th byte of this array as 4 (4 bit) BCD.
    +
    +
    +
    Note
    The user can obtain the current time in GMT by invocking the W3 library routine w3fq02 which fills an eight word array with the current date and time. The 5th word from this array contains the time which can be passed to w3aq15 as the input parameter-itime.
    +
    Author
    B. Struble
    +
    Date
    1983-12-12
    + +

    Definition at line 28 of file w3aq15.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3aq15_8f.js b/ver-2.10.0/w3aq15_8f.js new file mode 100644 index 00000000..e28dc65b --- /dev/null +++ b/ver-2.10.0/w3aq15_8f.js @@ -0,0 +1,4 @@ +var w3aq15_8f = +[ + [ "w3aq15", "w3aq15_8f.html#aa2f10d43798cbba2f9089d37ab1fcdaa", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3aq15_8f_source.html b/ver-2.10.0/w3aq15_8f_source.html new file mode 100644 index 00000000..700571d8 --- /dev/null +++ b/ver-2.10.0/w3aq15_8f_source.html @@ -0,0 +1,149 @@ + + + + + + + +NCEPLIBS-w3emc: w3aq15.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3aq15.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief GMT time packer.
    +
    3 C> @author B. Struble @date 1983-12-12
    +
    4 
    +
    5 C>
    +
    6 C> @note Convert 32 or 64 bit binary time (GMT) into a 16 bit
    +
    7 C> string and store these 4 packed decimal numbers into bytes
    +
    8 C> 39 and 40 of the output array.
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - B. Struble 1983-12-12
    +
    12 C> - Ralph Jones 1984-07-06 Change to ibm assembler v 02.
    +
    13 C> - Ralph Jones 1995-10-16 Change to fortran for cray and 32 bit workstations.
    +
    14 C>
    +
    15 C> @param[in] ITIME Integer word containing time in binary.
    +
    16 C> @param[out] QDESCR Array containing transmission queue descriptor
    +
    17 C> Time will be placed in 39 and 40th byte of this array as 4 (4 bit) BCD.
    +
    18 C>
    +
    19 C>
    +
    20 C> @note The user can obtain the current time in GMT by invocking
    +
    21 C> the W3 library routine w3fq02 which fills an eight word array
    +
    22 C> with the current date and time. The 5th word from this array
    +
    23 C> contains the time which can be passed to w3aq15 as the
    +
    24 C> input parameter-itime.
    +
    25 C>
    +
    26 C> @author B. Struble @date 1983-12-12
    +
    27  SUBROUTINE w3aq15(ITIME, QDESCR)
    +
    28  INTEGER ITIME
    +
    29 C
    +
    30  CHARACTER * 80 QDESCR
    +
    31 C
    +
    32 C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION
    +
    33 C TWO BYTES AS 4 BIT BCD
    +
    34 C
    +
    35 C
    +
    36 C CONVERT INTO 4 BIT BCD
    +
    37 C
    +
    38  ka = itime / 1000
    +
    39  kb = mod(itime,1000) / 100
    +
    40  kc = mod(itime,100) / 10
    +
    41  kd = mod(itime,10)
    +
    42 C
    +
    43  qdescr(39:39) = char(ka * 16 + kb)
    +
    44  qdescr(40:40) = char(kc * 16 + kd)
    +
    45 C
    +
    46  RETURN
    +
    47  END
    +
    +
    +
    w3aq15
    subroutine w3aq15(ITIME, QDESCR)
    Definition: w3aq15.f:28
    + + + + diff --git a/ver-2.10.0/w3as00_8f.html b/ver-2.10.0/w3as00_8f.html new file mode 100644 index 00000000..a3fb4128 --- /dev/null +++ b/ver-2.10.0/w3as00_8f.html @@ -0,0 +1,199 @@ + + + + + + + +NCEPLIBS-w3emc: w3as00.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3as00.f File Reference
    +
    +
    + +

    Get parm field from command-line. +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + +

    +Functions/Subroutines

    +integer function lastch (str)
     
    +integer function notrail (str)
     
    subroutine w3as00 (nch_parm, cparm, iret_parm)
     To get the one command-line argument which starts with "parm="; returning the parm field (without the keyword "parm=") as a null-terminated string in the character string:cparm. More...
     
    +

    Detailed Description

    +

    Get parm field from command-line.

    +
    Author
    David Shimomura
    +
    Date
    1995-05-23
    + +

    Definition in file w3as00.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3as00()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3as00 (integer nch_parm,
    character*(*) cparm,
    integer iret_parm 
    )
    +
    + +

    To get the one command-line argument which starts with "parm="; returning the parm field (without the keyword "parm=") as a null-terminated string in the character string:cparm.

    +

    Program history log:

      +
    • David Shimomura 1995-05-23
      • +
    • Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive
      • +
    +
    Parameters
    + + + + +
    [out]NCH_PARMNo. of characters in the parm field
    [out]CPARMC*(*) cparm – the destination for the parmfield obtained from the command line; user should define the character string for a size .le. 101-bytes, which would be big enough for the 100-char ibm limit plus one extra byte for my null-terminator.
    [out]iret_parm- Return code
      +
    • = 0; Normal return
      • +
    • = -1; Abnormal exit. the user has failed to define the cparm destination as a character string.
      • +
    • = +1; A Warning: the given arg in the command line was too long to fit in the destination: cparm, so i have truncated it.
      • +
    • = +2; A warning: no args at all on command line, so i could not fetch the parm field.
      • +
    • = +3; A warning: no "parm="-argument exists among the args on the command line, so i could not fetch the parm field.
      • +
    +
    +
    +
    +
      +
    • OKL:
        +
      • FT06F001 - Some checkout printout
        • +
      +
      • +
    +
    Note
    To emulate the ibm parm field, the user should key_in on the command line:
      +
    • parm='in between the single_quotes is the parm field' what is returned from w3as00() from the parm= arg is the parm field: which starts with the location beyond the equal_sign of the keyword "parm=", and includes everything which was within the bounds of the single-quote signs. But the quote signs themselves will disappear; and a null- terminator will be added. The starting "parm=" is a key word for the parms, and should not be used to start any other argument.
      • +
    +
    +
    +I have changed the call sequence by adding a return code.
    +
    Author
    David Shimomura
    +
    Date
    1995-05-23
    + +

    Definition at line 54 of file w3as00.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3as00_8f.js b/ver-2.10.0/w3as00_8f.js new file mode 100644 index 00000000..1a4e0fbf --- /dev/null +++ b/ver-2.10.0/w3as00_8f.js @@ -0,0 +1,6 @@ +var w3as00_8f = +[ + [ "lastch", "w3as00_8f.html#a26ea8486571f9eff4e6e0c10f120518a", null ], + [ "notrail", "w3as00_8f.html#abd251a32b0d875bec7b812d2342950a1", null ], + [ "w3as00", "w3as00_8f.html#ac8d842c4ccf854fbe44fc54123c40529", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3as00_8f_source.html b/ver-2.10.0/w3as00_8f_source.html new file mode 100644 index 00000000..30fd0927 --- /dev/null +++ b/ver-2.10.0/w3as00_8f_source.html @@ -0,0 +1,401 @@ + + + + + + + +NCEPLIBS-w3emc: w3as00.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3as00.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Get parm field from command-line.
    +
    3 C> @author David Shimomura @date 1995-05-23
    +
    4 
    +
    5 C> To get the one command-line argument which starts with
    +
    6 C> "parm="; returning the parm field (without the keyword "parm=")
    +
    7 C> as a null-terminated string in the character string:cparm.
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - David Shimomura 1995-05-23
    +
    11 C> - Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive
    +
    12 C>
    +
    13 C> @param[out] NCH_PARM No. of characters in the parm field
    +
    14 C> @param[out] CPARM C*(*) cparm -- the destination for the parmfield
    +
    15 C> obtained from the command line; user should define the character string for
    +
    16 C> a size .le. 101-bytes, which would be big enough for the 100-char ibm
    +
    17 C> limit plus one extra byte for my null-terminator.
    +
    18 C> @param[out] iret_parm - Return code
    +
    19 C> - = 0; Normal return
    +
    20 C> - = -1; Abnormal exit. the user has failed
    +
    21 C> to define the cparm destination as a character string.
    +
    22 C>
    +
    23 C> - = +1; A Warning:
    +
    24 C> the given arg in the command line was
    +
    25 C> too long to fit in the destination: cparm,
    +
    26 C> so i have truncated it.
    +
    27 C>
    +
    28 C> - = +2; A warning: no args at all on command line,
    +
    29 C> so i could not fetch the parm field.
    +
    30 C>
    +
    31 C> - = +3; A warning: no "parm="-argument exists
    +
    32 C> among the args on the command line,
    +
    33 C> so i could not fetch the parm field.
    +
    34 C>
    +
    35 C> - OKL:
    +
    36 C> - FT06F001 - Some checkout printout
    +
    37 C>
    +
    38 C> @note To emulate the ibm parm field, the user should key_in on the
    +
    39 C> command line:
    +
    40 C> - parm='in between the single_quotes is the parm field'
    +
    41 C> what is returned from w3as00() from the parm= arg is
    +
    42 C> the parm field: which starts with the location beyond the
    +
    43 C> equal_sign of the keyword "parm=", and includes everything
    +
    44 C> which was within the bounds of the single-quote signs.
    +
    45 C> But the quote signs themselves will disappear; and a null-
    +
    46 C> terminator will be added.
    +
    47 C> The starting "parm=" is a key word for the parms, and should
    +
    48 C> not be used to start any other argument.
    +
    49 C>
    +
    50 C> @note I have changed the call sequence by adding a return code.
    +
    51 C>
    +
    52 C> @author David Shimomura @date 1995-05-23
    +
    53  subroutine w3as00(nch_parm,cparm,iret_parm)
    +
    54 C
    +
    55  integer kbytpwrd
    +
    56  parameter(kbytpwrd=8)
    +
    57  integer maxnbyt
    +
    58  parameter(maxnbyt=112)
    +
    59 C ... WHERE 112 CHARACTERS IS SIZE OF CWORK FOR 100 CHARACTERS
    +
    60 C ... WITHIN QUOTES + 'PARM=' + BACKSLASHES + LINEFEEDS
    +
    61 
    +
    62  integer maxnwrds
    +
    63  parameter(maxnwrds=maxnbyt/kbytpwrd)
    +
    64 
    +
    65 C ... call seq. args ...
    +
    66  INTEGER NCH_PARM
    +
    67  CHARACTER*(*) CPARM
    +
    68  integer iret_parm
    +
    69 
    +
    70 C
    +
    71 C ... FUNCTIONS ...
    +
    72  external lastch
    +
    73  integer lastch
    +
    74  external notrail
    +
    75  integer notrail
    +
    76 C -------------------------------------------------------------
    +
    77  integer jwork(maxnwrds)
    +
    78  character*112 cwork
    +
    79  equivalence(jwork,cwork)
    +
    80 
    +
    81  integer(4) nargsinline,iargc,iar
    +
    82  integer nchars
    +
    83  integer lmt_txt
    +
    84  integer non_parm
    +
    85 
    +
    86  LOGICAL LPARMQQ
    +
    87  character*1 KLF
    +
    88  character*1 NULLCHR
    +
    89  character*1 lonech
    +
    90 
    +
    91 C . . . . . . . . S T A R T . . . . . . . . . . . . . . . .
    +
    92 
    +
    93  nullchr = char(0)
    +
    94  klf = char(10)
    +
    95 C
    +
    96  iret_parm = 0
    +
    97  non_parm = 0
    +
    98 
    +
    99  lparmqq = .false.
    +
    100  nch_parm = 0
    +
    101 
    +
    102  lmt_dest = len(cparm)
    +
    103  write(6,103)lmt_dest
    +
    104  103 format(1h ,'W3AS00: dimensioned size (in bytes) of dest strng=',
    +
    105  1 i11)
    +
    106  if(lmt_dest .le. 0) then
    +
    107  write(6,105)
    +
    108  105 format(1h ,'W3AS00:FAILED on undefined destination ',
    +
    109  1 'character string: CPARM')
    +
    110  iret_parm = -1
    +
    111  nch_parm = 0
    +
    112  go to 999
    +
    113  else if (lmt_dest .gt. 101) then
    +
    114  lmt_dest = 101
    +
    115  endif
    +
    116  lmt_txt = lmt_dest - 1
    +
    117 
    +
    118  cparm(1:lmt_dest) = ' '
    +
    119 
    +
    120  narg_got = 0
    +
    121 C
    +
    122  nargsinline = iargc()
    +
    123 
    +
    124  write(6,115) nargsinline
    +
    125  115 format(1h ,'W3AS00: count of args found in command line =', i3)
    +
    126 
    +
    127  if(nargsinline .gt. 0) then
    +
    128 C ... to scan every argument, looking only for the Arg which
    +
    129 C ... starts with "PARM="
    +
    130  do iar = 1,nargsinline
    +
    131  lparmqq = .false.
    +
    132 
    +
    133  cwork(1:) = ' '
    +
    134 
    +
    135  call getarg(iar,cwork)
    +
    136 
    +
    137  narg_got = narg_got + 1
    +
    138  nchars = lastch(cwork)
    +
    139 
    +
    140  if(nchars .le. 0) then
    +
    141  write(6,125)iar
    +
    142  125 format(1h ,'W3AS00:getarg() returned an empty arg for',
    +
    143  a ' no.',i3 )
    +
    144  else
    +
    145 C ... SOME TEXT EXISTS IN THIS ARG ...
    +
    146 C ... DOES IT START WITH "PARM=" ???
    +
    147  if((cwork(1:5) .EQ. 'PARM=') .OR.
    +
    148  1 (cwork(1:5) .EQ. 'parm=') ) then
    +
    149  lparmqq = .true.
    +
    150 C ... this arg is special case of PARM=
    +
    151 C ... which can include blanks, so cannot lastch() it ...
    +
    152  nchars = notrail(cwork)
    +
    153  endif
    +
    154 C ... iwdss = ((nchars-1)/kbytpwrd) + 1
    +
    155 C ... where iwdss points to last word so I could hex dump
    +
    156 C ... that last word, to see if NULL is there
    +
    157 C ... There was no NULL; only blank fill.
    +
    158  IF(lparmqq) THEN
    +
    159 C ... FILTER OUT ANY BACKSLASH or LINE_FEED ...
    +
    160  ioutc = 0
    +
    161  do inc = 6,nchars
    +
    162  if(ioutc .LT. lmt_txt) then
    +
    163  lonech = cwork(inc:inc)
    +
    164  if((lonech .EQ. '\\') .OR.
    +
    165  1 (lonech .EQ. klf)) then
    +
    166  else
    +
    167  ioutc = ioutc + 1
    +
    168  cparm(ioutc:ioutc) = lonech
    +
    169  endif
    +
    170  else
    +
    171 C ... comes here if ioutc .GE. lmt_txt,
    +
    172 C ... so I cannot increment ioutc for this inc char
    +
    173 C ... so truncate the string at (1:ioutc)
    +
    174 C ... a warning be return-coded ...
    +
    175  iret_parm = +1
    +
    176  go to 155
    +
    177  endif
    +
    178  enddo
    +
    179  155 continue
    +
    180  nch_parm = ioutc
    +
    181  np1 = nchars+1
    +
    182  cparm(np1:np1) = nullchr
    +
    183  go to 999
    +
    184 C ... jump out of DO when PARM has been processed ...
    +
    185  else
    +
    186 C ... this is .not. a PARM field, do nothing w/ those,
    +
    187  non_parm = non_parm + 1
    +
    188  endif
    +
    189 
    +
    190  endif
    +
    191  enddo
    +
    192 C ... IF IT FALLS THRU BOTTOM OF DO, THEN IT DID NOT FIND
    +
    193 C ... THE PARM FIELD AMONG THE EXISTING ARGS
    +
    194  iret_parm = 3
    +
    195  nch_parm = 0
    +
    196 
    +
    197  ELSE
    +
    198 C ... COMES HERE IF nargsinline = 0, so there were no args at all
    +
    199  iret_parm = 2
    +
    200  nch_parm = 0
    +
    201  endif
    +
    202  go to 999
    +
    203 
    +
    204  999 continue
    +
    205  return
    +
    206  end
    +
    207  integer function lastch(str)
    +
    208 C ... lastch() ... to point to the last character of a character
    +
    209 C ... string
    +
    210 C ... String terminators are first BLANK or NULL character
    +
    211 C ... encountered.
    +
    212 C ... Caution: I will limit scan on LEN(str)
    +
    213 C so you must give me a character string.
    +
    214 C
    +
    215 
    +
    216  character*(*) str
    +
    217 
    +
    218  character*1 NULLCHR
    +
    219  character*1 BLANK
    +
    220 C
    +
    221  integer i
    +
    222  integer limit
    +
    223 C
    +
    224  nullchr = char(0)
    +
    225  blank = ' '
    +
    226  limit = len(str)
    +
    227  i = 0
    +
    228  do while(i .LT. limit .AND. str(i+1:i+1) .NE. nullchr
    +
    229  1 .AND. str(i+1:i+1) .NE. blank)
    +
    230  i = i + 1
    +
    231  enddo
    +
    232 
    +
    233  lastch = i
    +
    234  return
    +
    235  end
    +
    236  integer function notrail(str)
    +
    237 C ... mods for CRAY version 8-Dec-1994/dss
    +
    238 C
    +
    239 C ... notrail() ... to point to the last non-blank character of a
    +
    240 C ... character string (which can have leading
    +
    241 C blanks and intermediate blanks); but after
    +
    242 C ignoring all trailing blank characters.
    +
    243 C ... String terminators are last BLANK or first NULL
    +
    244 C ... character encountered.
    +
    245 C
    +
    246 C ... This differs from LASTCH() which stops on first
    +
    247 C ... BLANK encountered when scanning from the start;
    +
    248 C ... NOTRAIL() will scan backwards from the end of the
    +
    249 C ... string, skipping over trailing blanks, until the
    +
    250 C ... last non-blank character is hit.
    +
    251 C ...
    +
    252 C ... Caution: I will limit scan on LEN(str)
    +
    253 C so you must give me a character string.
    +
    254 C
    +
    255 
    +
    256  character*(*) str
    +
    257 
    +
    258  character*1 BLANK
    +
    259  parameter(blank = ' ')
    +
    260 C
    +
    261  integer i
    +
    262  integer limit
    +
    263  integer limitnl
    +
    264  character*1 NULLCHR
    +
    265 C
    +
    266  nullchr = char(0)
    +
    267  i = 0
    +
    268  limitnl = 0
    +
    269  limit = len(str)
    +
    270  if(limit .le. 0) go to 999
    +
    271 C ... otherwise, at least one char len string ...
    +
    272  limitnl = index(str(1:limit),nullchr)
    +
    273  if(limitnl .le. 0) then
    +
    274 C ... no NULLCHR exists in str(1:limit) ...
    +
    275 C ... so go scan from limit
    +
    276  go to 300
    +
    277 
    +
    278  else if(limitnl .eq. 1) then
    +
    279  go to 999
    +
    280 C ... which jumped out w/ pointer=0 if NULL in first position
    +
    281  else
    +
    282 C ... a NULLCHR existed within str(1:limit); so
    +
    283 C ... I want to scan backwards from before that NULLCHR
    +
    284 C ... which is located at limitnl
    +
    285  limit = limitnl - 1
    +
    286  endif
    +
    287  if(limit .le. 0) go to 999
    +
    288  300 continue
    +
    289 C ... otherwise, we have a string of at least one char to look at
    +
    290 C ... which has no NULLCHR in interval (1:limit)
    +
    291  i = limit
    +
    292  do while((i .GT. 0) .AND. (str(i:i) .EQ. blank))
    +
    293  i = i - 1
    +
    294  enddo
    +
    295 
    +
    296  999 continue
    +
    297  notrail = i
    +
    298  return
    +
    299  end
    +
    +
    +
    w3as00
    subroutine w3as00(nch_parm, cparm, iret_parm)
    To get the one command-line argument which starts with "parm="; returning the parm field (without the...
    Definition: w3as00.f:54
    + + + + diff --git a/ver-2.10.0/w3ctzdat_8f.html b/ver-2.10.0/w3ctzdat_8f.html new file mode 100644 index 00000000..e21e779b --- /dev/null +++ b/ver-2.10.0/w3ctzdat_8f.html @@ -0,0 +1,173 @@ + + + + + + + +NCEPLIBS-w3emc: w3ctzdat.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ctzdat.f File Reference
    +
    +
    + +

    Converts an ncep absolute date and time to another time zone. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ctzdat (ntz, idat, jdat)
     THis subprogram converts an ncep absolute date and time to another time zone. More...
     
    +

    Detailed Description

    +

    Converts an ncep absolute date and time to another time zone.

    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition in file w3ctzdat.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ctzdat()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ctzdat ( ntz,
    integer, dimension(8) idat,
    integer, dimension(8) jdat 
    )
    +
    + +

    THis subprogram converts an ncep absolute date and time to another time zone.

    +

    Program history log:

      +
    • Mark Iredell 1998-01-05
      • +
    +
    Parameters
    + + + + +
    [in]NTZInteger new time zone differential from utc in signed hh or hhmm format (if ntz is invalid, no change is made.)
    [in]IDATInteger (8) ncep absolute date and time (year, month, day, time zone, hour, minute, second, millisecond)
    [out]JDATInteger (8) ncep absolute date and time (year, month, day, time zone, hour, minute, second, millisecond)
    +
    +
    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition at line 21 of file w3ctzdat.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ctzdat_8f.js b/ver-2.10.0/w3ctzdat_8f.js new file mode 100644 index 00000000..805ebe75 --- /dev/null +++ b/ver-2.10.0/w3ctzdat_8f.js @@ -0,0 +1,4 @@ +var w3ctzdat_8f = +[ + [ "w3ctzdat", "w3ctzdat_8f.html#a7a6f88432171c9c1d03d4fc7c3e2d035", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ctzdat_8f_source.html b/ver-2.10.0/w3ctzdat_8f_source.html new file mode 100644 index 00000000..1e4e8f50 --- /dev/null +++ b/ver-2.10.0/w3ctzdat_8f_source.html @@ -0,0 +1,135 @@ + + + + + + + +NCEPLIBS-w3emc: w3ctzdat.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ctzdat.f
    +
    +
    +Go to the documentation of this file.
    1 
    +
    4 
    +
    19 
    +
    20  subroutine w3ctzdat(ntz,idat,jdat)
    +
    21  integer idat(8),jdat(8)
    +
    22  real rinc1(5),rinc2(5)
    +
    23 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    24 ! determine if the input time zone is in valid hh or hhmm format
    +
    25  if(ntz.gt.-24.and.ntz.lt.24) then
    +
    26  itz=ntz*100
    +
    27  elseif(ntz.eq.mod(ntz/100,24)*100+mod(mod(ntz,100),60)/30*30) then
    +
    28  itz=ntz
    +
    29  else
    +
    30  itz=idat(4)
    +
    31  endif
    +
    32 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    33 ! determine new time of day, putting into reduced form
    +
    34 ! and possibly adjust the date as well
    +
    35  rinc1(1)=0
    +
    36  rinc1(2)=idat(5)+itz/100-idat(4)/100
    +
    37  rinc1(3)=idat(6)+mod(itz,100)-mod(idat(4),100)
    +
    38  rinc1(4)=idat(7)
    +
    39  rinc1(5)=idat(8)
    +
    40  call w3reddat(-1,rinc1,rinc2)
    +
    41  jldayn=iw3jdn(idat(1),idat(2),idat(3))+nint(rinc2(1))
    +
    42  call w3fs26(jldayn,jdat(1),jdat(2),jdat(3),jdow,jdoy)
    +
    43  jdat(4)=itz
    +
    44  jdat(5:8)=nint(rinc2(2:5))
    +
    45 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    46  end
    +
    +
    +
    w3fs26
    subroutine w3fs26(JLDAYN, IYEAR, MONTH, IDAY, IDAYWK, IDAYYR)
    Computes year (4 digits), month, day, day of week, day of year from julian day number.
    Definition: w3fs26.f:56
    +
    w3ctzdat
    subroutine w3ctzdat(ntz, idat, jdat)
    THis subprogram converts an ncep absolute date and time to another time zone.
    Definition: w3ctzdat.f:21
    +
    w3reddat
    subroutine w3reddat(it, rinc, dinc)
    This subprogram reduces an ncep relative time interval into one of seven canonical forms,...
    Definition: w3reddat.f:86
    +
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    + + + + diff --git a/ver-2.10.0/w3difdat_8f.html b/ver-2.10.0/w3difdat_8f.html new file mode 100644 index 00000000..d4878496 --- /dev/null +++ b/ver-2.10.0/w3difdat_8f.html @@ -0,0 +1,181 @@ + + + + + + + +NCEPLIBS-w3emc: w3difdat.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3difdat.f File Reference
    +
    +
    + +

    Return a time interval between two dates. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3difdat (jdat, idat, it, rinc)
     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. More...
     
    +

    Detailed Description

    +

    Return a time interval between two dates.

    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition in file w3difdat.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3difdat()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3difdat (integer, dimension(8) jdat,
    integer, dimension(8) idat,
     it,
    real, dimension(5) rinc 
    )
    +
    + +

    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:

      +
    • Mark Iredell 1998-01-05
      • +
    +
    Parameters
    + + + + + +
    [in]JDATInteger (8) ncep absolute date and time (year, month, day, time zone, hour, minute, second, millisecond)
    [in]IDATInteger (8) ncep absolute date and time (year, month, day, time zone, hour, minute, second, millisecond)
    [in]ITInteger 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)
    [out]RINCReal (5) ncep relative time interval (days, hours, minutes, seconds, milliseconds) (time interval is positive if jdat is later than idat.)
    +
    +
    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition at line 29 of file w3difdat.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3difdat_8f.js b/ver-2.10.0/w3difdat_8f.js new file mode 100644 index 00000000..a92182f9 --- /dev/null +++ b/ver-2.10.0/w3difdat_8f.js @@ -0,0 +1,4 @@ +var w3difdat_8f = +[ + [ "w3difdat", "w3difdat_8f.html#a2936ff0b58e9174ca023c557fe3d57b1", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3difdat_8f_source.html b/ver-2.10.0/w3difdat_8f_source.html new file mode 100644 index 00000000..ae5d2ebe --- /dev/null +++ b/ver-2.10.0/w3difdat_8f_source.html @@ -0,0 +1,117 @@ + + + + + + + +NCEPLIBS-w3emc: w3difdat.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3difdat.f
    +
    +
    +Go to the documentation of this file.
    1 
    +
    4 
    +
    28  subroutine w3difdat(jdat,idat,it,rinc)
    +
    29  integer jdat(8),idat(8)
    +
    30  real rinc(5)
    +
    31  real rinc1(5)
    +
    32 ! difference the days and time and put into canonical form
    +
    33  rinc1(1)=iw3jdn(jdat(1),jdat(2),jdat(3))-
    +
    34  & iw3jdn(idat(1),idat(2),idat(3))
    +
    35  rinc1(2:5)=jdat(5:8)-idat(5:8)
    +
    36  call w3reddat(it,rinc1,rinc)
    +
    37 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    38  end
    +
    +
    +
    w3reddat
    subroutine w3reddat(it, rinc, dinc)
    This subprogram reduces an ncep relative time interval into one of seven canonical forms,...
    Definition: w3reddat.f:86
    +
    w3difdat
    subroutine w3difdat(jdat, idat, it, rinc)
    Returns the elapsed time interval from an NCEP absolute date and time given in the second argument un...
    Definition: w3difdat.f:29
    +
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    + + + + diff --git a/ver-2.10.0/w3doxdat_8f.html b/ver-2.10.0/w3doxdat_8f.html new file mode 100644 index 00000000..6f00d37b --- /dev/null +++ b/ver-2.10.0/w3doxdat_8f.html @@ -0,0 +1,180 @@ + + + + + + + +NCEPLIBS-w3emc: w3doxdat.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3doxdat.f File Reference
    +
    +
    + +

    Returns the integer day of week, the day of year, and julian day given an NCEP absolute date and time. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3doxdat (idat, jdow, jdoy, jday)
     Program history log: More...
     
    +

    Detailed Description

    +

    Returns the integer day of week, the day of year, and julian day given an NCEP absolute date and time.

    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition in file w3doxdat.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3doxdat()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3doxdat (integer, dimension(8) idat,
     jdow,
     jdoy,
     jday 
    )
    +
    + +

    Program history log:

    +
      +
    • Mark Iredell 1998-01-05
      • +
    +
    Parameters
    + + + + + +
    [in]IDATInteger (8) NCEP absolute date and time (year, month, day, time zone, hour, minute, second, millisecond)
    [out]JDOWInteger day of week (1-7, where 1 is sunday)
    [out]JDOYInteger day of year (1-366, where 1 is january 1)
    [out]JDAYInteger julian day (day number from jan. 1,4713 b.c.)
    +
    +
    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition at line 17 of file w3doxdat.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3doxdat_8f.js b/ver-2.10.0/w3doxdat_8f.js new file mode 100644 index 00000000..570f4e46 --- /dev/null +++ b/ver-2.10.0/w3doxdat_8f.js @@ -0,0 +1,4 @@ +var w3doxdat_8f = +[ + [ "w3doxdat", "w3doxdat_8f.html#aac79cad5709e4bc418ee85ac469afa29", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3doxdat_8f_source.html b/ver-2.10.0/w3doxdat_8f_source.html new file mode 100644 index 00000000..8a17d82d --- /dev/null +++ b/ver-2.10.0/w3doxdat_8f_source.html @@ -0,0 +1,112 @@ + + + + + + + +NCEPLIBS-w3emc: w3doxdat.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3doxdat.f
    +
    +
    +Go to the documentation of this file.
    1 
    +
    5 
    +
    16  subroutine w3doxdat(idat,jdow,jdoy,jday)
    +
    17  integer idat(8)
    +
    18 ! get julian day and then get day of week and day of year
    +
    19  jday=iw3jdn(idat(1),idat(2),idat(3))
    +
    20  call w3fs26(jday,jy,jm,jd,jdow,jdoy)
    +
    21  end
    +
    +
    +
    w3fs26
    subroutine w3fs26(JLDAYN, IYEAR, MONTH, IDAY, IDAYWK, IDAYYR)
    Computes year (4 digits), month, day, day of week, day of year from julian day number.
    Definition: w3fs26.f:56
    +
    w3doxdat
    subroutine w3doxdat(idat, jdow, jdoy, jday)
    Program history log:
    Definition: w3doxdat.f:17
    +
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    + + + + diff --git a/ver-2.10.0/w3fa01_8f.html b/ver-2.10.0/w3fa01_8f.html new file mode 100644 index 00000000..c26b1231 --- /dev/null +++ b/ver-2.10.0/w3fa01_8f.html @@ -0,0 +1,199 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa01.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fa01.f File Reference
    +
    +
    + +

    Compute lifting condendsation level. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fa01 (P, T, RH, TD, PLCL, TLCL)
     Given the pressure, temperature and relative humidity of an air parcel at some point in the atmosphere, calculate the dewpoint temperature and the pressure and temperature of the lifting condensation level. More...
     
    +

    Detailed Description

    +

    Compute lifting condendsation level.

    +
    Author
    James Howcroft
    +
    Date
    1979-07-01
    + +

    Definition in file w3fa01.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fa01()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fa01 ( P,
     T,
     RH,
     TD,
     PLCL,
     TLCL 
    )
    +
    + +

    Given the pressure, temperature and relative humidity of an air parcel at some point in the atmosphere, calculate the dewpoint temperature and the pressure and temperature of the lifting condensation level.

    +

    Program history log:

      +
    • James Howcroft 1979-07-01
      • +
    • Ralph Jones 1989-01-24 Change to microsoft fortran 4.10.
      • +
    • Ralph Jones 1990-06-11 Change to sun fortran 1.3.
      • +
    • Ralph Jones 1991-03-29 Convert to silicongraphics fortran.
      • +
    • Ralph Jones 1993-03-29 Add save statement.
      • +
    • Ralph Jones 1995-09-25 Put in cray w3 library.
      • +
    +
    Parameters
    + + + + + + + +
    [in]PParcel pressure in millibars.
    [in]TParcel temperature in degrees celsius.
    [in]RHParcel relative humidity in percent.
    [out]TDDewpoint temperature in degrees celsius.
    [out]PLCLPressure of LCL in millibars.
    [out]TLCLTemperature at LCL in degrees celsius.
    +
    +
    +
    Author
    James Howcroft
    +
    Date
    1979-07-01
    + +

    Definition at line 27 of file w3fa01.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fa01_8f.js b/ver-2.10.0/w3fa01_8f.js new file mode 100644 index 00000000..e0324d17 --- /dev/null +++ b/ver-2.10.0/w3fa01_8f.js @@ -0,0 +1,4 @@ +var w3fa01_8f = +[ + [ "w3fa01", "w3fa01_8f.html#ae5c40f5b79f9833cb7012d9401bfa7b8", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fa01_8f_source.html b/ver-2.10.0/w3fa01_8f_source.html new file mode 100644 index 00000000..8250fefb --- /dev/null +++ b/ver-2.10.0/w3fa01_8f_source.html @@ -0,0 +1,183 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa01.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fa01.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Compute lifting condendsation level.
    +
    3 C> @author James Howcroft @date 1979-07-01
    +
    4 
    +
    5 C> Given the pressure, temperature and relative humidity of
    +
    6 C> an air parcel at some point in the atmosphere, calculate the
    +
    7 C> dewpoint temperature and the pressure and temperature of the
    +
    8 C> lifting condensation level.
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - James Howcroft 1979-07-01
    +
    12 C> - Ralph Jones 1989-01-24 Change to microsoft fortran 4.10.
    +
    13 C> - Ralph Jones 1990-06-11 Change to sun fortran 1.3.
    +
    14 C> - Ralph Jones 1991-03-29 Convert to silicongraphics fortran.
    +
    15 C> - Ralph Jones 1993-03-29 Add save statement.
    +
    16 C> - Ralph Jones 1995-09-25 Put in cray w3 library.
    +
    17 C>
    +
    18 C> @param[in] P Parcel pressure in millibars.
    +
    19 C> @param[in] T Parcel temperature in degrees celsius.
    +
    20 C> @param[in] RH Parcel relative humidity in percent.
    +
    21 C> @param[out] TD Dewpoint temperature in degrees celsius.
    +
    22 C> @param[out] PLCL Pressure of LCL in millibars.
    +
    23 C> @param[out] TLCL Temperature at LCL in degrees celsius.
    +
    24 C>
    +
    25 C> @author James Howcroft @date 1979-07-01
    +
    26  SUBROUTINE w3fa01(P,T,RH,TD,PLCL,TLCL)
    +
    27 C
    +
    28  SAVE
    +
    29 C
    +
    30 C DEFINITION OF THE POTENTIAL TEMPERATURE
    +
    31 C
    +
    32  potemp(t,p) = (t+273.16)*((1000./p)**0.2857)
    +
    33 C
    +
    34 C TETENS FORMULA WITH NATURAL BASE
    +
    35 C
    +
    36  vapres(t) = 6.11*exp((17.2694*t)/(t+237.3))
    +
    37 C
    +
    38 C BEGIN
    +
    39 C
    +
    40  IF (rh.LT.100) GO TO 10
    +
    41  plcl = p
    +
    42  tlcl = t
    +
    43  td = t
    +
    44  GO TO 40
    +
    45 C
    +
    46 C CALCULATE DEW POINT FROM RH AND T
    +
    47 C
    +
    48  10 CONTINUE
    +
    49  ar = alog(rh*0.01)/17.269
    +
    50  td = (-237.3*(ar+1.0)*t - ar*237.3**2)/(ar*t+237.3*(ar-1.0))
    +
    51  e = vapres(td)
    +
    52  w = (0.622*e)/(p-e)
    +
    53  theta = potemp(t,p)
    +
    54 C
    +
    55 C DO STACKPOLE'S THING AS IN JOUR APPL MET, VOL 6, PP 464-467.
    +
    56 C
    +
    57  eps = 0.1
    +
    58  cges = 0.5
    +
    59 C
    +
    60 C CONSTANTS -35.86 = 237.30 - 273.16
    +
    61 C 2048.7 = 273.16 * 7.50
    +
    62 C
    +
    63  pges = (((cges*(-35.86)+2048.7)/(theta*(7.5-cges)))**3.5)*1000.
    +
    64 C
    +
    65 C START ITERATION.
    +
    66 C
    +
    67  20 CONTINUE
    +
    68  cges = alog10((pges*w)/(6.11*(0.622+w)))
    +
    69  plcl = (((cges*(-35.86)+2048.7)/(theta*(7.5-cges)))**3.5)*1000.
    +
    70  IF (abs(plcl-pges) .LT. eps) GO TO 30
    +
    71  pges = plcl
    +
    72  GO TO 20
    +
    73 C
    +
    74  30 CONTINUE
    +
    75  tlcl = (cges * 237.3) / (7.5 - cges)
    +
    76 C
    +
    77 C FALL THRU WITH P,T OF THE LIFTED CONDENSATION LEVEL.
    +
    78 C
    +
    79  40 CONTINUE
    +
    80  RETURN
    +
    81  END
    +
    +
    +
    w3fa01
    subroutine w3fa01(P, T, RH, TD, PLCL, TLCL)
    Given the pressure, temperature and relative humidity of an air parcel at some point in the atmospher...
    Definition: w3fa01.f:27
    + + + + diff --git a/ver-2.10.0/w3fa03_8f.html b/ver-2.10.0/w3fa03_8f.html new file mode 100644 index 00000000..61464067 --- /dev/null +++ b/ver-2.10.0/w3fa03_8f.html @@ -0,0 +1,184 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa03.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fa03.f File Reference
    +
    +
    + +

    Compute standard height, temp, and pot temp. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fa03 (PRESS, HEIGHT, TEMP, THETA)
     Computes the standard height, temperature, and potential temperature given the pressure in millibars ( > 8.68 mb ). More...
     
    +

    Detailed Description

    +

    Compute standard height, temp, and pot temp.

    +
    Author
    James McDonell
    +
    Date
    1974-06-01
    + +

    Definition in file w3fa03.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fa03()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fa03 ( PRESS,
     HEIGHT,
     TEMP,
     THETA 
    )
    +
    + +

    Computes the standard height, temperature, and potential temperature given the pressure in millibars ( > 8.68 mb ).

    +

    For height and temperature the results duplicate the values in the U.S. standard atmosphere (l962), which is the icao standard atmosphere to 54.7487 mb (20 km) and the proposed extension to 8.68 mb (32 km). For potential temperature a value of 2/7 is used for rd/cp.

    +

    Program history log:

      +
    • James McDonell 1974-06-01
      • +
    • Ralph Jones 1984-06-01 Change to ibm vs fortran.
      • +
    • Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + +
    [in]PRESSPressure in millibars.
    [out]HEIGHTHeight in meters.
    [out]TEMPTemperature in degrees kelvin.
    [out]THETAPotential temperature in degrees kelvin.
    +
    +
    +
    Note
    Not valid for pressures less than 8.68 millibars, declare all parameters as type real.
    +
    Author
    James McDonell
    +
    Date
    1974-06-01
    + +

    Definition at line 28 of file w3fa03.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fa03_8f.js b/ver-2.10.0/w3fa03_8f.js new file mode 100644 index 00000000..98353cbe --- /dev/null +++ b/ver-2.10.0/w3fa03_8f.js @@ -0,0 +1,4 @@ +var w3fa03_8f = +[ + [ "w3fa03", "w3fa03_8f.html#a682b3b6383a8cf898b6f57ce304501e3", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fa03_8f_source.html b/ver-2.10.0/w3fa03_8f_source.html new file mode 100644 index 00000000..3a628bad --- /dev/null +++ b/ver-2.10.0/w3fa03_8f_source.html @@ -0,0 +1,170 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa03.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fa03.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Compute standard height, temp, and pot temp.
    +
    3 C> @author James McDonell @date 1974-06-01
    +
    4 
    +
    5 C> Computes the standard height, temperature, and potential
    +
    6 C> temperature given the pressure in millibars ( > 8.68 mb ). For
    +
    7 C> height and temperature the results duplicate the values in the
    +
    8 C> U.S. standard atmosphere (l962), which is the icao standard
    +
    9 C> atmosphere to 54.7487 mb (20 km) and the proposed extension to
    +
    10 C> 8.68 mb (32 km). For potential temperature a value of 2/7 is
    +
    11 C> used for rd/cp.
    +
    12 C>
    +
    13 C> Program history log:
    +
    14 C> - James McDonell 1974-06-01
    +
    15 C> - Ralph Jones 1984-06-01 Change to ibm vs fortran.
    +
    16 C> - Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
    +
    17 C>
    +
    18 C> @param[in] PRESS Pressure in millibars.
    +
    19 C> @param[out] HEIGHT Height in meters.
    +
    20 C> @param[out] TEMP Temperature in degrees kelvin.
    +
    21 C> @param[out] THETA Potential temperature in degrees kelvin.
    +
    22 C>
    +
    23 C> @note Not valid for pressures less than 8.68 millibars, declare
    +
    24 C> all parameters as type real.
    +
    25 C>
    +
    26 C> @author James McDonell @date 1974-06-01
    +
    27  SUBROUTINE w3fa03(PRESS,HEIGHT,TEMP,THETA)
    +
    28 C
    +
    29  REAL M0
    +
    30 C
    +
    31  SAVE
    +
    32 C
    +
    33  DATA g/9.80665/,rstar/8314.32/,m0/28.9644/,piso/54.7487/,
    +
    34  $ ziso/20000./,salp/-.0010/,pzero/1013.25/,t0/288.15/,alp/.0065/,
    +
    35  $ ptrop/226.321/,tstr/216.65/
    +
    36 C
    +
    37  rovcp = 2.0/7.0
    +
    38  r = rstar/m0
    +
    39  rovg = r/g
    +
    40  fkt = rovg * tstr
    +
    41  ar = alp * rovg
    +
    42  pp0 = pzero**ar
    +
    43  IF(press.LT.piso) GO TO 100
    +
    44  IF(press.GT.ptrop) GO TO 200
    +
    45 C
    +
    46 C COMPUTE ISOTHERMAL CASES
    +
    47 C
    +
    48  height = 11000.0 + (fkt * alog(ptrop/press))
    +
    49  temp = tstr
    +
    50  GO TO 300
    +
    51 C
    +
    52 C COMPUTE LAPSE RATE = -.0010 CASES
    +
    53 C
    +
    54  100 CONTINUE
    +
    55  ar = salp * rovg
    +
    56  pp0 = piso**ar
    +
    57  height = ((tstr/(pp0 * salp )) * (pp0-(press ** ar))) + ziso
    +
    58  temp = tstr - ((height - ziso) * salp)
    +
    59  GO TO 300
    +
    60 C
    +
    61  200 CONTINUE
    +
    62  height = (t0/(pp0 * alp)) * (pp0 - (press ** ar))
    +
    63  temp = t0 - (height * alp)
    +
    64 C
    +
    65  300 CONTINUE
    +
    66  theta = temp * ((1000./press)**rovcp)
    +
    67  RETURN
    +
    68  END
    +
    +
    +
    w3fa03
    subroutine w3fa03(PRESS, HEIGHT, TEMP, THETA)
    Computes the standard height, temperature, and potential temperature given the pressure in millibars ...
    Definition: w3fa03.f:28
    + + + + diff --git a/ver-2.10.0/w3fa03v_8f.html b/ver-2.10.0/w3fa03v_8f.html new file mode 100644 index 00000000..d7c7af76 --- /dev/null +++ b/ver-2.10.0/w3fa03v_8f.html @@ -0,0 +1,143 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa03v.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fa03v.f File Reference
    +
    +
    + +

    Compute standard height, temp, and pot temp. +More...

    + +

    Go to the source code of this file.

    + + + + +

    +Functions/Subroutines

    +subroutine w3fa03v (PRESS, HEIGHT, TEMP, THETA, N)
     
    +

    Detailed Description

    +

    Compute standard height, temp, and pot temp.

    +
    Author
    James McDonell
    +
    Date
    1974-06-01
    +

    Computes the standard height, temperature, and potential temperature given the pressure in millibars (>8.68 mb). For height and temperature the results duplicate the values in the U.S. standard atmosphere (l962), which is the icao standard atmosphere to 54.7487 mb (20 km) and the proposed extension to 8.68 mb (32 km). For potential temperature a value of 2/7 is used for rd/cp.

    +

    Program history log:

      +
    • James McDonell 1974-06-01
      • +
    • Ralph Jones 1984-06-01 Change to ibm vs fortran.
      • +
    • Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
      • +
    • Ralph Jones 1994-09-13 Vectorized version to do array instead of one word.
      • +
    +
    Parameters
    + + + + + + +
    [in]PRESSPressure array in millibars.
    [out]HEIGHTHeight array in meters.
    [out]TEMPTemperature array in degrees kelvin.
    [out]THETAPotential temperature array in degrees kelvin.
    [out]NNumber of points in array press.
    +
    +
    +
    Note
    Not valid for pressures less than 8.68 millibars, declare all parameters as type real.
    +
    +Height, temp, theta are now all arrays, you must have arrays of size n or you will wipe out memory.
    +
    Author
    James McDonell
    +
    Date
    1974-06-01
    + +

    Definition in file w3fa03v.f.

    +
    +
    + + + + diff --git a/ver-2.10.0/w3fa03v_8f.js b/ver-2.10.0/w3fa03v_8f.js new file mode 100644 index 00000000..caaa28c8 --- /dev/null +++ b/ver-2.10.0/w3fa03v_8f.js @@ -0,0 +1,4 @@ +var w3fa03v_8f = +[ + [ "w3fa03v", "w3fa03v_8f.html#a0e7dfe3a41d6a2022f45cadb7c78231c", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fa03v_8f_source.html b/ver-2.10.0/w3fa03v_8f_source.html new file mode 100644 index 00000000..cc61ff15 --- /dev/null +++ b/ver-2.10.0/w3fa03v_8f_source.html @@ -0,0 +1,182 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa03v.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fa03v.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Compute standard height, temp, and pot temp.
    +
    3 C> @author James McDonell @date 1974-06-01
    +
    4 C>
    +
    5 C> Computes the standard height, temperature, and potential
    +
    6 C> temperature given the pressure in millibars (>8.68 mb). For
    +
    7 C> height and temperature the results duplicate the values in the
    +
    8 C> U.S. standard atmosphere (l962), which is the icao standard
    +
    9 C> atmosphere to 54.7487 mb (20 km) and the proposed extension to
    +
    10 C> 8.68 mb (32 km). For potential temperature a value of 2/7 is
    +
    11 C> used for rd/cp.
    +
    12 C>
    +
    13 C> Program history log:
    +
    14 C> - James McDonell 1974-06-01
    +
    15 C> - Ralph Jones 1984-06-01 Change to ibm vs fortran.
    +
    16 C> - Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
    +
    17 C> - Ralph Jones 1994-09-13 Vectorized version to do array instead of one word.
    +
    18 C>
    +
    19 C> @param[in] PRESS Pressure array in millibars.
    +
    20 C> @param[out] HEIGHT Height array in meters.
    +
    21 C> @param[out] TEMP Temperature array in degrees kelvin.
    +
    22 C> @param[out] THETA Potential temperature array in degrees kelvin.
    +
    23 C> @param[out] N Number of points in array press.
    +
    24 C>
    +
    25 C> @note Not valid for pressures less than 8.68 millibars, declare
    +
    26 C> all parameters as type real.
    +
    27 C>
    +
    28 C> @note Height, temp, theta are now all arrays, you must
    +
    29 C> have arrays of size n or you will wipe out memory.
    +
    30 C>
    +
    31 C> @author James McDonell @date 1974-06-01
    +
    32  SUBROUTINE w3fa03v(PRESS,HEIGHT,TEMP,THETA,N)
    +
    33 C
    +
    34  REAL M0
    +
    35  REAL HEIGHT(*)
    +
    36  REAL PRESS(*)
    +
    37  REAL TEMP(*)
    +
    38  REAL THETA(*)
    +
    39 C
    +
    40  SAVE
    +
    41 C
    +
    42  DATA g/9.80665/,rstar/8314.32/,m0/28.9644/,piso/54.7487/,
    +
    43  $ ziso/20000./,salp/-.0010/,pzero/1013.25/,t0/288.15/,alp/.0065/,
    +
    44  $ ptrop/226.321/,tstr/216.65/
    +
    45 C
    +
    46  rovcp = 2.0/7.0
    +
    47  r = rstar/m0
    +
    48  rovg = r/g
    +
    49  fkt = rovg * tstr
    +
    50  ar = alp * rovg
    +
    51  pp0 = pzero**ar
    +
    52  ar1 = salp * rovg
    +
    53  pp01 = piso**ar1
    +
    54 C
    +
    55  DO j = 1,n
    +
    56  IF (press(j).LT.piso) THEN
    +
    57 C
    +
    58 C COMPUTE LAPSE RATE = -.0010 CASES
    +
    59 C
    +
    60  height(j) = ((tstr/(pp01 * salp )) * (pp01-(press(j) ** ar1)))
    +
    61  & + ziso
    +
    62  temp(j) = tstr - ((height(j) - ziso) * salp)
    +
    63 C
    +
    64  ELSE IF (press(j).GT.ptrop) THEN
    +
    65 C
    +
    66  height(j) = (t0/(pp0 * alp)) * (pp0 - (press(j) ** ar))
    +
    67  temp(j) = t0 - (height(j) * alp)
    +
    68 C
    +
    69  ELSE
    +
    70 C
    +
    71 C COMPUTE ISOTHERMAL CASES
    +
    72 C
    +
    73  height(j) = 11000.0 + (fkt * alog(ptrop/press(j)))
    +
    74  temp(j) = tstr
    +
    75 C
    +
    76  END IF
    +
    77  theta(j) = temp(j) * ((1000./press(j))**rovcp)
    +
    78  END DO
    +
    79 C
    +
    80  RETURN
    +
    81  END
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fa04_8f.html b/ver-2.10.0/w3fa04_8f.html new file mode 100644 index 00000000..a79d636f --- /dev/null +++ b/ver-2.10.0/w3fa04_8f.html @@ -0,0 +1,184 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa04.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fa04.f File Reference
    +
    +
    + +

    Compute standard pressure, temp, pot temp. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fa04 (HEIGHT, PRESS, TEMP, THETA)
     Computes the standard pressure, temperature, and poten- tial temperature given the height in meters (<32 km). More...
     
    +

    Detailed Description

    +

    Compute standard pressure, temp, pot temp.

    +
    Author
    James McDonell
    +
    Date
    1974-06-01
    + +

    Definition in file w3fa04.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fa04()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fa04 ( HEIGHT,
     PRESS,
     TEMP,
     THETA 
    )
    +
    + +

    Computes the standard pressure, temperature, and poten- tial temperature given the height in meters (<32 km).

    +

    For the pressure and temperature the results duplicate the values in the U.S. standard atmosphere (1962), which is the icao standard atmosphere to 54.7487 mb (20 km) and the proposed extension to 8.68 mb (32 km). For potential temperature a value of 2/7 is used for rd/cp.

    +

    Program history log:

      +
    • James McDonell 1974-06-01
      • +
    • Ralph Jones 1984-07-05 Change to ibm vs fortran.
      • +
    • Ralph Jones 1990-04-27 Change to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + +
    [in]HEIGHTHeight in meters.
    [out]PRESSStandard pressure in millibars.
    [out]TEMPTemperature in degrees kelvin.
    [out]THETAPotential temperature in degrees kelvin.
    +
    +
    +
    Note
    Not valid for heights greater than 32 km. declare all parameters as type real*4.
    +
    Author
    James McDonell
    +
    Date
    1974-06-01
    + +

    Definition at line 29 of file w3fa04.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fa04_8f.js b/ver-2.10.0/w3fa04_8f.js new file mode 100644 index 00000000..b7c6d893 --- /dev/null +++ b/ver-2.10.0/w3fa04_8f.js @@ -0,0 +1,4 @@ +var w3fa04_8f = +[ + [ "w3fa04", "w3fa04_8f.html#a5f4b61c8c65ffd2662ca4918d08c8fc6", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fa04_8f_source.html b/ver-2.10.0/w3fa04_8f_source.html new file mode 100644 index 00000000..8ba03c5b --- /dev/null +++ b/ver-2.10.0/w3fa04_8f_source.html @@ -0,0 +1,176 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa04.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fa04.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Compute standard pressure, temp, pot temp.
    +
    3 C> @author James McDonell @date 1974-06-01
    +
    4 
    +
    5 C> Computes the standard pressure, temperature, and poten-
    +
    6 C> tial temperature given the height in meters (<32 km). For
    +
    7 C> the pressure and temperature the results duplicate the values in
    +
    8 C> the U.S. standard atmosphere (1962), which is the icao standard
    +
    9 C> atmosphere to 54.7487 mb (20 km) and the proposed extension to
    +
    10 C> 8.68 mb (32 km). For potential temperature a value of 2/7 is
    +
    11 C> used for rd/cp.
    +
    12 C>
    +
    13 C> Program history log:
    +
    14 C> - James McDonell 1974-06-01
    +
    15 C> - Ralph Jones 1984-07-05 Change to ibm vs fortran.
    +
    16 C> - Ralph Jones 1990-04-27 Change to cray cft77 fortran.
    +
    17 C>
    +
    18 C> @param[in] HEIGHT Height in meters.
    +
    19 C> @param[out] PRESS Standard pressure in millibars.
    +
    20 C> @param[out] TEMP Temperature in degrees kelvin.
    +
    21 C> @param[out] THETA Potential temperature in degrees kelvin.
    +
    22 C>
    +
    23 C> @note Not valid for heights greater than 32 km. declare all parameters
    +
    24 C> as type real*4.
    +
    25 C>
    +
    26 C> @author James McDonell @date 1974-06-01
    +
    27 
    +
    28  SUBROUTINE w3fa04(HEIGHT,PRESS,TEMP,THETA)
    +
    29 C
    +
    30  REAL M0
    +
    31 C
    +
    32  DATA
    +
    33  *g /9.80665/,
    +
    34  *rstar /8314.32/,
    +
    35  *m0 /28.9644/,
    +
    36  *piso /54.7487/,
    +
    37  *ziso /20000./,
    +
    38  *salp /-.0010/,
    +
    39  *tstr /216.65/,
    +
    40  *ptrop /226.321/,
    +
    41  *alp /.0065/,
    +
    42  *t0 /288.15/,
    +
    43  *pzero /1013.25/
    +
    44 C
    +
    45  rovcp = 2.0 / 7.0
    +
    46  r = rstar/m0
    +
    47  IF (height.GT.ziso) GO TO 100
    +
    48  IF (height.GT.11000.) GO TO 200
    +
    49 C
    +
    50 C COMPUTE IN TROPOSPHERE
    +
    51 C
    +
    52  temp = t0 - height * alp
    +
    53  press = pzero * ((1.0 - ((alp/t0) * height)) ** (g/(alp * r)))
    +
    54  GO TO 300
    +
    55 C
    +
    56 C COMPUTE LAPSE RATE = -.0010 CASES
    +
    57 C
    +
    58  100 CONTINUE
    +
    59  d = height - ziso
    +
    60  press = piso * ((1.-(( salp /tstr) * d )) ** (g/( salp * r)))
    +
    61  temp = tstr - d * salp
    +
    62  GO TO 300
    +
    63 C
    +
    64 C COMPUTE ISOTHERMAL CASES
    +
    65 C
    +
    66  200 CONTINUE
    +
    67  d = exp((height - 11000.0) / ((r / g) * tstr))
    +
    68  press = ptrop / d
    +
    69  temp = tstr
    +
    70 C
    +
    71  300 CONTINUE
    +
    72  theta = temp * ((1000.0 / press) ** rovcp)
    +
    73  RETURN
    +
    74  END
    +
    +
    +
    w3fa04
    subroutine w3fa04(HEIGHT, PRESS, TEMP, THETA)
    Computes the standard pressure, temperature, and poten- tial temperature given the height in meters (...
    Definition: w3fa04.f:29
    + + + + diff --git a/ver-2.10.0/w3fa06_8f.html b/ver-2.10.0/w3fa06_8f.html new file mode 100644 index 00000000..d7feac33 --- /dev/null +++ b/ver-2.10.0/w3fa06_8f.html @@ -0,0 +1,193 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa06.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fa06.f File Reference
    +
    +
    + +

    Calculation of the lifted index. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fa06 (P, T, RH, T5, TLI)
     Given the pressure,temperature and relative humidity of an air parcel at some point in the atmosphere, calculate the lifted index of the parcel. More...
     
    +

    Detailed Description

    +

    Calculation of the lifted index.

    +
    Author
    James Howcroft
    +
    Date
    1978-07-01
    + +

    Definition in file w3fa06.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fa06()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fa06 ( P,
     T,
     RH,
     T5,
     TLI 
    )
    +
    + +

    Given the pressure,temperature and relative humidity of an air parcel at some point in the atmosphere, calculate the lifted index of the parcel.

    +

    Lifted index is defined as the temperature difference between the observed 500mb temperature and the supposed temperature that the parcel would obtain if it were lifted dry-adiabatically to saturation and then moved moist adiabatically to the 500mb level.

    +

    Program history log:

      +
    • James Howcroft 1978-07-01
      • +
    • Ralph Jones 1989-01-24 Change to microsoft fortran 4.10.
      • +
    • Ralph Jones 1990-06-08 Change to sun fortran 1.3.
      • +
    • Ralph Jones 1991-03-29 Convert to silicongraphics fortran.
      • +
    • Ralph Jones 1993-03-29 Add save statement.
      • +
    • Ralph Jones 1995-09-25 Put in w3 library on cray.
      • +
    +
    Parameters
    + + + + + + +
    [in]PParcel pressure in millibars.
    [in]TParcel temperataure in degrees celsius.
    [in]RHParcel relative humidity in percent.
    [in]T5Temperature at the 500mb level in deg. celsius.
    [out]TLILifted index in degrees celsius tli = 9.9999 iteration diverges; return to user program.
    +
    +
    +
    Author
    James Howcroft
    +
    Date
    1978-07-01
    + +

    Definition at line 30 of file w3fa06.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fa06_8f.js b/ver-2.10.0/w3fa06_8f.js new file mode 100644 index 00000000..03474762 --- /dev/null +++ b/ver-2.10.0/w3fa06_8f.js @@ -0,0 +1,4 @@ +var w3fa06_8f = +[ + [ "w3fa06", "w3fa06_8f.html#a232d431173943399677b1eb13275bb05", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fa06_8f_source.html b/ver-2.10.0/w3fa06_8f_source.html new file mode 100644 index 00000000..a2bb77ef --- /dev/null +++ b/ver-2.10.0/w3fa06_8f_source.html @@ -0,0 +1,208 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa06.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fa06.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Calculation of the lifted index.
    +
    3 C> @author James Howcroft @date 1978-07-01
    +
    4 
    +
    5 C> Given the pressure,temperature and relative humidity of
    +
    6 C> an air parcel at some point in the atmosphere, calculate the
    +
    7 C> lifted index of the parcel. Lifted index is defined as the
    +
    8 C> temperature difference between the observed 500mb temperature and
    +
    9 C> the supposed temperature that the parcel would obtain if it were
    +
    10 C> lifted dry-adiabatically to saturation and then moved moist
    +
    11 C> adiabatically to the 500mb level.
    +
    12 C>
    +
    13 C> Program history log:
    +
    14 C> - James Howcroft 1978-07-01
    +
    15 C> - Ralph Jones 1989-01-24 Change to microsoft fortran 4.10.
    +
    16 C> - Ralph Jones 1990-06-08 Change to sun fortran 1.3.
    +
    17 C> - Ralph Jones 1991-03-29 Convert to silicongraphics fortran.
    +
    18 C> - Ralph Jones 1993-03-29 Add save statement.
    +
    19 C> - Ralph Jones 1995-09-25 Put in w3 library on cray.
    +
    20 C>
    +
    21 C> @param[in] P Parcel pressure in millibars.
    +
    22 C> @param[in] T Parcel temperataure in degrees celsius.
    +
    23 C> @param[in] RH Parcel relative humidity in percent.
    +
    24 C> @param[in] T5 Temperature at the 500mb level in deg. celsius.
    +
    25 C> @param[out] TLI Lifted index in degrees celsius
    +
    26 C> tli = 9.9999 iteration diverges; return to user program.
    +
    27 C>
    +
    28 C> @author James Howcroft @date 1978-07-01
    +
    29  SUBROUTINE w3fa06 (P,T,RH,T5,TLI)
    +
    30 C
    +
    31  SAVE
    +
    32 C
    +
    33  DATA eps /0.5/
    +
    34  DATA kout / 6/
    +
    35 C
    +
    36  300 FORMAT (' *** ITERATION NOT CONVERGING IN W3FA06 ***')
    +
    37  350 FORMAT (' INPUT PARAMS ARE:',4f15.8,/
    +
    38  1 ' CALCULATIONS ARE',7e15.8)
    +
    39 C
    +
    40  potemp(t,p) = (t+273.16)*((1000./p)**0.2857)
    +
    41 C
    +
    42  eep(t,p,es) = exp((596.73-0.601*t)*((0.622*es)/(p-es))
    +
    43  1 / (0.24*(t+273.16)))
    +
    44 C
    +
    45  unpot(te,p) = (((p/1000.)**0.2857)*te)-273.16
    +
    46 C
    +
    47  vapres(t) = 6.11*exp(17.2694*t/(t+237.3))
    +
    48 C
    +
    49  CALL w3fa01 (p,t,rh,td,plcl,tlcl)
    +
    50  IF (plcl .GT. 500.) GO TO 30
    +
    51  IF (plcl .LT. 500.) GO TO 20
    +
    52  tli = t5 - tlcl
    +
    53  GO TO 80
    +
    54  20 CONTINUE
    +
    55 C LCL IS ABOVE THE 500MB LVL
    +
    56  tli = t5 - unpot((potemp(tlcl,plcl)),500.)
    +
    57  GO TO 80
    +
    58  30 CONTINUE
    +
    59 C USE STACKPOLE ALGORITHM (JAM VOL 6/1967 PP 464-7) TO FIND TGES
    +
    60 C SO THAT (TGES,500) IS ON SAME MOIST ADIABAT AS (TLCL,PLCL).
    +
    61  es = vapres(tlcl)
    +
    62  thd = potemp(tlcl,(plcl-es))
    +
    63  theta = thd * eep(tlcl,plcl,es)
    +
    64 C THETA IS THE PSEUDO-EQUIV POTENTIAL TEMP THRU (PLCL,TLCL).
    +
    65 C NOW FIND TEMP WHERE THETA INTERSECTS 500MB SFC.
    +
    66 C INITIALIZE FOR STACKPOLIAN ITERATION
    +
    67  tges = t5
    +
    68  dtt = 10.
    +
    69  piin = 1./(0.5**0.2857)
    +
    70  a = 0.
    +
    71  istp = 0
    +
    72 C START ITERATION.
    +
    73  40 CONTINUE
    +
    74  istp = istp + 1
    +
    75  IF (istp .GT. 200) GO TO 50
    +
    76  sva = vapres(tges)
    +
    77  ax = a
    +
    78  a = (tges+273.16)*piin * eep(tges,500.,sva) - theta
    +
    79  IF (abs(a) .LT. eps) GO TO 70
    +
    80  dtt = dtt * 0.5
    +
    81  IF (a*ax.LT.0.0) dtt = -dtt
    +
    82  tp = tges + dtt
    +
    83  sva = vapres(tp)
    +
    84  ap = (tp+273.16)*piin * eep(tp,500.,sva) - theta
    +
    85  IF (abs(ap) .LT. eps) GO TO 60
    +
    86 C FIND NEXT ESTIMATE, DTT IS ADJUSTMENT FROM OLD TO NEW TGES.
    +
    87  dtt = a*dtt/(a-ap)
    +
    88  IF (abs(dtt).LT.0.01) dtt = sign(0.01,dtt)
    +
    89  tges = tges + dtt
    +
    90  IF (tges .GT. 50) tges = 50.
    +
    91  GO TO 40
    +
    92 C
    +
    93  50 CONTINUE
    +
    94 C DISASTER SECTION
    +
    95  WRITE (kout,300)
    +
    96  WRITE (kout,350) p,t,rh,t5,theta,ax,a,ap,tges,tp,sva
    +
    97  tli = 9.9999
    +
    98  GO TO 80
    +
    99  60 CONTINUE
    +
    100  tges = tp
    +
    101  70 CONTINUE
    +
    102  tli = t5 - tges
    +
    103  80 CONTINUE
    +
    104  RETURN
    +
    105  END
    +
    +
    +
    w3fa06
    subroutine w3fa06(P, T, RH, T5, TLI)
    Given the pressure,temperature and relative humidity of an air parcel at some point in the atmosphere...
    Definition: w3fa06.f:30
    +
    w3fa01
    subroutine w3fa01(P, T, RH, TD, PLCL, TLCL)
    Given the pressure, temperature and relative humidity of an air parcel at some point in the atmospher...
    Definition: w3fa01.f:27
    + + + + diff --git a/ver-2.10.0/w3fa09_8f.html b/ver-2.10.0/w3fa09_8f.html new file mode 100644 index 00000000..1d08429b --- /dev/null +++ b/ver-2.10.0/w3fa09_8f.html @@ -0,0 +1,163 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa09.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fa09.f File Reference
    +
    +
    + +

    Temperature to saturation vapor pressure. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    real function w3fa09 (TK)
     Computes saturation vapor pressure in kilopascals given temperataure in kelvins. More...
     
    +

    Detailed Description

    +

    Temperature to saturation vapor pressure.

    +
    Author
    P. Chase
    +
    Date
    1978-10-01
    + +

    Definition in file w3fa09.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fa09()

    + +
    +
    + + + + + + + + +
    real function w3fa09 ( TK)
    +
    + +

    Computes saturation vapor pressure in kilopascals given temperataure in kelvins.

    +

    Program history log:

      +
    • P. Chase 1978-10-01 P.CHASE
      • +
    • Ralph Jones 1984-06-26 Change to ibm vs fortran.
      • +
    • Ralph Jones 1984-06-26 Change to microsoft fortran 4.10.
      • +
    • Ralph Jones 1990-06-08 Change to sun fortran 1.3.
      • +
    • Ralph Jones 1991-03-29 Convert to silicongraphic fortran.
      • +
    • Ralph Jones 1993-03-29 Add save statement.
      • +
    • Ralph Jones 1995-09-25 Change tk to cray 64 bit real, change double. precision to cray 64 bit real.
      • +
    +
    Parameters
    + + +
    [in]TKREAL*8 Temperature in kelvins. if tk < 223.16, the value 223.16 will be used. if tk > 323.16, the value 323.16 will be used as the argument. 'tk' itself is unchanged.
    +
    +
    +
    Returns
    VP Saturation vapor pressure in kilopascals 0.0063558 < VP < 12.3395.
    +
    Note
    W3FA09 may be declared real*8 so that a real*8 value is returned, but no increase in accuracy is implied.
    +
    Author
    P. Chase
    +
    Date
    1978-10-01
    + +

    Definition at line 27 of file w3fa09.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fa09_8f.js b/ver-2.10.0/w3fa09_8f.js new file mode 100644 index 00000000..2583a382 --- /dev/null +++ b/ver-2.10.0/w3fa09_8f.js @@ -0,0 +1,4 @@ +var w3fa09_8f = +[ + [ "w3fa09", "w3fa09_8f.html#a97cb87ce42a1cba4c96dd80fefb9eafe", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fa09_8f_source.html b/ver-2.10.0/w3fa09_8f_source.html new file mode 100644 index 00000000..313a3875 --- /dev/null +++ b/ver-2.10.0/w3fa09_8f_source.html @@ -0,0 +1,157 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa09.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fa09.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Temperature to saturation vapor pressure.
    +
    3 C> @author P. Chase @date 1978-10-01
    +
    4 
    +
    5 C> Computes saturation vapor pressure in kilopascals given temperataure in kelvins.
    +
    6 C>
    +
    7 C> Program history log:
    +
    8 C> - P. Chase 1978-10-01 P.CHASE
    +
    9 C> - Ralph Jones 1984-06-26 Change to ibm vs fortran.
    +
    10 C> - Ralph Jones 1984-06-26 Change to microsoft fortran 4.10.
    +
    11 C> - Ralph Jones 1990-06-08 Change to sun fortran 1.3.
    +
    12 C> - Ralph Jones 1991-03-29 Convert to silicongraphic fortran.
    +
    13 C> - Ralph Jones 1993-03-29 Add save statement.
    +
    14 C> - Ralph Jones 1995-09-25 Change tk to cray 64 bit real, change double.
    +
    15 C> precision to cray 64 bit real.
    +
    16 C>
    +
    17 C> @param[in] TK REAL*8 Temperature in kelvins. if tk < 223.16, the value
    +
    18 C> 223.16 will be used. if tk > 323.16, the value 323.16
    +
    19 C> will be used as the argument. 'tk' itself is unchanged.
    +
    20 C> @return VP Saturation vapor pressure in kilopascals 0.0063558 < VP < 12.3395.
    +
    21 C>
    +
    22 C> @note W3FA09 may be declared real*8 so that a real*8 value is
    +
    23 C> returned, but no increase in accuracy is implied.
    +
    24 C>
    +
    25 C> @author P. Chase @date 1978-10-01
    +
    26  REAL FUNCTION W3FA09 (TK)
    +
    27 C
    +
    28 C THE CHEBYSHEV COEFFICIENTS ARE IN ARRAY C, LOW-ORDER TERM FIRST.
    +
    29 C
    +
    30  REAL c(9)
    +
    31  REAL arg,h0,h1,h2
    +
    32 C
    +
    33  SAVE
    +
    34 C
    +
    35  DATA c /
    +
    36  & 0.313732865927e+01, 0.510038215244e+01, 0.277816535655e+01,
    +
    37  & 0.102673379933e+01, 0.254577145215e+00, 0.396055201295e-01,
    +
    38  & 0.292209288468e-02,-0.119497199712e-03,-0.352745603496e-04/
    +
    39 C
    +
    40 C SCALE TK TO RANGE -2, +2 FOR SERIES EVALUATION. INITIALIZE TERMS.
    +
    41 C
    +
    42  arg = -1.09264e1+4.0e-2*amax1(223.16,amin1(323.16,tk))
    +
    43  h0 = 0.0
    +
    44  h1 = 0.0
    +
    45 C
    +
    46 C EVALUATE CHEBYSHEV POLYNOMIAL
    +
    47 C
    +
    48  DO 10 i=1,9
    +
    49  h2 = h1
    +
    50  h1 = h0
    +
    51  h0 = arg * h1 - h2 + c(10-i)
    +
    52  10 CONTINUE
    +
    53  w3fa09 = 0.5 * (c(1) - h2 + h0)
    +
    54  RETURN
    +
    55  END
    +
    +
    +
    w3fa09
    real function w3fa09(TK)
    Computes saturation vapor pressure in kilopascals given temperataure in kelvins.
    Definition: w3fa09.f:27
    + + + + diff --git a/ver-2.10.0/w3fa11_8f.html b/ver-2.10.0/w3fa11_8f.html new file mode 100644 index 00000000..072c7541 --- /dev/null +++ b/ver-2.10.0/w3fa11_8f.html @@ -0,0 +1,169 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa11.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fa11.f File Reference
    +
    +
    + +

    Computes coefficients for use in w3fa12. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fa11 (EPS, JCAP)
     Subroutine computes double precision coefficients used in generating legendre polynomials in subr. More...
     
    +

    Detailed Description

    +

    Computes coefficients for use in w3fa12.

    +
    Author
    Joe Sela
    +
    Date
    1980-10-28
    + +

    Definition in file w3fa11.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fa11()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3fa11 (real, dimension(*) EPS,
     JCAP 
    )
    +
    + +

    Subroutine computes double precision coefficients used in generating legendre polynomials in subr.

    +

    w3fa12. on a cray double precision is changed to real, dsqrt to sqrt.

    +

    Program history log:

      +
    • Joe Sela 1980-10-28
      • +
    • Ralph Jones 1984-06-01 0change to ibm vs fortran.
      • +
    • Ralph Jones 1993-04-12 0changes for cray, double precision to real.
      • +
    +
    Parameters
    + + + +
    [out]EPSReal coefficients used in computing legendre polynomials. dimension of eps is (jcap+2)*(jcap+1)
    [in]JCAPZonal wave number thirty, etc.
    +
    +
    +
    Author
    Joe Sela
    +
    Date
    1980-10-28
    + +

    Definition at line 21 of file w3fa11.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fa11_8f.js b/ver-2.10.0/w3fa11_8f.js new file mode 100644 index 00000000..dfa3bbed --- /dev/null +++ b/ver-2.10.0/w3fa11_8f.js @@ -0,0 +1,4 @@ +var w3fa11_8f = +[ + [ "w3fa11", "w3fa11_8f.html#ad62a05c9654e2a4aa35667a814dee8a2", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fa11_8f_source.html b/ver-2.10.0/w3fa11_8f_source.html new file mode 100644 index 00000000..de12ea0a --- /dev/null +++ b/ver-2.10.0/w3fa11_8f_source.html @@ -0,0 +1,148 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa11.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fa11.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes coefficients for use in w3fa12.
    +
    3 C> @author Joe Sela @date 1980-10-28
    +
    4 
    +
    5 C> Subroutine computes double precision coefficients
    +
    6 C> used in generating legendre polynomials in subr. w3fa12.
    +
    7 C> on a cray double precision is changed to real, dsqrt to sqrt.
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - Joe Sela 1980-10-28
    +
    11 C> - Ralph Jones 1984-06-01 0change to ibm vs fortran.
    +
    12 C> - Ralph Jones 1993-04-12 0changes for cray, double precision to real.
    +
    13 C>
    +
    14 C> @param[out] EPS Real coefficients used in computing legendre polynomials.
    +
    15 C> dimension of eps is (jcap+2)*(jcap+1)
    +
    16 C> @param[in] JCAP Zonal wave number thirty, etc.
    +
    17 C>
    +
    18 C> @author Joe Sela @date 1980-10-28
    +
    19 
    +
    20  SUBROUTINE w3fa11 (EPS,JCAP)
    +
    21 C
    +
    22  REAL EPS(*)
    +
    23  REAL A
    +
    24 C
    +
    25  SAVE
    +
    26 C
    +
    27  jcap1 = jcap + 1
    +
    28  jcap2 = jcap + 2
    +
    29 C
    +
    30  DO 100 ll = 1,jcap1
    +
    31  l = ll - 1
    +
    32  jle = (ll-1) * jcap2
    +
    33 C
    +
    34  DO 100 inde = 2,jcap2
    +
    35  n = l + inde - 1
    +
    36  a=(n*n-l*l)/(4.0*n*n-1.0)
    +
    37  eps(jle+inde) = sqrt(a)
    +
    38  100 CONTINUE
    +
    39 C
    +
    40  DO 200 ll = 1,jcap1
    +
    41  jle = (ll-1) * jcap2
    +
    42  eps(jle+1) = 0.0
    +
    43  200 CONTINUE
    +
    44 C
    +
    45  RETURN
    +
    46  END
    +
    +
    +
    w3fa11
    subroutine w3fa11(EPS, JCAP)
    Subroutine computes double precision coefficients used in generating legendre polynomials in subr.
    Definition: w3fa11.f:21
    + + + + diff --git a/ver-2.10.0/w3fa12_8f.html b/ver-2.10.0/w3fa12_8f.html new file mode 100644 index 00000000..ca2b5c6c --- /dev/null +++ b/ver-2.10.0/w3fa12_8f.html @@ -0,0 +1,138 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa12.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fa12.f File Reference
    +
    +
    + +

    Computes legendre polynomials at a given latitude. +More...

    + +

    Go to the source code of this file.

    + + + + +

    +Functions/Subroutines

    +subroutine w3fa12 (PLN, COLRAD, JCAP, EPS)
     
    +

    Detailed Description

    +

    Computes legendre polynomials at a given latitude.

    +
    Author
    Joe Sela
    +
    Date
    1980-10-28
    +

    Subroutine computes legendre polynomials at a given latitude.

    +

    Program history log:

      +
    • Joe Sela 1980-10-20
      • +
    • Ralph Jones 1984-06-01 Change to ibm vs fortran.
      • +
    • Ralph Jones 1993-04-12 Changes for cray, double precision to real.
      • +
    +
    Parameters
    + + + + + +
    [out]PLNReal locations contain legendre polynomials, size is (jcap+2)*(jcap+1)
    [in]COLRADColatitude in radians of desired point.
    [in]JCAPFor rhomboiadal truncation of zonal wave
    [in]EPSCoeff. used in recursion equation. Dimension of eps is (jcap+2)*(jcap+1)
    +
    +
    +
    Author
    Joe Sela
    +
    Date
    1980-10-28
    + +

    Definition in file w3fa12.f.

    +
    +
    + + + + diff --git a/ver-2.10.0/w3fa12_8f.js b/ver-2.10.0/w3fa12_8f.js new file mode 100644 index 00000000..bcb461b6 --- /dev/null +++ b/ver-2.10.0/w3fa12_8f.js @@ -0,0 +1,4 @@ +var w3fa12_8f = +[ + [ "w3fa12", "w3fa12_8f.html#af8c0b914691cd0a708ca37b26be47c25", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fa12_8f_source.html b/ver-2.10.0/w3fa12_8f_source.html new file mode 100644 index 00000000..2e5aed80 --- /dev/null +++ b/ver-2.10.0/w3fa12_8f_source.html @@ -0,0 +1,169 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa12.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fa12.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes legendre polynomials at a given latitude.
    +
    3 C> @author Joe Sela @date 1980-10-28
    +
    4 C>
    +
    5 C> Subroutine computes legendre polynomials at a given latitude.
    +
    6 C>
    +
    7 C> Program history log:
    +
    8 C> - Joe Sela 1980-10-20
    +
    9 C> - Ralph Jones 1984-06-01 Change to ibm vs fortran.
    +
    10 C> - Ralph Jones 1993-04-12 Changes for cray, double precision to real.
    +
    11 C>
    +
    12 C> @param[out] PLN Real locations contain legendre
    +
    13 C> polynomials, size is (jcap+2)*(jcap+1)
    +
    14 C> @param[in] COLRAD Colatitude in radians of desired point.
    +
    15 C> @param[in] JCAP For rhomboiadal truncation of zonal wave
    +
    16 C> @param[in] EPS Coeff. used in recursion equation.
    +
    17 C> Dimension of eps is (jcap+2)*(jcap+1)
    +
    18 C>
    +
    19 C> @author Joe Sela @date 1980-10-28
    +
    20  SUBROUTINE w3fa12(PLN,COLRAD,JCAP,EPS)
    +
    21  REAL A
    +
    22  REAL B
    +
    23  REAL COLRAD
    +
    24  REAL COS2
    +
    25  REAL EPS(*)
    +
    26  REAL FL
    +
    27  REAL PROD
    +
    28  REAL P1
    +
    29  REAL P2
    +
    30  REAL P3
    +
    31  REAL SINLAT
    +
    32  REAL PLN(*)
    +
    33 C
    +
    34  SAVE
    +
    35 C
    +
    36  sinlat = cos(colrad)
    +
    37  cos2 = 1.0 - sinlat * sinlat
    +
    38  prod = 1.0
    +
    39  a = 1.0
    +
    40  b = 0.0
    +
    41  jcap1 = jcap+1
    +
    42  jcap2 = jcap+2
    +
    43 C
    +
    44  DO 300 ll = 1,jcap1
    +
    45  l = ll - 1
    +
    46  fl = l
    +
    47  jle = l * jcap2
    +
    48  IF (l.EQ.0) GO TO 100
    +
    49  a = a + 2.0
    +
    50  b = b + 2.0
    +
    51  prod = prod * cos2 * a / b
    +
    52  100 CONTINUE
    +
    53  p1 = sqrt(0.5 * prod)
    +
    54  pln(jle+1) = p1
    +
    55  p2 = sqrt(2.0 * fl + 3.0) * sinlat * p1
    +
    56  pln(jle+2) = p2
    +
    57 C
    +
    58  DO 200 n = 3,jcap2
    +
    59  lindex = jle + n
    +
    60  p3 = (sinlat*p2 - eps(lindex-1)*p1)/eps(lindex)
    +
    61  pln(lindex) = p3
    +
    62  p1 = p2
    +
    63  p2 = p3
    +
    64 200 CONTINUE
    +
    65 300 CONTINUE
    +
    66  RETURN
    +
    67 C
    +
    68  END
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fa13_8f.html b/ver-2.10.0/w3fa13_8f.html new file mode 100644 index 00000000..8e9b3a4b --- /dev/null +++ b/ver-2.10.0/w3fa13_8f.html @@ -0,0 +1,168 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa13.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fa13.f File Reference
    +
    +
    + +

    Computes Trig Functions. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fa13 (TRIGS, RCOS)
     Computes trig functions used in 2.5 by 2.5 lat,lon mapping routines. More...
     
    +

    Detailed Description

    +

    Computes Trig Functions.

    +
    Author
    Joe Sela
    +
    Date
    1980-11-21
    + +

    Definition in file w3fa13.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fa13()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3fa13 (real, dimension(*) TRIGS,
    real, dimension(*) RCOS 
    )
    +
    + +

    Computes trig functions used in 2.5 by 2.5 lat,lon mapping routines.

    +

    w3fa13() must be called at least once before calls to w3ft08(), w3ft09(), w3ft10(), w3ft11().

    +

    Program history log:

      +
    • Joe Sela 1980-11-21
      • +
    • Ralph Jones 1984-06-01 Change to vs fortran
      • +
    +
    Parameters
    + + + +
    [out]TRIGS216 trig values, used by subroutine w3fa12().
    [out]RCOS37 colatitudes used by subroutines w3ft09() ,w3ft11()
    +
    +
    +
    Author
    Joe Sela
    +
    Date
    1980-11-21
    + +

    Definition at line 18 of file w3fa13.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fa13_8f.js b/ver-2.10.0/w3fa13_8f.js new file mode 100644 index 00000000..91be60aa --- /dev/null +++ b/ver-2.10.0/w3fa13_8f.js @@ -0,0 +1,4 @@ +var w3fa13_8f = +[ + [ "w3fa13", "w3fa13_8f.html#ae3485639e68c6074ead756064096216a", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fa13_8f_source.html b/ver-2.10.0/w3fa13_8f_source.html new file mode 100644 index 00000000..c6c7dc29 --- /dev/null +++ b/ver-2.10.0/w3fa13_8f_source.html @@ -0,0 +1,176 @@ + + + + + + + +NCEPLIBS-w3emc: w3fa13.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fa13.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes Trig Functions
    +
    3 C> @author Joe Sela @date 1980-11-21
    +
    4 
    +
    5 C> Computes trig functions used in 2.5 by 2.5 lat,lon
    +
    6 C> mapping routines. w3fa13() must be called at least once before
    +
    7 C> calls to w3ft08(), w3ft09(), w3ft10(), w3ft11().
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - Joe Sela 1980-11-21
    +
    11 C> - Ralph Jones 1984-06-01 Change to vs fortran
    +
    12 C>
    +
    13 C> @param[out] TRIGS 216 trig values, used by subroutine w3fa12().
    +
    14 C> @param[out] RCOS 37 colatitudes used by subroutines w3ft09() ,w3ft11()
    +
    15 C>
    +
    16 C> @author Joe Sela @date 1980-11-21
    +
    17  SUBROUTINE w3fa13(TRIGS,RCOS)
    +
    18 C
    +
    19  REAL RCOS(*)
    +
    20  REAL TRIGS(*)
    +
    21 C
    +
    22  SAVE
    +
    23 C
    +
    24  DATA pi /3.14159265358979323846/
    +
    25 C
    +
    26  n = 144
    +
    27  mode = 3
    +
    28  drad = 2.5*pi/180.
    +
    29 C
    +
    30  DO 100 lat = 2,37
    +
    31  arg = (lat-1)*drad
    +
    32  rcos(lat) = 1./sin(arg)
    +
    33  100 CONTINUE
    +
    34 C
    +
    35  rcos(1) = 77777.777
    +
    36  imode = iabs(mode)
    +
    37  nn = n
    +
    38  IF (imode.GT.1.AND.imode.LT.6) nn = n/2
    +
    39  angle = 0.0
    +
    40  del = (pi+pi)/float(nn)
    +
    41  l = nn+nn
    +
    42 C
    +
    43  DO 200 i = 1,l,2
    +
    44  trigs(i) = cos(angle)
    +
    45  trigs(i+1) = sin(angle)
    +
    46  angle = angle+del
    +
    47  200 CONTINUE
    +
    48 C
    +
    49  IF (imode.EQ.1) RETURN
    +
    50  IF (imode.EQ.8) RETURN
    +
    51  angle = 0.0
    +
    52  del = 0.5*del
    +
    53  nh = (nn+1)/2
    +
    54  l = nh+nh
    +
    55  la = nn+nn
    +
    56 C
    +
    57  DO 300 i = 1,l,2
    +
    58  trigs(la+i) = cos(angle)
    +
    59  trigs(la+i+1) = sin(angle)
    +
    60  angle = angle+del
    +
    61  300 CONTINUE
    +
    62 C
    +
    63  IF (imode.LE.3) RETURN
    +
    64  del = 0.5*del
    +
    65  angle = del
    +
    66  la = la+nn
    +
    67 C
    +
    68  DO 400 i = 2,nn
    +
    69  trigs(la+i) = 2.0*sin(angle)
    +
    70  angle = angle+del
    +
    71  400 CONTINUE
    +
    72 C
    +
    73  RETURN
    +
    74  END
    +
    +
    +
    w3fa13
    subroutine w3fa13(TRIGS, RCOS)
    Computes trig functions used in 2.5 by 2.5 lat,lon mapping routines.
    Definition: w3fa13.f:18
    + + + + diff --git a/ver-2.10.0/w3fb00_8f.html b/ver-2.10.0/w3fb00_8f.html new file mode 100644 index 00000000..8706f7eb --- /dev/null +++ b/ver-2.10.0/w3fb00_8f.html @@ -0,0 +1,190 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb00.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb00.f File Reference
    +
    +
    + +

    Convert latitude, longitude to i,j. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fb00 (ALAT, ALONG, XMESHL, XI, XJ)
     Converts the coordinates of a location on earth from the natural coordinate system of latitude/longitude to the grid (i,j) coordinate system overlaid on the polar stereographic map pro- jection true at 60 n. More...
     
    +

    Detailed Description

    +

    Convert latitude, longitude to i,j.

    +
    Author
    A. Heermann
    +
    Date
    1969-08-01
    + +

    Definition in file w3fb00.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb00()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb00 ( ALAT,
     ALONG,
     XMESHL,
     XI,
     XJ 
    )
    +
    + +

    Converts the coordinates of a location on earth from the natural coordinate system of latitude/longitude to the grid (i,j) coordinate system overlaid on the polar stereographic map pro- jection true at 60 n.

    +

    a preferable, more flexible subroutine to use is w3fb04(). w3fb00() is the reverse of w3fb01().

    +

    Program history log:

      +
    • A. Heermann 1969-08-01
      • +
    • Ralph Jones 1990-08-31 Convert to cray cft77 fortran
      • +
    +
    Parameters
    + + + + + + +
    [in]ALATLatitude in deg. (-20.0 (s. hemis)) alat) 90.0).
    [in]ALONGWest longitude in degrees.
    [in]XMESHLMesh length of grid in kilometers at 60n.
    [out]XII of the point relative to north pole.
    [out]XJJ of the point relative to north pole.
    +
    +
    +
    Note
    The grid used in this subroutine has its origin (i=0,j=0) at the north pole, so if the user's grid has its origin at a point other than the north pole, a translation is required to get i and j. The subroutine grid is oriented so that longitude 80w is parallel to the gridlines of i=constant. The radius of the earth is taken to be 6371.2 km. All parameters in the call statement must be real this code will not vectorize on a cray. You will have put it line to vectorize it.
    +
    Author
    A. Heermann
    +
    Date
    1969-08-01
    + +

    Definition at line 32 of file w3fb00.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb00_8f.js b/ver-2.10.0/w3fb00_8f.js new file mode 100644 index 00000000..fd074c56 --- /dev/null +++ b/ver-2.10.0/w3fb00_8f.js @@ -0,0 +1,4 @@ +var w3fb00_8f = +[ + [ "w3fb00", "w3fb00_8f.html#a007817ca2f1dd94a58abdb00f54aab28", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb00_8f_source.html b/ver-2.10.0/w3fb00_8f_source.html new file mode 100644 index 00000000..467406a4 --- /dev/null +++ b/ver-2.10.0/w3fb00_8f_source.html @@ -0,0 +1,146 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb00.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb00.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert latitude, longitude to i,j
    +
    3 C> @author A. Heermann @date 1969-08-01
    +
    4 
    +
    5 C> Converts the coordinates of a location on earth from the
    +
    6 C> natural coordinate system of latitude/longitude to the grid (i,j)
    +
    7 C> coordinate system overlaid on the polar stereographic map pro-
    +
    8 C> jection true at 60 n. a preferable, more flexible subroutine to
    +
    9 C> use is w3fb04(). w3fb00() is the reverse of w3fb01().
    +
    10 C>
    +
    11 C> Program history log:
    +
    12 C> - A. Heermann 1969-08-01
    +
    13 C> - Ralph Jones 1990-08-31 Convert to cray cft77 fortran
    +
    14 C>
    +
    15 C> @param[in] ALAT Latitude in deg. (-20.0 (s. hemis)) alat) 90.0).
    +
    16 C> @param[in] ALONG West longitude in degrees.
    +
    17 C> @param[in] XMESHL Mesh length of grid in kilometers at 60n.
    +
    18 C> @param[out] XI I of the point relative to north pole.
    +
    19 C> @param[out] XJ J of the point relative to north pole.
    +
    20 C>
    +
    21 C> @note The grid used in this subroutine has its origin (i=0,j=0)
    +
    22 C> at the north pole, so if the user's grid has its origin at a
    +
    23 C> point other than the north pole, a translation is required to
    +
    24 C> get i and j. The subroutine grid is oriented so that longitude
    +
    25 C> 80w is parallel to the gridlines of i=constant. The radius of
    +
    26 C> the earth is taken to be 6371.2 km. All parameters in the call statement
    +
    27 C> must be real this code will not vectorize on a cray. You will have put
    +
    28 C> it line to vectorize it.
    +
    29 C>
    +
    30 C> @author A. Heermann @date 1969-08-01
    +
    31  SUBROUTINE w3fb00(ALAT,ALONG,XMESHL,XI,XJ)
    +
    32 C
    +
    33  DATA radpd /.01745329/
    +
    34  DATA earthr/6371.2/
    +
    35 C
    +
    36  re = (earthr * 1.86603) / xmeshl
    +
    37  xlat = alat * radpd
    +
    38  sinl = sin(xlat)
    +
    39  wlong = (along + 100.0) * radpd
    +
    40  r = (re * cos(xlat)) / (1. + sinl)
    +
    41  xi = r * sin(wlong)
    +
    42  xj = r * cos(wlong)
    +
    43  RETURN
    +
    44  END
    +
    +
    +
    w3fb00
    subroutine w3fb00(ALAT, ALONG, XMESHL, XI, XJ)
    Converts the coordinates of a location on earth from the natural coordinate system of latitude/longit...
    Definition: w3fb00.f:32
    + + + + diff --git a/ver-2.10.0/w3fb01_8f.html b/ver-2.10.0/w3fb01_8f.html new file mode 100644 index 00000000..8108e179 --- /dev/null +++ b/ver-2.10.0/w3fb01_8f.html @@ -0,0 +1,190 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb01.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb01.f File Reference
    +
    +
    + +

    I,J TO LATITUDE, LONGITUDE. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fb01 (XI, XJ, XMESHL, ALAT, ALONG)
     Converts the coordinates of a location from the grid(i,j) coordinate system overlaid on the polar stereographic map pro- jection true at 60 n to the natural coordinate system of latitude /longitude on the Earth. More...
     
    +

    Detailed Description

    +

    I,J TO LATITUDE, LONGITUDE.

    +
    Author
    A. Heermann
    +
    Date
    1969-08-01
    + +

    Definition in file w3fb01.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb01()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb01 ( XI,
     XJ,
     XMESHL,
     ALAT,
     ALONG 
    )
    +
    + +

    Converts the coordinates of a location from the grid(i,j) coordinate system overlaid on the polar stereographic map pro- jection true at 60 n to the natural coordinate system of latitude /longitude on the Earth.

    +

    A preferable more flexible subroutine to use is w3fb05(). w3fb01() is the reverse of w3fb00().

    +

    PROGRAM HISTORY LOG:

      +
    • A. Heermann 1969-08-01 A. HEERMANN
      • +
    • Ralph Jones 1990-08-31 Change to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + + +
    [in]XII of the point relative to north pole.
    [in]XJJ of the point relative to north pole.
    [in]XMESHLMesh length of grid in kilometers at 60n.
    [out]ALATLatitude in deg. (-20.0(s. hemis) < alat < 90.0).
    [out]ALONGWest longitude in degrees.
    +
    +
    +
    Note
    The grid used in this subroutine has its origin (i=0,j=0) at the north pole, so if the user's grid has its origin at a point other than the north pole, a translation is required to get i and j for input into w3fb01(). The subroutine grid is oriented so that longitude 80w is parallel to gridlines of i=constant. The Earth's radius is taken to be 6371.2 km. All parameters in the call statement must be real.
    +
    Author
    A. Heermann
    +
    Date
    1969-08-01
    + +

    Definition at line 31 of file w3fb01.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb01_8f.js b/ver-2.10.0/w3fb01_8f.js new file mode 100644 index 00000000..1c596fe1 --- /dev/null +++ b/ver-2.10.0/w3fb01_8f.js @@ -0,0 +1,4 @@ +var w3fb01_8f = +[ + [ "w3fb01", "w3fb01_8f.html#a17796145ddabcec090b9d7249091293b", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb01_8f_source.html b/ver-2.10.0/w3fb01_8f_source.html new file mode 100644 index 00000000..b8da48cf --- /dev/null +++ b/ver-2.10.0/w3fb01_8f_source.html @@ -0,0 +1,160 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb01.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb01.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief I,J TO LATITUDE, LONGITUDE
    +
    3 C> @author A. Heermann @date 1969-08-01
    +
    4 
    +
    5 C> Converts the coordinates of a location from the grid(i,j)
    +
    6 C> coordinate system overlaid on the polar stereographic map pro-
    +
    7 C> jection true at 60 n to the natural coordinate system of latitude
    +
    8 C> /longitude on the Earth. A preferable more flexible subroutine to
    +
    9 C> use is w3fb05(). w3fb01() is the reverse of w3fb00().
    +
    10 C>
    +
    11 C> PROGRAM HISTORY LOG:
    +
    12 C> - A. Heermann 1969-08-01 A. HEERMANN
    +
    13 C> - Ralph Jones 1990-08-31 Change to cray cft77 fortran.
    +
    14 C>
    +
    15 C> @param[in] XI I of the point relative to north pole.
    +
    16 C> @param[in] XJ J of the point relative to north pole.
    +
    17 C> @param[in] XMESHL Mesh length of grid in kilometers at 60n.
    +
    18 C> @param[out] ALAT Latitude in deg. (-20.0(s. hemis) < alat < 90.0).
    +
    19 C> @param[out] ALONG West longitude in degrees.
    +
    20 C>
    +
    21 C> @note The grid used in this subroutine has its origin (i=0,j=0)
    +
    22 C> at the north pole, so if the user's grid has its origin at a
    +
    23 C> point other than the north pole, a translation is required to
    +
    24 C> get i and j for input into w3fb01(). The subroutine grid is
    +
    25 C> oriented so that longitude 80w is parallel to gridlines of
    +
    26 C> i=constant. The Earth's radius is taken to be 6371.2 km.
    +
    27 C> All parameters in the call statement must be real.
    +
    28 C>
    +
    29 C> @author A. Heermann @date 1969-08-01
    +
    30  SUBROUTINE w3fb01(XI,XJ,XMESHL,ALAT,ALONG)
    +
    31 C
    +
    32  DATA degprd/57.2957795/
    +
    33  DATA earthr/6371.2/
    +
    34 C
    +
    35  gi2 = (1.86603 * earthr) / xmeshl
    +
    36  gi2 = gi2 * gi2
    +
    37  r2 = xi * xi + xj * xj
    +
    38  IF (r2.NE.0.0) GO TO 100
    +
    39  along = 0.0
    +
    40  alat = 90.0
    +
    41  RETURN
    +
    42 C
    +
    43 100 CONTINUE
    +
    44  alat = asin((gi2-r2) / (gi2+r2)) * degprd
    +
    45  xlong = degprd * atan2(xj,xi)
    +
    46  IF (xlong) 200,300,300
    +
    47 C
    +
    48 200 CONTINUE
    +
    49  along = -10.0 - xlong
    +
    50  IF (along.LT.0.0) along = along + 360.0
    +
    51  GO TO 400
    +
    52 C
    +
    53 300 CONTINUE
    +
    54  along = 350.0 - xlong
    +
    55 C
    +
    56 400 CONTINUE
    +
    57  RETURN
    +
    58  END
    +
    +
    +
    w3fb01
    subroutine w3fb01(XI, XJ, XMESHL, ALAT, ALONG)
    Converts the coordinates of a location from the grid(i,j) coordinate system overlaid on the polar ste...
    Definition: w3fb01.f:31
    + + + + diff --git a/ver-2.10.0/w3fb02_8f.html b/ver-2.10.0/w3fb02_8f.html new file mode 100644 index 00000000..0ac88f51 --- /dev/null +++ b/ver-2.10.0/w3fb02_8f.html @@ -0,0 +1,188 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb02.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb02.f File Reference
    +
    +
    + +

    COnvert s. hemisphere lat/lon to i and j. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fb02 (ALAT, ALONG, XMESHL, XI, XJ)
     Computes i and j coordinates for a latitude/longitude point on the southern hemisphere polar stereographic map projection. More...
     
    +

    Detailed Description

    +

    COnvert s. hemisphere lat/lon to i and j.

    +
    Author
    Ralph Jones
    +
    Date
    1985-09-13
    + +

    Definition in file w3fb02.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb02()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb02 ( ALAT,
     ALONG,
     XMESHL,
     XI,
     XJ 
    )
    +
    + +

    Computes i and j coordinates for a latitude/longitude point on the southern hemisphere polar stereographic map projection.

    +

    Program history log:

      +
    • Ralph Jones 1985-09-13 Convert to fortran 77.
      • +
    • Ralph Jones 1990-08-31 Convert to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + + +
    [in]ALATReal*4 latitude (s.h. latitudes are negative)
    [in]ALONGReal*4 west longitude.
    [in]XMESHLReal*4 grid interval in km.
    [out]XIReal*4 i coordinate.
    [out]XJReal*4 j coordinate.
    +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1985-09-13
    + +

    Definition at line 21 of file w3fb02.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb02_8f.js b/ver-2.10.0/w3fb02_8f.js new file mode 100644 index 00000000..016663bd --- /dev/null +++ b/ver-2.10.0/w3fb02_8f.js @@ -0,0 +1,4 @@ +var w3fb02_8f = +[ + [ "w3fb02", "w3fb02_8f.html#a86b57ee57a85c801ccca67cc7e6ef2a9", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb02_8f_source.html b/ver-2.10.0/w3fb02_8f_source.html new file mode 100644 index 00000000..03609e1f --- /dev/null +++ b/ver-2.10.0/w3fb02_8f_source.html @@ -0,0 +1,159 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb02.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb02.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief COnvert s. hemisphere lat/lon to i and j.
    +
    3 C> @author Ralph Jones @date 1985-09-13
    +
    4 
    +
    5 C> Computes i and j coordinates for a latitude/longitude
    +
    6 C> point on the southern hemisphere polar stereographic map
    +
    7 C> projection.
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - Ralph Jones 1985-09-13 Convert to fortran 77.
    +
    11 C> - Ralph Jones 1990-08-31 Convert to cray cft77 fortran.
    +
    12 C>
    +
    13 C> @param[in] ALAT Real*4 latitude (s.h. latitudes are negative)
    +
    14 C> @param[in] ALONG Real*4 west longitude.
    +
    15 C> @param[in] XMESHL Real*4 grid interval in km.
    +
    16 C> @param[out] XI Real*4 i coordinate.
    +
    17 C> @param[out] XJ Real*4 j coordinate.
    +
    18 C>
    +
    19 C> @author Ralph Jones @date 1985-09-13
    +
    20  SUBROUTINE w3fb02(ALAT, ALONG, XMESHL, XI, XJ)
    +
    21 C
    +
    22 C ...GIVEN ... ALAT SRN HEMI LATS ARE NEGATIVE VALUED
    +
    23 C ALONG IN DEGREES WEST LONGITUDE
    +
    24 C XMESHL= GRID INTERVAL IN KM, E.G., 381.0 KM
    +
    25 C ...TO COMPUTE XI,XJ FOR A PT ON THE SRN HEMI POLAR STEREOGRAPHIC
    +
    26 C ... PROJECTION, WITH 80W LONGITUDE VERTICAL AT THE TOP OF MAP,
    +
    27 C ... AND 100E LONGITUDE VERTICAL AT THE BOTTOM OF THE MAP.
    +
    28 C ...THE RESULTING XI AND XJ ARE RELATIVE TO (0,0) AT SOUTH POLE.
    +
    29 C
    +
    30  DATA addlng/80.0/
    +
    31 C
    +
    32 C ...WHICH IS DIFFERENCE BETWEEN 180 DEGREES AND VERTICAL MERIDIAN.
    +
    33 C ... THE VERTICAL BEING 100 WEST AFTER CHANGING THE SENSE
    +
    34 C
    +
    35  DATA tiny /0.00001/
    +
    36  DATA earthr/6371.2/
    +
    37  DATA convt /0.017453293/
    +
    38 C
    +
    39 C ...WHICH CONVERTS DEGREES TO RADIANS
    +
    40 C
    +
    41  re = (earthr * 1.86603) / xmeshl
    +
    42 C
    +
    43 C ...WHICH IS DISTANCE IN GRID INTERVALS FROM POLE TO EQUATOR
    +
    44 C
    +
    45  xlat = -alat * convt
    +
    46 C
    +
    47 C ...WHERE NEGATIVE ALATS WERE GIVEN FOR SRN HEMI
    +
    48 C
    +
    49  wlong = 360.0 - along
    +
    50  wlong = (wlong + addlng) * convt
    +
    51  r = (re * cos(xlat))/(1.0 + sin(xlat))
    +
    52  xi = r * sin(wlong)
    +
    53  IF (abs(xi) .LT. tiny) xi = 0.0
    +
    54  xj = r * cos(wlong)
    +
    55  IF (abs(xj) .LT. tiny) xj = 0.0
    +
    56  RETURN
    +
    57  END
    +
    +
    +
    w3fb02
    subroutine w3fb02(ALAT, ALONG, XMESHL, XI, XJ)
    Computes i and j coordinates for a latitude/longitude point on the southern hemisphere polar stereogr...
    Definition: w3fb02.f:21
    + + + + diff --git a/ver-2.10.0/w3fb03_8f.html b/ver-2.10.0/w3fb03_8f.html new file mode 100644 index 00000000..ef92fb34 --- /dev/null +++ b/ver-2.10.0/w3fb03_8f.html @@ -0,0 +1,188 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb03.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb03.f File Reference
    +
    +
    + +

    Convert i,j grid coordinates to lat/lon. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fb03 (XI, XJ, XMESHL, TLAT, TLONG)
     Converts i,j grid coordinates to the corresponding latitude/longitude on a southern hemisphere polar stereographic map projection. More...
     
    +

    Detailed Description

    +

    Convert i,j grid coordinates to lat/lon.

    +
    Author
    Ralph Jones
    +
    Date
    1986-07-17
    + +

    Definition in file w3fb03.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb03()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb03 ( XI,
     XJ,
     XMESHL,
     TLAT,
     TLONG 
    )
    +
    + +

    Converts i,j grid coordinates to the corresponding latitude/longitude on a southern hemisphere polar stereographic map projection.

    +

    Program history log.

      +
    • Ralph Jones 1986-07-17 Convert to fortran 77.
      • +
    • Ralph Jones 1990-08-31 Convert to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + + +
    [in]XIReal i coordinate.
    [in]XJReal j coordinate.
    [in]XMESHLReal grid interval in km.
    [out]TLATReal s.h. latitude.
    [out]TLONGReal longitude.
    +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1986-07-17
    + +

    Definition at line 21 of file w3fb03.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb03_8f.js b/ver-2.10.0/w3fb03_8f.js new file mode 100644 index 00000000..69951590 --- /dev/null +++ b/ver-2.10.0/w3fb03_8f.js @@ -0,0 +1,4 @@ +var w3fb03_8f = +[ + [ "w3fb03", "w3fb03_8f.html#a0b68e4622016d2c2fe409ac880d66a3f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb03_8f_source.html b/ver-2.10.0/w3fb03_8f_source.html new file mode 100644 index 00000000..4b50f224 --- /dev/null +++ b/ver-2.10.0/w3fb03_8f_source.html @@ -0,0 +1,156 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb03.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb03.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert i,j grid coordinates to lat/lon.
    +
    3 C> @author Ralph Jones @date 1986-07-17
    +
    4 
    +
    5 C> Converts i,j grid coordinates to the corresponding
    +
    6 C> latitude/longitude on a southern hemisphere polar stereographic
    +
    7 C> map projection.
    +
    8 C>
    +
    9 C> Program history log.
    +
    10 C> - Ralph Jones 1986-07-17 Convert to fortran 77.
    +
    11 C> - Ralph Jones 1990-08-31 Convert to cray cft77 fortran.
    +
    12 C>
    +
    13 C> @param[in] XI Real i coordinate.
    +
    14 C> @param[in] XJ Real j coordinate.
    +
    15 C> @param[in] XMESHL Real grid interval in km.
    +
    16 C> @param[out] TLAT Real s.h. latitude.
    +
    17 C> @param[out] TLONG Real longitude.
    +
    18 C>
    +
    19 C> @author Ralph Jones @date 1986-07-17
    +
    20  SUBROUTINE w3fb03(XI, XJ, XMESHL, TLAT, TLONG)
    +
    21 C
    +
    22 C ...GIVEN ... XI/XJ GRID COORDINATES OF A POINT RELATIVE
    +
    23 C ... TO (0,0) AT SOUTH POLE
    +
    24 C ...TO COMPUTE TLAT,TLONG ON THE SRN HEMI POLAR STEREO PROJECTION
    +
    25 C ...WITH 80W VERTICAL AT TOP OF THE MAP
    +
    26 C
    +
    27  DATA degprd/57.2957795/
    +
    28  DATA earthr/6371.2/
    +
    29 C
    +
    30  re = (earthr * 1.86603) / xmeshl
    +
    31  gi2 = re * re
    +
    32 C
    +
    33 C ...WHERE GI2 IS THE SQUARE OF DISTANCE IN GRID INTERVALS
    +
    34 C ... FROM POLE TO EQUATOR...
    +
    35 C
    +
    36  r2 = xi * xi + xj * xj
    +
    37  IF (r2 .NE. 0.0) THEN
    +
    38 C
    +
    39  xlong = degprd * atan2(xj,xi)
    +
    40  tlong = xlong - 10.0
    +
    41  IF (tlong .LT. 0.0) tlong = tlong + 360.0
    +
    42  tlat = asin((gi2 - r2)/(gi2 + r2)) * degprd
    +
    43  tlat = -tlat
    +
    44 C
    +
    45  ELSE
    +
    46  tlat = -90.0
    +
    47 C
    +
    48 C ...FOR SOUTH POLE...
    +
    49 C
    +
    50  tlong = 0.0
    +
    51  ENDIF
    +
    52 C
    +
    53  RETURN
    +
    54  END
    +
    +
    +
    w3fb03
    subroutine w3fb03(XI, XJ, XMESHL, TLAT, TLONG)
    Converts i,j grid coordinates to the corresponding latitude/longitude on a southern hemisphere polar ...
    Definition: w3fb03.f:21
    + + + + diff --git a/ver-2.10.0/w3fb04_8f.html b/ver-2.10.0/w3fb04_8f.html new file mode 100644 index 00000000..ddfaa01f --- /dev/null +++ b/ver-2.10.0/w3fb04_8f.html @@ -0,0 +1,200 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb04.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb04.f File Reference
    +
    +
    + +

    Latitude, longitude to grid coordinates. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fb04 (ALAT, ALONG, XMESHL, ORIENT, XI, XJ)
     Converts the coordinates of a location on earth from the natural coordinate system of latitude/longitude to the grid (i,j) coordinate system overlaid on a polar stereographic map pro- jection true at 60 degrees n or s latitude. More...
     
    +

    Detailed Description

    +

    Latitude, longitude to grid coordinates.

    +
    Author
    James McDonell
    +
    Date
    1986-07-17
    + +

    Definition in file w3fb04.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb04()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb04 ( ALAT,
     ALONG,
     XMESHL,
     ORIENT,
     XI,
     XJ 
    )
    +
    + +

    Converts the coordinates of a location on earth from the natural coordinate system of latitude/longitude to the grid (i,j) coordinate system overlaid on a polar stereographic map pro- jection true at 60 degrees n or s latitude.

    +

    w3fb04() is the reverse of w3fb05().

    +

    Program history log:

      +
    • James McDonell 1986-07-17
      • +
    • Ralph Jones 1988-06-07 Clean up code, take out goto, use then, else.
      • +
    • Ralph Jones 1989-11-02 Change to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + + + +
    [in]ALATLatitude in degrees (<0 if sh).
    [in]ALONGWest longitude in degrees.
    [in]XMESHLMesh length of grid in km at 60 deg lat(<0 if sh) (190.5 lfm grid, 381.0 nh pe grid,-381.0 sh pe grid).
    [in]ORIENTOrientation west longitude of the grid (105.0 lfm grid, 80.0 nh pe grid, 260.0 sh pe grid).
    [out]XII of the point relative to north or south pole.
    [out]XJJ of the point relative to north or south pole.
    +
    +
    +
    Note
    All parameters in the calling statement must be real. the range of allowable latitudes is from a pole to 30 degrees into the opposite hemisphere. The grid used in this subroutine has its origin (i=0,j=0) at the pole in either hemisphere, so if the user's grid has its origin at a point other than the pole, a translation is needed to get i and j. The gridlines of i=constant are parallel to a longitude designated by the user. the earth's radius is taken to be 6371.2 km.
    +
    +This code is not vectorized. To vectorize take it and the subroutine it calls and put them in line.
    +
    Author
    James McDonell
    +
    Date
    1986-07-17
    + +

    Definition at line 40 of file w3fb04.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb04_8f.js b/ver-2.10.0/w3fb04_8f.js new file mode 100644 index 00000000..87321bb7 --- /dev/null +++ b/ver-2.10.0/w3fb04_8f.js @@ -0,0 +1,4 @@ +var w3fb04_8f = +[ + [ "w3fb04", "w3fb04_8f.html#a239793420ab239a1a96df658749018ff", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb04_8f_source.html b/ver-2.10.0/w3fb04_8f_source.html new file mode 100644 index 00000000..6453a0ce --- /dev/null +++ b/ver-2.10.0/w3fb04_8f_source.html @@ -0,0 +1,164 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb04.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb04.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Latitude, longitude to grid coordinates.
    +
    3 C> @author James McDonell @date 1986-07-17
    +
    4 
    +
    5 C> Converts the coordinates of a location on earth from the
    +
    6 C> natural coordinate system of latitude/longitude to the grid (i,j)
    +
    7 C> coordinate system overlaid on a polar stereographic map pro-
    +
    8 C> jection true at 60 degrees n or s latitude. w3fb04() is the reverse
    +
    9 C> of w3fb05().
    +
    10 C>
    +
    11 C> Program history log:
    +
    12 C> - James McDonell 1986-07-17
    +
    13 C> - Ralph Jones 1988-06-07 Clean up code, take out goto, use then, else.
    +
    14 C> - Ralph Jones 1989-11-02 Change to cray cft77 fortran.
    +
    15 C>
    +
    16 C> @param[in] ALAT Latitude in degrees (<0 if sh).
    +
    17 C> @param[in] ALONG West longitude in degrees.
    +
    18 C> @param[in] XMESHL Mesh length of grid in km at 60 deg lat(<0 if sh)
    +
    19 C> (190.5 lfm grid, 381.0 nh pe grid,-381.0 sh pe grid).
    +
    20 C> @param[in] ORIENT Orientation west longitude of the grid
    +
    21 C> (105.0 lfm grid, 80.0 nh pe grid, 260.0 sh pe grid).
    +
    22 C> @param[out] XI I of the point relative to north or south pole.
    +
    23 C> @param[out] XJ J of the point relative to north or south pole.
    +
    24 C>
    +
    25 C> @note All parameters in the calling statement must be
    +
    26 c> real. the range of allowable latitudes is from a pole to
    +
    27 c> 30 degrees into the opposite hemisphere.
    +
    28 c> The grid used in this subroutine has its origin (i=0,j=0)
    +
    29 c> at the pole in either hemisphere, so if the user's grid has its
    +
    30 c> origin at a point other than the pole, a translation is needed
    +
    31 c> to get i and j. The gridlines of i=constant are parallel to a
    +
    32 c> longitude designated by the user. the earth's radius is taken
    +
    33 c> to be 6371.2 km.
    +
    34 C>
    +
    35 C> @note This code is not vectorized. To vectorize take it and the
    +
    36 C> subroutine it calls and put them in line.
    +
    37 C>
    +
    38 C> @author James McDonell @date 1986-07-17
    +
    39  SUBROUTINE w3fb04(ALAT,ALONG,XMESHL,ORIENT,XI,XJ)
    +
    40 C
    +
    41  DATA radpd /.01745329/
    +
    42  DATA earthr/6371.2/
    +
    43 C
    +
    44  re = (earthr * 1.86603) / xmeshl
    +
    45  xlat = alat * radpd
    +
    46 C
    +
    47  IF (xmeshl.GE.0.) THEN
    +
    48  wlong = (along + 180.0 - orient) * radpd
    +
    49  r = (re * cos(xlat)) / (1.0 + sin(xlat))
    +
    50  xi = r * sin(wlong)
    +
    51  xj = r * cos(wlong)
    +
    52  ELSE
    +
    53  re = -re
    +
    54  xlat = -xlat
    +
    55  wlong = (along - orient) * radpd
    +
    56  r = (re * cos(xlat)) / (1.0 + sin(xlat))
    +
    57  xi = r * sin(wlong)
    +
    58  xj = -r * cos(wlong)
    +
    59  ENDIF
    +
    60 C
    +
    61  RETURN
    +
    62  END
    +
    +
    +
    w3fb04
    subroutine w3fb04(ALAT, ALONG, XMESHL, ORIENT, XI, XJ)
    Converts the coordinates of a location on earth from the natural coordinate system of latitude/longit...
    Definition: w3fb04.f:40
    + + + + diff --git a/ver-2.10.0/w3fb05_8f.html b/ver-2.10.0/w3fb05_8f.html new file mode 100644 index 00000000..8c2bf1c3 --- /dev/null +++ b/ver-2.10.0/w3fb05_8f.html @@ -0,0 +1,142 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb05.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb05.f File Reference
    +
    +
    + +

    Grid coordinates to latitude, longitude. +More...

    + +

    Go to the source code of this file.

    + + + + +

    +Functions/Subroutines

    +subroutine w3fb05 (XI, XJ, XMESHL, ORIENT, ALAT, ALONG)
     
    +

    Detailed Description

    +

    Grid coordinates to latitude, longitude.

    +
    Author
    Ralph Jones
    +
    Date
    1986-07-17
    +

    Converts the coordinates of a location from the grid(i,j) coordinate system overlaid on the polar stereographic map projec- tion true at 60 degrees n or s latitude to the natural coordinate system of latitude/longitude on the earth. w3fb05() is the reverse of w3fb04().

    +

    Program history log:

      +
    • Ralph Jones 1986-07-17
      • +
    • Ralph Jones 1989-11-01 Change to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + + + +
    [in]XII of the point relative to the north or s. pole
    [in]XJJ of the point relative to the north or s. pole
    [in]XMESHLMesh length of grid in km at 60 degrees(<0 if sh) (190.5 lfm grid, 381.0 nh pe grid,-381.0 sh pe grid)
    [in]ORIENTOrientation west longitude of the grid (105.0 lfm grid, 80.0 nh pe grid, 260.0 sh pe grid)
    [out]ALATLatitude in degrees (<0 if sh)
    [out]ALONGWest longitude in degrees
    +
    +
    +
    Note
    All parameters in the calling statement must be real. the range of allowable latitudes is from a pole to 30 degrees into the opposite hemisphere. the grid used in this subroutine has its origin (i=0,j=0) at the pole, so if the user's grid has its origin at a point other than a pole, a translation is required to get i and j for input into w3fb05(). the subroutine grid is oriented so that gridlines of i=constant are parallel to a west longitude sup- plied by the user. the earth's radius is taken to be 6371.2 km.
    +
    +This code will not vectorize, it is normaly used in a double do loop with w3ft01(), w3ft00(), etc. to vectorize it, put it in line, put w3ft01(), w3ft00(), etc. in line.
    +
    Author
    Ralph Jones
    +
    Date
    1986-07-17
    + +

    Definition in file w3fb05.f.

    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb05_8f.js b/ver-2.10.0/w3fb05_8f.js new file mode 100644 index 00000000..fe1b4542 --- /dev/null +++ b/ver-2.10.0/w3fb05_8f.js @@ -0,0 +1,4 @@ +var w3fb05_8f = +[ + [ "w3fb05", "w3fb05_8f.html#af9a92b376a6fb25c5ac8c778994753bd", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb05_8f_source.html b/ver-2.10.0/w3fb05_8f_source.html new file mode 100644 index 00000000..267fa4cc --- /dev/null +++ b/ver-2.10.0/w3fb05_8f_source.html @@ -0,0 +1,173 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb05.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb05.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Grid coordinates to latitude, longitude.
    +
    3 C> @author Ralph Jones @date 1986-07-17
    +
    4 C>
    +
    5 C> Converts the coordinates of a location from the grid(i,j)
    +
    6 C> coordinate system overlaid on the polar stereographic map projec-
    +
    7 C> tion true at 60 degrees n or s latitude to the natural coordinate
    +
    8 C> system of latitude/longitude on the earth. w3fb05() is the reverse
    +
    9 C> of w3fb04().
    +
    10 C>
    +
    11 C> Program history log:
    +
    12 C> - Ralph Jones 1986-07-17
    +
    13 C> - Ralph Jones 1989-11-01 Change to cray cft77 fortran.
    +
    14 C>
    +
    15 C> @param[in] XI I of the point relative to the north or s. pole
    +
    16 C> @param[in] XJ J of the point relative to the north or s. pole
    +
    17 C> @param[in] XMESHL Mesh length of grid in km at 60 degrees(<0 if sh)
    +
    18 C> (190.5 lfm grid, 381.0 nh pe grid,-381.0 sh pe grid)
    +
    19 C> @param[in] ORIENT Orientation west longitude of the grid
    +
    20 C> (105.0 lfm grid, 80.0 nh pe grid, 260.0 sh pe grid)
    +
    21 C> @param[out] ALAT Latitude in degrees (<0 if sh)
    +
    22 C> @param[out] ALONG West longitude in degrees
    +
    23 C>
    +
    24 C> @note All parameters in the calling statement must be
    +
    25 C> real. the range of allowable latitudes is from a pole to
    +
    26 C> 30 degrees into the opposite hemisphere.
    +
    27 C> the grid used in this subroutine has its origin (i=0,j=0)
    +
    28 C> at the pole, so if the user's grid has its origin at a point
    +
    29 C> other than a pole, a translation is required to get i and j for
    +
    30 C> input into w3fb05(). the subroutine grid is oriented so that
    +
    31 C> gridlines of i=constant are parallel to a west longitude sup-
    +
    32 C> plied by the user. the earth's radius is taken to be 6371.2 km.
    +
    33 C>
    +
    34 C> @note This code will not vectorize, it is normaly used in a
    +
    35 C> double do loop with w3ft01(), w3ft00(), etc. to vectorize it,
    +
    36 C> put it in line, put w3ft01(), w3ft00(), etc. in line.
    +
    37 C>
    +
    38 C> @author Ralph Jones @date 1986-07-17
    +
    39  SUBROUTINE w3fb05(XI,XJ,XMESHL,ORIENT,ALAT,ALONG)
    +
    40 C
    +
    41  DATA degprd/57.2957795/
    +
    42  DATA earthr/6371.2/
    +
    43 C
    +
    44  gi2 = ((1.86603 * earthr) / (xmeshl))**2
    +
    45  r2 = xi * xi + xj * xj
    +
    46 C
    +
    47  IF (r2.EQ.0.0) THEN
    +
    48  along = 0.0
    +
    49  alat = 90.0
    +
    50  IF (xmeshl.LT.0.0) alat = -alat
    +
    51  RETURN
    +
    52  ELSE
    +
    53  alat = asin((gi2 - r2) / (gi2 + r2)) * degprd
    +
    54  angle = degprd * atan2(xj,xi)
    +
    55  IF (angle.LT.0.0) angle = angle + 360.0
    +
    56  ENDIF
    +
    57 C
    +
    58  IF (xmeshl.GE.0.0) THEN
    +
    59  along = 270.0 + orient - angle
    +
    60 C
    +
    61  ELSE
    +
    62 C
    +
    63  along = angle + orient - 270.0
    +
    64  alat = -(alat)
    +
    65  ENDIF
    +
    66 C
    +
    67  IF (along.LT.0.0) along = along + 360.0
    +
    68  IF (along.GE.360.0) along = along - 360.0
    +
    69 C
    +
    70  RETURN
    +
    71 C
    +
    72  END
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb06_8f.html b/ver-2.10.0/w3fb06_8f.html new file mode 100644 index 00000000..127f282b --- /dev/null +++ b/ver-2.10.0/w3fb06_8f.html @@ -0,0 +1,211 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb06.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb06.f File Reference
    +
    +
    + +

    Lat/lon to pola (i,j) for grib. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fb06 (ALAT, ALON, ALAT1, ALON1, DX, ALONV, XI, XJ)
     Converts the coordinates of a location on earth given in the natural coordinate system of latitude/longitude to a grid coordinate system overlaid on a polar stereographic map pro- jection true at 60 degrees n or s latitude. More...
     
    +

    Detailed Description

    +

    Lat/lon to pola (i,j) for grib.

    +
    Author
    John Stackpole
    +
    Date
    1988-01-01
    + +

    Definition in file w3fb06.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb06()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb06 ( ALAT,
     ALON,
     ALAT1,
     ALON1,
     DX,
     ALONV,
     XI,
     XJ 
    )
    +
    + +

    Converts the coordinates of a location on earth given in the natural coordinate system of latitude/longitude to a grid coordinate system overlaid on a polar stereographic map pro- jection true at 60 degrees n or s latitude.

    +

    w3fb06() is the reverse of w3fb07(). uses grib specification of the location of the grid

    +

    Program history log:

      +
    • John Stackpole 1988-01-01
      • +
    • Ralph Jones 1990-04-12 Convert to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + + + + + +
    [in]ALATLatitude in degrees (negative in southern hemis)
    [in]ALONEast longitude in degrees, real*4
    [in]ALAT1Latitude of lower left point of grid (point (1,1))
    [in]ALON1Longitude of lower left point of grid (point (1,1)) all real*4
    [in]DXMesh length of grid in meters at 60 deg lat must be set negative if using southern hemisphere projection. 190500.0 lfm grid, 381000.0 nh pe grid, -381000.0 sh pe grid, etc.
    [in]ALONVThe orientation of the grid. i.e., the east longitude value of the vertical meridian which is parallel to the y-axis (or columns of of the grid)along which latitude increases as the y-coordinate increases. real*4 for example: 255.0 for lfm grid, 280.0 nh pe grid, 100.0 sh pe grid, etc.
    [out]XII Coordinate of the point specified by alat, alon.
    [out]XJJ Coordinate of the point; both real*4.
    +
    +
    +
    Note
    Formulae and notation loosely based on hoke, hayes, and renninger's "map projections and grid systems...", march 1981 afgwc/tn-79/003
    +
    Author
    John Stackpole
    +
    Date
    1988-01-01
    + +

    Definition at line 42 of file w3fb06.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb06_8f.js b/ver-2.10.0/w3fb06_8f.js new file mode 100644 index 00000000..a24b7070 --- /dev/null +++ b/ver-2.10.0/w3fb06_8f.js @@ -0,0 +1,4 @@ +var w3fb06_8f = +[ + [ "w3fb06", "w3fb06_8f.html#a04de76d1aea61cb48ebcd1470101bca9", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb06_8f_source.html b/ver-2.10.0/w3fb06_8f_source.html new file mode 100644 index 00000000..beb7acab --- /dev/null +++ b/ver-2.10.0/w3fb06_8f_source.html @@ -0,0 +1,191 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb06.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb06.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Lat/lon to pola (i,j) for grib.
    +
    3 C> @author John Stackpole @date 1988-01-01
    +
    4 
    +
    5 C> Converts the coordinates of a location on earth given in
    +
    6 C> the natural coordinate system of latitude/longitude to a grid
    +
    7 C> coordinate system overlaid on a polar stereographic map pro-
    +
    8 C> jection true at 60 degrees n or s latitude. w3fb06() is the reverse
    +
    9 C> of w3fb07(). uses grib specification of the location of the grid
    +
    10 C>
    +
    11 C> Program history log:
    +
    12 C> - John Stackpole 1988-01-01
    +
    13 C> - Ralph Jones 1990-04-12 Convert to cray cft77 fortran.
    +
    14 C>
    +
    15 C> @param[in] ALAT Latitude in degrees (negative in southern hemis)
    +
    16 C> @param[in] ALON East longitude in degrees, real*4
    +
    17 C> @param[in] ALAT1 Latitude of lower left point of grid (point (1,1))
    +
    18 C> @param[in] ALON1 Longitude of lower left point of grid (point (1,1))
    +
    19 C> all real*4
    +
    20 C> @param[in] DX Mesh length of grid in meters at 60 deg lat
    +
    21 C> must be set negative if using
    +
    22 C> southern hemisphere projection.
    +
    23 C> 190500.0 lfm grid,
    +
    24 C> 381000.0 nh pe grid, -381000.0 sh pe grid, etc.
    +
    25 C> @param[in] ALONV The orientation of the grid. i.e.,
    +
    26 C> the east longitude value of the vertical meridian
    +
    27 C> which is parallel to the y-axis (or columns of
    +
    28 C> of the grid)along which latitude increases as
    +
    29 C> the y-coordinate increases. real*4
    +
    30 C> for example:
    +
    31 C> 255.0 for lfm grid,
    +
    32 C> 280.0 nh pe grid, 100.0 sh pe grid, etc.
    +
    33 C> @param[out] XI I Coordinate of the point specified by alat, alon.
    +
    34 C> @param[out] XJ J Coordinate of the point; both real*4.
    +
    35 C>
    +
    36 C> @note Formulae and notation loosely based on hoke, hayes,
    +
    37 C> and renninger's "map projections and grid systems...", march 1981
    +
    38 C> afgwc/tn-79/003
    +
    39 C>
    +
    40 C> @author John Stackpole @date 1988-01-01
    +
    41  SUBROUTINE w3fb06(ALAT,ALON,ALAT1,ALON1,DX,ALONV,XI,XJ)
    +
    42 C
    +
    43  DATA rerth /6.3712e+6/, pi/3.1416/
    +
    44  DATA ss60 /1.86603/
    +
    45 C
    +
    46 C PRELIMINARY VARIABLES AND REDIFINITIONS
    +
    47 C
    +
    48 C H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN
    +
    49 C
    +
    50 C REFLON IS LONGITUDE UPON WHICH THE POSITIVE X-COORDINATE
    +
    51 C DRAWN THROUGH THE POLE AND TO THE RIGHT LIES
    +
    52 C ROTATED AROUND FROM ORIENTATION (Y-COORDINATE) LONGITUDE
    +
    53 C DIFFERENTLY IN EACH HEMISPHERE
    +
    54 C
    +
    55  IF (dx.LT.0) THEN
    +
    56  h = -1.0
    +
    57  dxl = -dx
    +
    58  reflon = alonv - 90.0
    +
    59  ELSE
    +
    60  h = 1.0
    +
    61  dxl = dx
    +
    62  reflon = alonv - 270.0
    +
    63  ENDIF
    +
    64 C
    +
    65  radpd = pi / 180.0
    +
    66  rebydx = rerth/dxl
    +
    67 C
    +
    68 C RADIUS TO LOWER LEFT HAND (LL) CORNER
    +
    69 C
    +
    70  ala1 = alat1 * radpd
    +
    71  rmll = rebydx * cos(ala1) * ss60/(1. + h * sin(ala1))
    +
    72 C
    +
    73 C USE LL POINT INFO TO LOCATE POLE POINT
    +
    74 C
    +
    75  alo1 = (alon1 - reflon) * radpd
    +
    76  polei = 1. - rmll * cos(alo1)
    +
    77  polej = 1. - h * rmll * sin(alo1)
    +
    78 C
    +
    79 C RADIUS TO DESIRED POINT AND THE I J TOO
    +
    80 C
    +
    81  ala = alat * radpd
    +
    82  rm = rebydx * cos(ala) * ss60/(1. + h * sin(ala))
    +
    83 C
    +
    84  alo = (alon - reflon) * radpd
    +
    85  xi = polei + rm * cos(alo)
    +
    86  xj = polej + h * rm * sin(alo)
    +
    87 C
    +
    88  RETURN
    +
    89  END
    +
    +
    +
    w3fb06
    subroutine w3fb06(ALAT, ALON, ALAT1, ALON1, DX, ALONV, XI, XJ)
    Converts the coordinates of a location on earth given in the natural coordinate system of latitude/lo...
    Definition: w3fb06.f:42
    + + + + diff --git a/ver-2.10.0/w3fb07_8f.html b/ver-2.10.0/w3fb07_8f.html new file mode 100644 index 00000000..dd9b0fe1 --- /dev/null +++ b/ver-2.10.0/w3fb07_8f.html @@ -0,0 +1,211 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb07.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb07.f File Reference
    +
    +
    + +

    Grid coords to lat/lon for grib. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fb07 (XI, XJ, ALAT1, ALON1, DX, ALONV, ALAT, ALON)
     Converts the coordinates of a location on earth given in a grid coordinate system overlaid on a polar stereographic map pro- jection true at 60 degrees n or s latitude to the natural coordinate system of latitude/longitude w3fb07() is the reverse of w3fb06(). More...
     
    +

    Detailed Description

    +

    Grid coords to lat/lon for grib.

    +
    Author
    John Stackpole
    +
    Date
    1988-01-01
    + +

    Definition in file w3fb07.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb07()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb07 ( XI,
     XJ,
     ALAT1,
     ALON1,
     DX,
     ALONV,
     ALAT,
     ALON 
    )
    +
    + +

    Converts the coordinates of a location on earth given in a grid coordinate system overlaid on a polar stereographic map pro- jection true at 60 degrees n or s latitude to the natural coordinate system of latitude/longitude w3fb07() is the reverse of w3fb06().

    +

    uses grib specification of the location of the grid

    +

    Program history log:

      +
    • John Stackpole 1988-01-01
      • +
    • Ralph Jones 1990-04-12 Convert to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + + + + + +
    [in]XII coordinate of the point real*4.
    [in]XJJ coordinate of the point real*4.
    [in]ALAT1Latitude of lower left point of grid (point 1,1) latitude <0 for southern hemisphere; real*4.
    [in]ALON1Longitude of lower left point of grid (point 1,1) east longitude used throughout; real*4.
    [in]DXMesh length of grid in meters at 60 deg lat must be set negative if using southern hemisphere projection; real*4 190500.0 lfm grid, 381000.0 nh pe grid, -381000.0 sh pe grid, etc.
    [in]ALONVThe orientation of the grid. i.e., the east longitude value of the vertical meridian which is parallel to the y-axis (or columns of the grid) along which latitude increases as the y-coordinate increases. real*4 for example: 255.0 for lfm grid, 280.0 nh pe grid, 100.0 sh pe grid, etc.
    [out]ALATLatitude in degrees (negative in southern hemi.).
    [out]ALONEast longitude in degrees, real*4.
    +
    +
    +
    Note
    Formulae and notation loosely based on hoke, hayes, and renninger's "map projections and grid systems...", march 1981 afgwc/tn-79/003
    +
    Author
    John Stackpole
    +
    Date
    1988-01-01
    + +

    Definition at line 44 of file w3fb07.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb07_8f.js b/ver-2.10.0/w3fb07_8f.js new file mode 100644 index 00000000..2fc218d1 --- /dev/null +++ b/ver-2.10.0/w3fb07_8f.js @@ -0,0 +1,4 @@ +var w3fb07_8f = +[ + [ "w3fb07", "w3fb07_8f.html#a2c8196faf8798dbc2b7593e0a1ec5b68", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb07_8f_source.html b/ver-2.10.0/w3fb07_8f_source.html new file mode 100644 index 00000000..0c6abe27 --- /dev/null +++ b/ver-2.10.0/w3fb07_8f_source.html @@ -0,0 +1,208 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb07.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb07.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Grid coords to lat/lon for grib.
    +
    3 C> @author John Stackpole @date 1988-01-01
    +
    4 
    +
    5 C> Converts the coordinates of a location on earth given in a
    +
    6 C> grid coordinate system overlaid on a polar stereographic map pro-
    +
    7 C> jection true at 60 degrees n or s latitude to the
    +
    8 C> natural coordinate system of latitude/longitude
    +
    9 C> w3fb07() is the reverse of w3fb06().
    +
    10 C> uses grib specification of the location of the grid
    +
    11 C>
    +
    12 C> Program history log:
    +
    13 C> - John Stackpole 1988-01-01
    +
    14 C> - Ralph Jones 1990-04-12 Convert to cray cft77 fortran.
    +
    15 C>
    +
    16 C> @param[in] XI I coordinate of the point real*4.
    +
    17 C> @param[in] XJ J coordinate of the point real*4.
    +
    18 C> @param[in] ALAT1 Latitude of lower left point of grid (point 1,1)
    +
    19 C> latitude <0 for southern hemisphere; real*4.
    +
    20 C> @param[in] ALON1 Longitude of lower left point of grid (point 1,1)
    +
    21 C> east longitude used throughout; real*4.
    +
    22 C> @param[in] DX Mesh length of grid in meters at 60 deg lat
    +
    23 C> must be set negative if using
    +
    24 C> southern hemisphere projection; real*4
    +
    25 C> 190500.0 lfm grid,
    +
    26 C> 381000.0 nh pe grid, -381000.0 sh pe grid, etc.
    +
    27 C> @param[in] ALONV The orientation of the grid. i.e.,
    +
    28 C> the east longitude value of the vertical meridian
    +
    29 C> which is parallel to the y-axis (or columns of
    +
    30 C> the grid) along which latitude increases as
    +
    31 C> the y-coordinate increases. real*4
    +
    32 C> for example:
    +
    33 C> 255.0 for lfm grid,
    +
    34 C> 280.0 nh pe grid, 100.0 sh pe grid, etc.
    +
    35 C> @param[out] ALAT Latitude in degrees (negative in southern hemi.).
    +
    36 C> @param[out] ALON East longitude in degrees, real*4.
    +
    37 C>
    +
    38 C> @note Formulae and notation loosely based on hoke, hayes,
    +
    39 C> and renninger's "map projections and grid systems...", march 1981
    +
    40 C> afgwc/tn-79/003
    +
    41 C>
    +
    42 C> @author John Stackpole @date 1988-01-01
    +
    43  SUBROUTINE w3fb07(XI,XJ,ALAT1,ALON1,DX,ALONV,ALAT,ALON)
    +
    44 C
    +
    45  DATA rerth /6.3712e+6/,pi/3.1416/
    +
    46  DATA ss60 /1.86603/
    +
    47 C
    +
    48 C PRELIMINARY VARIABLES AND REDIFINITIONS
    +
    49 C
    +
    50 C H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN
    +
    51 C
    +
    52 C REFLON IS LONGITUDE UPON WHICH THE POSITIVE X-COORDINATE
    +
    53 C DRAWN THROUGH THE POLE AND TO THE RIGHT LIES
    +
    54 C ROTATED AROUND FROM ORIENTATION (Y-COORDINATE) LONGITUDE
    +
    55 C DIFFERENTLY IN EACH HEMISPHERE
    +
    56 C
    +
    57  IF (dx.LT.0) THEN
    +
    58  h = -1.0
    +
    59  dxl = -dx
    +
    60  reflon = alonv - 90.0
    +
    61  ELSE
    +
    62  h = 1.0
    +
    63  dxl = dx
    +
    64  reflon = alonv - 270.0
    +
    65  ENDIF
    +
    66 C
    +
    67  radpd = pi / 180.0
    +
    68  degprd = 180.0 / pi
    +
    69  rebydx = rerth / dxl
    +
    70 C
    +
    71 C RADIUS TO LOWER LEFT HAND (LL) CORNER
    +
    72 C
    +
    73  ala1 = alat1 * radpd
    +
    74  rmll = rebydx * cos(ala1) * ss60/(1. + h * sin(ala1))
    +
    75 C
    +
    76 C USE LL POINT INFO TO LOCATE POLE POINT
    +
    77 C
    +
    78  alo1 = (alon1 - reflon) * radpd
    +
    79  polei = 1. - rmll * cos(alo1)
    +
    80  polej = 1. - h * rmll * sin(alo1)
    +
    81 C
    +
    82 C RADIUS TO THE I,J POINT (IN GRID UNITS)
    +
    83 C
    +
    84  xx = xi - polei
    +
    85  yy = (xj - polej) * h
    +
    86  r2 = xx**2 + yy**2
    +
    87 C
    +
    88 C NOW THE MAGIC FORMULAE
    +
    89 C
    +
    90  IF (r2.EQ.0) THEN
    +
    91  alat = h * 90.
    +
    92  alon = reflon
    +
    93  ELSE
    +
    94  gi2 = (rebydx * ss60)**2
    +
    95  alat = degprd * h * asin((gi2 - r2)/(gi2 + r2))
    +
    96  arccos = acos(xx/sqrt(r2))
    +
    97  IF (yy.GT.0) THEN
    +
    98  alon = reflon + degprd * arccos
    +
    99  ELSE
    +
    100  alon = reflon - degprd * arccos
    +
    101  ENDIF
    +
    102  ENDIF
    +
    103  IF (alon.LT.0) alon = alon + 360.
    +
    104 C
    +
    105  RETURN
    +
    106  END
    +
    +
    +
    w3fb07
    subroutine w3fb07(XI, XJ, ALAT1, ALON1, DX, ALONV, ALAT, ALON)
    Converts the coordinates of a location on earth given in a grid coordinate system overlaid on a polar...
    Definition: w3fb07.f:44
    + + + + diff --git a/ver-2.10.0/w3fb08_8f.html b/ver-2.10.0/w3fb08_8f.html new file mode 100644 index 00000000..d18a4353 --- /dev/null +++ b/ver-2.10.0/w3fb08_8f.html @@ -0,0 +1,210 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb08.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb08.f File Reference
    +
    +
    + +

    Lat/lon to merc (i,j) for grib. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fb08 (ALAT, ALON, ALAT1, ALON1, ALATIN, DX, XI, XJ)
     Converts a location on earth given in the coordinate system of latitude/longitude to an (i,j) coordinate system overlaid on a mercator map projection w3fb08() is the reverse of w3fb09() uses grib specification of the location of the grid. More...
     
    +

    Detailed Description

    +

    Lat/lon to merc (i,j) for grib.

    +
    Author
    John Stackpole
    +
    Date
    1988-03-01
    + +

    Definition in file w3fb08.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb08()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb08 ( ALAT,
     ALON,
     ALAT1,
     ALON1,
     ALATIN,
     DX,
     XI,
     XJ 
    )
    +
    + +

    Converts a location on earth given in the coordinate system of latitude/longitude to an (i,j) coordinate system overlaid on a mercator map projection w3fb08() is the reverse of w3fb09() uses grib specification of the location of the grid.

    +

    Program history log:

      +
    • John Stackpole 1988-03-01
      • +
    • Ralph Jones 1990-04-12 Convert to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + + + + + +
    [in]ALATLatitude in degrees (negative in southern hemis).
    [in]ALONEast longitude in degrees, real*4.
    [in]ALAT1Latitude of lower left corner of grid (point (1,1)).
    [in]ALON1Longitude of lower left corner of grid (point (1,1)) all real*4.
    [in]ALATINThe latitude at which the mercator cylinder intersects the earth.
    [in]DXMesh length of grid in meters at alatin.
    [out]XII coordinate of the point specified by alat, alon.
    [out]XJJ coordinate of the point; both real*4.
    +
    +
    +
    Note
    Formulae and notation loosely based on hoke, hayes, and renninger's "map projections and grid systems...", march 1981 afgwc/tn-79/003
    +
    Author
    John Stackpole
    +
    Date
    1988-03-01
    + +

    Definition at line 32 of file w3fb08.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb08_8f.js b/ver-2.10.0/w3fb08_8f.js new file mode 100644 index 00000000..74c61040 --- /dev/null +++ b/ver-2.10.0/w3fb08_8f.js @@ -0,0 +1,4 @@ +var w3fb08_8f = +[ + [ "w3fb08", "w3fb08_8f.html#ad3b516b61a4b4b53e680c775f3e92a5b", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb08_8f_source.html b/ver-2.10.0/w3fb08_8f_source.html new file mode 100644 index 00000000..51b164d7 --- /dev/null +++ b/ver-2.10.0/w3fb08_8f_source.html @@ -0,0 +1,158 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb08.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb08.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Lat/lon to merc (i,j) for grib.
    +
    3 C> @author John Stackpole @date 1988-03-01
    +
    4 
    +
    5 C> Converts a location on earth given in
    +
    6 C> the coordinate system of latitude/longitude to an (i,j)
    +
    7 C> coordinate system overlaid on a mercator map projection
    +
    8 C> w3fb08() is the reverse of w3fb09()
    +
    9 C> uses grib specification of the location of the grid.
    +
    10 C>
    +
    11 C> Program history log:
    +
    12 C> - John Stackpole 1988-03-01
    +
    13 C> - Ralph Jones 1990-04-12 Convert to cray cft77 fortran.
    +
    14 C>
    +
    15 C> @param[in] ALAT Latitude in degrees (negative in southern hemis).
    +
    16 C> @param[in] ALON East longitude in degrees, real*4.
    +
    17 C> @param[in] ALAT1 Latitude of lower left corner of grid (point (1,1)).
    +
    18 C> @param[in] ALON1 Longitude of lower left corner of grid (point (1,1))
    +
    19 C> all real*4.
    +
    20 C> @param[in] ALATIN The latitude at which the mercator cylinder
    +
    21 C> intersects the earth.
    +
    22 C> @param[in] DX Mesh length of grid in meters at alatin.
    +
    23 C> @param[out] XI I coordinate of the point specified by alat, alon.
    +
    24 C> @param[out] XJ J coordinate of the point; both real*4.
    +
    25 C>
    +
    26 C> @note Formulae and notation loosely based on hoke, hayes,
    +
    27 C> and renninger's "map projections and grid systems...", march 1981
    +
    28 C> afgwc/tn-79/003
    +
    29 C>
    +
    30 C> @author John Stackpole @date 1988-03-01
    +
    31  SUBROUTINE w3fb08(ALAT,ALON,ALAT1,ALON1,ALATIN,DX,XI,XJ)
    +
    32 C
    +
    33  DATA rerth /6.3712e+6/, pi/3.1416/
    +
    34 C
    +
    35 C PRELIMINARY VARIABLES AND REDIFINITIONS
    +
    36 C
    +
    37  radpd = pi / 180.0
    +
    38  degpr = 180.0 / pi
    +
    39  clain = cos(radpd*alatin)
    +
    40  dellon = dx / (rerth*clain)
    +
    41 C
    +
    42 C GET DISTANCE FROM EQUATOR TO ORIGIN ALAT1
    +
    43 C
    +
    44  djeo = 0.
    +
    45  IF (alat1.NE.0.)
    +
    46  & djeo = (alog(tan(0.5*((alat1+90.0)*radpd))))/dellon
    +
    47 C
    +
    48 C NOW THE I AND J COORDINATES
    +
    49 C
    +
    50  xi = 1. + ((alon - alon1)/(dellon*degpr))
    +
    51  xj = 1. + (alog(tan(0.5*((alat + 90.) * radpd))))/
    +
    52  & dellon
    +
    53  & - djeo
    +
    54 C
    +
    55  RETURN
    +
    56  END
    +
    +
    +
    w3fb08
    subroutine w3fb08(ALAT, ALON, ALAT1, ALON1, ALATIN, DX, XI, XJ)
    Converts a location on earth given in the coordinate system of latitude/longitude to an (i,...
    Definition: w3fb08.f:32
    + + + + diff --git a/ver-2.10.0/w3fb09_8f.html b/ver-2.10.0/w3fb09_8f.html new file mode 100644 index 00000000..dd408157 --- /dev/null +++ b/ver-2.10.0/w3fb09_8f.html @@ -0,0 +1,210 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb09.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb09.f File Reference
    +
    +
    + +

    Merc (i,j) to lat/lon for grib. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fb09 (XI, XJ, ALAT1, ALON1, ALATIN, DX, ALAT, ALON)
     Converts a location on Earth given in an i,j coordinate system overlaid on a mercator map projection to the coordinate system of latitude/longitude w3fb09() is the reverse of w3fb08() uses grib specification of the location of the grid. More...
     
    +

    Detailed Description

    +

    Merc (i,j) to lat/lon for grib.

    +
    Author
    John Stackpole
    +
    Date
    1988-03-01
    + +

    Definition in file w3fb09.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb09()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb09 ( XI,
     XJ,
     ALAT1,
     ALON1,
     ALATIN,
     DX,
     ALAT,
     ALON 
    )
    +
    + +

    Converts a location on Earth given in an i,j coordinate system overlaid on a mercator map projection to the coordinate system of latitude/longitude w3fb09() is the reverse of w3fb08() uses grib specification of the location of the grid.

    +

    Program history log:

      +
    • John Stackpole 1988-03-01
      • +
    • Ralph Jones 1990-04-12 Convert to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + + + + + +
    [in]XII coordinate of the point.
    [in]XJJ coordinate of the point; both real*4.
    [in]ALAT1Latitude of lower left corner of grid (point (1,1)).
    [in]ALON1Longitude of lower left corner of grid (point (1,1)) all real*4.
    [in]ALATINThe latitude at which the mercator cylinder intersects the Earth.
    [in]DXMesh length of grid in meters at alatin.
    [out]ALATLatitude in degrees (negative in southern hemis).
    [out]ALONEast longitude in degrees, real*4 of the point specified by (i,j).
    +
    +
    +
    Note
    Formulae and notation loosely based on hoke, hayes, and renninger's "map projections and grid systems...", march 1981 afgwc/tn-79/003
    +
    Author
    John Stackpole
    +
    Date
    1988-03-01
    + +

    Definition at line 33 of file w3fb09.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb09_8f.js b/ver-2.10.0/w3fb09_8f.js new file mode 100644 index 00000000..e2027fbc --- /dev/null +++ b/ver-2.10.0/w3fb09_8f.js @@ -0,0 +1,4 @@ +var w3fb09_8f = +[ + [ "w3fb09", "w3fb09_8f.html#a44a5c4c417459876b5cbc4aaab8e4a25", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb09_8f_source.html b/ver-2.10.0/w3fb09_8f_source.html new file mode 100644 index 00000000..fcafe002 --- /dev/null +++ b/ver-2.10.0/w3fb09_8f_source.html @@ -0,0 +1,157 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb09.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb09.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Merc (i,j) to lat/lon for grib
    +
    3 C> @author John Stackpole @date 1988-03-01
    +
    4 
    +
    5 C> Converts a location on Earth given in
    +
    6 C> an i,j coordinate system overlaid on a mercator map projection
    +
    7 C> to the coordinate system of latitude/longitude
    +
    8 C> w3fb09() is the reverse of w3fb08()
    +
    9 C> uses grib specification of the location of the grid.
    +
    10 C>
    +
    11 C> Program history log:
    +
    12 C> - John Stackpole 1988-03-01
    +
    13 C> - Ralph Jones 1990-04-12 Convert to cray cft77 fortran.
    +
    14 C>
    +
    15 C> @param[in] XI I coordinate of the point.
    +
    16 C> @param[in] XJ J coordinate of the point; both real*4.
    +
    17 C> @param[in] ALAT1 Latitude of lower left corner of grid (point (1,1)).
    +
    18 C> @param[in] ALON1 Longitude of lower left corner of grid (point (1,1))
    +
    19 C> all real*4.
    +
    20 C> @param[in] ALATIN The latitude at which the mercator cylinder
    +
    21 C> intersects the Earth.
    +
    22 C> @param[in] DX Mesh length of grid in meters at alatin.
    +
    23 C> @param[out] ALAT Latitude in degrees (negative in southern hemis).
    +
    24 C> @param[out] ALON East longitude in degrees, real*4
    +
    25 C> of the point specified by (i,j).
    +
    26 C>
    +
    27 C> @note Formulae and notation loosely based on hoke, hayes,
    +
    28 C> and renninger's "map projections and grid systems...", march 1981
    +
    29 C> afgwc/tn-79/003
    +
    30 C>
    +
    31 C> @author John Stackpole @date 1988-03-01
    +
    32  SUBROUTINE w3fb09(XI,XJ,ALAT1,ALON1,ALATIN,DX,ALAT,ALON)
    +
    33 C
    +
    34  DATA rerth /6.3712e+6/, pi/3.1416/
    +
    35 C
    +
    36 C PRELIMINARY VARIABLES AND REDIFINITIONS
    +
    37 C
    +
    38  radpd = pi / 180.0
    +
    39  degpr = 180.0 / pi
    +
    40  clain = cos(radpd*alatin)
    +
    41  dellon = dx / (rerth*clain)
    +
    42 C
    +
    43 C GET DISTANCE FROM EQUATOR TO ORIGIN ALAT1
    +
    44 C
    +
    45  djeo = 0.
    +
    46  IF (alat1.NE.0.)
    +
    47  & djeo = (alog(tan(0.5*((alat1+90.0)*radpd))))/dellon
    +
    48 C
    +
    49 C NOW THE LAT AND LON
    +
    50 C
    +
    51  alat = 2.0*atan(exp(dellon*(djeo + xj-1.)))*degpr - 90.0
    +
    52  alon = (xi-1.) * dellon * degpr + alon1
    +
    53 C
    +
    54  RETURN
    +
    55  END
    +
    +
    +
    w3fb09
    subroutine w3fb09(XI, XJ, ALAT1, ALON1, ALATIN, DX, ALAT, ALON)
    Converts a location on Earth given in an i,j coordinate system overlaid on a mercator map projection ...
    Definition: w3fb09.f:33
    + + + + diff --git a/ver-2.10.0/w3fb10_8f.html b/ver-2.10.0/w3fb10_8f.html new file mode 100644 index 00000000..1c13b9cf --- /dev/null +++ b/ver-2.10.0/w3fb10_8f.html @@ -0,0 +1,205 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb10.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb10.f File Reference
    +
    +
    + +

    Lat/long pair to compass bearing, gcd. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fb10 (DLAT1, DLON1, DLAT2, DLON2, BEARD, GCDKM)
     Given a pair of points (1) and (2) given by latitude and longitude, w3fb10() computes the bearing and great circle distance from point (1) to point (2) assuming a spherical Earth. More...
     
    +

    Detailed Description

    +

    Lat/long pair to compass bearing, gcd.

    +
    Author
    Peter Chase
    +
    Date
    1988-08-29
    + +

    Definition in file w3fb10.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb10()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb10 (real DLAT1,
    real DLON1,
    real DLAT2,
    real DLON2,
    real BEARD,
    real GCDKM 
    )
    +
    + +

    Given a pair of points (1) and (2) given by latitude and longitude, w3fb10() computes the bearing and great circle distance from point (1) to point (2) assuming a spherical Earth.

    +

    The north and south poles are special cases. If latitude of point (1) is within 1e-10 degrees of the north pole, bearing is the negative longitude of point (2) by convention. If latitude of point (1) is within 1e-10 degrees of the south pole, bearing is the longitude of point (2) by convention. If point (2) is within 1e-6 radians of the antipode of point (1), the bearing will be set to zero. If point (1) and point (2) are within 1e-10 radians of each other, both bearing and distance will be set to zero.

    +

    Program history log:

      +
    • Peter Chase 1988-08-29
      • +
    • Peter Chase 1988-09-23 Fix dumb south pole error.
      • +
    • Peter Chase 1988-10-05 Fix bearing ambiguity.
      • +
    • Ralph Jones 1990-04-12 Convert to cft77 fortran.
      • +
    +
    Parameters
    + + + + + + + +
    [in]DLAT1REAL Latitude of point (1) in degrees north.
    [in]DLON1REAL Longitude of point (1) in degrees east.
    [in]DLAT2REAL Latitude of point (2) in degrees north.
    [in]DLON2REAL Longitude of point (2) in degrees east.
    [out]BEARDREAL Bearing of point (2) from point (1) in compass degrees with north = 0.0, values from -180.0 to +180.0 degrees.
    [out]GCDKMREAL Great circle distance from point (1) to point (2) in kilometers.
    +
    +
    +
    Note
    According to the nmc handbook, the Earth's radius is 6371.2 kilometers. This is what we use, even though the value recommended by the smithsonian meteorological handbook is 6371.221 km. (I wouldn't want you to think that I didn't know what the correct value was.)
    +
    +Method: The poles are special cases, and handled separately. otherwise, from spherical trigonometry, the law of cosines is used to calculate the third side of the spherical triangle having sides from the pole to points (1) and (2) (the colatitudes). then the law of sines is used to calculate the angle at point (1). A test is applied to see whether the arcsine result may be be used as such, giving an acute angle as the bearing, or whether the arcsine result should be subtracted from pi, giving an obtuse angle as the bearing. This test is derived by constructing a right spherical triangle using the pole, point (2), and the meridian through point(1). The latitude of the right-angled vertex then provides a test–if latitude (1) is greater than this latitude, the bearing angle must be obtuse, otherwise acute. If the two points are within 1e-6 radians of each other a flat Earth is assumed, and the four-quadrant arctangent function is used to find the bearing. The y-displacement is the difference in latitude and the x-displacement is the difference in longitude times cosine latitude, both in radians. distance is then the diagonal.
    +
    +Fundamental trigonometric identities are used freely, such as that cos(x) = sin(pi/2 - x), etc. See almost any mathematical handbook, such as the c.r.c. standard math tables under 'relations in any spherical triangle', or the national bureau of standards 'handbook of mathematical functions' under section 4.3.149, formulas for solution of spherical triangles.
    +
    +Double precision is used internally because of the wide range of geographic values that may be used.
    +
    Author
    Peter Chase
    +
    Date
    1988-08-29
    + +

    Definition at line 71 of file w3fb10.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb10_8f.js b/ver-2.10.0/w3fb10_8f.js new file mode 100644 index 00000000..82127e2a --- /dev/null +++ b/ver-2.10.0/w3fb10_8f.js @@ -0,0 +1,4 @@ +var w3fb10_8f = +[ + [ "w3fb10", "w3fb10_8f.html#a5f021ccf55ac42f4034f0fd60e612911", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb10_8f_source.html b/ver-2.10.0/w3fb10_8f_source.html new file mode 100644 index 00000000..64bbe48b --- /dev/null +++ b/ver-2.10.0/w3fb10_8f_source.html @@ -0,0 +1,330 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb10.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb10.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Lat/long pair to compass bearing, gcd.
    +
    3 C> @author Peter Chase @date 1988-08-29
    +
    4 
    +
    5 C> Given a pair of points (1) and (2) given by latitude and
    +
    6 C> longitude, w3fb10() computes the bearing and great circle distance
    +
    7 C> from point (1) to point (2) assuming a spherical Earth. The
    +
    8 C> north and south poles are special cases. If latitude of point
    +
    9 C> (1) is within 1e-10 degrees of the north pole, bearing is the
    +
    10 C> negative longitude of point (2) by convention. If latitude of
    +
    11 C> point (1) is within 1e-10 degrees of the south pole, bearing is
    +
    12 C> the longitude of point (2) by convention. If point (2) is within
    +
    13 C> 1e-6 radians of the antipode of point (1), the bearing will be
    +
    14 C> set to zero. If point (1) and point (2) are within 1e-10 radians
    +
    15 C> of each other, both bearing and distance will be set to zero.
    +
    16 C>
    +
    17 C> Program history log:
    +
    18 C> - Peter Chase 1988-08-29
    +
    19 C> - Peter Chase 1988-09-23 Fix dumb south pole error.
    +
    20 C> - Peter Chase 1988-10-05 Fix bearing ambiguity.
    +
    21 C> - Ralph Jones 1990-04-12 Convert to cft77 fortran.
    +
    22 C>
    +
    23 C> @param[in] DLAT1 REAL Latitude of point (1) in degrees north.
    +
    24 C> @param[in] DLON1 REAL Longitude of point (1) in degrees east.
    +
    25 C> @param[in] DLAT2 REAL Latitude of point (2) in degrees north.
    +
    26 C> @param[in] DLON2 REAL Longitude of point (2) in degrees east.
    +
    27 C> @param[out] BEARD REAL Bearing of point (2) from point (1) in
    +
    28 C> compass degrees with north = 0.0, values from
    +
    29 C> -180.0 to +180.0 degrees.
    +
    30 C> @param[out] GCDKM REAL Great circle distance from point (1) to
    +
    31 C> point (2) in kilometers.
    +
    32 C>
    +
    33 C> @note According to the nmc handbook, the Earth's radius is
    +
    34 C> 6371.2 kilometers. This is what we use, even though the value
    +
    35 C> recommended by the smithsonian meteorological handbook is
    +
    36 C> 6371.221 km. (I wouldn't want you to think that I didn't know
    +
    37 C> what the correct value was.)
    +
    38 C>
    +
    39 C> @note Method: The poles are special cases, and handled separately.
    +
    40 C> otherwise, from spherical trigonometry, the law of cosines is used
    +
    41 C> to calculate the third side of the spherical triangle having
    +
    42 C> sides from the pole to points (1) and (2) (the colatitudes).
    +
    43 C> then the law of sines is used to calculate the angle at point
    +
    44 C> (1). A test is applied to see whether the arcsine result may be
    +
    45 C> be used as such, giving an acute angle as the bearing, or whether
    +
    46 C> the arcsine result should be subtracted from pi, giving an obtuse
    +
    47 C> angle as the bearing. This test is derived by constructing a
    +
    48 C> right spherical triangle using the pole, point (2), and the
    +
    49 C> meridian through point(1). The latitude of the right-angled
    +
    50 C> vertex then provides a test--if latitude (1) is greater than this
    +
    51 C> latitude, the bearing angle must be obtuse, otherwise acute.
    +
    52 C> If the two points are within 1e-6 radians of each other
    +
    53 C> a flat Earth is assumed, and the four-quadrant arctangent
    +
    54 C> function is used to find the bearing. The y-displacement is
    +
    55 C> the difference in latitude and the x-displacement is the
    +
    56 C> difference in longitude times cosine latitude, both in radians.
    +
    57 C> distance is then the diagonal.
    +
    58 C>
    +
    59 C> @note Fundamental trigonometric identities are used freely, such
    +
    60 C> as that cos(x) = sin(pi/2 - x), etc. See almost any mathematical
    +
    61 C> handbook, such as the c.r.c. standard math tables under 'relations
    +
    62 C> in any spherical triangle', or the national bureau of standards
    +
    63 C> 'handbook of mathematical functions' under section 4.3.149,
    +
    64 C> formulas for solution of spherical triangles.
    +
    65 C>
    +
    66 C> @note Double precision is used internally because of the wide
    +
    67 C> range of geographic values that may be used.
    +
    68 C>
    +
    69 C> @author Peter Chase @date 1988-08-29
    +
    70  SUBROUTINE w3fb10(DLAT1, DLON1, DLAT2, DLON2, BEARD, GCDKM)
    +
    71 C
    +
    72 C *** IMPLICIT TYPE DEFAULTS.....
    +
    73 C
    +
    74  IMPLICIT REAL (A-H,O-Z)
    +
    75 C
    +
    76 C *** CONSTANTS......
    +
    77 C
    +
    78  REAL PI
    +
    79  REAL HALFPI
    +
    80  REAL DR
    +
    81  REAL RD
    +
    82  REAL TDEG, TRAD, TPOD, TFLT
    +
    83  REAL EARTHR
    +
    84  REAL WHOLCD, HALFCD, QUARCD
    +
    85 C
    +
    86 C *** VARIABLES......
    +
    87 C
    +
    88  REAL RLAT1, RLAT2, COSLA1, COSLA2, SINLA1, SINLA2
    +
    89  REAL DLOND, RLOND, COSLO, SINLO, SANGG, ABEAR
    +
    90  REAL YDISP, XDISP, DDLAT1, DDLAT2, DBANG
    +
    91  REAL DLAT1, DLAT2, DLON1, DLON2, BEARD, GCDKM
    +
    92 C
    +
    93 C *** CONVERT LATITUDES AND LONGITUDE DIFFERENCE TO RADIANS.
    +
    94 C
    +
    95  DATA pi /3.141592653589793238462643/
    +
    96  DATA halfpi/1.570796326794896619231322/
    +
    97  DATA dr /0.017453292519943295769237/
    +
    98  DATA rd /57.295779513082320876798155/
    +
    99  DATA tdeg /1e-10/, trad/1e-10/, tpod/1e-6/, tflt/1e-6/
    +
    100  DATA earthr/6371.2/
    +
    101  DATA wholcd/360.0/, halfcd/180.0/, quarcd/90.0/
    +
    102 
    +
    103  ddlat1 = dlat1
    +
    104  ddlat2 = dlat2
    +
    105  rlat1 = dr * ddlat1
    +
    106  rlat2 = dr * ddlat2
    +
    107  dlond = dlon2 - dlon1
    +
    108  IF (dlond .GT. halfcd) dlond = dlond - wholcd
    +
    109  IF (dlond .LT. -halfcd) dlond = dlond + wholcd
    +
    110  rlond = dr * dlond
    +
    111 C
    +
    112 C *** FIRST WE ATTACK THE CASES WHERE POINT 1 IS VERY CLOSE TO THE
    +
    113 C *** NORTH OR SOUTH POLES.
    +
    114 C *** HERE WE USE CONVENTIONAL VALUE FOR BEARING.. - LONG (2) AT THE
    +
    115 C *** NORTH POLE, AND + LONG (2) AT THE SOUTH POLE.
    +
    116 C
    +
    117  IF (abs(ddlat1-quarcd) .LT. tdeg) THEN
    +
    118  IF (abs(ddlat2-quarcd) .LT. tdeg) THEN
    +
    119  dbang = 0.0
    +
    120  sangg = 0.0
    +
    121  ELSE IF (abs(ddlat2+quarcd) .LT. tdeg) THEN
    +
    122  dbang = 0.0
    +
    123  sangg = pi
    +
    124  ELSE
    +
    125  dbang = -dlon2
    +
    126  sangg = halfpi - rlat2
    +
    127  ENDIF
    +
    128  ELSE IF (abs(ddlat1+quarcd) .LT. tdeg) THEN
    +
    129  IF (abs(ddlat2-quarcd) .LT. tdeg) THEN
    +
    130  dbang = 0.0
    +
    131  sangg = pi
    +
    132  ELSE IF (abs(ddlat2+quarcd) .LT. tdeg) THEN
    +
    133  dbang = 0.0
    +
    134  sangg = 0.0
    +
    135  ELSE
    +
    136  dbang = +dlon2
    +
    137  sangg = halfpi + rlat2
    +
    138  ENDIF
    +
    139 C
    +
    140 C *** NEXT WE ATTACK THE CASES WHERE POINT 2 IS VERY CLOSE TO THE
    +
    141 C *** NORTH OR SOUTH POLES.
    +
    142 C *** HERE BEARING IS SIMPLY 0 OR 180 DEGREES.
    +
    143 C
    +
    144  ELSE IF (abs(ddlat2-quarcd) .LT. tdeg) THEN
    +
    145  dbang = 0.0
    +
    146  sangg = halfpi - rlat1
    +
    147  ELSE IF (abs(ddlat2+quarcd) .LT. tdeg) THEN
    +
    148  dbang = halfcd
    +
    149  sangg = halfpi + rlat1
    +
    150 C
    +
    151 C *** THE CASE REMAINS THAT NEITHER POINT IS AT EITHER POLE.
    +
    152 C *** FIND COSINE AND SINE OF LATITUDES AND LONGITUDE DIFFERENCE
    +
    153 C *** SINCE THEY ARE USED IN MORE THAN ONE FORMULA.
    +
    154 C
    +
    155  ELSE
    +
    156  cosla1 = cos(rlat1)
    +
    157  sinla1 = sin(rlat1)
    +
    158  cosla2 = cos(rlat2)
    +
    159  sinla2 = sin(rlat2)
    +
    160  coslo = cos(rlond)
    +
    161  sinlo = sin(rlond)
    +
    162 C
    +
    163 C *** FOLLOWING IS FORMULA FOR GREAT CIRCLE SUBTENDED ANGLE BETWEEN
    +
    164 C *** POINTS IN RADIAN MEASURE.
    +
    165 C
    +
    166  sangg = acos(sinla1*sinla2 + cosla1*cosla2*coslo)
    +
    167 C
    +
    168 C *** IF THE GREAT CIRCLE SUBTENDED ANGLE IS VERY SMALL, FORCE BOTH
    +
    169 C *** BEARING AND DISTANCE TO BE ZERO.
    +
    170 C
    +
    171  IF (abs(sangg) .LT. trad) THEN
    +
    172  dbang = 0.0
    +
    173  sangg = 0.0
    +
    174 C
    +
    175 C *** IF THE GREAT CIRCLE SUBTENDED ANGLE IS JUST SMALL, ASSUME A
    +
    176 C *** FLAT EARTH AND CALCULATE Y- AND X-DISPLACEMENTS. THEN FIND
    +
    177 C *** BEARING USING THE ARCTANGENT FUNCTION AND DISTANCE USING THE
    +
    178 C *** SQUARE ROOT.
    +
    179 C
    +
    180  ELSE IF (abs(sangg) .LT. tflt) THEN
    +
    181  ydisp = rlat2-rlat1
    +
    182  xdisp = rlond*cosla2
    +
    183  abear = atan2(xdisp, ydisp)
    +
    184  dbang = rd*abear
    +
    185  sangg = sqrt(ydisp**2 + xdisp**2)
    +
    186 C
    +
    187 C *** IF THE ANGLE IS RATHER CLOSE TO PI RADIANS, FORCE BEARING TO
    +
    188 C *** BE ZERO AND DISTANCE TO BE PI.
    +
    189 C *** THE TEST FOR 'CLOSE TO PI' IS MORE RELAXED THAN THE TEST FOR
    +
    190 C *** 'CLOSE TO ZERO' TO ALLOW FOR GREATER RELATIVE ERROR.
    +
    191 C
    +
    192  ELSE IF (abs(sangg-pi) .LT. tpod) THEN
    +
    193  dbang = 0.0
    +
    194  sangg = pi
    +
    195 C
    +
    196 C *** OTHERWISE COMPUTE THE PRINCIPAL VALUE OF THE BEARING ANGLE
    +
    197 C *** USING THE LAW OF SINES. THE DIVISION BY THE SINE FORCES US TO
    +
    198 C *** LIMIT THE DOMAIN OF THE ARCSINE TO (-1,1).
    +
    199 C
    +
    200  ELSE
    +
    201  abear = asin(amax1(-1.0,amin1(+1.0,cosla2*sinlo/
    +
    202  & sin(sangg))))
    +
    203 C
    +
    204 C *** IF THE LONGITUDE DIFFERENCE IS LESS THAN PI/2 IT IS NECESSARY
    +
    205 C *** TO CHECK WHETHER THE BEARING ANGLE IS ACUTE OR OBTUSE BY
    +
    206 C *** COMPARING LATITUDE (1) WITH THE LATITUDE OF THE GREAT CIRCLE
    +
    207 C *** THROUGH POINT (2) NORMAL TO MERIDIAN OF LONGITUDE (1). IF
    +
    208 C *** LATITUDE (1) IS GREATER, BEARING IS OBTUSE AND THE ACTUAL
    +
    209 C *** BEARING ANGLE IS THE SUPPLEMENT OF THE ANGLE CALCULATED ABOVE.
    +
    210 C
    +
    211  IF (0.0 .LE. cosla1*sinla2 .AND. cosla1*sinla2 .LE.
    +
    212  & cosla2*sinla1*coslo .OR. cosla1*sinla2 .LE. 0.0 .AND.
    +
    213  & cosla2*sinla1*coslo .GE. cosla1*sinla2) abear =
    +
    214  & sign(pi,abear) - abear
    +
    215  dbang = rd * abear
    +
    216  ENDIF
    +
    217  ENDIF
    +
    218 C
    +
    219 C *** THIS FINISHES THE CASE WHERE POINTS ARE NOT AT THE POLES.
    +
    220 C *** NOW CONVERT BEARING TO DEGREES IN RANGE -180 TO +180 AND FIND
    +
    221 C *** GREAT CIRCLE DISTANCE IN KILOMETERS.
    +
    222 C
    +
    223  IF (dbang .LE. -halfcd) dbang = dbang + wholcd
    +
    224  IF (dbang .GT. halfcd) dbang = dbang - wholcd
    +
    225  gcdkm = earthr * sangg
    +
    226  beard = dbang
    +
    227  RETURN
    +
    228  END
    +
    +
    +
    w3fb10
    subroutine w3fb10(DLAT1, DLON1, DLAT2, DLON2, BEARD, GCDKM)
    Given a pair of points (1) and (2) given by latitude and longitude, w3fb10() computes the bearing and...
    Definition: w3fb10.f:71
    + + + + diff --git a/ver-2.10.0/w3fb11_8f.html b/ver-2.10.0/w3fb11_8f.html new file mode 100644 index 00000000..714dd8eb --- /dev/null +++ b/ver-2.10.0/w3fb11_8f.html @@ -0,0 +1,219 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb11.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb11.f File Reference
    +
    +
    + +

    Lat/lon to lambert(i,j) for grib. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fb11 (ALAT, ELON, ALAT1, ELON1, DX, ELONV, ALATAN, XI, XJ)
     Converts the coordinates of a location on Earth given in the natural coordinate system of latitude/longitude to a grid coordinate system overlaid on a lambert conformal tangent cone projection true at a given n or s latitude. More...
     
    +

    Detailed Description

    +

    Lat/lon to lambert(i,j) for grib.

    +
    Author
    John Stackpole
    +
    Date
    1988-11-25
    + +

    Definition in file w3fb11.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb11()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb11 ( ALAT,
     ELON,
     ALAT1,
     ELON1,
     DX,
     ELONV,
     ALATAN,
     XI,
     XJ 
    )
    +
    + +

    Converts the coordinates of a location on Earth given in the natural coordinate system of latitude/longitude to a grid coordinate system overlaid on a lambert conformal tangent cone projection true at a given n or s latitude.

    +

    w3fb11() is the reverse of w3fb12(). uses grib specification of the location of the grid

    +

    Program history log:

      +
    • John Stackpole 1988-11-25
      • +
    • Ralph Jones 1990-04-12 Convert to cft77 fortran.
      • +
    • Ralph Jones 1994-04-28 Add save statement.
      • +
    +
    Parameters
    + + + + + + + + + + +
    [in]ALATLatitude in degrees (negative in southern hemis).
    [in]ELONEast longitude in degrees, real*4.
    [in]ALAT1Latitude of lower left point of grid (point (1,1)).
    [in]ELON1Longitude of lower left point of grid (point (1,1)) all real*4.
    [in]DXMesh length of grid in meters at tangent latitude.
    [in]ELONVThe orientation of the grid. i.e., the east longitude value of the vertical meridian which is parallel to the y-axis (or columns of of the grid) along which latitude increases as the y-coordinate increases. real*4 this is also the meridian (on the back side of the tangent cone) along which the cut is made to lay the cone flat.
    [in]ALATANThe latitude at which the lambert cone is tangent to (touching) the spherical Earth. Set negative to indicate a southern hemisphere projection.
    [out]XII coordinate of the point specified by alat, elon
    [out]XJJ coordinate of the point; both real*4
    +
    +
    +
    Note
    Formulae and notation loosely based on hoke, hayes, and renninger's "map projections and grid systems...", march 1981 afgwc/tn-79/003.
    +
    Author
    John Stackpole
    +
    Date
    1988-11-25
    + +

    Definition at line 42 of file w3fb11.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb11_8f.js b/ver-2.10.0/w3fb11_8f.js new file mode 100644 index 00000000..c4f4e8e9 --- /dev/null +++ b/ver-2.10.0/w3fb11_8f.js @@ -0,0 +1,4 @@ +var w3fb11_8f = +[ + [ "w3fb11", "w3fb11_8f.html#a28b19a1336d3f885a04a97831726a3c0", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb11_8f_source.html b/ver-2.10.0/w3fb11_8f_source.html new file mode 100644 index 00000000..4dad6da1 --- /dev/null +++ b/ver-2.10.0/w3fb11_8f_source.html @@ -0,0 +1,214 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb11.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb11.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Lat/lon to lambert(i,j) for grib.
    +
    3 C> @author John Stackpole @date 1988-11-25
    +
    4 
    +
    5 C> Converts the coordinates of a location on Earth given in
    +
    6 C> the natural coordinate system of latitude/longitude to a grid
    +
    7 C> coordinate system overlaid on a lambert conformal tangent cone
    +
    8 C> projection true at a given n or s latitude. w3fb11() is the reverse
    +
    9 C> of w3fb12(). uses grib specification of the location of the grid
    +
    10 C>
    +
    11 C> Program history log:
    +
    12 C> - John Stackpole 1988-11-25
    +
    13 C> - Ralph Jones 1990-04-12 Convert to cft77 fortran.
    +
    14 C> - Ralph Jones 1994-04-28 Add save statement.
    +
    15 C>
    +
    16 C> @param[in] ALAT Latitude in degrees (negative in southern hemis).
    +
    17 C> @param[in] ELON East longitude in degrees, real*4.
    +
    18 C> @param[in] ALAT1 Latitude of lower left point of grid (point (1,1)).
    +
    19 C> @param[in] ELON1 Longitude of lower left point of grid (point (1,1))
    +
    20 C> all real*4.
    +
    21 C> @param[in] DX Mesh length of grid in meters at tangent latitude.
    +
    22 C> @param[in] ELONV The orientation of the grid. i.e.,
    +
    23 C> the east longitude value of the vertical meridian
    +
    24 C> which is parallel to the y-axis (or columns of
    +
    25 C> of the grid) along which latitude increases as
    +
    26 C> the y-coordinate increases. real*4
    +
    27 C> this is also the meridian (on the back side of the
    +
    28 C> tangent cone) along which the cut is made to lay
    +
    29 C> the cone flat.
    +
    30 C> @param[in] ALATAN The latitude at which the lambert cone is tangent to
    +
    31 C> (touching) the spherical Earth. Set negative to indicate a
    +
    32 C> southern hemisphere projection.
    +
    33 C> @param[out] XI I coordinate of the point specified by alat, elon
    +
    34 C> @param[out] XJ J coordinate of the point; both real*4
    +
    35 C>
    +
    36 C> @note Formulae and notation loosely based on hoke, hayes,
    +
    37 C> and renninger's "map projections and grid systems...", march 1981
    +
    38 C> afgwc/tn-79/003.
    +
    39 C>
    +
    40 C> @author John Stackpole @date 1988-11-25
    +
    41  SUBROUTINE w3fb11(ALAT,ELON,ALAT1,ELON1,DX,ELONV,ALATAN,XI,XJ)
    +
    42 C
    +
    43  SAVE
    +
    44 C
    +
    45  DATA rerth /6.3712e+6/, pi/3.14159/
    +
    46 C
    +
    47 C PRELIMINARY VARIABLES AND REDIFINITIONS
    +
    48 C
    +
    49 C H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN
    +
    50 C
    +
    51  IF (alatan.GT.0) THEN
    +
    52  h = 1.
    +
    53  ELSE
    +
    54  h = -1.
    +
    55  ENDIF
    +
    56 C
    +
    57  radpd = pi / 180.0
    +
    58  rebydx = rerth / dx
    +
    59  alatn1 = alatan * radpd
    +
    60  an = h * sin(alatn1)
    +
    61  cosltn = cos(alatn1)
    +
    62 C
    +
    63 C MAKE SURE THAT INPUT LONGITUDES DO NOT PASS THROUGH
    +
    64 C THE CUT ZONE (FORBIDDEN TERRITORY) OF THE FLAT MAP
    +
    65 C AS MEASURED FROM THE VERTICAL (REFERENCE) LONGITUDE.
    +
    66 C
    +
    67  elon1l = elon1
    +
    68  IF ((elon1 - elonv).GT.180.)
    +
    69  & elon1l = elon1 - 360.
    +
    70  IF ((elon1 - elonv).LT.(-180.))
    +
    71  & elon1l = elon1 + 360.
    +
    72 C
    +
    73  elonl = elon
    +
    74  IF ((elon - elonv).GT.180.)
    +
    75  & elonl = elon - 360.
    +
    76  IF ((elon - elonv).LT.(-180.))
    +
    77  & elonl = elon + 360.
    +
    78 C
    +
    79  elonvr = elonv * radpd
    +
    80 C
    +
    81 C RADIUS TO LOWER LEFT HAND (LL) CORNER
    +
    82 C
    +
    83  ala1 = alat1 * radpd
    +
    84  rmll = rebydx * (((cosltn)**(1.-an))*(1.+an)**an) *
    +
    85  & (((cos(ala1))/(1.+h*sin(ala1)))**an)/an
    +
    86 C
    +
    87 C USE LL POINT INFO TO LOCATE POLE POINT
    +
    88 C
    +
    89  elo1 = elon1l * radpd
    +
    90  arg = an * (elo1-elonvr)
    +
    91  polei = 1. - h * rmll * sin(arg)
    +
    92  polej = 1. + rmll * cos(arg)
    +
    93 C
    +
    94 C RADIUS TO DESIRED POINT AND THE I J TOO
    +
    95 C
    +
    96  ala = alat * radpd
    +
    97  rm = rebydx * ((cosltn**(1.-an))*(1.+an)**an) *
    +
    98  & (((cos(ala))/(1.+h*sin(ala)))**an)/an
    +
    99 C
    +
    100  elo = elonl * radpd
    +
    101  arg = an*(elo-elonvr)
    +
    102  xi = polei + h * rm * sin(arg)
    +
    103  xj = polej - rm * cos(arg)
    +
    104 C
    +
    105 C IF COORDINATE LESS THAN 1
    +
    106 C COMPENSATE FOR ORIGIN AT (1,1)
    +
    107 C
    +
    108  IF (xi.LT.1.) xi = xi - 1.
    +
    109  IF (xj.LT.1.) xj = xj - 1.
    +
    110 C
    +
    111  RETURN
    +
    112  END
    +
    +
    +
    w3fb11
    subroutine w3fb11(ALAT, ELON, ALAT1, ELON1, DX, ELONV, ALATAN, XI, XJ)
    Converts the coordinates of a location on Earth given in the natural coordinate system of latitude/lo...
    Definition: w3fb11.f:42
    + + + + diff --git a/ver-2.10.0/w3fb12_8f.html b/ver-2.10.0/w3fb12_8f.html new file mode 100644 index 00000000..f3967bb6 --- /dev/null +++ b/ver-2.10.0/w3fb12_8f.html @@ -0,0 +1,231 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb12.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fb12.f File Reference
    +
    +
    + +

    Lambert(i,j) to lat/lon for grib. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fb12 (XI, XJ, ALAT1, ELON1, DX, ELONV, ALATAN, ALAT, ELON, IERR)
     Converts the coordinates of a location on Earth given in a grid coordinate system overlaid on a lambert conformal tangent cone projection true at a given N or S latitude to the natural coordinate system of latitude/longitude w3fb12() is the reverse of w3fb11(). More...
     
    +

    Detailed Description

    +

    Lambert(i,j) to lat/lon for grib.

    +
    Author
    John Stackpole
    +
    Date
    1988-11-25
    + +

    Definition in file w3fb12.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fb12()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fb12 ( XI,
     XJ,
     ALAT1,
     ELON1,
     DX,
     ELONV,
     ALATAN,
     ALAT,
     ELON,
     IERR 
    )
    +
    + +

    Converts the coordinates of a location on Earth given in a grid coordinate system overlaid on a lambert conformal tangent cone projection true at a given N or S latitude to the natural coordinate system of latitude/longitude w3fb12() is the reverse of w3fb11().

    +

    Uses grib specification of the location of the grid

    +

    PROGRAM HISTORY LOG:

      +
    • John Stackpole 1988-11-25
      • +
    • Ralph Jones 1990-04-12 Convert to cft77 fortran.
      • +
    • Ralph Jones 1994-04-28 Add save statement.
      • +
    +
    Parameters
    + + + + + + + + + + + +
    [in]XII coordinate of the point real*4
    [in]XJJ coordinate of the point real*4
    [in]ALAT1Latitude of lower left point of grid (point 1,1) latitude <0 for southern hemisphere; real*4
    [in]ELON1Longitude of lower left point of grid (point 1,1) east longitude used throughout; real*4
    [in]DXMesh length of grid in meters at tangent latitude
    [in]ELONVThe orientation of the grid. i.e., the east longitude value of the vertical meridian which is parallel to the y-axis (or columns of the grid) along which latitude increases as the y-coordinate increases. real*4 this is also the meridian (on the other side of the tangent cone) along which the cut is made to lay the cone flat.
    [in]ALATANThe latitude at which the lambert cone is tangent to (touches or osculates) the spherical Earth. set negative to indicate a southern hemisphere projection; real*4
    [out]ALATLatitude in degrees (negative in southern hemi.)
    [out]ELONEast longitude in degrees, real*4
    [out]IERR
      +
    • .eq. 0 if no problem
      • +
    • .ge. 1 if the requested xi,xj point is in the forbidden zone, i.e. off the lambert map in the open space where the cone is cut.
      • +
    • if ierr.ge.1 then alat=999. and elon=999.
      • +
    +
    +
    +
    +
    Note
    Formulae and notation loosely based on hoke, hayes, and renninger's "map projections and grid systems...", march 1981 afgwc/tn-79/003
    +
    Author
    John Stackpole
    +
    Date
    1988-11-25
    + +

    Definition at line 53 of file w3fb12.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fb12_8f.js b/ver-2.10.0/w3fb12_8f.js new file mode 100644 index 00000000..702c7593 --- /dev/null +++ b/ver-2.10.0/w3fb12_8f.js @@ -0,0 +1,4 @@ +var w3fb12_8f = +[ + [ "w3fb12", "w3fb12_8f.html#ae5e7ad09f49bf57227336e663c180ee2", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fb12_8f_source.html b/ver-2.10.0/w3fb12_8f_source.html new file mode 100644 index 00000000..551698f0 --- /dev/null +++ b/ver-2.10.0/w3fb12_8f_source.html @@ -0,0 +1,268 @@ + + + + + + + +NCEPLIBS-w3emc: w3fb12.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fb12.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Lambert(i,j) to lat/lon for grib.
    +
    3 C> @author John Stackpole @date 1988-11-25
    +
    4 
    +
    5 C> Converts the coordinates of a location on Earth given in a
    +
    6 C> grid coordinate system overlaid on a lambert conformal tangent
    +
    7 C> cone projection true at a given N or S latitude to the
    +
    8 C> natural coordinate system of latitude/longitude
    +
    9 C> w3fb12() is the reverse of w3fb11().
    +
    10 C> Uses grib specification of the location of the grid
    +
    11 C>
    +
    12 C> PROGRAM HISTORY LOG:
    +
    13 C> - John Stackpole 1988-11-25
    +
    14 C> - Ralph Jones 1990-04-12 Convert to cft77 fortran.
    +
    15 C> - Ralph Jones 1994-04-28 Add save statement.
    +
    16 C>
    +
    17 C> @param[in] XI I coordinate of the point real*4
    +
    18 C> @param[in] XJ J coordinate of the point real*4
    +
    19 C> @param[in] ALAT1 Latitude of lower left point of grid (point 1,1)
    +
    20 C> latitude <0 for southern hemisphere; real*4
    +
    21 C> @param[in] ELON1 Longitude of lower left point of grid (point 1,1)
    +
    22 C> east longitude used throughout; real*4
    +
    23 C> @param[in] DX Mesh length of grid in meters at tangent latitude
    +
    24 C> @param[in] ELONV The orientation of the grid. i.e.,
    +
    25 C> the east longitude value of the vertical meridian
    +
    26 C> which is parallel to the y-axis (or columns of
    +
    27 C> the grid) along which latitude increases as
    +
    28 C> the y-coordinate increases. real*4
    +
    29 C> this is also the meridian (on the other side of the
    +
    30 C> tangent cone) along which the cut is made to lay
    +
    31 C> the cone flat.
    +
    32 C> @param[in] ALATAN The latitude at which the lambert cone is tangent to
    +
    33 C> (touches or osculates) the spherical Earth.
    +
    34 C> set negative to indicate a
    +
    35 C> southern hemisphere projection; real*4
    +
    36 C>
    +
    37 C> @param[out] ALAT Latitude in degrees (negative in southern hemi.)
    +
    38 C> @param[out] ELON East longitude in degrees, real*4
    +
    39 C> @param[out] IERR
    +
    40 C> - .eq. 0 if no problem
    +
    41 C> - .ge. 1 if the requested xi,xj point is in the
    +
    42 C> forbidden zone, i.e. off the lambert map
    +
    43 C> in the open space where the cone is cut.
    +
    44 C> - if ierr.ge.1 then alat=999. and elon=999.
    +
    45 C>
    +
    46 C> @note Formulae and notation loosely based on hoke, hayes,
    +
    47 C> and renninger's "map projections and grid systems...", march 1981
    +
    48 C> afgwc/tn-79/003
    +
    49 C>
    +
    50 C> @author John Stackpole @date 1988-11-25
    +
    51  SUBROUTINE w3fb12(XI,XJ,ALAT1,ELON1,DX,ELONV,ALATAN,ALAT,ELON,
    +
    52  & IERR)
    +
    53 C
    +
    54  LOGICAL NEWMAP
    +
    55 C
    +
    56  SAVE
    +
    57 C
    +
    58  DATA rerth /6.3712e+6/, pi/3.14159/, oldrml/99999./
    +
    59 C
    +
    60 C PRELIMINARY VARIABLES AND REDIFINITIONS
    +
    61 C
    +
    62 C H = 1 FOR NORTHERN HEMISPHERE; = -1 FOR SOUTHERN
    +
    63 C
    +
    64  IF (alatan.GT.0) THEN
    +
    65  h = 1.
    +
    66  ELSE
    +
    67  h = -1.
    +
    68  ENDIF
    +
    69 C
    +
    70  piby2 = pi / 2.0
    +
    71  radpd = pi / 180.0
    +
    72  degprd = 1.0 / radpd
    +
    73  rebydx = rerth / dx
    +
    74  alatn1 = alatan * radpd
    +
    75  an = h * sin(alatn1)
    +
    76  cosltn = cos(alatn1)
    +
    77 C
    +
    78 C MAKE SURE THAT INPUT LONGITUDE DOES NOT PASS THROUGH
    +
    79 C THE CUT ZONE (FORBIDDEN TERRITORY) OF THE FLAT MAP
    +
    80 C AS MEASURED FROM THE VERTICAL (REFERENCE) LONGITUDE
    +
    81 C
    +
    82  elon1l = elon1
    +
    83  IF ((elon1-elonv).GT.180.)
    +
    84  & elon1l = elon1 - 360.
    +
    85  IF ((elon1-elonv).LT.(-180.))
    +
    86  & elon1l = elon1 + 360.
    +
    87 C
    +
    88  elonvr = elonv * radpd
    +
    89 C
    +
    90 C RADIUS TO LOWER LEFT HAND (LL) CORNER
    +
    91 C
    +
    92  ala1 = alat1 * radpd
    +
    93  rmll = rebydx * ((cosltn**(1.-an))*(1.+an)**an) *
    +
    94  & (((cos(ala1))/(1.+h*sin(ala1)))**an)/an
    +
    95 C
    +
    96 C USE RMLL TO TEST IF MAP AND GRID UNCHANGED FROM PREVIOUS
    +
    97 C CALL TO THIS CODE. THUS AVOID UNNEEDED RECOMPUTATIONS.
    +
    98 C
    +
    99  IF (rmll.EQ.oldrml) THEN
    +
    100  newmap = .false.
    +
    101  ELSE
    +
    102  newmap = .true.
    +
    103  oldrml = rmll
    +
    104 C
    +
    105 C USE LL POINT INFO TO LOCATE POLE POINT
    +
    106 C
    +
    107  elo1 = elon1l * radpd
    +
    108  arg = an * (elo1-elonvr)
    +
    109  polei = 1. - h * rmll * sin(arg)
    +
    110  polej = 1. + rmll * cos(arg)
    +
    111  ENDIF
    +
    112 C
    +
    113 C RADIUS TO THE I,J POINT (IN GRID UNITS)
    +
    114 C YY REVERSED SO POSITIVE IS DOWN
    +
    115 C
    +
    116  xx = xi - polei
    +
    117  yy = polej - xj
    +
    118  r2 = xx**2 + yy**2
    +
    119 C
    +
    120 C CHECK THAT THE REQUESTED I,J IS NOT IN THE FORBIDDEN ZONE
    +
    121 C YY MUST BE POSITIVE UP FOR THIS TEST
    +
    122 C
    +
    123  theta = pi*(1.-an)
    +
    124  beta = abs(atan2(xx,-yy))
    +
    125  ierr = 0
    +
    126  IF (beta.LE.theta) THEN
    +
    127  ierr = 1
    +
    128  alat = 999.
    +
    129  elon = 999.
    +
    130  IF (.NOT.newmap) RETURN
    +
    131  ENDIF
    +
    132 C
    +
    133 C NOW THE MAGIC FORMULAE
    +
    134 C
    +
    135  IF (r2.EQ.0) THEN
    +
    136  alat = h * 90.0
    +
    137  elon = elonv
    +
    138  ELSE
    +
    139 C
    +
    140 C FIRST THE LONGITUDE
    +
    141 C
    +
    142  elon = elonv + degprd * atan2(h*xx,yy)/an
    +
    143  elon = amod(elon+360., 360.)
    +
    144 C
    +
    145 C NOW THE LATITUDE
    +
    146 C RECALCULATE THE THING ONLY IF MAP IS NEW SINCE LAST TIME
    +
    147 C
    +
    148  IF (newmap) THEN
    +
    149  aninv = 1./an
    +
    150  aninv2 = aninv/2.
    +
    151  thing = ((an/rebydx) ** aninv)/
    +
    152  & ((cosltn**((1.-an)*aninv))*(1.+ an))
    +
    153  ENDIF
    +
    154  alat = h*(piby2 - 2.*atan(thing*(r2**aninv2)))*degprd
    +
    155  ENDIF
    +
    156 C
    +
    157 C FOLLOWING TO ASSURE ERROR VALUES IF FIRST TIME THRU
    +
    158 C IS OFF THE MAP
    +
    159 C
    +
    160  IF (ierr.NE.0) THEN
    +
    161  alat = 999.
    +
    162  elon = 999.
    +
    163  ierr = 2
    +
    164  ENDIF
    +
    165  RETURN
    +
    166  END
    +
    +
    +
    w3fb12
    subroutine w3fb12(XI, XJ, ALAT1, ELON1, DX, ELONV, ALATAN, ALAT, ELON, IERR)
    Converts the coordinates of a location on Earth given in a grid coordinate system overlaid on a lambe...
    Definition: w3fb12.f:53
    + + + + diff --git a/ver-2.10.0/w3fc02_8f.html b/ver-2.10.0/w3fc02_8f.html new file mode 100644 index 00000000..a787ab38 --- /dev/null +++ b/ver-2.10.0/w3fc02_8f.html @@ -0,0 +1,201 @@ + + + + + + + +NCEPLIBS-w3emc: w3fc02.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fc02.f File Reference
    +
    +
    + +

    Grid U,V wind comps. to dir. and speed. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fc02 (FFID, FFJD, FGU, FGV, DIR, SPD)
     Given the grid-oriented wind components on a northern hemisphere polar stereographic grid point, compute the direction and speed of the wind at that point. More...
     
    +

    Detailed Description

    +

    Grid U,V wind comps. to dir. and speed.

    +
    Author
    John Stackpole
    +
    Date
    1981-12-30
    + +

    Definition in file w3fc02.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fc02()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fc02 ( FFID,
     FFJD,
     FGU,
     FGV,
     DIR,
     SPD 
    )
    +
    + +

    Given the grid-oriented wind components on a northern hemisphere polar stereographic grid point, compute the direction and speed of the wind at that point.

    +

    Input winds at the north pole point are assumed to have their components follow the wmo standards for reporting winds at the north pole. (see office note 241 for wmo definition). Output direction will follow wmo convention.

    +

    Program history log:

      +
    • John Stackpole 1981-12-30
      • +
    • Ralph Jones 1989-01-20 Convert to microsoft fortran 4.10.
      • +
    • Ralph Jones 1990-06-11 Convert to sun fortran 1.3.
      • +
    • Ralph Jones 1991-03-30 Convert to silicongraphics fortran.
      • +
    • Ralph Jones 1993-03-29 Add save statement.
      • +
    • Ralph Jones 1995-08-09 Compile on cray.
      • +
    +
    Parameters
    + + + + + + + +
    [in]FFIDREAL*4 I(north pole) - i(point).
    [in]FFJDREAL*4 J(north pole) - j(point).
    [in]FGUREAL*4 Grid-oriented u-component.
    [in]FGVREAL*4 Grid-oriented v-component.
    [out]DIRREAL*4 Wind direction, degrees.
    [out]SPDREAL*4 Wind speed.
    +
    +
    +
    Note
    This job will not vectorize on a cray.
    +
    Author
    John Stackpole
    +
    Date
    1981-12-30
    + +

    Definition at line 33 of file w3fc02.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fc02_8f.js b/ver-2.10.0/w3fc02_8f.js new file mode 100644 index 00000000..e6c50c6e --- /dev/null +++ b/ver-2.10.0/w3fc02_8f.js @@ -0,0 +1,4 @@ +var w3fc02_8f = +[ + [ "w3fc02", "w3fc02_8f.html#a2572657557b50b4f9580f1cf204d7aaf", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fc02_8f_source.html b/ver-2.10.0/w3fc02_8f_source.html new file mode 100644 index 00000000..e75307da --- /dev/null +++ b/ver-2.10.0/w3fc02_8f_source.html @@ -0,0 +1,162 @@ + + + + + + + +NCEPLIBS-w3emc: w3fc02.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fc02.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Grid U,V wind comps. to dir. and speed.
    +
    3 C> @author John Stackpole @date 1981-12-30
    +
    4 
    +
    5 C> Given the grid-oriented wind components on a northern
    +
    6 C> hemisphere polar stereographic grid point, compute the direction
    +
    7 C> and speed of the wind at that point. Input winds at the north
    +
    8 C> pole point are assumed to have their components follow the wmo
    +
    9 C> standards for reporting winds at the north pole.
    +
    10 C> (see office note 241 for wmo definition). Output direction
    +
    11 C> will follow wmo convention.
    +
    12 C>
    +
    13 C> Program history log:
    +
    14 C> - John Stackpole 1981-12-30
    +
    15 C> - Ralph Jones 1989-01-20 Convert to microsoft fortran 4.10.
    +
    16 C> - Ralph Jones 1990-06-11 Convert to sun fortran 1.3.
    +
    17 C> - Ralph Jones 1991-03-30 Convert to silicongraphics fortran.
    +
    18 C> - Ralph Jones 1993-03-29 Add save statement.
    +
    19 C> - Ralph Jones 1995-08-09 Compile on cray.
    +
    20 C>
    +
    21 C> @param[in] FFID REAL*4 I(north pole) - i(point).
    +
    22 C> @param[in] FFJD REAL*4 J(north pole) - j(point).
    +
    23 C> @param[in] FGU REAL*4 Grid-oriented u-component.
    +
    24 C> @param[in] FGV REAL*4 Grid-oriented v-component.
    +
    25 C>
    +
    26 C> @param[out] DIR REAL*4 Wind direction, degrees.
    +
    27 C> @param[out] SPD REAL*4 Wind speed.
    +
    28 C>
    +
    29 C> @note This job will not vectorize on a cray.
    +
    30 C>
    +
    31 C> @author John Stackpole @date 1981-12-30
    +
    32  SUBROUTINE w3fc02(FFID,FFJD,FGU,FGV,DIR,SPD)
    +
    33 C
    +
    34  SAVE
    +
    35 C
    +
    36  spd = sqrt(fgu * fgu + fgv * fgv)
    +
    37  IF (spd.NE.0.) GO TO 1000
    +
    38  fgu = 0.
    +
    39  fgv = 0.
    +
    40  GO TO 3000
    +
    41  1000 CONTINUE
    +
    42  dfp = sqrt(ffid * ffid + ffjd * ffjd)
    +
    43  IF (dfp.NE.0.) GO TO 2000
    +
    44  xlam = acos(fgu / spd)
    +
    45  xlam = xlam * 57.29578
    +
    46  IF (fgv.LT.0.) dir = 170. + xlam
    +
    47  IF ((fgv.GT.0.).AND.(xlam.LT.170.)) dir = 170. - xlam
    +
    48  IF ((fgv.GT.0.).AND.(xlam.GE.170.)) dir = 530. - xlam
    +
    49  IF ((abs(fgv).LE.0.001).AND.(fgu.GT.0.)) dir = 170.
    +
    50  IF ((abs(fgv).LE.0.001).AND.(fgu.LT.0.)) dir = 350.
    +
    51  GO TO 3000
    +
    52  2000 CONTINUE
    +
    53  cal = ffjd / dfp
    +
    54  sal = ffid / dfp
    +
    55  u = fgu * cal - fgv * sal
    +
    56  v = fgu * sal + fgv * cal
    +
    57  dir = 57.29578 * atan2(u,v) + 180.
    +
    58  3000 CONTINUE
    +
    59  RETURN
    +
    60  END
    +
    +
    +
    w3fc02
    subroutine w3fc02(FFID, FFJD, FGU, FGV, DIR, SPD)
    Given the grid-oriented wind components on a northern hemisphere polar stereographic grid point,...
    Definition: w3fc02.f:33
    + + + + diff --git a/ver-2.10.0/w3fc05_8f.html b/ver-2.10.0/w3fc05_8f.html new file mode 100644 index 00000000..fbe73ee2 --- /dev/null +++ b/ver-2.10.0/w3fc05_8f.html @@ -0,0 +1,185 @@ + + + + + + + +NCEPLIBS-w3emc: w3fc05.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fc05.f File Reference
    +
    +
    + +

    Earth U,V wind components to dir and spd. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fc05 (U, V, DIR, SPD)
     Given the true (Earth oriented) wind components compute the wind direction and speed. More...
     
    +

    Detailed Description

    +

    Earth U,V wind components to dir and spd.

    +
    Author
    John Stackpole
    +
    Date
    1981-12-30
    + +

    Definition in file w3fc05.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fc05()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fc05 (real U,
    real V,
    real DIR,
    real SPD 
    )
    +
    + +

    Given the true (Earth oriented) wind components compute the wind direction and speed.

    +

    Input winds at the pole are assumed to follow the WMO conventions, with the output direction computed in accordance with WMO standards for reporting winds at the pole. (see office note 241 for WMO definition.)

    +

    Program history log:

      +
    • John Stackpole 1981-12-30
      • +
    • P. Chase 1988-10-19 Allow output values to overlay input
      • +
    • Ralph Jones 1991-03-05 Changes for cray cft77 fortran
      • +
    • Dennis Keyser 1992-10-21 Added 1.e-3 to direction to allow truncation to nearest whole degree to be correct (keeps agreement between cray & nas versions)
      • +
    +
    Parameters
    + + + + + +
    [in]UREAL Earth-oriented U-component.
    [in]VREAL Earth-oriented V-component.
    [out]DIRREAL Wind direction, degrees. Values will be from 0 to 360 inclusive.
    [out]SPDREAL Wind speed in same units as input.
    +
    +
    +
    Note
    If speed is less than 1e-10 then direction will be set to zero.
    +
    Author
    John Stackpole
    +
    Date
    1981-12-30
    + +

    Definition at line 29 of file w3fc05.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fc05_8f.js b/ver-2.10.0/w3fc05_8f.js new file mode 100644 index 00000000..09bb400a --- /dev/null +++ b/ver-2.10.0/w3fc05_8f.js @@ -0,0 +1,4 @@ +var w3fc05_8f = +[ + [ "w3fc05", "w3fc05_8f.html#ae77a21f468d05a34fa3a201c89b30530", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fc05_8f_source.html b/ver-2.10.0/w3fc05_8f_source.html new file mode 100644 index 00000000..777a1676 --- /dev/null +++ b/ver-2.10.0/w3fc05_8f_source.html @@ -0,0 +1,150 @@ + + + + + + + +NCEPLIBS-w3emc: w3fc05.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fc05.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Earth U,V wind components to dir and spd.
    +
    3 C> @author John Stackpole @date 1981-12-30
    +
    4 
    +
    5 C> Given the true (Earth oriented) wind components
    +
    6 C> compute the wind direction and speed.
    +
    7 C> Input winds at the pole are assumed to follow the WMO
    +
    8 C> conventions, with the output direction computed in accordance
    +
    9 C> with WMO standards for reporting winds at the pole.
    +
    10 C> (see office note 241 for WMO definition.)
    +
    11 C>
    +
    12 C> Program history log:
    +
    13 C> - John Stackpole 1981-12-30
    +
    14 C> - P. Chase 1988-10-19 Allow output values to overlay input
    +
    15 C> - Ralph Jones 1991-03-05 Changes for cray cft77 fortran
    +
    16 C> - Dennis Keyser 1992-10-21 Added 1.e-3 to direction to allow truncation
    +
    17 C> to nearest whole degree to be correct (keeps agreement between cray & nas versions)
    +
    18 C>
    +
    19 C> @param[in] U REAL Earth-oriented U-component.
    +
    20 C> @param[in] V REAL Earth-oriented V-component.
    +
    21 C> @param[out] DIR REAL Wind direction, degrees. Values will
    +
    22 C> be from 0 to 360 inclusive.
    +
    23 C> @param[out] SPD REAL Wind speed in same units as input.
    +
    24 C>
    +
    25 C> @note If speed is less than 1e-10 then direction will be set to zero.
    +
    26 C>
    +
    27 C> @author John Stackpole @date 1981-12-30
    +
    28  SUBROUTINE w3fc05(U, V, DIR, SPD) 11700000
    +
    29 C
    +
    30 C VARIABLES.....
    +
    31 C
    +
    32  REAL U, V, DIR, SPD, XSPD
    +
    33 C
    +
    34 C CONSTANTS.....
    +
    35 C
    +
    36  DATA spdtst/1.0e-10/
    +
    37  DATA rtod /57.2957795/
    +
    38  DATA dchalf/180.0/
    +
    39 C
    +
    40  xspd = sqrt(u * u + v * v)
    +
    41  IF (xspd .LT. spdtst) THEN
    +
    42  dir = 0.0
    +
    43  ELSE
    +
    44  dir = atan2(u,v) * rtod + dchalf + 1.e-3
    +
    45  ENDIF
    +
    46  spd = xspd
    +
    47  RETURN
    +
    48  END
    +
    +
    +
    w3fc05
    subroutine w3fc05(U, V, DIR, SPD)
    Given the true (Earth oriented) wind components compute the wind direction and speed.
    Definition: w3fc05.f:29
    + + + + diff --git a/ver-2.10.0/w3fc06_8f.html b/ver-2.10.0/w3fc06_8f.html new file mode 100644 index 00000000..ebf7e862 --- /dev/null +++ b/ver-2.10.0/w3fc06_8f.html @@ -0,0 +1,183 @@ + + + + + + + +NCEPLIBS-w3emc: w3fc06.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fc06.f File Reference
    +
    +
    + +

    Wind dir and spd to Earth U,V components. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fc06 (DIR, SPD, U, V)
     Given the wind direction and speed, compute Earth-oriented (true) wind components. More...
     
    +

    Detailed Description

    +

    Wind dir and spd to Earth U,V components.

    +
    Author
    John Stackpole
    +
    Date
    1981-12-30
    + +

    Definition in file w3fc06.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fc06()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fc06 ( DIR,
     SPD,
     U,
     V 
    )
    +
    + +

    Given the wind direction and speed, compute Earth-oriented (true) wind components.

    +

    Input direction at the pole point must be consistent with WMO conventions, and output components will follow those conventions. (See office note 241 for WMO definition.)

    +

    Program history log:

      +
    • John Stackpole 1981-12-30
      • +
    • Ralph Jones 1991-03-06 Change to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + +
    [in]DIRREAL*4 Wind direction, degrees
    [in]SPDREAL*4 Wind speed, any units
    [out]UREAL*4 Earth-oriented U-component.
    [out]VREAL*4 Earth-oriented V-component.
    +
    +
    +
    Note
    This code will not vectorize on cray, you could put the four lines in your code with a couple of do loops.
    +
    Author
    John Stackpole
    +
    Date
    1981-12-30
    + +

    Definition at line 27 of file w3fc06.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fc06_8f.js b/ver-2.10.0/w3fc06_8f.js new file mode 100644 index 00000000..b0b8fe53 --- /dev/null +++ b/ver-2.10.0/w3fc06_8f.js @@ -0,0 +1,4 @@ +var w3fc06_8f = +[ + [ "w3fc06", "w3fc06_8f.html#a586eff5e859341d86f5ab00dbcca2169", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fc06_8f_source.html b/ver-2.10.0/w3fc06_8f_source.html new file mode 100644 index 00000000..9562155b --- /dev/null +++ b/ver-2.10.0/w3fc06_8f_source.html @@ -0,0 +1,136 @@ + + + + + + + +NCEPLIBS-w3emc: w3fc06.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fc06.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Wind dir and spd to Earth U,V components.
    +
    3 C> @author John Stackpole @date 1981-12-30
    +
    4 
    +
    5 C> Given the wind direction and speed,
    +
    6 C> compute Earth-oriented (true) wind components.
    +
    7 C> Input direction at the pole point
    +
    8 C> must be consistent with WMO conventions, and output components
    +
    9 C> will follow those conventions.
    +
    10 C> (See office note 241 for WMO definition.)
    +
    11 C>
    +
    12 C> Program history log:
    +
    13 C> - John Stackpole 1981-12-30
    +
    14 C> - Ralph Jones 1991-03-06 Change to cray cft77 fortran.
    +
    15 C>
    +
    16 C> @param[in] DIR REAL*4 Wind direction, degrees
    +
    17 C> @param[in] SPD REAL*4 Wind speed, any units
    +
    18 C> @param[out] U REAL*4 Earth-oriented U-component.
    +
    19 C> @param[out] V REAL*4 Earth-oriented V-component.
    +
    20 C>
    +
    21 C> @note This code will not vectorize on cray, you could
    +
    22 C> put the four lines in your code with a couple of
    +
    23 C> do loops.
    +
    24 C>
    +
    25 C> @author John Stackpole @date 1981-12-30
    +
    26  SUBROUTINE w3fc06(DIR,SPD,U,V)
    +
    27 C
    +
    28  xspd = -spd
    +
    29  dirl = 0.0174533 * dir
    +
    30  u = xspd * sin(dirl)
    +
    31  v = xspd * cos(dirl)
    +
    32 C
    +
    33  RETURN
    +
    34  END
    +
    +
    +
    w3fc06
    subroutine w3fc06(DIR, SPD, U, V)
    Given the wind direction and speed, compute Earth-oriented (true) wind components.
    Definition: w3fc06.f:27
    + + + + diff --git a/ver-2.10.0/w3fc07_8f.html b/ver-2.10.0/w3fc07_8f.html new file mode 100644 index 00000000..4b002974 --- /dev/null +++ b/ver-2.10.0/w3fc07_8f.html @@ -0,0 +1,198 @@ + + + + + + + +NCEPLIBS-w3emc: w3fc07.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fc07.f File Reference
    +
    +
    + +

    Grid U-V to Earth U-V in north hem. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fc07 (FFID, FFJD, FGU, FGV, FU, FV)
     Given the grid-oriented wind components on a northern hemisphere polar stereographic grid point, compute the Earth- oriented wind components at that point. More...
     
    +

    Detailed Description

    +

    Grid U-V to Earth U-V in north hem.

    +
    Author
    John Stackpole
    +
    Date
    1981-12-30
    + +

    Definition in file w3fc07.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fc07()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fc07 ( FFID,
     FFJD,
     FGU,
     FGV,
     FU,
     FV 
    )
    +
    + +

    Given the grid-oriented wind components on a northern hemisphere polar stereographic grid point, compute the Earth- oriented wind components at that point.

    +

    If the input winds are at the north pole, the output components will be made consistent with the WMO standards for reporting winds at the north pole. (see office note 241 for WMO definition.)

    +

    Program history log:

      +
    • John Stackpole 1981-12-30
      • +
    • P. Chase 1988-10-13 Allow input and output to be the same
      • +
    • Ralph Jones 1991-03-06 Change to cray cft77 fortran
      • +
    +
    Parameters
    + + + + + + + +
    [in]FFIDREAL I-displacement from point to north pole
    [in]FFJDREAL J-displacement from point to north pole
    [in]FGVREAL Grid-oriented V-component
    [in]FGUREAL Grid-oriented U-component
    [out]FUREAL Earth-oriented U-component, positive from west may reference the same location as FGU.
    [out]FVREAL Earth-oriented V-component, positive from south may reference the same location as FGV.
    +
    +
    +
    Note
    Calculate FFID and FFJD as follows... FFID = real(ip - i) FFJD = real(jp - j) where (ip,jp) is the grid coordinates of the north pole and (i,j) is the grid coordinates of the point where FGU and FGV occur. See w3fc11 for a southern hemisphere companion subroutine.
    +
    Author
    John Stackpole
    +
    Date
    1981-12-30
    + +

    Definition at line 35 of file w3fc07.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fc07_8f.js b/ver-2.10.0/w3fc07_8f.js new file mode 100644 index 00000000..00a51eae --- /dev/null +++ b/ver-2.10.0/w3fc07_8f.js @@ -0,0 +1,4 @@ +var w3fc07_8f = +[ + [ "w3fc07", "w3fc07_8f.html#a84dac72c47bb275c7c251c620052b54d", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fc07_8f_source.html b/ver-2.10.0/w3fc07_8f_source.html new file mode 100644 index 00000000..38d7eefd --- /dev/null +++ b/ver-2.10.0/w3fc07_8f_source.html @@ -0,0 +1,156 @@ + + + + + + + +NCEPLIBS-w3emc: w3fc07.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fc07.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Grid U-V to Earth U-V in north hem.
    +
    3 C> @author John Stackpole @date 1981-12-30
    +
    4 
    +
    5 C> Given the grid-oriented wind components on a northern
    +
    6 C> hemisphere polar stereographic grid point, compute the Earth-
    +
    7 C> oriented wind components at that point. If the input winds
    +
    8 C> are at the north pole, the output components will be made
    +
    9 C> consistent with the WMO standards for reporting winds at the
    +
    10 C> north pole. (see office note 241 for WMO definition.)
    +
    11 C>
    +
    12 C> Program history log:
    +
    13 C> - John Stackpole 1981-12-30
    +
    14 C> - P. Chase 1988-10-13 Allow input and output to be the same
    +
    15 C> - Ralph Jones 1991-03-06 Change to cray cft77 fortran
    +
    16 C>
    +
    17 C> @param[in] FFID REAL I-displacement from point to north pole
    +
    18 C> @param[in] FFJD REAL J-displacement from point to north pole
    +
    19 C> @param[in] FGV REAL Grid-oriented V-component
    +
    20 C> @param[in] FGU REAL Grid-oriented U-component
    +
    21 C> @param[out] FU REAL Earth-oriented U-component, positive from west
    +
    22 C> may reference the same location as FGU.
    +
    23 C> @param[out] FV REAL Earth-oriented V-component, positive from south
    +
    24 C> may reference the same location as FGV.
    +
    25 C>
    +
    26 C> @note Calculate FFID and FFJD as follows...
    +
    27 C> FFID = real(ip - i)
    +
    28 C> FFJD = real(jp - j)
    +
    29 C> where (ip,jp) is the grid coordinates of the north pole and
    +
    30 C> (i,j) is the grid coordinates of the point where FGU and FGV
    +
    31 C> occur. See w3fc11 for a southern hemisphere companion subroutine.
    +
    32 C>
    +
    33 C> @author John Stackpole @date 1981-12-30
    +
    34  SUBROUTINE w3fc07(FFID, FFJD, FGU, FGV, FU, FV)
    +
    35 C
    +
    36  SAVE
    +
    37 C
    +
    38  DATA cos80 / 0.1736482 /
    +
    39  DATA sin80 / 0.9848078 /
    +
    40 
    +
    41 C COS80 AND SIN80 ARE FOR WIND AT POLE
    +
    42 C (USED FOR CO-ORDINATE ROTATION TO EARTH ORIENTATION)
    +
    43 
    +
    44  dfp = sqrt(ffid * ffid + ffjd * ffjd)
    +
    45  IF (dfp .EQ. 0.0) THEN
    +
    46  xfu = -(fgu * cos80 + fgv * sin80)
    +
    47  fv = -(fgv * cos80 - fgu * sin80)
    +
    48  ELSE
    +
    49  xfu = (fgu * ffjd - fgv * ffid) / dfp
    +
    50  fv = (fgu * ffid + fgv * ffjd) / dfp
    +
    51  ENDIF
    +
    52  fu = xfu
    +
    53  RETURN
    +
    54  END
    +
    +
    +
    w3fc07
    subroutine w3fc07(FFID, FFJD, FGU, FGV, FU, FV)
    Given the grid-oriented wind components on a northern hemisphere polar stereographic grid point,...
    Definition: w3fc07.f:35
    + + + + diff --git a/ver-2.10.0/w3fc08_8f.html b/ver-2.10.0/w3fc08_8f.html new file mode 100644 index 00000000..7fb3923f --- /dev/null +++ b/ver-2.10.0/w3fc08_8f.html @@ -0,0 +1,198 @@ + + + + + + + +NCEPLIBS-w3emc: w3fc08.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fc08.f File Reference
    +
    +
    + +

    U-V Comps from Earth to north hem grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fc08 (FFID, FFJD, FU, FV, FGU, FGV)
     Given the Earth-oriented wind components on a northern hemisphere polar stereographic grid point, compute the grid- oriented components at that point. More...
     
    +

    Detailed Description

    +

    U-V Comps from Earth to north hem grid.

    +
    Author
    John Stackpole
    +
    Date
    1981-12-30
    + +

    Definition in file w3fc08.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fc08()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fc08 ( FFID,
     FFJD,
     FU,
     FV,
     FGU,
     FGV 
    )
    +
    + +

    Given the Earth-oriented wind components on a northern hemisphere polar stereographic grid point, compute the grid- oriented components at that point.

    +

    Input wind components at the north pole point are assumed to conform to the 'WMO' standards for reporting winds at the north pole, with the output components computed relative to the X-Y axes on the grid. (see office note 241 for WMO definition.)

    +

    Program history log:

      +
    • John Stackpole 1981-12-30
      • +
    • P. Chase 1988-10-18 Let output variables overlay input.
      • +
    • Ralph Jones 1991-03-06 Change to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + + + +
    [in]FFIDREAL I-displacement from point to north pole in grid units.
    [in]FFJDREAL J-displacement from point to north pole in grid units.
    [in]FUREAL Earth-oriented u-component, positive from west.
    [in]FVREAL Earth-oriented v-component, positive from east.
    [out]FGUREAL Grid-oriented u-component. May reference same location as FU.
    [out]FGVREAL Grid-oriented v-component. May reference same location as FV.
    +
    +
    +
    Note
    FFID and FFJD may be calculated as followS..... FFID = real(ip - i) FFJD = real(jp - j) where (ip, jp) are the grid coordinates of the north pole and (i,j) are the grid coordinates of the point.
    +
    Author
    John Stackpole
    +
    Date
    1981-12-30
    + +

    Definition at line 37 of file w3fc08.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fc08_8f.js b/ver-2.10.0/w3fc08_8f.js new file mode 100644 index 00000000..46d4f162 --- /dev/null +++ b/ver-2.10.0/w3fc08_8f.js @@ -0,0 +1,4 @@ +var w3fc08_8f = +[ + [ "w3fc08", "w3fc08_8f.html#ac768b413af58dd51c57c6bf6d2d48a84", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fc08_8f_source.html b/ver-2.10.0/w3fc08_8f_source.html new file mode 100644 index 00000000..23184ec6 --- /dev/null +++ b/ver-2.10.0/w3fc08_8f_source.html @@ -0,0 +1,158 @@ + + + + + + + +NCEPLIBS-w3emc: w3fc08.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fc08.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief U-V Comps from Earth to north hem grid.
    +
    3 C> @author John Stackpole @date 1981-12-30
    +
    4 
    +
    5 C> Given the Earth-oriented wind components on a northern
    +
    6 C> hemisphere polar stereographic grid point, compute the grid-
    +
    7 C> oriented components at that point. Input wind components at the
    +
    8 C> north pole point are assumed to conform to
    +
    9 C> the 'WMO' standards for reporting winds at the north pole, with
    +
    10 C> the output components computed relative to the X-Y axes on the
    +
    11 C> grid. (see office note 241 for WMO definition.)
    +
    12 C>
    +
    13 C> Program history log:
    +
    14 C> - John Stackpole 1981-12-30
    +
    15 C> - P. Chase 1988-10-18 Let output variables overlay input.
    +
    16 C> - Ralph Jones 1991-03-06 Change to cray cft77 fortran.
    +
    17 C>
    +
    18 C> @param[in] FFID REAL I-displacement from point to north pole in
    +
    19 C> grid units.
    +
    20 C> @param[in] FFJD REAL J-displacement from point to north pole in
    +
    21 C> grid units.
    +
    22 C> @param[in] FU REAL Earth-oriented u-component, positive from west.
    +
    23 C> @param[in] FV REAL Earth-oriented v-component, positive from east.
    +
    24 C> @param[out] FGU REAL Grid-oriented u-component. May reference
    +
    25 C> same location as FU.
    +
    26 C> @param[out] FGV REAL Grid-oriented v-component. May reference
    +
    27 C> same location as FV.
    +
    28 C>
    +
    29 C> @note FFID and FFJD may be calculated as followS.....
    +
    30 C> FFID = real(ip - i)
    +
    31 C> FFJD = real(jp - j)
    +
    32 C> where (ip, jp) are the grid coordinates of the north pole and
    +
    33 C> (i,j) are the grid coordinates of the point.
    +
    34 C>
    +
    35 C> @author John Stackpole @date 1981-12-30
    +
    36  SUBROUTINE w3fc08(FFID, FFJD, FU, FV, FGU, FGV)
    +
    37 C
    +
    38  SAVE
    +
    39 C
    +
    40  DATA cos280/ 0.1736482 /
    +
    41  DATA sin280/ -0.9848078 /
    +
    42 C
    +
    43 C COS280 AND SIN280 ARE FOR WIND AT POLE
    +
    44 C (USED FOR CO-ORDINATE ROTATION TO GRID ORIENTATION)
    +
    45 C
    +
    46  dfp = sqrt(ffid * ffid + ffjd * ffjd)
    +
    47  IF (dfp .EQ. 0.) THEN
    +
    48  xfgu = -(fu * cos280 + fv * sin280)
    +
    49  fgv = -(fv * cos280 - fu * sin280)
    +
    50  ELSE
    +
    51  xfgu = (fu * ffjd + fv * ffid) / dfp
    +
    52  fgv = (fv * ffjd - fu * ffid) / dfp
    +
    53  ENDIF
    +
    54  fgu = xfgu
    +
    55  RETURN
    +
    56  END
    +
    +
    +
    w3fc08
    subroutine w3fc08(FFID, FFJD, FU, FV, FGU, FGV)
    Given the Earth-oriented wind components on a northern hemisphere polar stereographic grid point,...
    Definition: w3fc08.f:37
    + + + + diff --git a/ver-2.10.0/w3fi01_8f.html b/ver-2.10.0/w3fi01_8f.html new file mode 100644 index 00000000..c60f97b4 --- /dev/null +++ b/ver-2.10.0/w3fi01_8f.html @@ -0,0 +1,153 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi01.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi01.f File Reference
    +
    +
    + +

    Determines machine word length in bytes. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi01 (LW)
     Determines the number of bytes in a full word for the particular machine (IBM or cray). More...
     
    +

    Detailed Description

    +

    Determines machine word length in bytes.

    +
    Author
    R. Kistler
    +
    Date
    1992-01-10
    + +

    Definition in file w3fi01.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi01()

    + +
    +
    + + + + + + + + +
    subroutine w3fi01 (integer LW)
    +
    + +

    Determines the number of bytes in a full word for the particular machine (IBM or cray).

    +

    Program history log:

      +
    • R. Kistler 1992-01-10
      • +
    • Dennis Keyser 1992-05-22 Docblocked/commented.
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints.
      • +
    • Stephen Gilbert 2001-06-07 Uses f90 standard routine bit_size to find integer word length
      • +
    +
    Note
    Subprogram can be called from a multiprocessing environment.
    +
    Author
    R. Kistler
    +
    Date
    1992-01-10
    + +

    Definition at line 19 of file w3fi01.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi01_8f.js b/ver-2.10.0/w3fi01_8f.js new file mode 100644 index 00000000..d85c57cf --- /dev/null +++ b/ver-2.10.0/w3fi01_8f.js @@ -0,0 +1,4 @@ +var w3fi01_8f = +[ + [ "w3fi01", "w3fi01_8f.html#a10ac20498f7eca8e2281cad1218bede4", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi01_8f_source.html b/ver-2.10.0/w3fi01_8f_source.html new file mode 100644 index 00000000..7a101ec3 --- /dev/null +++ b/ver-2.10.0/w3fi01_8f_source.html @@ -0,0 +1,126 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi01.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi01.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Determines machine word length in bytes.
    +
    3 C> @author R. Kistler @date 1992-01-10
    +
    4 
    +
    5 C> Determines the number of bytes in a full word for the
    +
    6 C> particular machine (IBM or cray).
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - R. Kistler 1992-01-10
    +
    10 C> - Dennis Keyser 1992-05-22 Docblocked/commented.
    +
    11 C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    12 C> - Stephen Gilbert 2001-06-07 Uses f90 standard routine bit_size to
    +
    13 C> find integer word length
    +
    14 C>
    +
    15 C> @note Subprogram can be called from a multiprocessing environment.
    +
    16 C>
    +
    17 C> @author R. Kistler @date 1992-01-10
    +
    18  SUBROUTINE w3fi01(LW)
    +
    19 C
    +
    20  INTEGER LW
    +
    21  lw=bit_size(lw)
    +
    22  lw=lw/8
    +
    23  RETURN
    +
    24  END
    +
    +
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    + + + + diff --git a/ver-2.10.0/w3fi02_8f.html b/ver-2.10.0/w3fi02_8f.html new file mode 100644 index 00000000..2e76ab15 --- /dev/null +++ b/ver-2.10.0/w3fi02_8f.html @@ -0,0 +1,175 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi02.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi02.f File Reference
    +
    +
    + +

    Transfers array from 16 to 64 bit words. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi02 (IN, IDEST, NUM)
     Transfers an array of numbers from 16 bit (ibm integer*2) IBM half-words to default integers. More...
     
    +

    Detailed Description

    +

    Transfers array from 16 to 64 bit words.

    +
    Author
    Dennis Keyser
    +
    Date
    1992-06-29
    + +

    Definition in file w3fi02.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi02()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi02 (integer(2), dimension(*) IN,
    integer, dimension(*) IDEST,
     NUM 
    )
    +
    + +

    Transfers an array of numbers from 16 bit (ibm integer*2) IBM half-words to default integers.

    +

    Program history log:

      +
    • Dennis Keyser 1992-06-29
      • +
    • Stephen Gilbert 1998-11-17 Removed Cray references.
      • +
    +
    Parameters
    + + + + +
    [in]INStarting address for array of 16 bit IBM half-words.
    [in]NUMNumber of numbers in 'IN' to transfer.
    [out]IDESTStarting address for array of output integers.
    +
    +
    +
    Note
    This is the inverse of library routine w3fi03.
    +
    Author
    Dennis Keyser
    +
    Date
    1992-06-29
    + +

    Definition at line 20 of file w3fi02.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi02_8f.js b/ver-2.10.0/w3fi02_8f.js new file mode 100644 index 00000000..abebf9de --- /dev/null +++ b/ver-2.10.0/w3fi02_8f.js @@ -0,0 +1,4 @@ +var w3fi02_8f = +[ + [ "w3fi02", "w3fi02_8f.html#a217b3130b7e509776b74fde620e5b715", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi02_8f_source.html b/ver-2.10.0/w3fi02_8f_source.html new file mode 100644 index 00000000..8df6babb --- /dev/null +++ b/ver-2.10.0/w3fi02_8f_source.html @@ -0,0 +1,132 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi02.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi02.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Transfers array from 16 to 64 bit words.
    +
    3 C> @author Dennis Keyser @date 1992-06-29
    +
    4 
    +
    5 C> Transfers an array of numbers from 16 bit (ibm integer*2)
    +
    6 C> IBM half-words to default integers.
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - Dennis Keyser 1992-06-29
    +
    10 C> - Stephen Gilbert 1998-11-17 Removed Cray references.
    +
    11 C>
    +
    12 C> @param[in] IN Starting address for array of 16 bit IBM half-words.
    +
    13 C> @param[in] NUM Number of numbers in 'IN' to transfer.
    +
    14 C> @param[out] IDEST Starting address for array of output integers.
    +
    15 C>
    +
    16 C> @note This is the inverse of library routine w3fi03.
    +
    17 C>
    +
    18 C> @author Dennis Keyser @date 1992-06-29
    +
    19  SUBROUTINE w3fi02(IN,IDEST,NUM)
    +
    20 C
    +
    21  INTEGER(2) IN(*)
    +
    22  INTEGER IDEST(*)
    +
    23 C
    +
    24  SAVE
    +
    25 C
    +
    26 C CALL USICTC(IN,1,IDEST,NUM,2)
    +
    27  idest(1:num)=in(1:num)
    +
    28 C
    +
    29  RETURN
    +
    30  END
    +
    +
    +
    w3fi02
    subroutine w3fi02(IN, IDEST, NUM)
    Transfers an array of numbers from 16 bit (ibm integer*2) IBM half-words to default integers.
    Definition: w3fi02.f:20
    + + + + diff --git a/ver-2.10.0/w3fi03_8f.html b/ver-2.10.0/w3fi03_8f.html new file mode 100644 index 00000000..c39876bd --- /dev/null +++ b/ver-2.10.0/w3fi03_8f.html @@ -0,0 +1,186 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi03.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi03.f File Reference
    +
    +
    + +

    Transfers default integers to 16 bit ints. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi03 (IN, IDEST, NUM, IER)
     Transfers an array of numbers from default integer words to 16 bit (IBM integer*2) IBM half-words. More...
     
    +

    Detailed Description

    +

    Transfers default integers to 16 bit ints.

    +
    Author
    Dennis Keyser
    +
    Date
    1992-06-29
    + +

    Definition in file w3fi03.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi03()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi03 (integer, dimension(*) IN,
    integer(2), dimension(*) IDEST,
     NUM,
     IER 
    )
    +
    + +

    Transfers an array of numbers from default integer words to 16 bit (IBM integer*2) IBM half-words.

    +

    Program history log:

      +
    • Dennis Keyser 1992-06-29
      • +
    • Stephen Gilbert 1998-11-17 Removed Cray references.
      • +
    +
    Parameters
    + + + + + +
    [in]INStarting address for array of default integers
    [in]NUMNumber of numbers in 'IN' to transfer.
    [out]IDESTStarting address for array of 16 bit IBM half-words
    [out]IERError return code as follows: IER = 0 - Transfer successful, all numbers
      +
    • Transferred without overflow. IER = 1 - The transfer of one or more numbers
      • +
    • Resulted in an overflow.
      • +
    +
    +
    +
    +
    Note
    This is the inverse of library routine w3fi02().
    +
    Author
    Dennis Keyser
    +
    Date
    1992-06-29
    + +

    Definition at line 25 of file w3fi03.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi03_8f.js b/ver-2.10.0/w3fi03_8f.js new file mode 100644 index 00000000..8b9795b2 --- /dev/null +++ b/ver-2.10.0/w3fi03_8f.js @@ -0,0 +1,4 @@ +var w3fi03_8f = +[ + [ "w3fi03", "w3fi03_8f.html#a3cfc13ff3a45dea4c4f6f7c1832df3d3", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi03_8f_source.html b/ver-2.10.0/w3fi03_8f_source.html new file mode 100644 index 00000000..5c9d1086 --- /dev/null +++ b/ver-2.10.0/w3fi03_8f_source.html @@ -0,0 +1,137 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi03.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi03.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Transfers default integers to 16 bit ints.
    +
    3 C> @author Dennis Keyser @date 1992-06-29
    +
    4 
    +
    5 C> Transfers an array of numbers from default integer
    +
    6 C> words to 16 bit (IBM integer*2) IBM half-words.
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - Dennis Keyser 1992-06-29
    +
    10 C> - Stephen Gilbert 1998-11-17 Removed Cray references.
    +
    11 C>
    +
    12 C> @param[in] IN Starting address for array of default integers
    +
    13 C> @param[in] NUM Number of numbers in 'IN' to transfer.
    +
    14 C> @param[out] IDEST Starting address for array of 16 bit IBM half-words
    +
    15 C> @param[out] IER Error return code as follows:
    +
    16 C> IER = 0 - Transfer successful, all numbers
    +
    17 C> - Transferred without overflow.
    +
    18 C> IER = 1 - The transfer of one or more numbers
    +
    19 C> - Resulted in an overflow.
    +
    20 C>
    +
    21 C> @note This is the inverse of library routine w3fi02().
    +
    22 C>
    +
    23 C> @author Dennis Keyser @date 1992-06-29
    +
    24  SUBROUTINE w3fi03(IN,IDEST,NUM,IER)
    +
    25 C
    +
    26  INTEGER(2) IDEST(*)
    +
    27  INTEGER IN(*)
    +
    28 C
    +
    29  SAVE
    +
    30 C
    +
    31 C CALL USICTI(IN,IDEST,1,NUM,2,IER)
    +
    32  idest(1:num)=in(1:num)
    +
    33 C
    +
    34  RETURN
    +
    35  END
    +
    +
    +
    w3fi03
    subroutine w3fi03(IN, IDEST, NUM, IER)
    Transfers an array of numbers from default integer words to 16 bit (IBM integer*2) IBM half-words.
    Definition: w3fi03.f:25
    + + + + diff --git a/ver-2.10.0/w3fi04_8f.html b/ver-2.10.0/w3fi04_8f.html new file mode 100644 index 00000000..d87c65f1 --- /dev/null +++ b/ver-2.10.0/w3fi04_8f.html @@ -0,0 +1,189 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi04.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi04.f File Reference
    +
    +
    + +

    Find word size, endian, character set. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi04 (IENDN, ITYPEC, LW)
     Subroutine computes word size, the type of character set, ASCII or EBCDIC, and if the computer is big-endian, or little-endian. More...
     
    +

    Detailed Description

    +

    Find word size, endian, character set.

    +
    Author
    Ralph Jones
    +
    Date
    1994-10-07
    + +

    Definition in file w3fi04.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi04()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi04 (integer IENDN,
    integer ITYPEC,
    integer LW 
    )
    +
    + +

    Subroutine computes word size, the type of character set, ASCII or EBCDIC, and if the computer is big-endian, or little-endian.

    +

    Program history log:

      +
    • Relph Jones 1994-10-07
      • +
    • Stephen Gilbert 1998-07-08 Removed the Fortran SAVE Statement. The SAVE statement is not needed for this outine, and may have been causing errors using the f90 compiler under the 2.0 Programming Environment.
      • +
    • Boi Vuong 2002-10-15 Replaced Function ICHAR with mova2i
      • +
    +
    Parameters
    + + + + +
    [out]IENDNInteger for big-endian or little-endian
      +
    • =0 big-endian
      • +
    • =1 little-endian
      • +
    • =2 cannot compute
      • +
    +
    [out]ITYPECInteger for type of character set
      +
    • =0 ASCII character set
      • +
    • =1 EBCDIC character set
      • +
    • =2 not ASCII or EBCDIC
      • +
    +
    [out]LWInteger for words size of computer in bytes
      +
    • =4 for 32 bit computers
      • +
    • =8 for 64 bit computers
      • +
    +
    +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1994-10-07
    + +

    Definition at line 30 of file w3fi04.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi04_8f.js b/ver-2.10.0/w3fi04_8f.js new file mode 100644 index 00000000..3918385d --- /dev/null +++ b/ver-2.10.0/w3fi04_8f.js @@ -0,0 +1,4 @@ +var w3fi04_8f = +[ + [ "w3fi04", "w3fi04_8f.html#a43d8dd578a2f24d52b45332ed3ccc6c9", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi04_8f_source.html b/ver-2.10.0/w3fi04_8f_source.html new file mode 100644 index 00000000..5c42dab3 --- /dev/null +++ b/ver-2.10.0/w3fi04_8f_source.html @@ -0,0 +1,215 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi04.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi04.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Find word size, endian, character set.
    +
    3 C> @author Ralph Jones @date 1994-10-07
    +
    4 
    +
    5 C> Subroutine computes word size, the type of character
    +
    6 C> set, ASCII or EBCDIC, and if the computer is big-endian, or
    +
    7 C> little-endian.
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - Relph Jones 1994-10-07
    +
    11 C> - Stephen Gilbert 1998-07-08 Removed the Fortran SAVE Statement.
    +
    12 C> The SAVE statement is not needed for this outine, and may have been
    +
    13 C> causing errors using the f90 compiler under the 2.0 Programming Environment.
    +
    14 C> - Boi Vuong 2002-10-15 Replaced Function ICHAR with mova2i
    +
    15 C>
    +
    16 C> @param[out] IENDN Integer for big-endian or little-endian
    +
    17 C> - =0 big-endian
    +
    18 C> - =1 little-endian
    +
    19 C> - =2 cannot compute
    +
    20 C> @param[out] ITYPEC Integer for type of character set
    +
    21 C> - =0 ASCII character set
    +
    22 C> - =1 EBCDIC character set
    +
    23 C> - =2 not ASCII or EBCDIC
    +
    24 C> @param[out] LW Integer for words size of computer in bytes
    +
    25 C> - =4 for 32 bit computers
    +
    26 C> - =8 for 64 bit computers
    +
    27 C>
    +
    28 C> @author Ralph Jones @date 1994-10-07
    +
    29  SUBROUTINE w3fi04(IENDN,ITYPEC,LW)
    +
    30 C
    +
    31  INTEGER ITEST1
    +
    32  INTEGER ITEST2
    +
    33  INTEGER ITEST3
    +
    34  INTEGER IENDN
    +
    35  INTEGER ITYPEC
    +
    36  INTEGER LW
    +
    37 C
    +
    38  CHARACTER * 8 CTEST1
    +
    39  CHARACTER * 8 CTEST2
    +
    40  CHARACTER * 1 CTEST3(8)
    +
    41  CHARACTER * 1 BLANK
    +
    42 C
    +
    43  equivalence(ctest1,itest1),(ctest2,itest2)
    +
    44 C
    +
    45  equivalence(itest3,ctest3(1))
    +
    46 C
    +
    47  DATA ctest1/'12345678'/
    +
    48  DATA itest3/z'01020304'/
    +
    49  DATA blank /' '/
    +
    50 C
    +
    51 C SAVE
    +
    52 C
    +
    53 C TEST FOR TYPE OF CHARACTER SET
    +
    54 C BLANK IS 32 (20 HEX) IN ASCII, 64 (40 HEX) IN EBCDEC
    +
    55 C
    +
    56  IF (mova2i(blank).EQ.32) THEN
    +
    57  itypec = 0
    +
    58  ELSE IF (mova2i(blank).EQ.64) THEN
    +
    59 C
    +
    60 C COMPUTER IS PROBABLY AN IBM360, 370, OR 390 WITH
    +
    61 C A 32 BIT WORD SIZE, AND BIG-ENDIAN.
    +
    62 C
    +
    63  itypec = 1
    +
    64  ELSE
    +
    65  itypec = 2
    +
    66  END IF
    +
    67 C
    +
    68 C TEST FOR WORD SIZE, SET LW TO 4 FOR 32 BIT COMPUTER,
    +
    69 C 8 FOR FOR 64 BIT COMPUTERS
    +
    70 C
    +
    71  itest2 = itest1
    +
    72  IF (ctest1 .EQ. ctest2) THEN
    +
    73 C
    +
    74 C COMPUTER MAY BE A CRAY, OR COULD BE DEC VAX ALPHA
    +
    75 C OR SGI WITH R4000, R4400, R8800 AFTER THEY CHANGE
    +
    76 C FORTRAN COMPILERS FOR 64 BIT INTEGER.
    +
    77 C
    +
    78  lw = 8
    +
    79  ELSE
    +
    80  lw = 4
    +
    81  ENDIF
    +
    82 C
    +
    83 C USING ITEST3 WITH Z'01020304' EQUIVALNCED TO CTEST3
    +
    84 C ON A 32 BIT BIG-ENDIAN COMPUTER 03 IS IN THE 3RD
    +
    85 C BYTE OF A 4 BYTE WORD. ON A 32 BIT LITTLE-ENDIAN
    +
    86 C COMPUTER IT IS IN 2ND BYTE.
    +
    87 C ON A 64 BIT COMPUTER Z'01020304' IS RIGHT ADJUSTED IN
    +
    88 C A 64 BIT WORD, 03 IS IN THE 7TH BYTE. ON A LITTLE-
    +
    89 C ENDIAN 64 BIT COMPUTER IT IS IN THE 2ND BYTE.
    +
    90 C
    +
    91  IF (lw.EQ.4) THEN
    +
    92  IF (mova2i(ctest3(3)).EQ.3) THEN
    +
    93  iendn = 0
    +
    94  ELSE IF (mova2i(ctest3(3)).EQ.2) THEN
    +
    95  iendn = 1
    +
    96  ELSE
    +
    97  iendn = 2
    +
    98  END IF
    +
    99  ELSE IF (lw.EQ.8) THEN
    +
    100  IF (mova2i(ctest3(7)).EQ.3) THEN
    +
    101  iendn = 0
    +
    102  ELSE IF (mova2i(ctest3(2)).EQ.3) THEN
    +
    103  iendn = 1
    +
    104  ELSE
    +
    105  iendn = 2
    +
    106  END IF
    +
    107  ELSE
    +
    108  iendn = 2
    +
    109  END IF
    +
    110 C
    +
    111  RETURN
    +
    112  END
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    w3fi04
    subroutine w3fi04(IENDN, ITYPEC, LW)
    Subroutine computes word size, the type of character set, ASCII or EBCDIC, and if the computer is big...
    Definition: w3fi04.f:30
    + + + + diff --git a/ver-2.10.0/w3fi18_8f.html b/ver-2.10.0/w3fi18_8f.html new file mode 100644 index 00000000..94f317c5 --- /dev/null +++ b/ver-2.10.0/w3fi18_8f.html @@ -0,0 +1,183 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi18.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi18.f File Reference
    +
    +
    + +

    NMC octagon boundary finding subroutine. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi18 (I, J, NW)
     Relates the I,J coordinate point in a 65x65 grid-point array as being either inside, outside, or on the boundary of the NMC octagon centered in the 65x65 array. More...
     
    +

    Detailed Description

    +

    NMC octagon boundary finding subroutine.

    +
    Author
    James Howcroft
    +
    Date
    1973-10-15
    + +

    Definition in file w3fi18.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi18()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi18 ( I,
     J,
     NW 
    )
    +
    + +

    Relates the I,J coordinate point in a 65x65 grid-point array as being either inside, outside, or on the boundary of the NMC octagon centered in the 65x65 array.

    +

    Program history log:

      +
    • James Howcroft 1973-10-15
      • +
    • Ralph Jones 1984-07-02 Convert to fortran 77.
      • +
    • Ralph Jones 1989-02-02 Convert to microsoft fortran 4.10.
      • +
    • Ralph Jones 1990-06-12 Convert to sun fortran 1.3.
      • +
    • Ralph Jones 1991-03-16 Convert to silicongraphics 3.3 fortran 77.
      • +
    • Ralph Jones 1993-03-29 Add save statement.
      • +
    +
    Parameters
    + + + + +
    [in]ICoordinate identification of a point in the 65x65 array.
    [in]JCoordinate identification of a point in the 65x65 array.
    [out]NWInteger return code.
    +
    +
    +

    Exit states:

      +
    • NW = -1 Point is outside the octagon.
      • +
    • NW = 0 Point is on the octagon boundary.
      • +
    • NW = +1 Point is inside the octagon.
      • +
    +
    Author
    James Howcroft
    +
    Date
    1973-10-15
    + +

    Definition at line 28 of file w3fi18.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi18_8f.js b/ver-2.10.0/w3fi18_8f.js new file mode 100644 index 00000000..5a68dd41 --- /dev/null +++ b/ver-2.10.0/w3fi18_8f.js @@ -0,0 +1,4 @@ +var w3fi18_8f = +[ + [ "w3fi18", "w3fi18_8f.html#a684daaf76526713839d9d702a2c8aff7", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi18_8f_source.html b/ver-2.10.0/w3fi18_8f_source.html new file mode 100644 index 00000000..21aee397 --- /dev/null +++ b/ver-2.10.0/w3fi18_8f_source.html @@ -0,0 +1,149 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi18.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi18.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief NMC octagon boundary finding subroutine.
    +
    3 C> @author James Howcroft @date 1973-10-15
    +
    4 
    +
    5 C> Relates the I,J coordinate point in a 65x65 grid-point
    +
    6 C> array as being either inside, outside, or on the boundary of the
    +
    7 C> NMC octagon centered in the 65x65 array.
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - James Howcroft 1973-10-15
    +
    11 C> - Ralph Jones 1984-07-02 Convert to fortran 77.
    +
    12 C> - Ralph Jones 1989-02-02 Convert to microsoft fortran 4.10.
    +
    13 C> - Ralph Jones 1990-06-12 Convert to sun fortran 1.3.
    +
    14 C> - Ralph Jones 1991-03-16 Convert to silicongraphics 3.3 fortran 77.
    +
    15 C> - Ralph Jones 1993-03-29 Add save statement.
    +
    16 C>
    +
    17 C> @param[in] I Coordinate identification of a point in the 65x65 array.
    +
    18 C> @param[in] J Coordinate identification of a point in the 65x65 array.
    +
    19 C> @param[out] NW Integer return code.
    +
    20 C>
    +
    21 C> Exit states:
    +
    22 C> - NW = -1 Point is outside the octagon.
    +
    23 C> - NW = 0 Point is on the octagon boundary.
    +
    24 C> - NW = +1 Point is inside the octagon.
    +
    25 C>
    +
    26 C> @author James Howcroft @date 1973-10-15
    +
    27  SUBROUTINE w3fi18(I,J,NW)
    +
    28 C
    +
    29  SAVE
    +
    30 C
    +
    31  k = i + j
    +
    32  m = i - j
    +
    33  IF (i.LT.10.OR.i.GT.56.OR.j.LT.8.OR.j.GT.58) GO TO 10
    +
    34  IF (k.LT.32.OR.k.GT.100.OR.m.LT.-34.OR.m.GT.34) GO TO 10
    +
    35  IF (i.EQ.10.OR.i.EQ.56.OR.j.EQ.8.OR.j.EQ.58) GO TO 20
    +
    36  IF (k.EQ.32.OR.k.EQ.100.OR.m.EQ.-34.OR.m.EQ.34) GO TO 20
    +
    37  nw = 1
    +
    38  RETURN
    +
    39 C
    +
    40  10 CONTINUE
    +
    41  nw = -1
    +
    42  RETURN
    +
    43 C
    +
    44  20 CONTINUE
    +
    45  nw = 0
    +
    46  RETURN
    +
    47  END
    +
    +
    +
    w3fi18
    subroutine w3fi18(I, J, NW)
    Relates the I,J coordinate point in a 65x65 grid-point array as being either inside,...
    Definition: w3fi18.f:28
    + + + + diff --git a/ver-2.10.0/w3fi19_8f.html b/ver-2.10.0/w3fi19_8f.html new file mode 100644 index 00000000..b1d2c4ea --- /dev/null +++ b/ver-2.10.0/w3fi19_8f.html @@ -0,0 +1,183 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi19.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi19.f File Reference
    +
    +
    + +

    NMC Rectangle boundary finding subroutine. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi19 (I, J, NW)
     Relates the I,J coordinate point in a 65x65 grid-point array as being either inside, outside, or on the boundary of the 53x57 NMC rectangle centered in the 65x65 array. More...
     
    +

    Detailed Description

    +

    NMC Rectangle boundary finding subroutine.

    +
    Author
    James Howcroft
    +
    Date
    1973-10-15
    + +

    Definition in file w3fi19.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi19()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi19 ( I,
     J,
     NW 
    )
    +
    + +

    Relates the I,J coordinate point in a 65x65 grid-point array as being either inside, outside, or on the boundary of the 53x57 NMC rectangle centered in the 65x65 array.

    +

    Program history log:

      +
    • James Howcroft 1973-10-15
      • +
    • Ralph Jones 1984-07-02 Convert to fortran 77.
      • +
    • Ralph Jones 1989-02-02 Convert to microsoft fortran 4.10.
      • +
    • Ralph Jones 1990-06-12 Convert to sun fortran 1.3.
      • +
    • Ralph Jones 1991-03-16 Convert to silicongraphics 3.3 fortran 77.
      • +
    • Ralph Jones 1993-03-29 Add save statement.
      • +
    +
    Parameters
    + + + + +
    [in]ICoordinate identification of a point in the 65x65 array.
    [in]JCoordinate identification of a point in the 65x65 array.
    [out]NWInteger return code.
    +
    +
    +

    Exit states:

      +
    • NW = -1 Point is outside the rectangle.
      • +
    • NW = 0 Point is on the rectangle boundary.
      • +
    • NW = +1 Point is inside the rectangle.
      • +
    +
    Author
    James Howcroft
    +
    Date
    1973-10-15
    + +

    Definition at line 28 of file w3fi19.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi19_8f.js b/ver-2.10.0/w3fi19_8f.js new file mode 100644 index 00000000..892d02c0 --- /dev/null +++ b/ver-2.10.0/w3fi19_8f.js @@ -0,0 +1,4 @@ +var w3fi19_8f = +[ + [ "w3fi19", "w3fi19_8f.html#afcb6e01340c836fbd0f940b8c0e6814f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi19_8f_source.html b/ver-2.10.0/w3fi19_8f_source.html new file mode 100644 index 00000000..b98b2bdf --- /dev/null +++ b/ver-2.10.0/w3fi19_8f_source.html @@ -0,0 +1,145 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi19.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi19.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief NMC Rectangle boundary finding subroutine.
    +
    3 C> @author James Howcroft @date 1973-10-15
    +
    4 
    +
    5 C> Relates the I,J coordinate point in a 65x65 grid-point
    +
    6 C> array as being either inside, outside, or on the boundary of the
    +
    7 C> 53x57 NMC rectangle centered in the 65x65 array.
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - James Howcroft 1973-10-15
    +
    11 C> - Ralph Jones 1984-07-02 Convert to fortran 77.
    +
    12 C> - Ralph Jones 1989-02-02 Convert to microsoft fortran 4.10.
    +
    13 C> - Ralph Jones 1990-06-12 Convert to sun fortran 1.3.
    +
    14 C> - Ralph Jones 1991-03-16 Convert to silicongraphics 3.3 fortran 77.
    +
    15 C> - Ralph Jones 1993-03-29 Add save statement.
    +
    16 C>
    +
    17 C> @param[in] I Coordinate identification of a point in the 65x65 array.
    +
    18 C> @param[in] J Coordinate identification of a point in the 65x65 array.
    +
    19 C> @param[out] NW Integer return code.
    +
    20 C>
    +
    21 C> Exit states:
    +
    22 C> - NW = -1 Point is outside the rectangle.
    +
    23 C> - NW = 0 Point is on the rectangle boundary.
    +
    24 C> - NW = +1 Point is inside the rectangle.
    +
    25 C>
    +
    26 C> @author James Howcroft @date 1973-10-15
    +
    27  SUBROUTINE w3fi19(I,J,NW)
    +
    28 C
    +
    29  SAVE
    +
    30 C
    +
    31  IF (i.LT.7.OR.i.GT.59.OR.j.LT.5.OR.j.GT.61) GO TO 10
    +
    32  IF (i.EQ.7.OR.i.EQ.59.OR.j.EQ.5.OR.j.EQ.61) GO TO 20
    +
    33  nw = 1
    +
    34  RETURN
    +
    35 C
    +
    36  10 CONTINUE
    +
    37  nw = -1
    +
    38  RETURN
    +
    39 C
    +
    40  20 CONTINUE
    +
    41  nw = 0
    +
    42  RETURN
    +
    43  END
    +
    +
    +
    w3fi19
    subroutine w3fi19(I, J, NW)
    Relates the I,J coordinate point in a 65x65 grid-point array as being either inside,...
    Definition: w3fi19.f:28
    + + + + diff --git a/ver-2.10.0/w3fi20_8f.html b/ver-2.10.0/w3fi20_8f.html new file mode 100644 index 00000000..0b04d83a --- /dev/null +++ b/ver-2.10.0/w3fi20_8f.html @@ -0,0 +1,172 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi20.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi20.f File Reference
    +
    +
    + +

    Cut a 65 x 65 grid to a nmc 1977 point grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi20 (A, B)
     Extracts the NMC 1977 point octagon grid points out of a 65x65 (4225 point) array. More...
     
    +

    Detailed Description

    +

    Cut a 65 x 65 grid to a nmc 1977 point grid.

    +
    Author
    Ralph Jones
    +
    Date
    1984-07-02
    + +

    Definition in file w3fi20.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi20()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3fi20 (real, dimension(*) A,
    real, dimension(*) B 
    )
    +
    + +

    Extracts the NMC 1977 point octagon grid points out of a 65x65 (4225 point) array.

    +

    Program history log:

      +
    • Ralph Jones 1973-06-15
      • +
    • Ralph Jones 1984-07-02 Convert to vs fortran
      • +
    • Ralph Jones 1989-02-02 Convert to microsoft fortran 4.10
      • +
    • Ralph Jones 1990-08-22 Convert to sun fortran 1.3
      • +
    • Ralph Jones 1991-03-29 Convert to silicongraphics fortran
      • +
    • Ralph Jones 1993-03-29 Add save statement
      • +
    +
    Parameters
    + + + +
    [in]AREAL*4 (65 x 65 grid, 4225 point) array grid is office note 84 type 27 or 1b hex.
    [out]B1977 point array (octagon) office note 84 type 0 or hex 0.
    +
    +
    +
    Note
    Arrays A and B may be the same array or be equivalenced, in which case the first 1977 words of 'A' are written over.
    +
    Author
    Ralph Jones
    +
    Date
    1984-07-02
    + +

    Definition at line 26 of file w3fi20.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi20_8f.js b/ver-2.10.0/w3fi20_8f.js new file mode 100644 index 00000000..baf56fa7 --- /dev/null +++ b/ver-2.10.0/w3fi20_8f.js @@ -0,0 +1,4 @@ +var w3fi20_8f = +[ + [ "w3fi20", "w3fi20_8f.html#a4d5864f48a1b0a2c1223f3dd4a06059f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi20_8f_source.html b/ver-2.10.0/w3fi20_8f_source.html new file mode 100644 index 00000000..83986001 --- /dev/null +++ b/ver-2.10.0/w3fi20_8f_source.html @@ -0,0 +1,162 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi20.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi20.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Cut a 65 x 65 grid to a nmc 1977 point grid.
    +
    3 C> @author Ralph Jones @date 1984-07-02
    +
    4 
    +
    5 C> Extracts the NMC 1977 point octagon grid points out of
    +
    6 C> a 65x65 (4225 point) array.
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - Ralph Jones 1973-06-15
    +
    10 C> - Ralph Jones 1984-07-02 Convert to vs fortran
    +
    11 C> - Ralph Jones 1989-02-02 Convert to microsoft fortran 4.10
    +
    12 C> - Ralph Jones 1990-08-22 Convert to sun fortran 1.3
    +
    13 C> - Ralph Jones 1991-03-29 Convert to silicongraphics fortran
    +
    14 C> - Ralph Jones 1993-03-29 Add save statement
    +
    15 C>
    +
    16 C> @param[in] A REAL*4 (65 x 65 grid, 4225 point) array
    +
    17 C> grid is office note 84 type 27 or 1b hex.
    +
    18 C> @param[out] B 1977 point array (octagon) office note 84 type
    +
    19 C> 0 or hex 0.
    +
    20 C>
    +
    21 C> @note Arrays A and B may be the same array or be equivalenced,
    +
    22 C> in which case the first 1977 words of 'A' are written over.
    +
    23 C>
    +
    24 C> @author Ralph Jones @date 1984-07-02
    +
    25  SUBROUTINE w3fi20(A,B)
    +
    26 C
    +
    27  REAL A(*)
    +
    28  REAL B(*)
    +
    29 C
    +
    30  INTEGER RB
    +
    31  INTEGER LBR(51)
    +
    32  INTEGER RBR(51)
    +
    33 C
    +
    34  SAVE
    +
    35 C
    +
    36  DATA lbr/479,543,607,671,735,799,863,927,991,1055,1119,1183,1247,
    +
    37  &1311,1375,1440,1505,1570,1635,1700,1765,1830,1895,1960,2025,2090,
    +
    38  &2155,2220,2285,2350,2415,2480,2545,2610,2675,2740,2805,2871,2937,
    +
    39  &3003,3069,3135,3201,3267,3333,3399,3465,3531,3597,3663,3729/
    +
    40 C
    +
    41  DATA rbr/497,563,629,695,761,827,893,959,1025,1091,1157,1223,1289,
    +
    42  &1355,1421,1486,1551,1616,1681,1746,1811,1876,1941,2006,2071,2136,
    +
    43  &2201,2266,2331,2396,2461,2526,2591,2656,2721,2786,2851,2915,2979,
    +
    44  &3043,3107,3171,3235,3299,3363,3427,3491,3555,3619,3683,3747/
    +
    45 C
    +
    46  n = 0
    +
    47 C
    +
    48  DO 200 i = 1,51
    +
    49  lb = lbr(i)
    +
    50  rb = rbr(i)
    +
    51 C
    +
    52  DO 100 j = lb,rb
    +
    53  n = n + 1
    +
    54  b(n) = a(j)
    +
    55  100 CONTINUE
    +
    56 C
    +
    57  200 CONTINUE
    +
    58 C
    +
    59  RETURN
    +
    60  END
    +
    +
    +
    w3fi20
    subroutine w3fi20(A, B)
    Extracts the NMC 1977 point octagon grid points out of a 65x65 (4225 point) array.
    Definition: w3fi20.f:26
    + + + + diff --git a/ver-2.10.0/w3fi32_8f.html b/ver-2.10.0/w3fi32_8f.html new file mode 100644 index 00000000..dc03ef4f --- /dev/null +++ b/ver-2.10.0/w3fi32_8f.html @@ -0,0 +1,174 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi32.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi32.f File Reference
    +
    +
    + +

    Pack id's into office note 84 format. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi32 (LARRAY, KIDNT)
     Converts an array of the 27 data field identifiers into an array of the first 8 identification words of the format de- scribed in NMC office note 84 (89-06-15, page-35). More...
     
    +

    Detailed Description

    +

    Pack id's into office note 84 format.

    +
    Author
    Alan Nierow
    +
    Date
    1986-02-07
    + +

    Definition in file w3fi32.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi32()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3fi32 (integer(8), dimension(27) LARRAY,
    integer(8), dimension(*) KIDNT 
    )
    +
    + +

    Converts an array of the 27 data field identifiers into an array of the first 8 identification words of the format de- scribed in NMC office note 84 (89-06-15, page-35).

    +

    On a cray they will fit into four 64 bit integer words.

    +

    Program history log:

      +
    • Alan Nierow 1986-02-07
      • +
    • Ralph Jones 1989-10-24 Convert to cray cft77 fortran.
      • +
    • Ralph Jones 1991-03-19 Changes for big records.
      • +
    • Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
      • +
    • Stephen Gilbert 1999-03-15 Specified 8-byte integer array explicitly.
      • +
    +
    Parameters
    + + + +
    [in]LARRAYInteger array containing 27 data field identifiers (see o.n. 84)
    [out]KIDNTInteger array of 6 words, 12 office note 84 32 bit words, first 4 words are made by w3fi32(), if you are using packer w3ai00(), it will compute word 5 and 6. (office note 84 words 9,10, 11 and 12). If J the word count in word 27 of LARRAY is greater than 32743 then bits 15-0 of the 4th ID word are set to zero, J is stored in bits 31-0 of the 6th ID word. ID word 5 is set zero, bit 63-32 of the 6th ID word are set zero.
    +
    +
    +
    Note
    bis are number left to right on the cray as 63-0.
    +
    +Exit states printed messages: If any number n in (LARRAY(i),i=1,27) is erroneously large: 'value in LARRAY(i)=n is too large to pack' if any number n in (LARRAY(i),i=1,27) is erroneously negative: 'value in LARRAY(i)=n should not be negative' in either of the above situations, that portion of the packed word corresponding to LARRAY(i) will be set to binary ones.
    +
    Author
    Alan Nierow
    +
    Date
    1986-02-07
    + +

    Definition at line 40 of file w3fi32.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi32_8f.js b/ver-2.10.0/w3fi32_8f.js new file mode 100644 index 00000000..34c294c7 --- /dev/null +++ b/ver-2.10.0/w3fi32_8f.js @@ -0,0 +1,4 @@ +var w3fi32_8f = +[ + [ "w3fi32", "w3fi32_8f.html#a28af7a8a671a5e22f09ba6f371a348db", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi32_8f_source.html b/ver-2.10.0/w3fi32_8f_source.html new file mode 100644 index 00000000..ad628828 --- /dev/null +++ b/ver-2.10.0/w3fi32_8f_source.html @@ -0,0 +1,242 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi32.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi32.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Pack id's into office note 84 format.
    +
    3 C> @author Alan Nierow @date 1986-02-07
    +
    4 
    +
    5 C> Converts an array of the 27 data field identifiers into
    +
    6 C> an array of the first 8 identification words of the format de-
    +
    7 C> scribed in NMC office note 84 (89-06-15, page-35). On a cray
    +
    8 C> they will fit into four 64 bit integer words.
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - Alan Nierow 1986-02-07
    +
    12 C> - Ralph Jones 1989-10-24 Convert to cray cft77 fortran.
    +
    13 C> - Ralph Jones 1991-03-19 Changes for big records.
    +
    14 C> - Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
    +
    15 C> - Stephen Gilbert 1999-03-15 Specified 8-byte integer array explicitly.
    +
    16 C>
    +
    17 C> @param[in] LARRAY Integer array containing 27 data field
    +
    18 C> identifiers (see o.n. 84)
    +
    19 C> @param[out] KIDNT Integer array of 6 words, 12 office note 84 32 bit
    +
    20 C> words, first 4 words are made by w3fi32(), if you are
    +
    21 C> using packer w3ai00(), it will compute word 5 and 6.
    +
    22 C> (office note 84 words 9,10, 11 and 12). If J the
    +
    23 C> word count in word 27 of LARRAY is greater than
    +
    24 C> 32743 then bits 15-0 of the 4th ID word are set to
    +
    25 C> zero, J is stored in bits 31-0 of the 6th ID word.
    +
    26 C> ID word 5 is set zero, bit 63-32 of the 6th ID
    +
    27 C> word are set zero.
    +
    28 C> @note bis are number left to right on the cray as 63-0.
    +
    29 C>
    +
    30 C> @note Exit states printed messages:
    +
    31 C> If any number n in (LARRAY(i),i=1,27) is erroneously large:
    +
    32 C> 'value in LARRAY(i)=n is too large to pack'
    +
    33 C> if any number n in (LARRAY(i),i=1,27) is erroneously negative:
    +
    34 C> 'value in LARRAY(i)=n should not be negative'
    +
    35 C> in either of the above situations, that portion of the packed
    +
    36 C> word corresponding to LARRAY(i) will be set to binary ones.
    +
    37 C>
    +
    38 C> @author Alan Nierow @date 1986-02-07
    +
    39  SUBROUTINE w3fi32(LARRAY,KIDNT)
    +
    40 C
    +
    41  INTEGER(8) LARRAY(27)
    +
    42  INTEGER(8) ITABLE(27)
    +
    43  INTEGER(8) KIDNT(*)
    +
    44  INTEGER(8) KX,MASK,MASK16,ISC,ITEMP8
    +
    45 C
    +
    46  SAVE
    +
    47 C
    +
    48  DATA itable/z'0000000000340C01',z'0000000000280C01',
    +
    49  & z'0000000000200801',z'00000000001C0401',
    +
    50  & z'0000000001081401',z'0000000001000801',
    +
    51  & z'00000000003C0402',z'0000000000340802',
    +
    52  & z'0000000000280C02',z'0000000000200802',
    +
    53  & z'00000000001C0402',z'0000000001081402',
    +
    54  & z'0000000001000802',z'0000000000380803',
    +
    55  & z'0000000000300803',z'0000000000280803',
    +
    56  & z'0000000000200803',z'00000000001C0403',
    +
    57  & z'0000000000100C03',z'0000000000001003',
    +
    58  & z'0000000000380804',z'0000000000300804',
    +
    59  & z'0000000000280804',z'0000000000200804',
    +
    60  & z'0000000000180804',z'0000000000100804',
    +
    61  & z'0000000000001004'/
    +
    62  DATA kx /z'00000000FFFFFFFF'/
    +
    63  DATA mask /z'00000000000000FF'/
    +
    64  DATA mask16/z'FFFFFFFFFFFF0000'/
    +
    65 C
    +
    66 C MAKE KIDNT = 0
    +
    67 C
    +
    68  DO 10 i = 1,4
    +
    69  kidnt(i) = 0
    +
    70  10 CONTINUE
    +
    71 C
    +
    72  isign = 0
    +
    73 C
    +
    74  DO 90 i = 1,27
    +
    75  isc = itable(i)
    +
    76  i1 = iand(isc,mask)
    +
    77  i2 = iand(ishft(isc,-8_8), mask)
    +
    78  i3 = iand(ishft(isc,-16_8),mask)
    +
    79  i4 = iand(ishft(isc,-24_8),mask)
    +
    80 C
    +
    81 C SIGN TEST
    +
    82 C
    +
    83  iv = larray(i)
    +
    84  IF (iv.GE.0) GO TO 50
    +
    85  IF (i4.NE.0) GO TO 30
    +
    86  WRITE (6,20) i, iv
    +
    87  20 FORMAT(/,1x,' W3FI32 - VALUE IN LARRAY(',i2,') =',i11,
    +
    88  & ' SHOULD NOT BE NEGATIVE',/)
    +
    89  GO TO 70
    +
    90 C
    +
    91  30 CONTINUE
    +
    92  iv = iabs(iv)
    +
    93  msign = 1
    +
    94  isign = msign
    +
    95  k = i2 / 4
    +
    96 C
    +
    97  DO 40 m = 1,k
    +
    98  isign = ishft(isign,4)
    +
    99  40 CONTINUE
    +
    100 C
    +
    101  isign = ishft(isign,-1)
    +
    102  iv = ior(iv,isign)
    +
    103 C
    +
    104  50 CONTINUE
    +
    105 C
    +
    106 C MAG TEST
    +
    107 C
    +
    108  IF (ishft(iv,-i2).EQ.0) GO TO 80
    +
    109  IF (larray(27).GT.32743) GO TO 70
    +
    110  print 60, i , iv
    +
    111  60 FORMAT(/,1x,' W3FI32 - VALUE IN LARRAY(',i2,') =',i11,
    +
    112  & ' IS TOO LARGE TO PACK',/)
    +
    113 C
    +
    114  70 CONTINUE
    +
    115  iv = kx
    +
    116  ia = 32 - i2
    +
    117  iv = ishft(iv,-ia)
    +
    118 C
    +
    119 C SHIFT
    +
    120 C
    +
    121  80 CONTINUE
    +
    122  itemp=ishft(iv,i3)
    +
    123  itemp8=itemp
    +
    124  kidnt(i1) = ior(kidnt(i1),itemp8)
    +
    125 C
    +
    126  90 CONTINUE
    +
    127 C
    +
    128 C TEST FOR BIG RECORDS, STORE J THE WORD COUNT IN THE 6TH
    +
    129 C ID WORD IF GREATER THAN 32743.
    +
    130 C
    +
    131  IF (larray(27).EQ.0) THEN
    +
    132  print *,' W3FI32 - ERROR, WORD COUNT J = 0'
    +
    133  ELSE IF (larray(27).GT.32743) THEN
    +
    134  kidnt(4) = iand(kidnt(4),mask16)
    +
    135  kidnt(5) = 0
    +
    136  kidnt(6) = larray(27)
    +
    137  END IF
    +
    138 C
    +
    139  RETURN
    +
    140  END
    +
    +
    +
    w3fi32
    subroutine w3fi32(LARRAY, KIDNT)
    Converts an array of the 27 data field identifiers into an array of the first 8 identification words ...
    Definition: w3fi32.f:40
    + + + + diff --git a/ver-2.10.0/w3fi47_8f.html b/ver-2.10.0/w3fi47_8f.html new file mode 100644 index 00000000..3bcb32c5 --- /dev/null +++ b/ver-2.10.0/w3fi47_8f.html @@ -0,0 +1,169 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi47.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi47.f File Reference
    +
    +
    + +

    Convert label to off. no. 85 format (cray) +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi47 (ILABEL, NLABEL)
     Converts a office note 85 label in IBM370 format to office note 85 cray format. More...
     
    +

    Detailed Description

    +

    Convert label to off. no. 85 format (cray)

    +
    Author
    Ralph Jones
    +
    Date
    1985-07-31
    + +

    Definition in file w3fi47.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi47()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3fi47 (character*1, dimension(32) ILABEL,
    character*1, dimension(32) NLABEL 
    )
    +
    + +

    Converts a office note 85 label in IBM370 format to office note 85 cray format.

    +

    All EBCDIC characters are converted to ASCII. Converts binary or coded label.

    +

    Program history log:

      +
    • Ralph Jones 1985-07-31
      • +
    • Ralph Jones 1989-10-24 Convert to cray cft77 fortran
      • +
    • Boi Vuong 2002-10-15 Replaced function ichar with mova2i
      • +
    +
    Parameters
    + + + +
    [in]ILABEL4 words (32 bytes) characters are in EBCDIc or binary.
    [out]NLABEL4 words (32 bytes), characters are in ASCII or binary.
    +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1985-07-31
    + +

    Definition at line 21 of file w3fi47.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi47_8f.js b/ver-2.10.0/w3fi47_8f.js new file mode 100644 index 00000000..1ad1e5b6 --- /dev/null +++ b/ver-2.10.0/w3fi47_8f.js @@ -0,0 +1,4 @@ +var w3fi47_8f = +[ + [ "w3fi47", "w3fi47_8f.html#aa65811b21988f0ddf7568b0a88f12282", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi47_8f_source.html b/ver-2.10.0/w3fi47_8f_source.html new file mode 100644 index 00000000..650b7637 --- /dev/null +++ b/ver-2.10.0/w3fi47_8f_source.html @@ -0,0 +1,170 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi47.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi47.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert label to off. no. 85 format (cray)
    +
    3 C> @author Ralph Jones @date 1985-07-31
    +
    4 
    +
    5 C> Converts a office note 85 label in IBM370 format
    +
    6 C> to office note 85 cray format. All EBCDIC characters are
    +
    7 C> converted to ASCII. Converts binary or coded label.
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - Ralph Jones 1985-07-31
    +
    11 C> - Ralph Jones 1989-10-24 Convert to cray cft77 fortran
    +
    12 C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i
    +
    13 C>
    +
    14 C> @param[in] ILABEL 4 words (32 bytes) characters are in EBCDIc or
    +
    15 C> binary.
    +
    16 C> @param[out] NLABEL 4 words (32 bytes), characters are in ASCII or
    +
    17 C> binary.
    +
    18 C>
    +
    19 C> @author Ralph Jones @date 1985-07-31
    +
    20  SUBROUTINE w3fi47(ILABEL,NLABEL)
    +
    21 C
    +
    22  CHARACTER*1 ILABEL(32)
    +
    23  CHARACTER*1 NLABEL(32)
    +
    24 C
    +
    25 C TEST FOR CODED LABEL, IF SO, CONVERT ALL CHARACTERS
    +
    26 C TEST FOR EBCDIC C, 195 IN DECIMAL
    +
    27 C
    +
    28  IF (mova2i(ilabel(7)).EQ.195) THEN
    +
    29 C
    +
    30  CALL aea(nlabel(1),ilabel(1),32)
    +
    31 C
    +
    32  ELSE
    +
    33 C
    +
    34 C BINARY LABEL, CONVERT BYTES 1-8, 21-30 TO ASCII
    +
    35 C
    +
    36  CALL aea(nlabel(1),ilabel(1),8)
    +
    37 C
    +
    38 C MOVE BYTES 9 TO 20
    +
    39 C
    +
    40  DO 10 i = 9,20
    +
    41  nlabel(i) = ilabel(i)
    +
    42  10 CONTINUE
    +
    43 C
    +
    44 C CONVERT WASHINGTON TO ASCII
    +
    45 C
    +
    46  CALL aea(nlabel(21),ilabel(21),10)
    +
    47 C
    +
    48 C TEST BYTES 31 AND 32 FOR BINARY ZERO, IF NOT ZERO
    +
    49 C CONVERT TO ASCII
    +
    50 C
    +
    51  IF (mova2i(ilabel(31)).EQ.0) THEN
    +
    52  nlabel(31) = char(0)
    +
    53  ELSE
    +
    54  CALL aea(nlabel(31),ilabel(31),1)
    +
    55  ENDIF
    +
    56 C
    +
    57  IF (mova2i(ilabel(32)).EQ.0) THEN
    +
    58  nlabel(32) = char(0)
    +
    59  ELSE
    +
    60  CALL aea(nlabel(32),ilabel(32),1)
    +
    61  ENDIF
    +
    62 C
    +
    63  ENDIF
    +
    64 C
    +
    65  RETURN
    +
    66  END
    +
    +
    +
    aea
    subroutine aea(IA, IE, NC)
    Program history log:
    Definition: aea.f:41
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    w3fi47
    subroutine w3fi47(ILABEL, NLABEL)
    Converts a office note 85 label in IBM370 format to office note 85 cray format.
    Definition: w3fi47.f:21
    + + + + diff --git a/ver-2.10.0/w3fi48_8f.html b/ver-2.10.0/w3fi48_8f.html new file mode 100644 index 00000000..e9087f95 --- /dev/null +++ b/ver-2.10.0/w3fi48_8f.html @@ -0,0 +1,170 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi48.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi48.f File Reference
    +
    +
    + +

    Convert office note 85 label to IBM. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi48 (ILABEL, NLABEL)
     Converts office note 85 label from the cray format into a nas-9050 label. More...
     
    +

    Detailed Description

    +

    Convert office note 85 label to IBM.

    +
    Author
    Ralph Jones
    +
    Date
    1985-07-31
    + +

    Definition in file w3fi48.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi48()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3fi48 (character*1, dimension(32) ILABEL,
    character*1, dimension(32) NLABEL 
    )
    +
    + +

    Converts office note 85 label from the cray format into a nas-9050 label.

    +

    All ASCII characters are converted into EBCDIC characters. Binary or coded labels can be converted.

    +

    Program history log:

      +
    • Ralph Jones 1985-07-31
      • +
    • Ralph Jones 1989-10-24 Convert to cray cft77 fortran.
      • +
    • Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
      • +
    +
    Parameters
    + + + +
    [in]ILABEL4 64 bit words or 32 characters characters are in ASCII or binary.
    [out]NLABEL4 64 bit words or 32 characters, characters are in EBCDIC or binary.
    +
    +
    +
    Note
    See office note 85.
    +
    Author
    Ralph Jones
    +
    Date
    1985-07-31
    + +

    Definition at line 24 of file w3fi48.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi48_8f.js b/ver-2.10.0/w3fi48_8f.js new file mode 100644 index 00000000..fc334cb2 --- /dev/null +++ b/ver-2.10.0/w3fi48_8f.js @@ -0,0 +1,4 @@ +var w3fi48_8f = +[ + [ "w3fi48", "w3fi48_8f.html#af4be979e393742d638626918089c9374", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi48_8f_source.html b/ver-2.10.0/w3fi48_8f_source.html new file mode 100644 index 00000000..9ba4abea --- /dev/null +++ b/ver-2.10.0/w3fi48_8f_source.html @@ -0,0 +1,173 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi48.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi48.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert office note 85 label to IBM.
    +
    3 C> @author Ralph Jones @date 1985-07-31
    +
    4 
    +
    5 C> Converts office note 85 label from the cray
    +
    6 C> format into a nas-9050 label. All ASCII characters are
    +
    7 C> converted into EBCDIC characters. Binary or coded labels
    +
    8 C> can be converted.
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - Ralph Jones 1985-07-31
    +
    12 C> - Ralph Jones 1989-10-24 Convert to cray cft77 fortran.
    +
    13 C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
    +
    14 C>
    +
    15 C> @param[in] ILABEL 4 64 bit words or 32 characters
    +
    16 C> characters are in ASCII or binary.
    +
    17 C> @param[out] NLABEL 4 64 bit words or 32 characters,
    +
    18 C> characters are in EBCDIC or binary.
    +
    19 C>
    +
    20 C> @note See office note 85.
    +
    21 C>
    +
    22 C> @author Ralph Jones @date 1985-07-31
    +
    23  SUBROUTINE w3fi48(ILABEL,NLABEL)
    +
    24 C
    +
    25  CHARACTER*1 ILABEL(32)
    +
    26  CHARACTER*1 NLABEL(32)
    +
    27 C
    +
    28 C TEST FOR CODED LABEL, IF SO, CONVERT ALL CHARACTERS
    +
    29 C TEST FOR ASCII C, 67 IN DECIMAL
    +
    30 C
    +
    31  IF (mova2i(ilabel(7)).EQ.67) THEN
    +
    32 C
    +
    33  CALL aea(ilabel(1),nlabel(1),-32)
    +
    34 C
    +
    35  ELSE
    +
    36 C
    +
    37 C BINARY LABEL, CONVERT BYTES 1-8, 21-30 TO EBCDIC
    +
    38 C
    +
    39  CALL aea (ilabel(1),nlabel(1),-8)
    +
    40 C
    +
    41 C MOVE BYTES 9 TO 20
    +
    42 C
    +
    43  DO 10 i = 9,20
    +
    44  nlabel(i) = ilabel(i)
    +
    45  10 CONTINUE
    +
    46 C
    +
    47 C CONVERT WASHINGTON TO EBCDIC
    +
    48 C
    +
    49  CALL aea (ilabel(21),nlabel(21),-10)
    +
    50 C
    +
    51 C TEST BYTES 31 AND 32 FOR BINARY ZERO, IF NOT ZERO
    +
    52 C CONVERT TO ASCII
    +
    53 C
    +
    54  IF (mova2i(ilabel(31)).EQ.0) THEN
    +
    55  nlabel(31) = char(0)
    +
    56  ELSE
    +
    57  CALL aea(ilabel(31),nlabel(31),-1)
    +
    58  ENDIF
    +
    59 C
    +
    60  IF (mova2i(ilabel(32)).EQ.0) THEN
    +
    61  nlabel(32) = char(0)
    +
    62  ELSE
    +
    63  CALL aea(ilabel(32),nlabel(32),-1)
    +
    64  ENDIF
    +
    65 C
    +
    66  ENDIF
    +
    67 C
    +
    68  RETURN
    +
    69  END
    +
    +
    +
    aea
    subroutine aea(IA, IE, NC)
    Program history log:
    Definition: aea.f:41
    +
    w3fi48
    subroutine w3fi48(ILABEL, NLABEL)
    Converts office note 85 label from the cray format into a nas-9050 label.
    Definition: w3fi48.f:24
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    + + + + diff --git a/ver-2.10.0/w3fi52_8f.html b/ver-2.10.0/w3fi52_8f.html new file mode 100644 index 00000000..0151d6fb --- /dev/null +++ b/ver-2.10.0/w3fi52_8f.html @@ -0,0 +1,180 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi52.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi52.f File Reference
    +
    +
    + +

    Computes scaling constants used by grdprt(). +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi52 (IDENT, CNST, IER)
     Computes the four scaling constants used by grdprt(), w3fp03(), or w3fp05() from the 1st 5 identifier words in office note 84 format. More...
     
    +

    Detailed Description

    +

    Computes scaling constants used by grdprt().

    +
    Author
    John Stackpole
    +
    Date
    1980-06-15
    + +

    Definition in file w3fi52.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi52()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi52 (integer, dimension(4) IDENT,
    real, dimension(4) CNST,
     IER 
    )
    +
    + +

    Computes the four scaling constants used by grdprt(), w3fp03(), or w3fp05() from the 1st 5 identifier words in office note 84 format.

    +

    Program history log:

      +
    • John Stackpole 1980-06-15
      • +
    • Ralph Jones 1985-12-03 Made subroutine in genout into this subr.
      • +
    • Ralph Jones 1989-07-07 Convert to microsoft fortran 4.10
      • +
    • Ralph Jones 1990-02-03 Convert to cray cft77 fortran
      • +
    +
    Parameters
    + + + + +
    [in]IDENTFirst 5 id's in office note 84 format.
    [out]CNST4 constant's used by grdprtO(), w3fp05(), or w3fp03()
    [out]IER
      +
    • 0 = normal return.
      • +
    • 1 = ID'S IN IDENT ARE NOT IN O.N. 84 FORMAT
      • +
    +
    +
    +
    +
    Author
    John Stackpole
    +
    Date
    1980-06-15
    + +

    Definition at line 22 of file w3fi52.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi52_8f.js b/ver-2.10.0/w3fi52_8f.js new file mode 100644 index 00000000..944d0de7 --- /dev/null +++ b/ver-2.10.0/w3fi52_8f.js @@ -0,0 +1,4 @@ +var w3fi52_8f = +[ + [ "w3fi52", "w3fi52_8f.html#a8ce70b189d09ff2d3acfb478833c640c", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi52_8f_source.html b/ver-2.10.0/w3fi52_8f_source.html new file mode 100644 index 00000000..9953472f --- /dev/null +++ b/ver-2.10.0/w3fi52_8f_source.html @@ -0,0 +1,438 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi52.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi52.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes scaling constants used by grdprt().
    +
    3 C> @author John Stackpole @date 1980-06-15
    +
    4 
    +
    5 C> Computes the four scaling constants used by grdprt(), w3fp03(),
    +
    6 C> or w3fp05() from the 1st 5 identifier words in office note 84 format.
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - John Stackpole 1980-06-15
    +
    10 C> - Ralph Jones 1985-12-03 Made subroutine in genout into this subr.
    +
    11 C> - Ralph Jones 1989-07-07 Convert to microsoft fortran 4.10
    +
    12 C> - Ralph Jones 1990-02-03 Convert to cray cft77 fortran
    +
    13 C>
    +
    14 C> @param[in] IDENT First 5 id's in office note 84 format.
    +
    15 C> @param[out] CNST 4 constant's used by grdprtO(), w3fp05(), or w3fp03()
    +
    16 C> @param[out] IER
    +
    17 C> - 0 = normal return.
    +
    18 C> - 1 = ID'S IN IDENT ARE NOT IN O.N. 84 FORMAT
    +
    19 C>
    +
    20 C> @author John Stackpole @date 1980-06-15
    +
    21  SUBROUTINE w3fi52(IDENT,CNST,IER)
    +
    22 C
    +
    23 CC SET DEFAULT VALUES FOR NMC FIELDS GRIDPRINTING
    +
    24 C
    +
    25  REAL CNST(4)
    +
    26 C
    +
    27  INTEGER IDENT(4)
    +
    28  INTEGER LABUNP(27)
    +
    29  INTEGER Q
    +
    30 C
    +
    31 C UPACK 8 OFFICE NOTE 84 ID'S INTO 27 PARTS
    +
    32 C
    +
    33  CALL w3fi33(ident,labunp)
    +
    34 C
    +
    35  itypeq = labunp(1)
    +
    36  q = itypeq
    +
    37  itypes = labunp(2)
    +
    38  itypec = labunp(5)
    +
    39  isc = labunp(6)
    +
    40  ier = 0
    +
    41  xlvl = itypec
    +
    42  IF (isc) 10,30,20
    +
    43 C
    +
    44  10 CONTINUE
    +
    45  isc = -isc
    +
    46 C
    +
    47 C DIVIDE BY WHOLE NUMBER RATHER THAN MULTIPLY BY FRACTION TO
    +
    48 C TO AVOID ROUND OF ERROR
    +
    49 C
    +
    50  xlvl = xlvl / (10.**isc)
    +
    51  GO TO 30
    +
    52 C
    +
    53  20 CONTINUE
    +
    54  xlvl = xlvl * (10.**isc)
    +
    55 C
    +
    56  30 CONTINUE
    +
    57  ilvl = xlvl
    +
    58  IF (q.NE.1.AND.q.NE.2) GO TO 40
    +
    59 C
    +
    60 C*** GEOPOTENTIAL METERS ............
    +
    61 C
    +
    62  cnst(3) = 60.
    +
    63  IF (ilvl .LT. 500) cnst(3) = 120.
    +
    64  IF ((itypes .EQ. 129) .OR. (itypes .EQ. 130)) cnst(3) = 500.
    +
    65  cnst(1) = 0.
    +
    66  cnst(2) = 1.
    +
    67  cnst(4) = 0.
    +
    68  IF (cnst(3) .EQ. 500.) cnst(4) = 2.
    +
    69  RETURN
    +
    70 C
    +
    71  40 CONTINUE
    +
    72  IF (q.NE.8) GO TO 50
    +
    73 C
    +
    74 C*** PRESSURE, MILLIBARS ...............
    +
    75 C
    +
    76  cnst(1) = 0.
    +
    77  cnst(2) = 1.
    +
    78  cnst(3) = 4.
    +
    79  cnst(4) = 0.
    +
    80 C
    +
    81 C*** IF SFC OR TROPOPAUSE PRESSURE ..
    +
    82 C
    +
    83  IF ((itypes .EQ. 129) .OR. (itypes .EQ. 130)) cnst(3) = 25.
    +
    84  RETURN
    +
    85 C
    +
    86  50 CONTINUE
    +
    87  DO 60 i = 16,21
    +
    88  IF (q.EQ.i) GO TO 70
    +
    89  60 CONTINUE
    +
    90  GO TO 80
    +
    91 C
    +
    92  70 CONTINUE
    +
    93 C
    +
    94 C*** TEMPERATURES (DEG K) CONVERT TO DEG C, EXCEPT FOR POTENTIAL TEMP.
    +
    95 C
    +
    96  cnst(1) = -273.15
    +
    97  cnst(2) = 1.
    +
    98  cnst(3) = 5.
    +
    99  cnst(4) = 0.
    +
    100  IF (itypeq .EQ. 19) cnst(1) = 0.
    +
    101  RETURN
    +
    102 C
    +
    103  80 CONTINUE
    +
    104  IF (q.NE.40) GO TO 90
    +
    105 C
    +
    106 C*** VERTICAL VELOCITY (MB/SEC) TO MICROBARS/SEC
    +
    107 C*** SIGN CHANGED SUCH THAT POSITIVE VALUES INDICATE UPWARD MOTION.
    +
    108 C
    +
    109  cnst(1) = 0.
    +
    110  cnst(2) = -1.e3
    +
    111  cnst(3) = 2.
    +
    112  cnst(4) = 0.
    +
    113  RETURN
    +
    114 C
    +
    115  90 CONTINUE
    +
    116  IF (q.NE.41) GO TO 100
    +
    117 C
    +
    118 C*** NET VERTICAL DISPLACEMENT ... MILLIBARS
    +
    119 C
    +
    120  cnst(1) = 0.
    +
    121  cnst(2) = 1.
    +
    122  cnst(3) = 10.
    +
    123  cnst(4) = 0.
    +
    124  RETURN
    +
    125 C
    +
    126  100 CONTINUE
    +
    127  DO 110 i = 48,51
    +
    128  IF (q.EQ.i) GO TO 120
    +
    129  110 CONTINUE
    +
    130  GO TO 130
    +
    131 C
    +
    132  120 CONTINUE
    +
    133 C
    +
    134 C*** WIND SPEEDS M/SEC
    +
    135 C
    +
    136  cnst(1) = 0.
    +
    137  cnst(2) = 1.
    +
    138  cnst(3) = 10.
    +
    139  cnst(4) = 0.
    +
    140  RETURN
    +
    141 C
    +
    142  130 CONTINUE
    +
    143  IF (q.NE.52) GO TO 140
    +
    144 C
    +
    145 C*** VERTICAL SPEED SHEAR(/ SEC)... TO BE CONVERTED TO KNOTS/1000 FT
    +
    146 C
    +
    147  cnst(1) = 0.
    +
    148  cnst(2) = 592.086
    +
    149  cnst(3) = 2.
    +
    150  cnst(4) = 0.
    +
    151  RETURN
    +
    152 C
    +
    153  140 CONTINUE
    +
    154  IF (q.NE.53.AND.q.NE.54) GO TO 150
    +
    155 C
    +
    156 C*** DIVERGENT U AND V COMPONENTS M/SEC
    +
    157 C
    +
    158  cnst(1) = 0.
    +
    159  cnst(2) = 1.
    +
    160  cnst(3) = 2.
    +
    161  cnst(4) = 0.
    +
    162  RETURN
    +
    163 C
    +
    164  150 CONTINUE
    +
    165  IF (q.NE.72.AND.q.NE.73) GO TO 160
    +
    166 C
    +
    167 C*** VORTICITY (APPROX 10**-5) TIMES 10**6 /SEC
    +
    168 C
    +
    169  cnst(1) = 0.
    +
    170  cnst(2) = 1.e6
    +
    171  cnst(3) = 40.
    +
    172  cnst(4) = 0.
    +
    173  RETURN
    +
    174 C
    +
    175  160 CONTINUE
    +
    176  IF (q.NE.74) GO TO 170
    +
    177 C
    +
    178 C*** DIVERGENCE (/SEC) TIMES 10**6
    +
    179 C
    +
    180  cnst(1) = 0.
    +
    181  cnst(2) = 1.e6
    +
    182  cnst(3) = 20.
    +
    183  cnst(4) = 0.
    +
    184  RETURN
    +
    185 C
    +
    186  170 CONTINUE
    +
    187  IF (q.NE.80.AND.q.NE.81) GO TO 180
    +
    188 C
    +
    189 C*** STREAM FUNCTION OR VELOCITY POTENTIAL (M*M/SEC) CONVERTED TO M.
    +
    190 C*** CONVERT TO METERS. (M*M/SEC * FOG)
    +
    191 C
    +
    192  cnst(1) = 0.
    +
    193  cnst(2) = 1.03125e-4 / 9.8
    +
    194  cnst(3) = 60.
    +
    195  cnst(4) = 0.
    +
    196  IF ((ilvl.LT.500) .AND. (itypec .EQ. 0)) cnst(3) = 120.
    +
    197  RETURN
    +
    198 C
    +
    199  180 CONTINUE
    +
    200  IF (q.NE.88) GO TO 190
    +
    201 C
    +
    202 C*** RELATIVE HUMIDITY ... PERCENT
    +
    203 C
    +
    204  cnst(1) = 0.
    +
    205  cnst(2) = 1.
    +
    206  cnst(3) = 10.
    +
    207  cnst(4) = 0.
    +
    208  RETURN
    +
    209 C
    +
    210  190 CONTINUE
    +
    211  IF (q.NE.89) GO TO 200
    +
    212 C
    +
    213 C*** PRECIPITABLE WATER (KG/M*M) OR .1 GRAM/CM*CM OR MILLIMETERS/CM*CM
    +
    214 C*** CHANGE TO CENTI-INCHES/CM*CM
    +
    215 C
    +
    216  cnst(1) = 0.
    +
    217  cnst(2) = 3.937
    +
    218  cnst(3) = 5.
    +
    219  cnst(4) = 0.
    +
    220  RETURN
    +
    221 C
    +
    222  200 CONTINUE
    +
    223  IF (q.NE.90) GO TO 210
    +
    224 C
    +
    225 C*** ACCUMULATED PRECIPITATION (METERS) TO CENTI-INCHES, AT 1/2 IN.
    +
    226 C
    +
    227  cnst(1) = 0.
    +
    228  cnst(2) = 3937.
    +
    229  cnst(3) = 50.
    +
    230  cnst(4) = 0.
    +
    231  RETURN
    +
    232 C
    +
    233  210 CONTINUE
    +
    234  IF (q.NE.91.AND.q.NE.92) GO TO 220
    +
    235 C
    +
    236 C*** PROBABILITY ... PERCENT
    +
    237 C
    +
    238  cnst(1) = 0.
    +
    239  cnst(2) = 1.
    +
    240  cnst(3) = 10.
    +
    241  cnst(4) = 0.
    +
    242  RETURN
    +
    243 C
    +
    244  220 CONTINUE
    +
    245  IF (q.NE.93) GO TO 230
    +
    246 C
    +
    247 C*** SNOW DEPTH (METERS) TO INCHES, AT INTERVALS OF 6 INCHES
    +
    248 C
    +
    249  cnst(1) = 0.
    +
    250  cnst(2) = 39.37
    +
    251  cnst(3) = 6.
    +
    252  cnst(4) = 0.
    +
    253  RETURN
    +
    254 C
    +
    255  230 CONTINUE
    +
    256  IF (q.NE.112) GO TO 240
    +
    257 C
    +
    258 C*** LIFTED INDEX ..(DEG K) TO DEG C.
    +
    259 C
    +
    260  cnst(1) = -273.15
    +
    261  cnst(2) = 1.
    +
    262  cnst(3) = 2.
    +
    263  cnst(4) = 0.
    +
    264  RETURN
    +
    265 C
    +
    266  240 CONTINUE
    +
    267  IF (q.NE.120.AND.q.NE.121) GO TO 250
    +
    268 C
    +
    269 C*** WAVE COMPONENT OF GEOPOTENTIAL (GEOP M)
    +
    270 C
    +
    271  cnst(1) = 0.
    +
    272  cnst(2) = 1.
    +
    273  cnst(3) = 10.
    +
    274  cnst(4) = 0.
    +
    275  RETURN
    +
    276 C
    +
    277  250 CONTINUE
    +
    278  IF (q.NE.160) GO TO 260
    +
    279 C
    +
    280 C*** DRAG COEFFICIENT DIMENSIONLESS TIMES 10**5
    +
    281 C
    +
    282  cnst(1) = 0.
    +
    283  cnst(2) = 1.e5
    +
    284  cnst(3) = 100.
    +
    285  cnst(4) = 0.
    +
    286  RETURN
    +
    287 C
    +
    288  260 CONTINUE
    +
    289  IF (q.NE.161) GO TO 270
    +
    290 C
    +
    291 C*** LAND/SEA DIMENSIONLESS
    +
    292 C
    +
    293  cnst(1) = 0.
    +
    294  cnst(2) = 1.
    +
    295  cnst(3) = 1.
    +
    296  cnst(4) = .5
    +
    297  RETURN
    +
    298 C
    +
    299  270 CONTINUE
    +
    300  IF (q.NE.169) GO TO 280
    +
    301 C
    +
    302 C ALBIDO * 100. (DIMENSIONLESS)
    +
    303 C
    +
    304  cnst(1) = 0.
    +
    305  cnst(2) = 100.
    +
    306  cnst(3) = 5.
    +
    307  cnst(4) = 0.
    +
    308  RETURN
    +
    309 C
    +
    310  280 CONTINUE
    +
    311  IF (itypeq .EQ. 384) GO TO 290
    +
    312  IF ((itypeq .GE. 385) .AND. (itypeq .LE. 387)) GO TO 300
    +
    313 C
    +
    314 C*** NONE OF THE ABOVE ....
    +
    315 C
    +
    316  ier = 1
    +
    317  RETURN
    +
    318 C
    +
    319 C*** OCEAN WATER TEMPERATURE (DEGREES K)
    +
    320 C
    +
    321  290 CONTINUE
    +
    322  cnst(1) = 0.
    +
    323  cnst(2) = 1.
    +
    324  cnst(3) = 5.
    +
    325  cnst(4) = 0.
    +
    326  RETURN
    +
    327 C
    +
    328 C*** HEIGHT OF WIND DRIVEN OCEAN WAVES, SEA SWELLS, OR COMBINATION
    +
    329 C
    +
    330  300 CONTINUE
    +
    331  cnst(1) = 0.
    +
    332  cnst(2) = 1.
    +
    333  cnst(3) = 2.
    +
    334  cnst(4) = 0.
    +
    335  RETURN
    +
    336  END
    +
    +
    +
    w3fi52
    subroutine w3fi52(IDENT, CNST, IER)
    Computes the four scaling constants used by grdprt(), w3fp03(), or w3fp05() from the 1st 5 identifier...
    Definition: w3fi52.f:22
    + + + + diff --git a/ver-2.10.0/w3fi58_8f.html b/ver-2.10.0/w3fi58_8f.html new file mode 100644 index 00000000..bafbb2b0 --- /dev/null +++ b/ver-2.10.0/w3fi58_8f.html @@ -0,0 +1,211 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi58.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi58.f File Reference
    +
    +
    + +

    Pack positive differences in least bits. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi58 (IFIELD, NPTS, NWORK, NPFLD, NBITS, LEN, KMIN)
     Converts an array of integer numbers into an array of positive differences (number(s) - minimum value) and packs the magnitude of each difference right-adjusted into the least number of bits that holds the largest difference. More...
     
    +

    Detailed Description

    +

    Pack positive differences in least bits.

    +
    Author
    Robert Allard
    +
    Date
    1987-09-02
    + +

    Definition in file w3fi58.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi58()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi58 (integer, dimension(*) IFIELD,
     NPTS,
    integer, dimension(*) NWORK,
    character*1, dimension(*) NPFLD,
     NBITS,
     LEN,
     KMIN 
    )
    +
    + +

    Converts an array of integer numbers into an array of positive differences (number(s) - minimum value) and packs the magnitude of each difference right-adjusted into the least number of bits that holds the largest difference.

    +

    Program history log:

      +
    • Robert Allard 1987-09-02
      • +
    • Ralph Jones 1988-10-02 Converted to cdc cyber 205 ftn200 fortran.
      • +
    • Ralph Jones 1990-05-17 Converted to cray cft77 fortran.
      • +
    • Ralph Jones 1990-05-18 Change name vbimpk to w3lib name w3fi58()
      • +
    • Mark Iredell 1996-05-14 Generalized computation of nbits.
      • +
    • Ebisuzaki 1998-06-30 Linux port.
      • +
    +
    Parameters
    + + + + + + + + +
    [in]IFIELDArray of integer data for processing.
    [in]NPTSNumber of data values to process in IFIELD (and nwork) where, npts > 0.
    [out]NWORKWork array with integer difference
    [out]NPFLDArray for packed data (character*1) (user is responsible for an adequate dimension.)
    [out]NBITSNumber of bits used to pack data where, 0 < nbits < 32 (the maximum difference without overflow is 2**31 -1)
    [out]LENNumber of packed bytes in npfld (set to 0 if no packing) where, len = (nbits * npts + 7) / 8 without remainder
    [out]KMINMinimum value (subtracted from each datum). If this packed data is being used for grib data, the programer will have to convert the KMIN value to an IBM370 32 bit floating point number.
    +
    +
    +
    Note
    LEN = 0, NBITS = 0, and no packing performed if
      +
    • (1) KMAX = KMIN (a constant field)
      • +
    • (2) NPTS < 1 (see input argument)
      • +
    +
    +
    Author
    Robert Allard
    +
    Date
    1987-09-02
    + +

    Definition at line 39 of file w3fi58.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi58_8f.js b/ver-2.10.0/w3fi58_8f.js new file mode 100644 index 00000000..f2f56bc1 --- /dev/null +++ b/ver-2.10.0/w3fi58_8f.js @@ -0,0 +1,4 @@ +var w3fi58_8f = +[ + [ "w3fi58", "w3fi58_8f.html#a9e29ba5f6e80a0133fdf08c4374d6e5e", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi58_8f_source.html b/ver-2.10.0/w3fi58_8f_source.html new file mode 100644 index 00000000..03450dc2 --- /dev/null +++ b/ver-2.10.0/w3fi58_8f_source.html @@ -0,0 +1,200 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi58.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi58.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Pack positive differences in least bits.
    +
    3 C> @author Robert Allard @date 1987-09-02
    +
    4 
    +
    5 C> Converts an array of integer numbers into an array of
    +
    6 C> positive differences (number(s) - minimum value) and packs the
    +
    7 C> magnitude of each difference right-adjusted into the least
    +
    8 C> number of bits that holds the largest difference.
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - Robert Allard 1987-09-02
    +
    12 C> - Ralph Jones 1988-10-02 Converted to cdc cyber 205 ftn200 fortran.
    +
    13 C> - Ralph Jones 1990-05-17 Converted to cray cft77 fortran.
    +
    14 C> - Ralph Jones 1990-05-18 Change name vbimpk to w3lib name w3fi58()
    +
    15 C> - Mark Iredell 1996-05-14 Generalized computation of nbits.
    +
    16 C> - Ebisuzaki 1998-06-30 Linux port.
    +
    17 C>
    +
    18 C> @param[in] IFIELD Array of integer data for processing.
    +
    19 C> @param[in] NPTS Number of data values to process in IFIELD (and nwork)
    +
    20 C> where, npts > 0.
    +
    21 C> @param[out] NWORK Work array with integer difference
    +
    22 C> @param[out] NPFLD Array for packed data (character*1)
    +
    23 C> (user is responsible for an adequate dimension.)
    +
    24 C> @param[out] NBITS Number of bits used to pack data where, 0 < nbits < 32
    +
    25 C> (the maximum difference without overflow is 2**31 -1)
    +
    26 C> @param[out] LEN Number of packed bytes in npfld (set to 0 if no packing)
    +
    27 C> where, len = (nbits * npts + 7) / 8 without remainder
    +
    28 C> @param[out] KMIN Minimum value (subtracted from each datum). If this
    +
    29 C> packed data is being used for grib data, the
    +
    30 C> programer will have to convert the KMIN value to an
    +
    31 C> IBM370 32 bit floating point number.
    +
    32 C>
    +
    33 C> @note LEN = 0, NBITS = 0, and no packing performed if
    +
    34 C> - (1) KMAX = KMIN (a constant field)
    +
    35 C> - (2) NPTS < 1 (see input argument)
    +
    36 C>
    +
    37 C> @author Robert Allard @date 1987-09-02
    +
    38  SUBROUTINE w3fi58(IFIELD,NPTS,NWORK,NPFLD,NBITS,LEN,KMIN)
    +
    39 C
    +
    40  parameter(alog2=0.69314718056)
    +
    41  INTEGER IFIELD(*)
    +
    42  CHARACTER*1 NPFLD(*)
    +
    43  INTEGER NWORK(*)
    +
    44 C
    +
    45  DATA kzero / 0 /
    +
    46 C
    +
    47 C / / / / / /
    +
    48 C
    +
    49  len = 0
    +
    50  nbits = 0
    +
    51  IF (npts.LE.0) GO TO 3000
    +
    52 C
    +
    53 C FIND THE MAX-MIN VALUES IN INTEGER FIELD (IFIELD).
    +
    54 C
    +
    55  kmax = ifield(1)
    +
    56  kmin = kmax
    +
    57  DO 1000 i = 2,npts
    +
    58  kmax = max(kmax,ifield(i))
    +
    59  kmin = min(kmin,ifield(i))
    +
    60  1000 CONTINUE
    +
    61 C
    +
    62 C IF A CONSTANT FIELD, RETURN WITH NO PACKING AND 'LEN' AND 'NBITS' SET
    +
    63 C TO ZERO.
    +
    64 C
    +
    65  IF (kmax.EQ.kmin) GO TO 3000
    +
    66 C
    +
    67 C DETERMINE LARGEST DIFFERENCE IN IFIELD AND FLOAT (BIGDIF).
    +
    68 C
    +
    69  bigdif = kmax - kmin
    +
    70 C
    +
    71 C NBITS IS COMPUTED AS THE LEAST INTEGER SUCH THAT
    +
    72 C BIGDIF < 2**NBITS
    +
    73 C
    +
    74  nbits=log(bigdif+0.5)/alog2+1
    +
    75 C
    +
    76 C FORM DIFFERENCES IN NWORK ARRAY.
    +
    77 C
    +
    78  DO 2000 k = 1,npts
    +
    79  nwork(k) = ifield(k) - kmin
    +
    80  2000 CONTINUE
    +
    81 C
    +
    82 C PACK EACH MAGNITUDE IN NBITS (NBITS = THE LEAST POWER OF 2 OR 'N')
    +
    83 C
    +
    84  len=(nbits*npts-1)/8+1
    +
    85  CALL sbytesc(npfld,nwork,0,nbits,0,npts)
    +
    86 C
    +
    87 C ADD ZERO-BITS AT END OF PACKED DATA TO INSURE A BYTE BOUNDARY.
    +
    88 C
    +
    89  noff = nbits * npts
    +
    90  nzero=len*8-noff
    +
    91  IF(nzero.GT.0) CALL sbytec(npfld,kzero,noff,nzero)
    +
    92 C
    +
    93  3000 CONTINUE
    +
    94  RETURN
    +
    95 C
    +
    96  END
    +
    +
    +
    w3fi58
    subroutine w3fi58(IFIELD, NPTS, NWORK, NPFLD, NBITS, LEN, KMIN)
    Converts an array of integer numbers into an array of positive differences (number(s) - minimum value...
    Definition: w3fi58.f:39
    +
    sbytesc
    subroutine sbytesc(OUT, IN, ISKIP, NBYTE, NSKIP, N)
    Store bytes - pack bits: Put arbitrary size values into a packed bit string, taking the low order bit...
    Definition: sbytesc.f:17
    +
    sbytec
    subroutine sbytec(OUT, IN, ISKIP, NBYTE)
    This is a wrapper for sbytesc()
    Definition: sbytec.f:14
    + + + + diff --git a/ver-2.10.0/w3fi59_8f.html b/ver-2.10.0/w3fi59_8f.html new file mode 100644 index 00000000..5826c254 --- /dev/null +++ b/ver-2.10.0/w3fi59_8f.html @@ -0,0 +1,219 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi59.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi59.f File Reference
    +
    +
    + +

    Form and pack positive, scaled differences. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi59 (FIELD, NPTS, NBITS, NWORK, NPFLD, ISCALE, LEN, RMIN)
     Converts an array of single precision real numbers into an array of positive scaled differences (number(s) - minimum value), in integer format and packs the argument-specified number of significant bits from each difference. More...
     
    +

    Detailed Description

    +

    Form and pack positive, scaled differences.

    +
    Author
    Robert Allard
    +
    Date
    1984-08-01
    + +

    Definition in file w3fi59.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi59()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi59 (real, dimension(*) FIELD,
     NPTS,
     NBITS,
    integer, dimension(*) NWORK,
    character*1, dimension(*) NPFLD,
     ISCALE,
     LEN,
     RMIN 
    )
    +
    + +

    Converts an array of single precision real numbers into an array of positive scaled differences (number(s) - minimum value), in integer format and packs the argument-specified number of significant bits from each difference.

    +

    Program history log:

      +
    • Robert Allard 1984-08-01 ALLARD
      • +
    • Ralph Jones 1990-05-17 Convert to cray cft77 fortran.
      • +
    • Ralph Jones 1990-05-18 Change name pakmag to w3lib name w3fi59().
      • +
    • Ralph Jones 1993-07-06 Add nint to do loop 2000 so numbers are rounded to nearest integer, not truncated.
      • +
    • Mark Iredell 1994-01-05 Computation of iscale fixed with respect to the 93-07-06 change.
      • +
    • Ebisuzaki 1998-06-30 Linux port.
      • +
    +
    Parameters
    + + + + + + + + + +
    [in]FIELDArray of floating point data for processing (real)
    [in]NPTSNumber of data values to process in field (and nwork) where, npts > 0
    [in]NBITSNumber of significant bits of processed data to be packed where, 0 < nbits < 32+1
    [out]NWORKArray for integer conversion (integer) if packing performed (see note below), the array will contain the pre-packed, right adjusted, scaled, integer differences upon return to the user. (the user may equivalence field and nwork. Same size.)
    [out]NPFLDArray for packed data (character*1) (dimension must be at least (nbits * npts) / 64 + 1)
    [out]ISCALEPower of 2 for restoring data, such that datum = (difference * 2**iscale) + rmin
    [out]LENNumber of packed bytes in npfld (set to 0 if no packing) where, len = (nbits * npts + 7) / 8 without remainder
    [out]RMINMinimum value (reference value subtracted from input data) this is a cray floating point number, it will have to be converted to an ibm370 32 bit floating point number at some point in your program if you are packing grib data.
    +
    +
    +
    Note
    : Len = 0 and no packing performed if
      +
    • (1) RMAX = RMIN (a constant field)
      • +
    • (2) NBITS value out of range (see input argument)
      • +
    • (3) NPTS value less than 1 (see input argument)
      • +
    +
    +
    Author
    Robert Allard
    +
    Date
    1984-08-01
    + +

    Definition at line 48 of file w3fi59.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi59_8f.js b/ver-2.10.0/w3fi59_8f.js new file mode 100644 index 00000000..8df331b3 --- /dev/null +++ b/ver-2.10.0/w3fi59_8f.js @@ -0,0 +1,4 @@ +var w3fi59_8f = +[ + [ "w3fi59", "w3fi59_8f.html#ab4f28b2c5e95c681036ef83142a58601", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi59_8f_source.html b/ver-2.10.0/w3fi59_8f_source.html new file mode 100644 index 00000000..27e4ad33 --- /dev/null +++ b/ver-2.10.0/w3fi59_8f_source.html @@ -0,0 +1,223 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi59.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi59.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Form and pack positive, scaled differences.
    +
    3 C> @author Robert Allard @date 1984-08-01
    +
    4 
    +
    5 C> Converts an array of single precision real numbers into
    +
    6 C> an array of positive scaled differences (number(s) - minimum value),
    +
    7 C> in integer format and packs the argument-specified number of
    +
    8 C> significant bits from each difference.
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - Robert Allard 1984-08-01 ALLARD
    +
    12 C> - Ralph Jones 1990-05-17 Convert to cray cft77 fortran.
    +
    13 C> - Ralph Jones 1990-05-18 Change name pakmag to w3lib name w3fi59().
    +
    14 C> - Ralph Jones 1993-07-06 Add nint to do loop 2000 so numbers are
    +
    15 C> rounded to nearest integer, not truncated.
    +
    16 C> - Mark Iredell 1994-01-05 Computation of iscale fixed with respect to
    +
    17 C> the 93-07-06 change.
    +
    18 C> - Ebisuzaki 1998-06-30 Linux port.
    +
    19 C>
    +
    20 C> @param[in] FIELD Array of floating point data for processing (real)
    +
    21 C> @param[in] NPTS Number of data values to process in field (and nwork)
    +
    22 C> where, npts > 0
    +
    23 C> @param[in] NBITS Number of significant bits of processed data to be packed
    +
    24 C> where, 0 < nbits < 32+1
    +
    25 C> @param[out] NWORK Array for integer conversion (integer)
    +
    26 C> if packing performed (see note below), the array will
    +
    27 C> contain the pre-packed, right adjusted, scaled, integer
    +
    28 C> differences upon return to the user.
    +
    29 C> (the user may equivalence field and nwork. Same size.)
    +
    30 C> @param[out] NPFLD Array for packed data (character*1)
    +
    31 C> (dimension must be at least (nbits * npts) / 64 + 1)
    +
    32 C> @param[out] ISCALE Power of 2 for restoring data, such that
    +
    33 C> datum = (difference * 2**iscale) + rmin
    +
    34 C> @param[out] LEN Number of packed bytes in npfld (set to 0 if no packing)
    +
    35 C> where, len = (nbits * npts + 7) / 8 without remainder
    +
    36 C> @param[out] RMIN Minimum value (reference value subtracted from input data)
    +
    37 C> this is a cray floating point number, it will have to be
    +
    38 C> converted to an ibm370 32 bit floating point number at
    +
    39 C> some point in your program if you are packing grib data.
    +
    40 C>
    +
    41 C> @note: Len = 0 and no packing performed if
    +
    42 C> - (1) RMAX = RMIN (a constant field)
    +
    43 C> - (2) NBITS value out of range (see input argument)
    +
    44 C> - (3) NPTS value less than 1 (see input argument)
    +
    45 C>
    +
    46 C> @author Robert Allard @date 1984-08-01
    +
    47  SUBROUTINE w3fi59(FIELD,NPTS,NBITS,NWORK,NPFLD,ISCALE,LEN,RMIN)
    +
    48 C NATURAL LOGARITHM OF 2 AND 0.5 PLUS NOMINAL SAFE EPSILON
    +
    49  parameter(alog2=0.69314718056,hpeps=0.500001)
    +
    50 C
    +
    51  REAL FIELD(*)
    +
    52 C
    +
    53  CHARACTER*1 NPFLD(*)
    +
    54  INTEGER NWORK(*)
    +
    55 C
    +
    56  DATA kzero / 0 /
    +
    57 C
    +
    58 C / / / / / /
    +
    59 C
    +
    60  len = 0
    +
    61  iscale = 0
    +
    62  IF (nbits.LE.0.OR.nbits.GT.32) GO TO 3000
    +
    63  IF (npts.LE.0) GO TO 3000
    +
    64 C
    +
    65 C FIND THE MAX-MIN VALUES IN FIELD.
    +
    66 C
    +
    67  rmax = field(1)
    +
    68  rmin = rmax
    +
    69  DO 1000 k = 2,npts
    +
    70  rmax = amax1(rmax,field(k))
    +
    71  rmin = amin1(rmin,field(k))
    +
    72  1000 CONTINUE
    +
    73 C
    +
    74 C IF A CONSTANT FIELD, RETURN WITH NO PACKING PERFORMED AND 'LEN' = 0.
    +
    75 C
    +
    76  IF (rmax.EQ.rmin) GO TO 3000
    +
    77 C
    +
    78 C DETERMINE LARGEST DIFFERENCE IN FIELD (BIGDIF).
    +
    79 C
    +
    80  bigdif = rmax - rmin
    +
    81 C
    +
    82 C ISCALE IS THE POWER OF 2 REQUIRED TO RESTORE THE PACKED DATA.
    +
    83 C ISCALE IS COMPUTED AS THE LEAST INTEGER SUCH THAT
    +
    84 C BIGDIF*2**(-ISCALE) < 2**NBITS-0.5
    +
    85 C IN ORDER TO ENSURE THAT THE PACKED INTEGERS (COMPUTED IN LOOP 2000
    +
    86 C WITH THE NEAREST INTEGER FUNCTION) STAY LESS THAN 2**NBITS.
    +
    87 C
    +
    88  iscale=nint(alog(bigdif/(2.**nbits-0.5))/alog2+hpeps)
    +
    89 C
    +
    90 C FORM DIFFERENCES, RESCALE, AND CONVERT TO INTEGER FORMAT.
    +
    91 C
    +
    92  twon = 2.0 ** (-iscale)
    +
    93  DO 2000 k = 1,npts
    +
    94  nwork(k) = nint( (field(k) - rmin) * twon )
    +
    95  2000 CONTINUE
    +
    96 C
    +
    97 C PACK THE MAGNITUDES (RIGHTMOST NBITS OF EACH WORD).
    +
    98 C
    +
    99  koff = 0
    +
    100  iskip = 0
    +
    101 C
    +
    102 C USE NCAR ARRAY BIT PACKER SBYTES (GBYTES PACKAGE)
    +
    103 C
    +
    104  CALL sbytesc(npfld,nwork,koff,nbits,iskip,npts)
    +
    105 C
    +
    106 C ADD 7 ZERO-BITS AT END OF PACKED DATA TO INSURE BYTE BOUNDARY.
    +
    107 C USE NCAR WORD BIT PACKER SBYTE
    +
    108 C
    +
    109  noff = nbits * npts
    +
    110  CALL sbytec(npfld,kzero,noff,7)
    +
    111 C
    +
    112 C DETERMINE BYTE LENGTH (LEN) OF PACKED FIELD (NPFLD).
    +
    113 C
    +
    114  len = (noff + 7) / 8
    +
    115 C
    +
    116  3000 CONTINUE
    +
    117  RETURN
    +
    118 C
    +
    119  END
    +
    +
    +
    w3fi59
    subroutine w3fi59(FIELD, NPTS, NBITS, NWORK, NPFLD, ISCALE, LEN, RMIN)
    Converts an array of single precision real numbers into an array of positive scaled differences (numb...
    Definition: w3fi59.f:48
    +
    sbytesc
    subroutine sbytesc(OUT, IN, ISKIP, NBYTE, NSKIP, N)
    Store bytes - pack bits: Put arbitrary size values into a packed bit string, taking the low order bit...
    Definition: sbytesc.f:17
    +
    sbytec
    subroutine sbytec(OUT, IN, ISKIP, NBYTE)
    This is a wrapper for sbytesc()
    Definition: sbytec.f:14
    + + + + diff --git a/ver-2.10.0/w3fi61_8f.html b/ver-2.10.0/w3fi61_8f.html new file mode 100644 index 00000000..38bdc5dc --- /dev/null +++ b/ver-2.10.0/w3fi61_8f.html @@ -0,0 +1,227 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi61.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi61.f File Reference
    +
    +
    + +

    Build 40 char communications prefix. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi61 (LOC, ICAT, AREG, IBCKUP, IDATYP, IERR)
     Using information from the user, build a 40 character communications prefix and place in indicated location. More...
     
    +

    Detailed Description

    +

    Build 40 char communications prefix.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-06-21
    + +

    Definition in file w3fi61.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi61()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi61 (integer, dimension(*) LOC,
    integer ICAT,
    character*6 AREG,
    integer IBCKUP,
    integer IDATYP,
    integer IERR 
    )
    +
    + +

    Using information from the user, build a 40 character communications prefix and place in indicated location.

    +

    Program history log:

      +
    • Bill Cavanaugh 1991-06-21
      • +
    • Ralph Jones 1991-09-20 Changes for silicongraphics 3.3 fortran 77.
      • +
    • Ralph Jones 1993-03-29 Add save statement.
      • +
    • Ralph Jones 1994-04-28 Change for cray 64 bit word size and for ASCII character set computers.
      • +
    • Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
      • +
    +
    Parameters
    + + + + + + + +
    [in]ICATCatalog number.
    [in]AREGAFOS regional addressing flags (6 positions) select any or all of the following. Selections will automatically be left justified and blank filled to 6 positions. If bulletins and/or messages are not to be routed to AFOS, then leave the field filled with blanks.
      +
    • E - Eastern region
      • +
    • C - Central region
      • +
    • W - Western region
      • +
    • S - Southern region
      • +
    • A - Atlantic region
      • +
    • P - Pacific region
      • +
    +
    [in]IERRError return.
    [in]IBCKUPBackup indicator w/header key
      +
    • 0 = Not a backup.
      • +
    • 1 = FD backup.
      • +
    • 2 = DF backup.
        +
      • Back up is only permitted for KU and KU bulletins.
        • +
      +
      • +
    +
    [in]IDATYPData type indicator.
      +
    • 0 = EBCIDIC data.
      • +
    • 11 = Binary data.
      • +
    • 12 = Psuedo-ASCII data.
      • +
    • 3 = ASCII data.
      • +
    +
    [out]LOCName of the array to receive the communications prefix.
    +
    +
    +
    Note
    Error returns IERR:
      +
    • = 0 Normal return.
      • +
    • = 1 Incorrect backup flag.
      • +
    • = 2 A regional addressing flag is non-blank and non-standard entry.
      • +
    • = 3 Data type is non-standard entry.
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-06-21
    + +

    Definition at line 51 of file w3fi61.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi61_8f.js b/ver-2.10.0/w3fi61_8f.js new file mode 100644 index 00000000..2a47e270 --- /dev/null +++ b/ver-2.10.0/w3fi61_8f.js @@ -0,0 +1,4 @@ +var w3fi61_8f = +[ + [ "w3fi61", "w3fi61_8f.html#a1b9630713670570f4aef4d99b284bfec", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi61_8f_source.html b/ver-2.10.0/w3fi61_8f_source.html new file mode 100644 index 00000000..463242ee --- /dev/null +++ b/ver-2.10.0/w3fi61_8f_source.html @@ -0,0 +1,302 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi61.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi61.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Build 40 char communications prefix.
    +
    3 C> @author Bill Cavanaugh @date 1991-06-21
    +
    4 
    +
    5 C> Using information from the user, build a 40 character
    +
    6 C> communications prefix and place in indicated location.
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - Bill Cavanaugh 1991-06-21
    +
    10 C> - Ralph Jones 1991-09-20 Changes for silicongraphics 3.3 fortran 77.
    +
    11 C> - Ralph Jones 1993-03-29 Add save statement.
    +
    12 C> - Ralph Jones 1994-04-28 Change for cray 64 bit word size and
    +
    13 C> for ASCII character set computers.
    +
    14 C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
    +
    15 C>
    +
    16 C> @param[in] ICAT Catalog number.
    +
    17 C> @param[in] AREG AFOS regional addressing flags (6 positions)
    +
    18 C> select any or all of the following. Selections
    +
    19 C> will automatically be left justified and blank
    +
    20 C> filled to 6 positions.
    +
    21 C> If bulletins and/or messages are not to be routed
    +
    22 C> to AFOS, then leave the field filled with blanks.
    +
    23 C> - E - Eastern region
    +
    24 C> - C - Central region
    +
    25 C> - W - Western region
    +
    26 C> - S - Southern region
    +
    27 C> - A - Atlantic region
    +
    28 C> - P - Pacific region
    +
    29 C> @param[in] IERR Error return.
    +
    30 C> @param[in] IBCKUP Backup indicator w/header key
    +
    31 C> - 0 = Not a backup.
    +
    32 C> - 1 = FD backup.
    +
    33 C> - 2 = DF backup.
    +
    34 C> - Back up is only permitted for KU and KU bulletins.
    +
    35 C> @param[in] IDATYP Data type indicator.
    +
    36 C> - 0 = EBCIDIC data.
    +
    37 C> - 11 = Binary data.
    +
    38 C> - 12 = Psuedo-ASCII data.
    +
    39 C> - 3 = ASCII data.
    +
    40 C> @param[out] LOC Name of the array to receive the communications prefix.
    +
    41 C>
    +
    42 C> @note Error returns
    +
    43 C> IERR:
    +
    44 C> - = 0 Normal return.
    +
    45 C> - = 1 Incorrect backup flag.
    +
    46 C> - = 2 A regional addressing flag is non-blank and non-standard entry.
    +
    47 C> - = 3 Data type is non-standard entry.
    +
    48 C>
    +
    49 C> @author Bill Cavanaugh @date 1991-06-21
    +
    50  SUBROUTINE w3fi61 (LOC,ICAT,AREG,IBCKUP,IDATYP,IERR)
    +
    51  INTEGER LOC(*)
    +
    52  INTEGER ICAT,IBCKUP,IDATYP
    +
    53  INTEGER IERR,IHOLD
    +
    54 C
    +
    55  CHARACTER*6 AREG
    +
    56  CHARACTER*8 AHOLD
    +
    57  CHARACTER*6 ARGNL
    +
    58  CHARACTER*1 BLANK
    +
    59 C
    +
    60  LOGICAL IBM370
    +
    61 C
    +
    62  equivalence(ihold,ahold)
    +
    63 C
    +
    64  SAVE
    +
    65 C
    +
    66  DATA argnl /'ECWSAP'/
    +
    67 C
    +
    68 C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE
    +
    69 C COMPUTER, THIS IS THE EBCDIC CHARACTER SET.
    +
    70 C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE
    +
    71 C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER
    +
    72 C SETS TO FIND IBM370 TYPE COMPUTER.
    +
    73 C
    +
    74  DATA blank /' '/
    +
    75  DATA ibm370/.false./
    +
    76 C
    +
    77 C ----------------------------------------------------------------
    +
    78 C
    +
    79 C TEST FOR CRAY 64 BIT COMPUTER, LW = 8
    +
    80 C
    +
    81  CALL w3fi01(lw)
    +
    82 C
    +
    83 C TEST FOR EBCDIC CHARACTER SET
    +
    84 C
    +
    85  IF (mova2i(blank).EQ.64) THEN
    +
    86  ibm370 = .true.
    +
    87  END IF
    +
    88 C
    +
    89  ierr = 0
    +
    90  inofst = 0
    +
    91 C BYTE 1 SOH - START OF HEADER
    +
    92  CALL sbyte (loc,125,inofst,8)
    +
    93  inofst = inofst + 8
    +
    94 C BYTE 2 TRANSMISSION PRIORITY
    +
    95  CALL sbyte (loc,1,inofst,8)
    +
    96  inofst = inofst + 8
    +
    97 C BYTE 3-7 CATALOG NUMBER
    +
    98  IF (icat.GT.0) THEN
    +
    99  IF (lw.EQ.4) THEN
    +
    100  kk = icat / 10
    +
    101  CALL w3ai15 (kk,ihold,1,4,'-')
    +
    102  IF (.NOT.ibm370) CALL w3ai39(ihold,4)
    +
    103  CALL sbyte (loc,ihold,inofst,32)
    +
    104  inofst = inofst + 32
    +
    105  kk = mod(icat,10)
    +
    106  CALL w3ai15 (kk,ihold,1,4,'-')
    +
    107  IF (.NOT.ibm370) CALL w3ai39(ihold,4)
    +
    108  CALL sbyte (loc,ihold,inofst,8)
    +
    109  inofst = inofst + 8
    +
    110  ELSE
    +
    111  CALL w3ai15 (icat,ihold,1,8,'-')
    +
    112  IF (.NOT.ibm370) CALL w3ai39(ihold,8)
    +
    113  CALL sbyte (loc,ihold,inofst,40)
    +
    114  inofst = inofst + 40
    +
    115  END IF
    +
    116  ELSE
    +
    117  CALL sbyte (loc,-252645136,inofst,32)
    +
    118  inofst = inofst + 32
    +
    119  CALL sbyte (loc,240,inofst,8)
    +
    120  inofst = inofst + 8
    +
    121  END IF
    +
    122 C BYTE 8-9-10 BACK-UP FLAG FOR FD OR DF BULLETINS
    +
    123 C 0 = NOT A BACKUP
    +
    124 C 1 = FD
    +
    125 C 2 = DF
    +
    126  IF (ibckup.EQ.0) THEN
    +
    127 C NOT A BACKUP
    +
    128  CALL sbyte (loc,4210752,inofst,24)
    +
    129  inofst = inofst + 24
    +
    130  ELSE IF (ibckup.EQ.1) THEN
    +
    131 C BACKUP FOR FD
    +
    132  CALL sbyte (loc,12764868,inofst,24)
    +
    133  inofst = inofst + 24
    +
    134  ELSE IF (ibckup.EQ.2) THEN
    +
    135 C BACKUP FOR DF
    +
    136  CALL sbyte (loc,12764358,inofst,24)
    +
    137  inofst = inofst + 24
    +
    138  END IF
    +
    139 C BYTE 11 BLANK
    +
    140  CALL sbyte (loc,64,inofst,8)
    +
    141  inofst = inofst + 8
    +
    142 C BYTE 12 DATA TYPE
    +
    143  IF (idatyp.EQ.0) THEN
    +
    144  ELSE IF (idatyp.EQ.11) THEN
    +
    145  ELSE IF (idatyp.EQ.12) THEN
    +
    146  ELSE IF (idatyp.EQ.3) THEN
    +
    147  ELSE
    +
    148  ierr = 3
    +
    149  RETURN
    +
    150  END IF
    +
    151  CALL sbyte (loc,idatyp,inofst,8)
    +
    152  inofst = inofst + 8
    +
    153 C BYTES 13-18 AFOS REGIONAL ADDRESSING FLAGS
    +
    154  CALL sbyte (loc,1077952576,inofst,32)
    +
    155  inofst = inofst + 32
    +
    156  CALL sbyte (loc,1077952576,inofst,16)
    +
    157  kreset = inofst + 16
    +
    158  inofst = inofst - 32
    +
    159  DO 1000 j = 1, 6
    +
    160  DO 900 k = 1, 6
    +
    161  IF (areg(j:j).EQ.argnl(k:k)) THEN
    +
    162 C PRINT *,AREG(J:J),ARGNL(K:K),' MATCH'
    +
    163  ihold = 0
    +
    164  IF (lw.EQ.4) THEN
    +
    165  ahold(4:4) = areg(j:j)
    +
    166  IF (.NOT.ibm370) CALL w3ai39(ihold,4)
    +
    167  ELSE
    +
    168  ahold(8:8) = areg(j:j)
    +
    169  CALL w3ai39(ihold,8)
    +
    170  END IF
    +
    171  CALL sbyte (loc,ihold,inofst,8)
    +
    172  inofst = inofst + 8
    +
    173  GO TO 1000
    +
    174  ELSE IF (areg(j:j).EQ.' ') THEN
    +
    175 C PRINT *,'BLANK SOURCE '
    +
    176  GO TO 1000
    +
    177  END IF
    +
    178  900 CONTINUE
    +
    179  ierr = 2
    +
    180  RETURN
    +
    181  1000 CONTINUE
    +
    182  inofst = kreset
    +
    183 C BYTES 19-39 UNUSED (SET TO BLANK)
    +
    184  DO 1938 i = 1, 20, 4
    +
    185  CALL sbyte (loc,1077952576,inofst,32)
    +
    186  inofst = inofst + 32
    +
    187  1938 CONTINUE
    +
    188 C BYTE 39 MUST BE A BLANK
    +
    189  CALL sbyte (loc,64,inofst,8)
    +
    190  inofst = inofst + 8
    +
    191 C BYTE 40 MUST BE A BLANK
    +
    192  CALL sbyte (loc,64,inofst,8)
    +
    193 C ----------------------------------------------------------------
    +
    194  RETURN
    +
    195  END
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    w3ai39
    subroutine w3ai39(NFLD, N)
    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
    Definition: w3ai39.f:26
    +
    w3fi61
    subroutine w3fi61(LOC, ICAT, AREG, IBCKUP, IDATYP, IERR)
    Using information from the user, build a 40 character communications prefix and place in indicated lo...
    Definition: w3fi61.f:51
    +
    sbyte
    subroutine sbyte(IOUT, IN, ISKIP, NBYTE)
    Definition: sbyte.f:12
    +
    w3ai15
    subroutine w3ai15(NBUFA, NBUFB, N1, N2, MINUS)
    Converts a set of binary numbers to an equivalent set of ascii number fields in core.
    Definition: w3ai15.f:48
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    + + + + diff --git a/ver-2.10.0/w3fi62_8f.html b/ver-2.10.0/w3fi62_8f.html new file mode 100644 index 00000000..93b7b125 --- /dev/null +++ b/ver-2.10.0/w3fi62_8f.html @@ -0,0 +1,201 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi62.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi62.f File Reference
    +
    +
    + +

    Build 80-char on295 queue descriptor. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi62 (LOC, TTAAII, KARY, IERR)
     Build 80 character queue descriptor using information supplied by user, placing the completed queue descriptor in the location specified by the user. More...
     
    +

    Detailed Description

    +

    Build 80-char on295 queue descriptor.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-06-21
    + +

    Definition in file w3fi62.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi62()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi62 (character*80 LOC,
    character*6 TTAAII,
    integer, dimension(7) KARY,
    integer IERR 
    )
    +
    + +

    Build 80 character queue descriptor using information supplied by user, placing the completed queue descriptor in the location specified by the user.

    +

    (based on office note 295).

    +

    PROGRAM HISTORY LOG:

      +
    • Bill Cavanaugh 1991-06-21
      • +
    • Bill Cavanaugh 1994-03-08 Modified to allow for bulletin sizes that exceed 20000 bytes
      • +
    • Ralph Jones 1994-04-28 Change for cray 64 bit word size and for ASCII character set computers
      • +
    • Ralph Jones 1996-01-29 Preset IERR to zero
      • +
    • Boi Vuong 2002-10-15 Replaced function ichar with mova2i
      • +
    +
    Parameters
    + + + + + +
    [in]TTAAIIFirst 6 characters of WMO header
    [in,out]KARYInteger array containing user information
      +
    • (1) = Day of month
      • +
    • (2) = Hour of day
      • +
    • (3) = Hour * 100 + minute
      • +
    • (4) = Catalog number
      • +
    • (5) = Number of 80 byte increments
      • +
    • (6) = Number of bytes in last increment
      • +
    • (7) = Total size of message WMO header + body of message in bytes (not including queue descriptor)
      • +
    +
    [out]LOCLocation to receive queue descriptor
    [out]IERRError return
    +
    +
    +
    Note
    If total size is entered (kary(7)) then kary(5) and kary(6) will be calculated. If kary(5) and kary(6) are provided then kary(7) will be ignored.
    +
    +Equivalence array loc to integer array so it starts on a word boundary for sbyte subroutine.
    +

    Error returns:

      +
    • IERR = 1 Total byte count and/or 80 byte increment count is missing. One or the other is required to complete the queue descriptor.
      • +
    • IERR = 2 Total size too small
      • +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-06-21
    + +

    Definition at line 48 of file w3fi62.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi62_8f.js b/ver-2.10.0/w3fi62_8f.js new file mode 100644 index 00000000..1d5e4b7a --- /dev/null +++ b/ver-2.10.0/w3fi62_8f.js @@ -0,0 +1,4 @@ +var w3fi62_8f = +[ + [ "w3fi62", "w3fi62_8f.html#a0dd3e7a53e1e42357c2579cbe74a4f77", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi62_8f_source.html b/ver-2.10.0/w3fi62_8f_source.html new file mode 100644 index 00000000..1ee3eb94 --- /dev/null +++ b/ver-2.10.0/w3fi62_8f_source.html @@ -0,0 +1,308 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi62.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi62.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Build 80-char on295 queue descriptor.
    +
    3 C> @author Bill Cavanaugh @date 1991-06-21
    +
    4 
    +
    5 C> Build 80 character queue descriptor using information
    +
    6 C> supplied by user, placing the completed queue descriptor in the
    +
    7 C> location specified by the user. (based on office note 295).
    +
    8 C>
    +
    9 C> PROGRAM HISTORY LOG:
    +
    10 C> - Bill Cavanaugh 1991-06-21
    +
    11 C> - Bill Cavanaugh 1994-03-08 Modified to allow for bulletin sizes that
    +
    12 C> exceed 20000 bytes
    +
    13 C> - Ralph Jones 1994-04-28 Change for cray 64 bit word size and
    +
    14 C> for ASCII character set computers
    +
    15 C> - Ralph Jones 1996-01-29 Preset IERR to zero
    +
    16 C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i
    +
    17 C>
    +
    18 C> @param[in] TTAAII First 6 characters of WMO header
    +
    19 C> @param[inout] KARY Integer array containing user information
    +
    20 C> - (1) = Day of month
    +
    21 C> - (2) = Hour of day
    +
    22 C> - (3) = Hour * 100 + minute
    +
    23 C> - (4) = Catalog number
    +
    24 C> - (5) = Number of 80 byte increments
    +
    25 C> - (6) = Number of bytes in last increment
    +
    26 C> - (7) = Total size of message
    +
    27 C> WMO header + body of message in bytes
    +
    28 C> (not including queue descriptor)
    +
    29 C> @param[out] LOC Location to receive queue descriptor
    +
    30 C> @param[out] IERR Error return
    +
    31 C>
    +
    32 C> @note If total size is entered (kary(7)) then kary(5) and
    +
    33 C> kary(6) will be calculated.
    +
    34 C> If kary(5) and kary(6) are provided then kary(7) will
    +
    35 C> be ignored.
    +
    36 C>
    +
    37 C> @note Equivalence array loc to integer array so it starts on
    +
    38 C> a word boundary for sbyte subroutine.
    +
    39 C>
    +
    40 C> Error returns:
    +
    41 C> - IERR = 1 Total byte count and/or 80 byte increment
    +
    42 C> count is missing. One or the other is
    +
    43 C> required to complete the queue descriptor.
    +
    44 C> - IERR = 2 Total size too small
    +
    45 C>
    +
    46 C> @author Bill Cavanaugh @date 1991-06-21
    +
    47  SUBROUTINE w3fi62 (LOC,TTAAII,KARY,IERR)
    +
    48 C
    +
    49  INTEGER IHOLD(2)
    +
    50  INTEGER KARY(7),II,IERR
    +
    51 C
    +
    52  LOGICAL IBM370
    +
    53 C
    +
    54  CHARACTER*6 TTAAII,AHOLD
    +
    55  CHARACTER*80 LOC
    +
    56  CHARACTER*1 BLANK
    +
    57 C
    +
    58  equivalence(ahold,ihold)
    +
    59 C
    +
    60  SAVE
    +
    61 C
    +
    62 C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE
    +
    63 C COMPUTER, THIS IS THE EBCDIC CHARACTER SET.
    +
    64 C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE
    +
    65 C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER
    +
    66 C SETS TO FIND IBM370 TYPE COMPUTER.
    +
    67 C
    +
    68  DATA blank /' '/
    +
    69 C ----------------------------------------------------------------
    +
    70 C
    +
    71 C TEST FOR CRAY 64 BIT COMPUTER, LW = 8
    +
    72 C
    +
    73  CALL w3fi01(lw)
    +
    74 C
    +
    75 C TEST FOR EBCDIC CHARACTER SET
    +
    76 C
    +
    77  ibm370 = .false.
    +
    78  IF (mova2i(blank).EQ.64) THEN
    +
    79  ibm370 = .true.
    +
    80  END IF
    +
    81 C
    +
    82  inofst = 0
    +
    83 C BYTES 1-16 'QUEUE DESCRIPTOR'
    +
    84  CALL sbyte (loc,-656095772,inofst,32)
    +
    85  inofst = inofst + 32
    +
    86  CALL sbyte (loc,-985611067,inofst,32)
    +
    87  inofst = inofst + 32
    +
    88  CALL sbyte (loc,-490481207,inofst,32)
    +
    89  inofst = inofst + 32
    +
    90  CALL sbyte (loc,-672934183,inofst,32)
    +
    91  inofst = inofst + 32
    +
    92 C BYTES 17-20 INTEGER ZEROES
    +
    93  CALL sbyte (loc,0,inofst,32)
    +
    94  inofst = inofst + 32
    +
    95 C IF TOTAL COUNT IS INCLUDED
    +
    96 C THEN WILL DETERMINE THE NUMBER OF
    +
    97 C 80 BYTE INCREMENTS AND WILL DETERMINE
    +
    98 C THE NUMBER OF BYTES IN THE LAST INCREMENT
    +
    99  ierr = 0
    +
    100  IF (kary(7).NE.0) THEN
    +
    101  IF (kary(7).LT.35) THEN
    +
    102 C PRINT *,'LESS THAN MINIMUM SIZE'
    +
    103  ierr = 2
    +
    104  RETURN
    +
    105  END IF
    +
    106  kary(5) = kary(7) / 80
    +
    107  kary(6) = mod(kary(7),80)
    +
    108  IF (kary(6).EQ.0) THEN
    +
    109  kary(6) = 80
    +
    110  ELSE
    +
    111  kary(5) = kary(5) + 1
    +
    112  END IF
    +
    113  ELSE
    +
    114  IF (kary(5).LT.1) THEN
    +
    115  ierr = 1
    +
    116  RETURN
    +
    117  END IF
    +
    118  END IF
    +
    119 C BYTE 21-22 NR OF 80 BYTE INCREMENTS
    +
    120  CALL sbyte (loc,kary(5),inofst,16)
    +
    121  inofst = inofst + 16
    +
    122 C BYTE 23 NR OF BYTES IN LAST INCREMENT
    +
    123  CALL sbyte (loc,kary(6),inofst,8)
    +
    124  inofst = inofst + 8
    +
    125 C BYTES 24-28 INTEGER ZEROES
    +
    126  CALL sbyte (loc,0,inofst,32)
    +
    127  inofst = inofst + 32
    +
    128  CALL sbyte (loc,0,inofst,8)
    +
    129  inofst = inofst + 8
    +
    130 C BYTES 29-34 6 CHAR BULLETIN NAME TTAAII
    +
    131  loc(29:34) = ttaaii(1:6)
    +
    132 C
    +
    133 C IF ON ASCII COMPUTER, CONVERT LAST 6 CHARACTERS TO EBCDIC
    +
    134 C
    +
    135  IF (.NOT.ibm370) CALL w3ai39(loc(29:29),6)
    +
    136 C
    +
    137  inofst = inofst + 48
    +
    138 C BYTES 35-38 DAY OF MONTH AND UTC(Z) HRS
    +
    139 C DAY
    +
    140 C
    +
    141 C NOTE: W3AI15 WILL MAKE ASCII OR EBCDIC CHARACTERS
    +
    142 C DEPENDING ON WHAT TYPE OF COMPUTER IT IS ON
    +
    143 C
    +
    144  CALL w3ai15 (kary(1),ii,1,lw,'-')
    +
    145  CALL sbyte (loc,ii,inofst,16)
    +
    146  inofst = inofst + 16
    +
    147 C HOURS
    +
    148  CALL w3ai15 (kary(2),ii,1,lw,'-')
    +
    149  CALL sbyte (loc,ii,inofst,16)
    +
    150 C
    +
    151 C IF ON ASCII COMPUTER, CONVERT LAST 4 CHARACTERS TO EBCDIC
    +
    152 C
    +
    153  IF (.NOT.ibm370) CALL w3ai39(loc(35:35),4)
    +
    154  inofst = inofst + 16
    +
    155 C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION
    +
    156 C TWO BYTES AS 4 BIT BCD
    +
    157  ka = kary(3) / 1000
    +
    158  kb = mod(kary(3),1000) / 100
    +
    159  kc = mod(kary(3),100) / 10
    +
    160  kd = mod(kary(3),10)
    +
    161  CALL sbyte (loc,ka,inofst,4)
    +
    162  inofst = inofst + 4
    +
    163  CALL sbyte (loc,kb,inofst,4)
    +
    164  inofst = inofst + 4
    +
    165  CALL sbyte (loc,kc,inofst,4)
    +
    166  inofst = inofst + 4
    +
    167  CALL sbyte (loc,kd,inofst,4)
    +
    168  inofst = inofst + 4
    +
    169 C BYTES 41-45 CATALOG NUMBER ELSE (SET TO 55555)
    +
    170  IF (kary(4).GE.1.AND.kary(4).LE.99999) THEN
    +
    171  CALL w3ai15 (kary(4),ihold,1,8,'-')
    +
    172  IF (lw.EQ.4) THEN
    +
    173  CALL sbyte (loc,ihold(1),inofst,8)
    +
    174  inofst = inofst + 8
    +
    175  CALL sbyte (loc,ihold(2),inofst,32)
    +
    176  inofst = inofst + 32
    +
    177 C
    +
    178 C ON CRAY 64 BIT COMPUTER
    +
    179 C
    +
    180  ELSE
    +
    181  CALL sbyte (loc,ihold,inofst,40)
    +
    182  inofst = inofst + 40
    +
    183  END IF
    +
    184 C
    +
    185 C IF ON ASCII COMPUTER, CONVERT LAST 5 CHARACTERS TO EBCDIC
    +
    186 C
    +
    187  IF (.NOT.ibm370) CALL w3ai39(loc(41:41),5)
    +
    188  ELSE
    +
    189  CALL sbyte (loc,-168430091,inofst,32)
    +
    190  inofst = inofst + 32
    +
    191  CALL sbyte (loc,245,inofst,8)
    +
    192  inofst = inofst + 8
    +
    193  END IF
    +
    194 C BYTES 46-80 INTEGER ZEROES
    +
    195  DO 4676 i = 1, 8
    +
    196  CALL sbyte (loc,0,inofst,32)
    +
    197  inofst = inofst + 32
    +
    198  4676 CONTINUE
    +
    199  CALL sbyte (loc,0,inofst,24)
    +
    200  RETURN
    +
    201  END
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    w3ai39
    subroutine w3ai39(NFLD, N)
    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
    Definition: w3ai39.f:26
    +
    sbyte
    subroutine sbyte(IOUT, IN, ISKIP, NBYTE)
    Definition: sbyte.f:12
    +
    w3ai15
    subroutine w3ai15(NBUFA, NBUFB, N1, N2, MINUS)
    Converts a set of binary numbers to an equivalent set of ascii number fields in core.
    Definition: w3ai15.f:48
    +
    w3fi62
    subroutine w3fi62(LOC, TTAAII, KARY, IERR)
    Build 80 character queue descriptor using information supplied by user, placing the completed queue d...
    Definition: w3fi62.f:48
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    + + + + diff --git a/ver-2.10.0/w3fi63_8f.html b/ver-2.10.0/w3fi63_8f.html new file mode 100644 index 00000000..71016b06 --- /dev/null +++ b/ver-2.10.0/w3fi63_8f.html @@ -0,0 +1,1697 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi63.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi63.f File Reference
    +
    +
    + +

    Unpack GRIB field to a GRIB grid. +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

    +Functions/Subroutines

    subroutine fi631 (MSGA, KPTR, KPDS, KRET)
     Find 'grib' chars & reset pointers. More...
     
    subroutine fi632 (MSGA, KPTR, KPDS, KRET)
     Gather info from product definition sec. More...
     
    subroutine fi633 (MSGA, KPTR, KGDS, KRET)
     Extract info from grib-gds. More...
     
    subroutine fi634 (MSGA, KPTR, KPDS, KGDS, KBMS, KRET)
     Extract or generate bit map for output. More...
     
    subroutine fi634x (NPTS, NSKP, MSGA, KBMS)
     Extract bit map. More...
     
    subroutine fi635 (MSGA, KPTR, KPDS, KGDS, KBMS, DATA, KRET)
     Extract grib data elements from bds. More...
     
    subroutine fi636 (DATA, MSGA, KBMS, REFNCE, KPTR, KPDS, KGDS)
     Process second order packing. More...
     
    subroutine fi637 (J, KPDS, KGDS, KRET)
     Grib grid/size test. More...
     
    subroutine w3fi63 (MSGA, KPDS, KGDS, KBMS, DATA, KPTR, KRET)
     Unpack a GRIB (edition 1) field to the exact grid specified in the GRIB message, isolate the bit map, and make the values of the product descripton section (PDS) and the grid description section (GDS) available in return arrays. More...
     
    +

    Detailed Description

    +

    Unpack GRIB field to a GRIB grid.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13
    + +

    Definition in file w3fi63.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ fi631()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi631 (character*1, dimension(*) MSGA,
    integer, dimension(*) KPTR,
    integer, dimension(*) KPDS,
    integer KRET 
    )
    +
    + +

    Find 'grib' chars & reset pointers.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13 Find 'grib; characters and set pointers to the next byte following 'grib'. If they exist extract counts from gds and bms. Extract count from bds. Determine if sum of counts actually places terminator '7777' at the correct location.
    +

    Program history log:

      +
    • Bill Cavanaugh 1991-09-13
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints.
      • +
    +
    Parameters
    + + + + + +
    [in]MSGAGrib field - "grib" thru "7777"
    [in,out]KPTRArray containing storage for following parameters
      +
    • 1 Total length of grib message
      • +
    • 2 Length of indicator (section 0)
      • +
    • 3 Length of pds (section 1)
      • +
    • 4 Length of gds (section 2)
      • +
    • 5 Length of bms (section 3)
      • +
    • 6 Length of bds (section 4)
      • +
    • 7 Value of current byte
      • +
    • 8 Bit pointer
      • +
    • 9 Grib start bit nr
      • +
    • 10 Grib/grid element count
      • +
    • 11 Nr unused bits at end of section 3
      • +
    • 12 Bit map flag
      • +
    • 13 Nr unused bits at end of section 2
      • +
    • 14 Bds flags
      • +
    • 15 Nr unused bits at end of section 4
      • +
    +
    [out]KPDSArray containing pds elements.
      +
    • 1 Id of center
      • +
    • 2 Model identification
      • +
    • 3 Grid identification
      • +
    • 4 Gds/bms flag
      • +
    • 5 Indicator of parameter
      • +
    • 6 Type of level
      • +
    • 7 Height/pressure , etc of level
      • +
    • 8 Year of century
      • +
    • 9 Month of year
      • +
    • 10 Day of month
      • +
    • 11 Hour of day
      • +
    • 12 Minute of hour
      • +
    • 13 Indicator of forecast time unit
      • +
    • 14 Time range 1
      • +
    • 15 Time range 2
      • +
    • 16 Time range flag
      • +
    • 17 Number included in average
      • +
    +
    [out]KRETError return
    +
    +
    +
    Note
    ERROR RETURNS KRET:
      +
    • 1 NO 'GRIB'
      • +
    • 2 NO '7777' OR MISLOCATED (BY COUNTS)
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13
    + +

    Definition at line 478 of file w3fi63.f.

    + +
    +
    + +

    ◆ fi632()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi632 (character*1, dimension(*) MSGA,
    integer, dimension(*) KPTR,
    integer, dimension(*) KPDS,
    integer KRET 
    )
    +
    + +

    Gather info from product definition sec.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13 Extract information from the product description sec , and generate label information to permit storage in office note 84 format.
    +

    Program history log:

      +
    • Bill Cavanaugh 1991-09-13
      • +
    • Bill Cavanaugh 1993-12-08 Corrected test for edition number instead of version number.
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints.
      • +
    • M. Baldwin 1999-01-20 Modified to handle grid 237.
      • +
    +
    Parameters
    + + + + + +
    [in]MSGAArray containing grib message.
    [in,out]KPTRArray containing storage for following parameters.
      +
    • 1 Total length of grib message
      • +
    • 2 Length of indicator (section 0)
      • +
    • 3 Length of pds (section 1)
      • +
    • 4 Length of gds (section 2)
      • +
    • 5 Length of bms (section 3)
      • +
    • 6 Length of bds (section 4)
      • +
    • 7 Value of current byte
      • +
    • 8 Bit pointer
      • +
    • 9 Grib start bit nr
      • +
    • 10 Grib/grid element count
      • +
    • 11 Nr unused bits at end of section 3
      • +
    • 12 Bit map flag
      • +
    • 13 Nr unused bits at end of section 2
      • +
    • 14 Bds flags
      • +
    • 15 Nr unused bits at end of section 4
      • +
    +
    [out]KPDSArray containing pds elements.
      +
    • 1 Id of center
      • +
    • 2 Model identification
      • +
    • 3 Grid identification
      • +
    • 4 Gds/bms flag
      • +
    • 5 Indicator of parameter
      • +
    • 6 Type of level
      • +
    • 7 Height/pressure , etc of level
      • +
    • 8 Year of century
      • +
    • 9 Month of year
      • +
    • 10 Day of month
      • +
    • 11 Hour of day
      • +
    • 12 Minute of hour
      • +
    • 13 Indicator of forecast time unit
      • +
    • 14 Time range 1
      • +
    • 15 Time range 2
      • +
    • 16 Time range flag
      • +
    • 17 Number included in average
      • +
    • 18
      • +
    • 19
      • +
    • 20 Number missing from avgs/accumulations
      • +
    • 21 Century
      • +
    • 22 Units decimal scale factor
      • +
    • 23 Subcenter
      • +
    +
    [out]KRETError return.
    +
    +
    +
    Note
    ERROR RETURN:
      +
    • 0 - NO ERRORS
      • +
    • 8 - TEMP GDS INDICATED, BUT NO GDS
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13
    + +

    Definition at line 635 of file w3fi63.f.

    + +
    +
    + +

    ◆ fi633()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi633 (character*1, dimension(*) MSGA,
    integer, dimension(*) KPTR,
    integer, dimension(*) KGDS,
    integer KRET 
    )
    +
    + +

    Extract info from grib-gds.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13 Extract information on unlisted grid to allow conversion to office note 84 format.
    +

    Program history log:

      +
    • Bill Cavanaugh 1991-09-13
      • +
    • M. Baldwin 1995-03-20 fi633 modification to get data rep types [kgds(1)] 201 and 202 to work.
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    • M. Baldwin 1998-09-08 Add data rep type [kgds(1)] 203
      • +
    • Boi Vuong 2007-04-24 Add data rep type [kgds(1)] 204
      • +
    • George Gayno 2010-07-20 Add data rep type [kgds(1)] 205
      • +
    +
    Parameters
    + + + + +
    [in]MSGAArray containing grib message
    [in,out]KPTRArray containing storage for following parameters
      +
    • 1 Total length of grib message
      • +
    • 2 Length of indicator (section 0)
      • +
    • 3 Length of pds (section 1)
      • +
    • 4 Length of gds (section 2)
      • +
    • 5 Length of bms (section 3)
      • +
    • 6 Length of bds (section 4)
      • +
    • 7 Value of current byte
      • +
    • 8 Bit pointer
      • +
    • 9 Grib start bit nr
      • +
    • 10 Grib/grid element count
      • +
    • 11 Nr unused bits at end of section 3
      • +
    • 12 Bit map flag
      • +
    • 13 Nr unused bits at end of section 2
      • +
    • 14 Bds flags
      • +
    • 15 Nr unused bits at end of section 4
      • +
    +
    [out]KGDSArray containing gds elements.
      +
    • 1) Data representation type
      • +
    • 19 Number of vertical coordinate parameters
      • +
    • 20 Octet number of the list of vertical coordinate parameters Or Octet number of the list of numbers of points in each row Or 255 if neither are present.
      • +
    • 21 For grids with pl, number of points in grid
      • +
    • 22 Number of words in each row
      • +
    +
    +
    +
    +
      +
    • Longitude grids
        +
      • 2) N(i) nr points on latitude circle
        • +
      • 3) N(j) nr points on longitude meridian
        • +
      • 4) La(1) latitude of origin
        • +
      • 5) Lo(1) longitude of origin
        • +
      • 6) Resolution flag
        • +
      • 7) La(2) latitude of extreme point
        • +
      • 8) Lo(2) longitude of extreme point
        • +
      • 9) Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag
        • +
      +
      • +
    • Polar stereographic grids
        +
      • 2) N(i) nr points along lat circle
        • +
      • 3) N(j) nr points along lon circle
        • +
      • 4) La(1) latitude of origin
        • +
      • 5) Lo(1) longitude of origin
        • +
      • 6) Reserved
        • +
      • 7) Lov grid orientation
        • +
      • 8) Dx - x direction increment
        • +
      • 9) Dy - y direction increment
        • +
      • 10 Projection center flag
        • +
      • 11 Scanning mode
        • +
      +
      • +
    • Spherical harmonic coefficients
        +
      • 2 J pentagonal resolution parameter
        • +
      • 3 K pentagonal resolution parameter
        • +
      • 4 M pentagonal resolution parameter
        • +
      • 5 Representation type
        • +
      • 6 Coefficient storage mode
        • +
      +
      • +
    • Mercator grids
        +
      • 2 N(i) nr points on latitude circle
        • +
      • 3 N(j) nr points on longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag
        • +
      • 7 La(2) latitude of last grid point
        • +
      • 8 Lo(2) longitude of last grid point
        • +
      • 9 Latin - latitude of projection intersection
        • +
      • 10 Reserved
        • +
      • 11 Scanning mode flag
        • +
      • 12 Longitudinal dir grid length
        • +
      • 13 Latitudinal dir grid length
        • +
      +
      • +
    • Lambert conformal grids
        +
      • 2 Nx nr points along x-axis
        • +
      • 3 Ny nr points along y-axis
        • +
      • 4 La1 lat of origin (lower left)
        • +
      • 5 Lo1 lon of origin (lower left)
        • +
      • 6 Resolution (right adj copy of octet 17)
        • +
      • 7 Lov - orientation of grid
        • +
      • 8 Dx - x-dir increment
        • +
      • 9 Dy - y-dir increment
        • +
      • 10 Projection center flag
        • +
      • 11 Scanning mode flag
        • +
      • 12 Latin 1 - first lat from pole of secant cone inter
        • +
      • 13 Latin 2 - second lat from pole of secant cone inter
        • +
      +
      • +
    • Staggered arakawa rotated lat/lon grids (203 e stagger)
        +
      • 2 N(i) nr points on rotated latitude circle
        • +
      • 3 N(j) nr points on rotated longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag
        • +
      • 7 La(2) latitude of center
        • +
      • 8 Lo(2) longitude of center
        • +
      • 9 Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag
        • +
      +
      • +
    • Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
        +
      • 2 N(i) nr points on rotated latitude circle
        • +
      • 3 N(j) nr points on rotated longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag
        • +
      • 7 La(2) latitude of center
        • +
      • 8 Lo(2) longitude of center
        • +
      • 9 Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag
        • +
      • 12 Latitude of last point
        • +
      • 13 Longitude of last point
        Parameters
        + + +
        [out]KRETError return
        +
        +
        +
        Note
        +
        • +
      +
      • +
    • KRET
        +
      • 0
        • +
      • 4 - Data representation type not currently acceptable
        • +
      +
      • +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13
    + +

    Definition at line 981 of file w3fi63.f.

    + +
    +
    + +

    ◆ fi634()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi634 (character*1, dimension(*) MSGA,
    integer, dimension(*) KPTR,
    integer, dimension(*) KPDS,
    integer, dimension(*) KGDS,
    logical*1, dimension(*) KBMS,
    integer KRET 
    )
    +
    + +

    Extract or generate bit map for output.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13 If bit map sec is available in grib message, extract for program use, otherwise generate an appropriate bit map.
    +

    Program history log:

      +
    • Bill Cavanaugh 1991-09-13
      • +
    • Bill Cavanaugh 1991-11-12 Modified size of ecmwf grids 5 - 8.
      • +
    • Mark Iredell 1995-10-31 removed saves and prints
      • +
    • W. Bostelman 1997-02-12 corrects ecmwf us grid 2 processing
      • +
    • Mark Iredell 1997-09-19 vectorized bitmap decoder
      • +
    • Stephen Gilbert 1998-09-02 corrected error in map size for u.s. grid 92
      • +
    • M. Baldwin 1998-09-08 add grids 190,192
      • +
    • M. Baldwin 1999-01-20 add grids 236,237
      • +
    • Eric Rogers 2001-10-02 redefined grid #218 for 12 km eta redefined grid 192 for new 32-km eta grid
      • +
    • Stephen Gilbert 2003-06-30 added grids 145 and 146 for cmaq and grid 175 for awips over guam.
      • +
    • Boi Vuong 2004-09-02 Added awips grids 147, 148, 173 and 254
      • +
    • Boi Vuong 2006-12-12 Added awips grids 120
      • +
    • Boi Vuong 2007-04-20 Added awips grids 176
      • +
    • Boi Vuong 2007-06-11 Added awips grids 11 to 18 and 122 to 125 and 180 to 183
      • +
    • Boi Vuong 2010-08-05 Added new grid 184, 199, 83 and redefined grid 90 for new rtma conus 1.27-km redefined grid 91 for new rtma alaska 2.976-km redefined grid 92 for new rtma alaska 1.488-km
      • +
    • Boi Vuong 2012-02-28 Added new grid 200
      • +
    +
    Parameters
    + + + + + +
    [in]MSGABufr message
    [in,out]KPTRArray containing storage for following parameters
      +
    • 1 Total length of grib message
      • +
    • 2 Length of indicator (section 0)
      • +
    • 3 Length of pds (section 1)
      • +
    • 4 Length of gds (section 2)
      • +
    • 5 Length of bms (section 3)
      • +
    • 6 Length of bds (section 4)
      • +
    • 7 Value of current byte
      • +
    • 8 Bit pointer
      • +
    • 9 Grib start bit nr
      • +
    • 10 Grib/grid element count
      • +
    • 11 Nr unused bits at end of section 3
      • +
    • 12 Bit map flag
      • +
    • 13 Nr unused bits at end of section 2
      • +
    • 14 Bds flags
      • +
    • 15 Nr unused bits at end of section 4
      • +
    +
    [in]KPDSArray containing pds elements.
      +
    • 1 Id of center
      • +
    • 2 Model identification
      • +
    • 3 Grid identification
      • +
    • 4 Gds/bms flag
      • +
    • 5 Indicator of parameter
      • +
    • 6 Type of level
      • +
    • 7 Height/pressure , etc of level
      • +
    • 8 Year of century
      • +
    • 9 Month of year
      • +
    • 10 Day of month
      • +
    • 11 Hour of day
      • +
    • 12 Minute of hour
      • +
    • 13 Indicator of forecast time unit
      • +
    • 14 Time range 1
      • +
    • 15 Time range 2
      • +
    • 16 Time range flag
      • +
    • 17 Number included in average
      • +
    +
    [in]KGDSArray containing gds elements.
      +
    • 1) Data representation type
      • +
    • 19 Number of vertical coordinate parameters
      • +
    • 20 Octet number of the list of vertical coordinate parameters Or Octet number of the list of numbers of points in each row Or 255 if neither are present.
      • +
    • 21 For grids with pl, number of points in grid
      • +
    • 22 Number of words in each row
      • +
    +
    +
    +
    +
      +
    • Longitude grids
        +
      • 2) N(i) nr points on latitude circle
        • +
      • 3) N(j) nr points on longitude meridian
        • +
      • 4) La(1) latitude of origin
        • +
      • 5) Lo(1) longitude of origin
        • +
      • 6) Resolution flag
        • +
      • 7) La(2) latitude of extreme point
        • +
      • 8) Lo(2) longitude of extreme point
        • +
      • 9) Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag
        • +
      +
      • +
    • Polar stereographic grids
        +
      • 2) N(i) nr points along lat circle
        • +
      • 3) N(j) nr points along lon circle
        • +
      • 4) La(1) latitude of origin
        • +
      • 5) Lo(1) longitude of origin
        • +
      • 6) Reserved
        • +
      • 7) Lov grid orientation
        • +
      • 8) Dx - x direction increment
        • +
      • 9) Dy - y direction increment
        • +
      • 10 Projection center flag
        • +
      • 11 Scanning mode
        • +
      +
      • +
    • Spherical harmonic coefficients
        +
      • 2 J pentagonal resolution parameter
        • +
      • 3 K pentagonal resolution parameter
        • +
      • 4 M pentagonal resolution parameter
        • +
      • 5 Representation type
        • +
      • 6 Coefficient storage mode
        • +
      +
      • +
    • Mercator grids
        +
      • 2 N(i) nr points on latitude circle
        • +
      • 3 N(j) nr points on longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag
        • +
      • 7 La(2) latitude of last grid point
        • +
      • 8 Lo(2) longitude of last grid point
        • +
      • 9 Latin - latitude of projection intersection
        • +
      • 10 Reserved
        • +
      • 11 Scanning mode flag
        • +
      • 12 Longitudinal dir grid length
        • +
      • 13 Latitudinal dir grid length
        • +
      +
      • +
    • Lambert conformal grids
        +
      • 2 Nx nr points along x-axis
        • +
      • 3 Ny nr points along y-axis
        • +
      • 4 La1 lat of origin (lower left)
        • +
      • 5 Lo1 lon of origin (lower left)
        • +
      • 6 Resolution (right adj copy of octet 17)
        • +
      • 7 Lov - orientation of grid
        • +
      • 8 Dx - x-dir increment
        • +
      • 9 Dy - y-dir increment
        • +
      • 10 Projection center flag
        • +
      • 11 Scanning mode flag
        • +
      • 12 Latin 1 - first lat from pole of secant cone inter
        • +
      • 13 Latin 2 - second lat from pole of secant cone inter
        • +
      +
      • +
    • Staggered arakawa rotated lat/lon grids (203 e stagger)
        +
      • 2 N(i) nr points on rotated latitude circle
        • +
      • 3 N(j) nr points on rotated longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag
        • +
      • 7 La(2) latitude of center
        • +
      • 8 Lo(2) longitude of center
        • +
      • 9 Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag
        • +
      +
      • +
    • Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
        +
      • 2 N(i) nr points on rotated latitude circle
        • +
      • 3 N(j) nr points on rotated longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag
        • +
      • 7 La(2) latitude of center
        • +
      • 8 Lo(2) longitude of center
        • +
      • 9 Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag
        • +
      • 12 Latitude of last point
        • +
      • 13 Longitude of last point
        Parameters
        + + + +
        [out]KBMSBitmap describing location of output elements.
        [out]KRETError return
        +
        +
        +
        Note
        +
        • +
      +
      • +
    • KRET
        +
      • 0 - No error
        • +
      • 5 - Grid not avail for center indicated
        • +
      • 10 - Incorrect center indicator
        • +
      • 12 - Bytes 5-6 are not zero in bms, predefined bit map not provided by this center
        • +
      +
      • +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13
    + +

    Definition at line 1527 of file w3fi63.f.

    + +
    +
    + +

    ◆ fi634x()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi634x ( NPTS,
     NSKP,
    character*1, dimension(*) MSGA,
    logical*1, dimension(npts) KBMS 
    )
    +
    + +

    Extract bit map.

    +
    Author
    Mark Iredell
    +
    Date
    1997-09-19 Extract the packed bitmap into a logical array.
    +

    Program history log: 97-09-19 Vectorized bitmap decoder.

    +
    Parameters
    + + + + + +
    [in]NPTSXInteger number of points in the bitmap field
    [in]NSKPInteger number of bits to skip in grib message
    [in]MSGACharacter*1 grib message
    [out]KBMSLogical*1 bitmap
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment.
    +
    Author
    Mark Iredell
    +
    Date
    1997-09-19
    + +

    Definition at line 2512 of file w3fi63.f.

    + +
    +
    + +

    ◆ fi635()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi635 (character*1, dimension(*) MSGA,
    integer, dimension(*) KPTR,
    integer, dimension(*) KPDS,
    integer, dimension(*) KGDS,
    logical*1, dimension(*) KBMS,
    real, dimension(*) DATA,
     KRET 
    )
    +
    + +

    Extract grib data elements from bds.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13 Extract grib data from binary data section and place into output array in proper position.
    +

    Program history log:

      +
    • Bill Cavanaugh 1991-09-13
      • +
    • Bill Cavanaugh 1994-04-01 Modified code to include decimal scaling when calculating the value of data points specified as being equal to the reference value
      • +
    • Farley 1994-11-10 Increased mxsize from 72960 to 260000 for .5 degree sst analysis fields.
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    • Mark Iredell 1998-08-31 Eliminated need for mxsize
      • +
    +
    Parameters
    + + + + + +
    [in]MSGAArray containing grib message
    [in,out]KPTRArray containing storage for following parameters
      +
    • 1 Total length of grib message
      • +
    • 2 Length of indicator (section 0)
      • +
    • 3 Length of pds (section 1)
      • +
    • 4 Length of gds (section 2)
      • +
    • 5 Length of bms (section 3)
      • +
    • 6 Length of bds (section 4)
      • +
    • 7 Value of current byte
      • +
    • 8 Bit pointer
      • +
    • 9 Grib start bit nr
      • +
    • 10 Grib/grid element count
      • +
    • 11 Nr unused bits at end of section 3
      • +
    • 12 Bit map flag
      • +
    • 13 Nr unused bits at end of section 2
      • +
    • 14 Bds flags
      • +
    • 15 Nr unused bits at end of section 4
      • +
    • 16 Reserved
      • +
    • 17 Reserved
      • +
    • 18 Reserved
      • +
    • 19 Binary scale factor
      • +
    • 20 Num bits used to pack each datum
      • +
    +
    [in]KPDSArray containing pds elements. See initial routine
    [in]KGDSArray containing gds elements.
      +
    • 1) Data representation type
      • +
    • 19 Number of vertical coordinate parameters
      • +
    • 20 Octet number of the list of vertical coordinate parameters Or Octet number of the list of numbers of points in each row Or 255 if neither are present.
      • +
    • 21 For grids with pl, number of points in grid
      • +
    • 22 Number of words in each row
      • +
    +
    +
    +
    +
      +
    • Longitude grids
        +
      • 2) N(i) nr points on latitude circle
        • +
      • 3) N(j) nr points on longitude meridian
        • +
      • 4) La(1) latitude of origin
        • +
      • 5) Lo(1) longitude of origin
        • +
      • 6) Resolution flag
        • +
      • 7) La(2) latitude of extreme point
        • +
      • 8) Lo(2) longitude of extreme point
        • +
      • 9) Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag
        • +
      +
      • +
    • Polar stereographic grids
        +
      • 2) N(i) nr points along lat circle
        • +
      • 3) N(j) nr points along lon circle
        • +
      • 4) La(1) latitude of origin
        • +
      • 5) Lo(1) longitude of origin
        • +
      • 6) Reserved
        • +
      • 7) Lov grid orientation
        • +
      • 8) Dx - x direction increment
        • +
      • 9) Dy - y direction increment
        • +
      • 10 Projection center flag
        • +
      • 11 Scanning mode
        • +
      +
      • +
    • Spherical harmonic coefficients
        +
      • 2 J pentagonal resolution parameter
        • +
      • 3 K pentagonal resolution parameter
        • +
      • 4 M pentagonal resolution parameter
        • +
      • 5 Representation type
        • +
      • 6 Coefficient storage mode
        • +
      +
      • +
    • Mercator grids
        +
      • 2 N(i) nr points on latitude circle
        • +
      • 3 N(j) nr points on longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag
        • +
      • 7 La(2) latitude of last grid point
        • +
      • 8 Lo(2) longitude of last grid point
        • +
      • 9 Latin - latitude of projection intersection
        • +
      • 10 Reserved
        • +
      • 11 Scanning mode flag
        • +
      • 12 Longitudinal dir grid length
        • +
      • 13 Latitudinal dir grid length
        • +
      +
      • +
    • Lambert conformal grids
        +
      • 2 Nx nr points along x-axis
        • +
      • 3 Ny nr points along y-axis
        • +
      • 4 La1 lat of origin (lower left)
        • +
      • 5 Lo1 lon of origin (lower left)
        • +
      • 6 Resolution (right adj copy of octet 17)
        • +
      • 7 Lov - orientation of grid
        • +
      • 8 Dx - x-dir increment
        • +
      • 9 Dy - y-dir increment
        • +
      • 10 Projection center flag
        • +
      • 11 Scanning mode flag
        • +
      • 12 Latin 1 - first lat from pole of secant cone inter
        • +
      • 13 Latin 2 - second lat from pole of secant cone inter
        • +
      +
      • +
    • Staggered arakawa rotated lat/lon grids (203 e stagger)
        +
      • 2 N(i) nr points on rotated latitude circle
        • +
      • 3 N(j) nr points on rotated longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag
        • +
      • 7 La(2) latitude of center
        • +
      • 8 Lo(2) longitude of center
        • +
      • 9 Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag
        • +
      +
      • +
    • Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
        +
      • 2 N(i) nr points on rotated latitude circle
        • +
      • 3 N(j) nr points on rotated longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag
        • +
      • 7 La(2) latitude of center
        • +
      • 8 Lo(2) longitude of center
        • +
      • 9 Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag
        • +
      • 12 Latitude of last point
        • +
      • 13 Longitude of last point
        Parameters
        + + +
        [in]KBMSBitmap describing location of output elements. -KBDS Information extracted from binary data section
        +
        +
        +
        • +
      • KBDS(1) - N1
        • +
      • KBDS(2) - N2
        • +
      • KBDS(3) - P1
        • +
      • KBDS(4) - P2
        • +
      • KBDS(5) - Bit pointer to 2nd order widths
        • +
      • KBDS(6) - Bit pointer to 2nd order bit maps
        • +
      • KBDS(7) - Bit pointer to first order values
        • +
      • KBDS(8) - Bit pointer to second order values
        • +
      • KBDS(9) - Bit pointer start of bds
        • +
      • KBDS(10) - Bit pointer main bit map
        • +
      • KBDS(11) - Binary scaling
        • +
      • KBDS(12) - Decimal scaling
        • +
      • KBDS(13) - Bit width of first order values
        • +
      • KBDS(14) - Bit map flag 0 = no second order bit map 1 = second order bit map present
        • +
      +
      • +
    • KBDS(15) - Second order bit width
      • +
    • KBDS(16) - Constant / different widths 0 = constant widths 1 = different widths
      • +
    • KBDS(17) - Single datum / matrix
        +
      • 0 = single datum at each grid point
        • +
      • 1 = matrix of values at each grid point
        • +
      • (18-20) - Unused
        Parameters
        + + + +
        [out]DATAReal*4 array of gridded elements in grib message.
        [out]KRETError return
        +
        +
        +
        Note
        +
        • +
      +
      • +
    • Error return
        +
      • 3 = Unpacked field is larger than 65160
        • +
      • 6 = Does not match nr of entries for this grib/grid
        • +
      • 7 = Number of bits in fill too large
        • +
      +
      • +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13
    + +

    Definition at line 2686 of file w3fi63.f.

    + +
    +
    + +

    ◆ fi636()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi636 (real, dimension(*) DATA,
    character*1, dimension(*) MSGA,
    logical*1, dimension(*) KBMS,
    real REFNCE,
    integer, dimension(*) KPTR,
    integer, dimension(*) KPDS,
    integer, dimension(*) KGDS 
    )
    +
    + +

    Process second order packing.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1992-09-22 Process second order packing from the binary data section (bds) for single data items grid point data.
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-06-08
      • +
    • Bill Cavanaugh 1993-12-15 Modified second order pointers to first order values and second order values correctly.
      • +
    • Ralph Jones 1995-04-26 Fi636 corection for 2nd order complex Unpacking.
      • +
    • Mark Iredell 1995-10-31 Saves and prints.
      • +
    +
    Parameters
    + + + + + + + + +
    [in]MSGAArray containing grib message
    [in]REFNCEReference value
    [in]KPTRWork array
    [out]DATALocation of output array
      +
    • KBDS Working array
        +
      • KBDS(1) N1
        • +
      • KBDS(2) N2
        • +
      • KBDS(3) P1
        • +
      • KBDS(4) P2
        • +
      • KBDS(5) Bit pointer to 2nd order widths
        • +
      • KBDS(6) Bit pointer to 2nd order bit maps
        • +
      • KBDS(7) Bit pointer to first order values
        • +
      • KBDS(8) Bit pointer to second order values
        • +
      • KBDS(9) Bit pointer start of bds
        • +
      • KBDS(10) Bit pointer main bit map
        • +
      • KBDS(11) Binary scaling
        • +
      • KBDS(12) Decimal scaling
        • +
      • KBDS(13) Bit width of first order values
        • +
      • KBDS(14) Bit map flag
          +
        • 0 = No second order bit map
          • +
        • 1 = Second order bit map present
          • +
        +
        • +
      • KBDS(15) Second order bit width
        • +
      • KBDS(16) Constant / different widths
          +
        • 0 = Constant widths
          • +
        • 1 = Different widths
          • +
        +
        • +
      • KBDS(17) Single datum / matrix
          +
        • 0 = Single datum at each grid point
          • +
        • 1 = Matrix of values at each grid point
          • +
        +
        • +
      • KBDS(18-20) Unused
        • +
      +
      • +
    +
    [in]KBMS
    [in]KPDS
    [in]KGDSArray containing gds elements.
      +
    • 1) Data representation type
      • +
    • 19 Number of vertical coordinate parameters
      • +
    • 20 Octet number of the list of vertical coordinate parameters Or Octet number of the list of numbers of points in each row Or 255 if neither are present.
      • +
    • 21 For grids with pl, number of points in grid
      • +
    • 22 Number of words in each row
      • +
    +
    +
    +
    +
      +
    • Longitude grids
        +
      • 2) N(i) nr points on latitude circle
        • +
      • 3) N(j) nr points on longitude meridian
        • +
      • 4) La(1) latitude of origin
        • +
      • 5) Lo(1) longitude of origin
        • +
      • 6) Resolution flag
        • +
      • 7) La(2) latitude of extreme point
        • +
      • 8) Lo(2) longitude of extreme point
        • +
      • 9) Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag
        • +
      +
      • +
    • Polar stereographic grids
        +
      • 2) N(i) nr points along lat circle
        • +
      • 3) N(j) nr points along lon circle
        • +
      • 4) La(1) latitude of origin
        • +
      • 5) Lo(1) longitude of origin
        • +
      • 6) Reserved
        • +
      • 7) Lov grid orientation
        • +
      • 8) Dx - x direction increment
        • +
      • 9) Dy - y direction increment
        • +
      • 10 Projection center flag
        • +
      • 11 Scanning mode
        • +
      +
      • +
    • Spherical harmonic coefficients
        +
      • 2 J pentagonal resolution parameter
        • +
      • 3 K pentagonal resolution parameter
        • +
      • 4 M pentagonal resolution parameter
        • +
      • 5 Representation type
        • +
      • 6 Coefficient storage mode
        • +
      +
      • +
    • Mercator grids
        +
      • 2 N(i) nr points on latitude circle
        • +
      • 3 N(j) nr points on longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag
        • +
      • 7 La(2) latitude of last grid point
        • +
      • 8 Lo(2) longitude of last grid point
        • +
      • 9 Latin - latitude of projection intersection
        • +
      • 10 Reserved
        • +
      • 11 Scanning mode flag
        • +
      • 12 Longitudinal dir grid length
        • +
      • 13 Latitudinal dir grid length
        • +
      +
      • +
    • Lambert conformal grids
        +
      • 2 Nx nr points along x-axis
        • +
      • 3 Ny nr points along y-axis
        • +
      • 4 La1 lat of origin (lower left)
        • +
      • 5 Lo1 lon of origin (lower left)
        • +
      • 6 Resolution (right adj copy of octet 17)
        • +
      • 7 Lov - orientation of grid
        • +
      • 8 Dx - x-dir increment
        • +
      • 9 Dy - y-dir increment
        • +
      • 10 Projection center flag
        • +
      • 11 Scanning mode flag
        • +
      • 12 Latin 1 - first lat from pole of secant cone inter
        • +
      • 13 Latin 2 - second lat from pole of secant cone inter
        • +
      +
      • +
    • Staggered arakawa rotated lat/lon grids (203 e stagger)
        +
      • 2 N(i) nr points on rotated latitude circle
        • +
      • 3 N(j) nr points on rotated longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag
        • +
      • 7 La(2) latitude of center
        • +
      • 8 Lo(2) longitude of center
        • +
      • 9 Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag
        • +
      +
      • +
    • Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
        +
      • 2 N(i) nr points on rotated latitude circle
        • +
      • 3 N(j) nr points on rotated longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag
        • +
      • 7 La(2) latitude of center
        • +
      • 8 Lo(2) longitude of center
        • +
      • 9 Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag
        • +
      • 12 Latitude of last point
        • +
      • 13 Longitude of last point
        • +
      +
      • +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1992-09-22
    + +

    Definition at line 3331 of file w3fi63.f.

    + +
    +
    + +

    ◆ fi637()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi637 (integer J,
    integer, dimension(*) KPDS,
    integer, dimension(*) KGDS,
     KRET 
    )
    +
    + +

    Grib grid/size test.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13 To test when gds is available to see if size mismatch on existing grids (by center) is indicated.
    +

    Program history log:

      +
    • Bill Cavanaugh 1991-09-13
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    • M. Bostelman 1997-02-12 Corrects ecmwf us grid 2 processing
      • +
    • Mark Iredell 1998-06-17 Removed alternate return
      • +
    • M. Baldwin 1999-01-20 Modify to handle grid 237
      • +
    • Boi Vuong 1909-05-21 Modify to handle grid 45
      • +
    +
    Parameters
    + + + + + +
    [in,out]JSize for indicated grid modified for ecmwf-us 2
    [in]KPDS
    [in]KGDS
    [out]KRETError return (a mismatch was detected if kret is not zero)
    +
    +
    +
    Note
      +
    • KRET:
        +
      • 9 - Gds indicates size mismatch with std grid
        • +
      +
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13
    + +

    Definition at line 3598 of file w3fi63.f.

    + +
    +
    + +

    ◆ w3fi63()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi63 (character*1, dimension(*) MSGA,
    integer, dimension(*) KPDS,
    integer, dimension(*) KGDS,
    logical*1, dimension(*) KBMS,
    real, dimension(*) DATA,
    integer, dimension(*) KPTR,
     KRET 
    )
    +
    + +

    Unpack a GRIB (edition 1) field to the exact grid specified in the GRIB message, isolate the bit map, and make the values of the product descripton section (PDS) and the grid description section (GDS) available in return arrays.

    +

    When decoding is completed, data at each grid point has been returned in the units specified in the GRIB manual.

    +

    See "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN GRIDDED BINARY FORM" dated July 1, 1988 by John D. Stackpolem DOC, NOAA, NWS, National Meteorological Center.

    +

    List of text messages from code:

      +
    • W3FI63/FI632
        +
      • 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
        • +
      • 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
        • +
      • 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
        • +
      • 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
        • +
      +
      • +
    • W3FI63/FI633
        +
      • 'POLAR STEREO PROCESSING NOT AVAILABLE'
        • +
      +
      • +
    • W3FI63/FI634
        +
      • 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL COEFFICIENTS'
        • +
      +
      • +
    • W3FI63/FI637
        +
      • 'NO CURRENT LISTING OF FNOC GRIDS'
        • +
      +
      • +
    +
    Parameters
    + + + + +
    [in]MSGAGrib field - "grib" thru "7777" char*1 (message can be preceded by junk chars). Contains the grib message to be unpacked. characters "GRIB" may begin anywhere within first 100 bytes.
    [out]KPDSArray of size 100 containing PDS elements, GRIB (edition 1):
      +
    • 1 Id of center
      • +
    • 2 Generating process id number
      • +
    • 3 Grid definition
      • +
    • 4 Gds/bms flag (right adj copy of octet 8)
      • +
    • 5 Indicator of parameter
      • +
    • 6 Type of level
      • +
    • 7 Height/pressure , etc of level
      • +
    • 8 Year including (century-1)
      • +
    • 9 Month of year
      • +
    • 10 Day of month
      • +
    • 11 Hour of day
      • +
    • 12 Minute of hour
      • +
    • 13 Indicator of forecast time unit
      • +
    • 14 Time range 1
      • +
    • 15 Time range 2
      • +
    • 16 Time range flag
      • +
    • 17 Number included in average
      • +
    • 18 Version nr of grib specification
      • +
    • 19 Version nr of parameter table
      • +
    • 20 Nr missing from average/accumulation
      • +
    • 21 Century of reference time of data
      • +
    • 22 Units decimal scale factor
      • +
    • 23 Subcenter number
      • +
    • 24 Pds byte 29, for nmc ensemble products
        +
      • 128 If forecast field error
        • +
      • 64 If bias corrected fcst field
        • +
      • 32 If smoothed field
        • +
      • Warning: can be combination of more than 1
        • +
      +
      • +
    • 25 Pds byte 30, not used
      • +
    • 26-35 Reserved
      • +
    • 36-N Consecutive bytes extracted from program Definition section (pds) of grib message
      • +
    +
    [out]KGDSARRAY CONTAINING GDS ELEMENTS.
      +
    • 1) Data representation type
      • +
    • 19 Number of vertical coordinate parameters
      • +
    • 20 Octet number of the list of vertical coordinate Parameters Or Octet number of the list of numbers of points In each row Or 255 if neither are present
      • +
    • 21 For grids with pl, number of points in grid
      • +
    • 22 Number of words in each row
      • +
    +
    +
    +
    +
      +
    • LATITUDE/LONGITUDE GRIDS
        +
      • 2 N(i) nr points on latitude circle
        • +
      • 3 N(j) nr points on longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag (right adj copy of octet 17)
        • +
      • 7 La(2) latitude of extreme point
        • +
      • 8 Lo(2) longitude of extreme point
        • +
      • 9 Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag (right adj copy of octet 28)
        • +
      +
      • +
    • GAUSSIAN GRIDS
        +
      • 2 N(i) nr points on latitude circle
        • +
      • 3 N(j) nr points on longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag (right adj copy of octet 17)
        • +
      • 7 La(2) latitude of extreme point
        • +
      • 8 Lo(2) longitude of extreme point
        • +
      • 9 Di longitudinal direction of increment
        • +
      • 10 N - nr of circles pole to equator
        • +
      • 11 Scanning mode flag (right adj copy of octet 28)
        • +
      • 12 Nv - nr of vert coord parameters
        • +
      • 13 Pv - octet nr of list of vert coord parameters or Pl - location of the list of numbers of points in each row (if no vert coord parameters are present or 255 if neither are present
        • +
      +
      • +
    • POLAR STEREOGRAPHIC GRIDS
        +
      • 2 N(i) nr points along lat circle
        • +
      • 3 N(j) nr points along lon circle
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag (right adj copy of octet 17)
        • +
      • 7 Lov grid orientation
        • +
      • 8 Dx - x direction increment
        • +
      • 9 Dy - y direction increment
        • +
      • 10 Projection center flag
        • +
      • 11 Scanning mode (right adj copy of octet 28)
        • +
      +
      • +
    • SPHERICAL HARMONIC COEFFICIENTS
        +
      • 2) J pentagonal resolution parameter
        • +
      • 3) K pentagonal resolution parameter
        • +
      • 4) M pentagonal resolution parameter
        • +
      • 5) Representation type
        • +
      • 6) Coefficient storage mode
        • +
      +
      • +
    • MERCATOR GRIDS
        +
      • 2 N(i) nr points on latitude circle
        • +
      • 3 N(j) nr points on longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag (right adj copy of octet 17)
        • +
      • 7 La(2) latitude of last grid point
        • +
      • 8 Lo(2) longitude of last grid point
        • +
      • 9 Latit - latitude of projection intersection
        • +
      • 10 Reserved
        • +
      • 11 Scanning mode flag (right adj copy of octet 28)
        • +
      • 12 Longitudinal dir grid length
        • +
      • 13 Latitudinal dir grid length
        • +
      +
      • +
    • LAMBERT CONFORMAL GRIDS
        +
      • 2 Nx nr points along x-axis
        • +
      • 3 Ny nr points along y-axis
        • +
      • 4 La1 lat of origin (lower left)
        • +
      • 5 Lo1 lon of origin (lower left)
        • +
      • 6 Resolution (right adj copy of octet 17)
        • +
      • 7 Lov - orientation of grid
        • +
      • 8 Dx - x-dir increment
        • +
      • 9 Dy - y-dir increment
        • +
      • 10 Projection center flag
        • +
      • 11 Scanning mode flag (right adj copy of octet 28)
        • +
      • 12 Latin 1 - first lat from pole of secant cone inter
        • +
      • 13 Latin 2 - second lat from pole of secant cone inter
        • +
      +
      • +
    • E-STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (TYPE 203)
        +
      • 2 N(i) nr points on latitude circle
        • +
      • 3 N(j) nr points on longitude meridian
        • +
      • 4 La(1) latitude of origin
        • +
      • 5 Lo(1) longitude of origin
        • +
      • 6 Resolution flag (right adj copy of octet 17)
        • +
      • 7 La(2) latitude of center
        • +
      • 8 Lo(2) longitude of center
        • +
      • 9 Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag (right adj copy of octet 28)
        • +
      +
      • +
    • CURVILINEAR ORTHIGINAL GRID (TYPE 204)
        +
      • 2 N(i) nr points on latitude circle
        • +
      • 3 N(j) nr points on longitude meridian
        • +
      • 4 Reserved set to 0
        • +
      • 5 Reserved set to 0
        • +
      • 6 Resolution flag (right adj copy of octet 17)
        • +
      • 7 Reserved set to 0
        • +
      • 8 Reserved set to 0
        • +
      • 9 Reserved set to 0
        • +
      • 10 Reserved set to 0
        • +
      • 11 Scanning mode flag (right adj copy of octet 28)
        • +
      +
      • +
    • ROTATED LAT/LON A,B,C,D-STAGGERED (TYPE 205)
        +
      • 2 N(i) nr points on latitude circle
        • +
      • 3 N(j) nr points on longitude meridian
        • +
      • 4 La(1) latitude of first point
        • +
      • 5 Lo(1) longitude of first point
        • +
      • 6 Resolution flag (right adj copy of octet 17)
        • +
      • 7 La(2) latitude of center
        • +
      • 8 Lo(2) longitude of center
        • +
      • 9 Di longitudinal direction of increment
        • +
      • 10 Dj latitudinal direction increment
        • +
      • 11 Scanning mode flag (right adj copy of octet 28)
        • +
      • 12 Latitude of last point
        • +
      • 13 Longitude of last point
        Parameters
        + + + + +
        [out]KBMSBitmap describing location of output elements. (always constructed)
        [out]DATAArray containing the unpacked data elements. Note: 65160 is maximun field size allowable.
        [out]KPTRArray containing storage for following parameters
        +
        +
        +
        • +
      +
      • +
    • 1 Total length of grib message
      • +
    • 2 Length of indicator (section 0)
      • +
    • 3 Length of pds (section 1)
      • +
    • 4 Length of gds (section 2)
      • +
    • 5 Length of bms (section 3)
      • +
    • 6 Length of bds (section 4)
      • +
    • 7 Value of current byte
      • +
    • 8 Bit pointer
      • +
    • 9 Grib start bit nr
      • +
    • 10 Grib/grid element count
      • +
    • 11 Nr unused bits at end of section 3
      • +
    • 12 Bit map flag (copy of bms octets 5,6)
      • +
    • 13 Nr unused bits at end of section 2
      • +
    • 14 Bds flags (right adj copy of octet 4)
      • +
    • 15 Nr unused bits at end of section 4
      • +
    • 16 Reserved
      • +
    • 17 Reserved
      • +
    • 18 Reserved
      • +
    • 19 Binary scale factor
      • +
    • 20 Num bits used to pack each datum
      Parameters
      + + +
      [out]KRETFlag indicating quality of completion.
      +
      +
      +
      Note
      When decoding is completed, data at each grid point has been returned in the units specified in the grib manual.
      +
      • +
    • Values for return flag (kret)
        +
      • 0 - Normal return, no errors
        • +
      • 1 - 'grib' not found in first 100 chars
        • +
      • 2 - '7777' not in correct location
        • +
      • 3 - Unpacked field is larger than 260000
        • +
      • 4 - Gds/ grid not one of currently accepted values
        • +
      • 5 - Grid not currently avail for center indicated
        • +
      • 8 - Temp gds indicated, but gds flag is off
        • +
      • 9 - Gds indicates size mismatch with std grid
        • +
      • 10 - Incorrect center indicator
        • +
      • 11 - Binary data section (bds) not completely processed. program is not set to process flag combinations shown in octets 4 and 14.
        • +
      • 12 - Binary data section (bds) not completely processed. program is not set to process flag combinations
        • +
      +
      • +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-09-13
    + +

    Definition at line 243 of file w3fi63.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi63_8f.js b/ver-2.10.0/w3fi63_8f.js new file mode 100644 index 00000000..13bb9d7d --- /dev/null +++ b/ver-2.10.0/w3fi63_8f.js @@ -0,0 +1,12 @@ +var w3fi63_8f = +[ + [ "fi631", "w3fi63_8f.html#a5e07fb32acda017ce2b31674761eddb0", null ], + [ "fi632", "w3fi63_8f.html#a49e798fade46eda6b55035a58e136185", null ], + [ "fi633", "w3fi63_8f.html#ae00e4a53f6509a2e49276ecc592522d1", null ], + [ "fi634", "w3fi63_8f.html#a573937997ce1f78d799c52ba6812d503", null ], + [ "fi634x", "w3fi63_8f.html#abe401baf1479cb539db68da3358232f1", null ], + [ "fi635", "w3fi63_8f.html#a88fef913d620c38a8795ad7b93cb73a7", null ], + [ "fi636", "w3fi63_8f.html#acf6e1d529f2d31927f198d24b8ca610b", null ], + [ "fi637", "w3fi63_8f.html#a7c07c9973bb0370c09e56fa6aa00665a", null ], + [ "w3fi63", "w3fi63_8f.html#aa59740e4c6a30f9c5f201204603d302f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi63_8f_source.html b/ver-2.10.0/w3fi63_8f_source.html new file mode 100644 index 00000000..40956d54 --- /dev/null +++ b/ver-2.10.0/w3fi63_8f_source.html @@ -0,0 +1,3964 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi63.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi63.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Unpack GRIB field to a GRIB grid.
    +
    3 C> @author Bill Cavanaugh @date 1991-09-13
    +
    4 
    +
    5 C> Unpack a GRIB (edition 1) field to the exact grid
    +
    6 C> specified in the GRIB message, isolate the bit map, and make
    +
    7 C> the values of the product descripton section (PDS) and the
    +
    8 C> grid description section (GDS) available in return arrays.
    +
    9 C>
    +
    10 C> When decoding is completed, data at each grid point has been
    +
    11 C> returned in the units specified in the GRIB manual.
    +
    12 C>
    +
    13 C> See "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT
    +
    14 C> INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN
    +
    15 C> GRIDDED BINARY FORM" dated July 1, 1988 by John D. Stackpolem
    +
    16 C> DOC, NOAA, NWS, National Meteorological Center.
    +
    17 C>
    +
    18 C> List of text messages from code:
    +
    19 C> - W3FI63/FI632
    +
    20 C> - 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY
    +
    21 C> AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    +
    22 C> (W/NMC42)'
    +
    23 C>
    +
    24 C> - 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY
    +
    25 C> AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    +
    26 C> (W/NMC42)'
    +
    27 C>
    +
    28 C> - 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL
    +
    29 C> OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION,
    +
    30 C> PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
    +
    31 C>
    +
    32 C> - 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY
    +
    33 C> AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
    +
    34 C> (W/NMC42)'
    +
    35 C>
    +
    36 C> - W3FI63/FI633
    +
    37 C> - 'POLAR STEREO PROCESSING NOT AVAILABLE'
    +
    38 C>
    +
    39 C> - W3FI63/FI634
    +
    40 C> - 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL
    +
    41 C> COEFFICIENTS'
    +
    42 C>
    +
    43 C> - W3FI63/FI637
    +
    44 C> - 'NO CURRENT LISTING OF FNOC GRIDS'
    +
    45 C>
    +
    46 C> @param[in] MSGA Grib field - "grib" thru "7777" char*1
    +
    47 C> (message can be preceded by junk chars). Contains the grib message to be unpacked. characters
    +
    48 C> "GRIB" may begin anywhere within first 100 bytes.
    +
    49 C> @param[out] KPDS Array of size 100 containing PDS elements, GRIB (edition 1):
    +
    50 C> - 1 Id of center
    +
    51 C> - 2 Generating process id number
    +
    52 C> - 3 Grid definition
    +
    53 C> - 4 Gds/bms flag (right adj copy of octet 8)
    +
    54 C> - 5 Indicator of parameter
    +
    55 C> - 6 Type of level
    +
    56 C> - 7 Height/pressure , etc of level
    +
    57 C> - 8 Year including (century-1)
    +
    58 C> - 9 Month of year
    +
    59 C> - 10 Day of month
    +
    60 C> - 11 Hour of day
    +
    61 C> - 12 Minute of hour
    +
    62 C> - 13 Indicator of forecast time unit
    +
    63 C> - 14 Time range 1
    +
    64 C> - 15 Time range 2
    +
    65 C> - 16 Time range flag
    +
    66 C> - 17 Number included in average
    +
    67 C> - 18 Version nr of grib specification
    +
    68 C> - 19 Version nr of parameter table
    +
    69 C> - 20 Nr missing from average/accumulation
    +
    70 C> - 21 Century of reference time of data
    +
    71 C> - 22 Units decimal scale factor
    +
    72 C> - 23 Subcenter number
    +
    73 C> - 24 Pds byte 29, for nmc ensemble products
    +
    74 C> - 128 If forecast field error
    +
    75 C> - 64 If bias corrected fcst field
    +
    76 C> - 32 If smoothed field
    +
    77 C> - Warning: can be combination of more than 1
    +
    78 C> - 25 Pds byte 30, not used
    +
    79 C> - 26-35 Reserved
    +
    80 C> - 36-N Consecutive bytes extracted from program
    +
    81 C> Definition section (pds) of grib message
    +
    82 C> @param[out] KGDS ARRAY CONTAINING GDS ELEMENTS.
    +
    83 C> - 1) Data representation type
    +
    84 C> - 19 Number of vertical coordinate parameters
    +
    85 C> - 20 Octet number of the list of vertical coordinate
    +
    86 C> Parameters Or Octet number of the list of numbers of points
    +
    87 C> In each row Or 255 if neither are present
    +
    88 C> - 21 For grids with pl, number of points in grid
    +
    89 C> - 22 Number of words in each row
    +
    90 C> - LATITUDE/LONGITUDE GRIDS
    +
    91 C> - 2 N(i) nr points on latitude circle
    +
    92 C> - 3 N(j) nr points on longitude meridian
    +
    93 C> - 4 La(1) latitude of origin
    +
    94 C> - 5 Lo(1) longitude of origin
    +
    95 C> - 6 Resolution flag (right adj copy of octet 17)
    +
    96 C> - 7 La(2) latitude of extreme point
    +
    97 C> - 8 Lo(2) longitude of extreme point
    +
    98 C> - 9 Di longitudinal direction of increment
    +
    99 C> - 10 Dj latitudinal direction increment
    +
    100 C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    101 C> - GAUSSIAN GRIDS
    +
    102 C> - 2 N(i) nr points on latitude circle
    +
    103 C> - 3 N(j) nr points on longitude meridian
    +
    104 C> - 4 La(1) latitude of origin
    +
    105 C> - 5 Lo(1) longitude of origin
    +
    106 C> - 6 Resolution flag (right adj copy of octet 17)
    +
    107 C> - 7 La(2) latitude of extreme point
    +
    108 C> - 8 Lo(2) longitude of extreme point
    +
    109 C> - 9 Di longitudinal direction of increment
    +
    110 C> - 10 N - nr of circles pole to equator
    +
    111 C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    112 C> - 12 Nv - nr of vert coord parameters
    +
    113 C> - 13 Pv - octet nr of list of vert coord parameters or
    +
    114 C> Pl - location of the list of numbers of points in
    +
    115 C> each row (if no vert coord parameters are present or
    +
    116 C> 255 if neither are present
    +
    117 C> - POLAR STEREOGRAPHIC GRIDS
    +
    118 C> - 2 N(i) nr points along lat circle
    +
    119 C> - 3 N(j) nr points along lon circle
    +
    120 C> - 4 La(1) latitude of origin
    +
    121 C> - 5 Lo(1) longitude of origin
    +
    122 C> - 6 Resolution flag (right adj copy of octet 17)
    +
    123 C> - 7 Lov grid orientation
    +
    124 C> - 8 Dx - x direction increment
    +
    125 C> - 9 Dy - y direction increment
    +
    126 C> - 10 Projection center flag
    +
    127 C> - 11 Scanning mode (right adj copy of octet 28)
    +
    128 C> - SPHERICAL HARMONIC COEFFICIENTS
    +
    129 C> - 2) J pentagonal resolution parameter
    +
    130 C> - 3) K pentagonal resolution parameter
    +
    131 C> - 4) M pentagonal resolution parameter
    +
    132 C> - 5) Representation type
    +
    133 C> - 6) Coefficient storage mode
    +
    134 C> - MERCATOR GRIDS
    +
    135 C> - 2 N(i) nr points on latitude circle
    +
    136 C> - 3 N(j) nr points on longitude meridian
    +
    137 C> - 4 La(1) latitude of origin
    +
    138 C> - 5 Lo(1) longitude of origin
    +
    139 C> - 6 Resolution flag (right adj copy of octet 17)
    +
    140 C> - 7 La(2) latitude of last grid point
    +
    141 C> - 8 Lo(2) longitude of last grid point
    +
    142 C> - 9 Latit - latitude of projection intersection
    +
    143 C> - 10 Reserved
    +
    144 C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    145 C> - 12 Longitudinal dir grid length
    +
    146 C> - 13 Latitudinal dir grid length
    +
    147 C> - LAMBERT CONFORMAL GRIDS
    +
    148 C> - 2 Nx nr points along x-axis
    +
    149 C> - 3 Ny nr points along y-axis
    +
    150 C> - 4 La1 lat of origin (lower left)
    +
    151 C> - 5 Lo1 lon of origin (lower left)
    +
    152 C> - 6 Resolution (right adj copy of octet 17)
    +
    153 C> - 7 Lov - orientation of grid
    +
    154 C> - 8 Dx - x-dir increment
    +
    155 C> - 9 Dy - y-dir increment
    +
    156 C> - 10 Projection center flag
    +
    157 C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    158 C> - 12 Latin 1 - first lat from pole of secant cone inter
    +
    159 C> - 13 Latin 2 - second lat from pole of secant cone inter
    +
    160 C> - E-STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (TYPE 203)
    +
    161 C> - 2 N(i) nr points on latitude circle
    +
    162 C> - 3 N(j) nr points on longitude meridian
    +
    163 C> - 4 La(1) latitude of origin
    +
    164 C> - 5 Lo(1) longitude of origin
    +
    165 C> - 6 Resolution flag (right adj copy of octet 17)
    +
    166 C> - 7 La(2) latitude of center
    +
    167 C> - 8 Lo(2) longitude of center
    +
    168 C> - 9 Di longitudinal direction of increment
    +
    169 C> - 10 Dj latitudinal direction increment
    +
    170 C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    171 C> - CURVILINEAR ORTHIGINAL GRID (TYPE 204)
    +
    172 C> - 2 N(i) nr points on latitude circle
    +
    173 C> - 3 N(j) nr points on longitude meridian
    +
    174 C> - 4 Reserved set to 0
    +
    175 C> - 5 Reserved set to 0
    +
    176 C> - 6 Resolution flag (right adj copy of octet 17)
    +
    177 C> - 7 Reserved set to 0
    +
    178 C> - 8 Reserved set to 0
    +
    179 C> - 9 Reserved set to 0
    +
    180 C> - 10 Reserved set to 0
    +
    181 C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    182 C> - ROTATED LAT/LON A,B,C,D-STAGGERED (TYPE 205)
    +
    183 C> - 2 N(i) nr points on latitude circle
    +
    184 C> - 3 N(j) nr points on longitude meridian
    +
    185 C> - 4 La(1) latitude of first point
    +
    186 C> - 5 Lo(1) longitude of first point
    +
    187 C> - 6 Resolution flag (right adj copy of octet 17)
    +
    188 C> - 7 La(2) latitude of center
    +
    189 C> - 8 Lo(2) longitude of center
    +
    190 C> - 9 Di longitudinal direction of increment
    +
    191 C> - 10 Dj latitudinal direction increment
    +
    192 C> - 11 Scanning mode flag (right adj copy of octet 28)
    +
    193 C> - 12 Latitude of last point
    +
    194 C> - 13 Longitude of last point
    +
    195 C> @param[out] KBMS Bitmap describing location of output elements.
    +
    196 C> (always constructed)
    +
    197 C> @param[out] DATA Array containing the unpacked data elements.
    +
    198 C> Note: 65160 is maximun field size allowable.
    +
    199 C> @param[out] KPTR Array containing storage for following parameters
    +
    200 C> - 1 Total length of grib message
    +
    201 C> - 2 Length of indicator (section 0)
    +
    202 C> - 3 Length of pds (section 1)
    +
    203 C> - 4 Length of gds (section 2)
    +
    204 C> - 5 Length of bms (section 3)
    +
    205 C> - 6 Length of bds (section 4)
    +
    206 C> - 7 Value of current byte
    +
    207 C> - 8 Bit pointer
    +
    208 C> - 9 Grib start bit nr
    +
    209 C> - 10 Grib/grid element count
    +
    210 C> - 11 Nr unused bits at end of section 3
    +
    211 C> - 12 Bit map flag (copy of bms octets 5,6)
    +
    212 C> - 13 Nr unused bits at end of section 2
    +
    213 C> - 14 Bds flags (right adj copy of octet 4)
    +
    214 C> - 15 Nr unused bits at end of section 4
    +
    215 C> - 16 Reserved
    +
    216 C> - 17 Reserved
    +
    217 C> - 18 Reserved
    +
    218 C> - 19 Binary scale factor
    +
    219 C> - 20 Num bits used to pack each datum
    +
    220 C> @param[out] KRET Flag indicating quality of completion.
    +
    221 C>
    +
    222 C> @note When decoding is completed, data at each grid point has been
    +
    223 C> returned in the units specified in the grib manual.
    +
    224 C>
    +
    225 C> - Values for return flag (kret)
    +
    226 C> - 0 - Normal return, no errors
    +
    227 C> - 1 - 'grib' not found in first 100 chars
    +
    228 C> - 2 - '7777' not in correct location
    +
    229 C> - 3 - Unpacked field is larger than 260000
    +
    230 C> - 4 - Gds/ grid not one of currently accepted values
    +
    231 C> - 5 - Grid not currently avail for center indicated
    +
    232 C> - 8 - Temp gds indicated, but gds flag is off
    +
    233 C> - 9 - Gds indicates size mismatch with std grid
    +
    234 C> - 10 - Incorrect center indicator
    +
    235 C> - 11 - Binary data section (bds) not completely processed.
    +
    236 C> program is not set to process flag combinations
    +
    237 C> shown in octets 4 and 14.
    +
    238 C> - 12 - Binary data section (bds) not completely processed.
    +
    239 C> program is not set to process flag combinations
    +
    240 C>
    +
    241 C> @author Bill Cavanaugh @date 1991-09-13
    +
    242  SUBROUTINE w3fi63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET)
    +
    243 C
    +
    244 C * WILL BE AVAILABLE IN NEXT UPDATE
    +
    245 C ***************************************************************
    +
    246 C
    +
    247 C INCOMING MESSAGE HOLDER
    +
    248  CHARACTER*1 MSGA(*)
    +
    249 C BIT MAP
    +
    250  LOGICAL*1 KBMS(*)
    +
    251 C
    +
    252 C ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS)
    +
    253  INTEGER KPDS(*)
    +
    254 C ELEMENTS OF GRID DESCRIPTION SEC (PDS)
    +
    255  INTEGER KGDS(*)
    +
    256 C
    +
    257 C CONTAINER FOR GRIB GRID
    +
    258  REAL DATA(*)
    +
    259 C
    +
    260 C ARRAY OF POINTERS AND COUNTERS
    +
    261  INTEGER KPTR(*)
    +
    262 C
    +
    263 C *****************************************************************
    +
    264  INTEGER JSGN,JEXP,IFR,NPTS
    +
    265  REAL REALKK,FVAL1,FDIFF1
    +
    266 C *****************************************************************
    +
    267 C 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE
    +
    268 C FIND 'GRIB' CHARACTERS
    +
    269 C 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE
    +
    270 C IF '7777' IS IN PROPER PLACE.
    +
    271 C 3.0 PARSE PRODUCT DEFINITION SECTION.
    +
    272 C 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED)
    +
    273 C 5.0 PARSE BIT MAP SEC (IF INCLUDED)
    +
    274 C 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID
    +
    275 C DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT
    +
    276 C DATA AND PLACE INTO PROPER ARRAY.
    +
    277 C *******************************************************************
    +
    278 C
    +
    279 C MAIN DRIVER
    +
    280 C
    +
    281 C *******************************************************************
    +
    282  kptr(10) = 0
    +
    283 C SEE IF PROPER 'GRIB' KEY EXISTS, THEN
    +
    284 C USING SEC COUNTS, DETERMINE IF '7777'
    +
    285 C IS IN THE PROPER LOCATION
    +
    286 C
    +
    287  CALL fi631(msga,kptr,kpds,kret)
    +
    288  IF(kret.NE.0) THEN
    +
    289  GO TO 900
    +
    290  END IF
    +
    291 C PRINT *,'FI631 KPTR',(KPTR(I),I=1,16)
    +
    292 C
    +
    293 C PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION
    +
    294 C
    +
    295  CALL fi632(msga,kptr,kpds,kret)
    +
    296  IF(kret.NE.0) THEN
    +
    297  GO TO 900
    +
    298  END IF
    +
    299 C PRINT *,'FI632 KPTR',(KPTR(I),I=1,16)
    +
    300 C
    +
    301 C IF AVAILABLE, EXTRACT NEW GRID DESCRIPTION
    +
    302 C
    +
    303  IF (iand(kpds(4),128).NE.0) THEN
    +
    304  CALL fi633(msga,kptr,kgds,kret)
    +
    305  IF(kret.NE.0) THEN
    +
    306  GO TO 900
    +
    307  END IF
    +
    308 C PRINT *,'FI633 KPTR',(KPTR(I),I=1,16)
    +
    309  END IF
    +
    310 C
    +
    311 C EXTRACT OR GENERATE BIT MAP
    +
    312 C
    +
    313  CALL fi634(msga,kptr,kpds,kgds,kbms,kret)
    +
    314  IF (kret.NE.0) THEN
    +
    315  IF (kret.NE.9) THEN
    +
    316  GO TO 900
    +
    317  END IF
    +
    318  END IF
    +
    319 C PRINT *,'FI634 KPTR',(KPTR(I),I=1,16)
    +
    320 C
    +
    321 C USING INFORMATION FROM PDS, BMS AND BIT DATA SEC ,
    +
    322 C EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES.
    +
    323 C
    +
    324  IF (kpds(18).EQ.1) THEN
    +
    325  CALL fi635(msga,kptr,kpds,kgds,kbms,DATA,kret)
    +
    326  IF (kptr(3).EQ.50) THEN
    +
    327 C
    +
    328 C PDS EQUAL 50 BYTES
    +
    329 C THEREFORE SOMETHING SPECIAL IS GOING ON
    +
    330 C
    +
    331 C IN THIS CASE 2ND DIFFERENCE PACKING
    +
    332 C NEEDS TO BE UNDONE.
    +
    333 C
    +
    334 C EXTRACT FIRST VALUE FROM BYTE 41-44 PDS
    +
    335 C KPTR(9) CONTAINS OFFSET TO START OF
    +
    336 C GRIB MESSAGE.
    +
    337 C EXTRACT FIRST FIRST-DIFFERENCE FROM BYTES 45-48 PDS
    +
    338 C
    +
    339 C AND EXTRACT SCALE FACTOR (E) TO UNDO 2**E
    +
    340 C THAT WAS APPLIED PRIOR TO 2ND ORDER PACKING
    +
    341 C AND PLACED IN PDS BYTES 49-51
    +
    342 C FACTOR IS A SIGNED TWO BYTE INTEGER
    +
    343 C
    +
    344 C ALSO NEED THE DECIMAL SCALING FROM PDS(27-28)
    +
    345 C (AVAILABLE IN KPDS(22) FROM UNPACKER)
    +
    346 C TO UNDO THE DECIMAL SCALING APPLIED TO THE
    +
    347 C SECOND DIFFERENCES DURING UNPACKING.
    +
    348 C SECOND DIFFS ALWAYS PACKED WITH 0 DECIMAL SCALE
    +
    349 C BUT UNPACKER DOESNT KNOW THAT.
    +
    350 C
    +
    351 C CALL GBYTE (MSGA,FVAL1,KPTR(9)+384,32)
    +
    352 C
    +
    353 C NOTE INTEGERS, CHARACTERS AND EQUIVALENCES
    +
    354 C DEFINED ABOVE TO MAKE THIS KKK EXTRACTION
    +
    355 C WORK AND LINE UP ON WORD BOUNDARIES
    +
    356 C
    +
    357 C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
    +
    358 C TO THE FLOATING POINT USED ON YOUR MACHINE.
    +
    359 C
    +
    360  call gbytec(msga,jsgn,kptr(9)+384,1)
    +
    361  call gbytec(msga,jexp,kptr(9)+385,7)
    +
    362  call gbytec(msga,ifr,kptr(9)+392,24)
    +
    363 C
    +
    364  IF (ifr.EQ.0) THEN
    +
    365  realkk = 0.0
    +
    366  ELSE IF (jexp.EQ.0.AND.ifr.EQ.0) THEN
    +
    367  realkk = 0.0
    +
    368  ELSE
    +
    369  realkk = float(ifr) * 16.0 ** (jexp - 64 - 6)
    +
    370  IF (jsgn.NE.0) realkk = -realkk
    +
    371  END IF
    +
    372  fval1 = realkk
    +
    373 C
    +
    374 C CALL GBYTE (MSGA,FDIFF1,KPTR(9)+416,32)
    +
    375 C (REPLACED BY FOLLOWING EXTRACTION)
    +
    376 C
    +
    377 C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
    +
    378 C TO THE FLOATING POINT USED ON YOUR MACHINE.
    +
    379 C
    +
    380  call gbytec(msga,jsgn,kptr(9)+416,1)
    +
    381  call gbytec(msga,jexp,kptr(9)+417,7)
    +
    382  call gbytec(msga,ifr,kptr(9)+424,24)
    +
    383 C
    +
    384  IF (ifr.EQ.0) THEN
    +
    385  realkk = 0.0
    +
    386  ELSE IF (jexp.EQ.0.AND.ifr.EQ.0) THEN
    +
    387  realkk = 0.0
    +
    388  ELSE
    +
    389  realkk = float(ifr) * 16.0 ** (jexp - 64 - 6)
    +
    390  IF (jsgn.NE.0) realkk = -realkk
    +
    391  END IF
    +
    392  fdiff1 = realkk
    +
    393 C
    +
    394  CALL gbytec (msga,isign,kptr(9)+448,1)
    +
    395  CALL gbytec (msga,iscal2,kptr(9)+449,15)
    +
    396  IF(isign.GT.0) THEN
    +
    397  iscal2 = - iscal2
    +
    398  ENDIF
    +
    399 C PRINT *,'DELTA POINT 1-',FVAL1
    +
    400 C PRINT *,'DELTA POINT 2-',FDIFF1
    +
    401 C PRINT *,'DELTA POINT 3-',ISCAL2
    +
    402  npts = kptr(10)
    +
    403 C WRITE (6,FMT='('' 2ND DIFF POINTS IN FIELD = '',/,
    +
    404 C & 10(3X,10F12.2,/))') (DATA(I),I=1,NPTS)
    +
    405 C PRINT *,'DELTA POINT 4-',KPDS(22)
    +
    406  CALL w3fi83 (DATA,npts,fval1,fdiff1,
    +
    407  & iscal2,kpds(22),kpds,kgds)
    +
    408 C WRITE (6,FMT='('' 2ND DIFF EXPANDED POINTS IN FIELD = '',
    +
    409 C & /,10(3X,10F12.2,/))') (DATA(I),I=1,NPTS)
    +
    410 C WRITE (6,FMT='('' END OF ARRAY IN FIELD = '',/,
    +
    411 C & 10(3X,10F12.2,/))') (DATA(I),I=NPTS-5,NPTS)
    +
    412  END IF
    +
    413  ELSE
    +
    414 C PRINT *,'FI635 NOT PROGRAMMED FOR EDITION NR',KPDS(18)
    +
    415  kret = 7
    +
    416  END IF
    +
    417 C
    +
    418  900 RETURN
    +
    419  END
    +
    420 
    +
    421 C> @brief Find 'grib' chars & reset pointers
    +
    422 C> @author Bill Cavanaugh @date 1991-09-13
    +
    423 
    +
    424 C> Find 'grib; characters and set pointers to the next
    +
    425 C> byte following 'grib'. If they exist extract counts from gds and
    +
    426 C> bms. Extract count from bds. Determine if sum of counts actually
    +
    427 C> places terminator '7777' at the correct location.
    +
    428 C>
    +
    429 C> Program history log:
    +
    430 C> - Bill Cavanaugh 1991-09-13
    +
    431 C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    432 C>
    +
    433 C> @param[in] MSGA Grib field - "grib" thru "7777"
    +
    434 C> @param[inout] KPTR Array containing storage for following parameters
    +
    435 C> - 1 Total length of grib message
    +
    436 C> - 2 Length of indicator (section 0)
    +
    437 C> - 3 Length of pds (section 1)
    +
    438 C> - 4 Length of gds (section 2)
    +
    439 C> - 5 Length of bms (section 3)
    +
    440 C> - 6 Length of bds (section 4)
    +
    441 C> - 7 Value of current byte
    +
    442 C> - 8 Bit pointer
    +
    443 C> - 9 Grib start bit nr
    +
    444 C> - 10 Grib/grid element count
    +
    445 C> - 11 Nr unused bits at end of section 3
    +
    446 C> - 12 Bit map flag
    +
    447 C> - 13 Nr unused bits at end of section 2
    +
    448 C> - 14 Bds flags
    +
    449 C> - 15 Nr unused bits at end of section 4
    +
    450 C> @param[out] KPDS Array containing pds elements.
    +
    451 C> - 1 Id of center
    +
    452 C> - 2 Model identification
    +
    453 C> - 3 Grid identification
    +
    454 C> - 4 Gds/bms flag
    +
    455 C> - 5 Indicator of parameter
    +
    456 C> - 6 Type of level
    +
    457 C> - 7 Height/pressure , etc of level
    +
    458 C> - 8 Year of century
    +
    459 C> - 9 Month of year
    +
    460 C> - 10 Day of month
    +
    461 C> - 11 Hour of day
    +
    462 C> - 12 Minute of hour
    +
    463 C> - 13 Indicator of forecast time unit
    +
    464 C> - 14 Time range 1
    +
    465 C> - 15 Time range 2
    +
    466 C> - 16 Time range flag
    +
    467 C> - 17 Number included in average
    +
    468 C> @param[out] KRET Error return
    +
    469 C>
    +
    470 C> @note
    +
    471 C> ERROR RETURNS
    +
    472 C> KRET:
    +
    473 C> - 1 NO 'GRIB'
    +
    474 C> - 2 NO '7777' OR MISLOCATED (BY COUNTS)
    +
    475 C>
    +
    476 C> @author Bill Cavanaugh @date 1991-09-13
    +
    477  SUBROUTINE fi631(MSGA,KPTR,KPDS,KRET)
    +
    478 C
    +
    479 C INCOMING MESSAGE HOLDER
    +
    480  CHARACTER*1 MSGA(*)
    +
    481 C ARRAY OF POINTERS AND COUNTERS
    +
    482  INTEGER KPTR(*)
    +
    483 C PRODUCT DESCRIPTION SECTION DATA.
    +
    484  INTEGER KPDS(*)
    +
    485 C
    +
    486  INTEGER KRET
    +
    487 C
    +
    488 C ******************************************************************
    +
    489  kret = 0
    +
    490 C ------------------- FIND 'GRIB' KEY
    +
    491  DO 50 i = 0, 839, 8
    +
    492  CALL gbytec (msga,mgrib,i,32)
    +
    493  IF (mgrib.EQ.1196575042) THEN
    +
    494  kptr(9) = i
    +
    495  GO TO 60
    +
    496  END IF
    +
    497  50 CONTINUE
    +
    498  kret = 1
    +
    499  RETURN
    +
    500  60 CONTINUE
    +
    501 C -------------FOUND 'GRIB'
    +
    502 C SKIP GRIB CHARACTERS
    +
    503 C PRINT *,'FI631 GRIB AT',I
    +
    504  kptr(8) = kptr(9) + 32
    +
    505  CALL gbytec (msga,itotal,kptr(8),24)
    +
    506 C HAVE LIFTED WHAT MAY BE A MSG TOTAL BYTE COUNT
    +
    507  ipoint = kptr(9) + itotal * 8 - 32
    +
    508  CALL gbytec (msga,i7777,ipoint,32)
    +
    509  IF (i7777.EQ.926365495) THEN
    +
    510 C HAVE FOUND END OF MESSAGE '7777' IN PROPER LOCATION
    +
    511 C MARK AND PROCESS AS GRIB VERSION 1 OR HIGHER
    +
    512 C PRINT *,'FI631 7777 AT',IPOINT
    +
    513  kptr(8) = kptr(8) + 24
    +
    514  kptr(1) = itotal
    +
    515  kptr(2) = 8
    +
    516  CALL gbytec (msga,kpds(18),kptr(8),8)
    +
    517  kptr(8) = kptr(8) + 8
    +
    518  ELSE
    +
    519 C CANNOT FIND END OF GRIB EDITION 1 MESSAGE
    +
    520  kret = 2
    +
    521  RETURN
    +
    522  END IF
    +
    523 C ------------------- PROCESS SECTION 1
    +
    524 C EXTRACT COUNT FROM PDS
    +
    525 C PRINT *,'START OF PDS',KPTR(8)
    +
    526  CALL gbytec (msga,kptr(3),kptr(8),24)
    +
    527  look = kptr(8) + 56
    +
    528 C EXTRACT GDS/BMS FLAG
    +
    529  CALL gbytec (msga,kpds(4),look,8)
    +
    530  kptr(8) = kptr(8) + kptr(3) * 8
    +
    531 C PRINT *,'START OF GDS',KPTR(8)
    +
    532  IF (iand(kpds(4),128).NE.0) THEN
    +
    533 C EXTRACT COUNT FROM GDS
    +
    534  CALL gbytec (msga,kptr(4),kptr(8),24)
    +
    535  kptr(8) = kptr(8) + kptr(4) * 8
    +
    536  ELSE
    +
    537  kptr(4) = 0
    +
    538  END IF
    +
    539 C PRINT *,'START OF BMS',KPTR(8)
    +
    540  IF (iand(kpds(4),64).NE.0) THEN
    +
    541 C EXTRACT COUNT FROM BMS
    +
    542  CALL gbytec (msga,kptr(5),kptr(8),24)
    +
    543  ELSE
    +
    544  kptr(5) = 0
    +
    545  END IF
    +
    546  kptr(8) = kptr(8) + kptr(5) * 8
    +
    547 C PRINT *,'START OF BDS',KPTR(8)
    +
    548 C EXTRACT COUNT FROM BDS
    +
    549  CALL gbytec (msga,kptr(6),kptr(8),24)
    +
    550 C --------------- TEST FOR '7777'
    +
    551 C PRINT *,(KPTR(KJ),KJ=1,10)
    +
    552  kptr(8) = kptr(8) + kptr(6) * 8
    +
    553 C EXTRACT FOUR BYTES FROM THIS LOCATION
    +
    554 C PRINT *,'FI631 LOOKING FOR 7777 AT',KPTR(8)
    +
    555  CALL gbytec (msga,k7777,kptr(8),32)
    +
    556  match = kptr(2) + kptr(3) + kptr(4) + kptr(5) + kptr(6) + 4
    +
    557  IF (k7777.NE.926365495.OR.match.NE.kptr(1)) THEN
    +
    558  kret = 2
    +
    559  ELSE
    +
    560 C PRINT *,'FI631 7777 AT',KPTR(8)
    +
    561  IF (kpds(18).EQ.0) THEN
    +
    562  kptr(1) = kptr(2) + kptr(3) + kptr(4) + kptr(5) +
    +
    563  * kptr(6) + 4
    +
    564  END IF
    +
    565  END IF
    +
    566 C PRINT *,'KPTR',(KPTR(I),I=1,16)
    +
    567  RETURN
    +
    568  END
    +
    569 
    +
    570 
    +
    571 C> @brief Gather info from product definition sec.
    +
    572 C> @author Bill Cavanaugh @date 1991-09-13
    +
    573 
    +
    574 C> Extract information from the product description
    +
    575 C> sec , and generate label information to permit storage
    +
    576 C> in office note 84 format.
    +
    577 C>
    +
    578 C> Program history log:
    +
    579 C> - Bill Cavanaugh 1991-09-13
    +
    580 C> - Bill Cavanaugh 1993-12-08 Corrected test for edition number instead
    +
    581 C> of version number.
    +
    582 C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    583 C> - M. Baldwin 1999-01-20 Modified to handle grid 237.
    +
    584 C>
    +
    585 C> @param[in] MSGA Array containing grib message.
    +
    586 C> @param[inout] KPTR Array containing storage for following parameters.
    +
    587 C> - 1 Total length of grib message
    +
    588 C> - 2 Length of indicator (section 0)
    +
    589 C> - 3 Length of pds (section 1)
    +
    590 C> - 4 Length of gds (section 2)
    +
    591 C> - 5 Length of bms (section 3)
    +
    592 C> - 6 Length of bds (section 4)
    +
    593 C> - 7 Value of current byte
    +
    594 C> - 8 Bit pointer
    +
    595 C> - 9 Grib start bit nr
    +
    596 C> - 10 Grib/grid element count
    +
    597 C> - 11 Nr unused bits at end of section 3
    +
    598 C> - 12 Bit map flag
    +
    599 C> - 13 Nr unused bits at end of section 2
    +
    600 C> - 14 Bds flags
    +
    601 C> - 15 Nr unused bits at end of section 4
    +
    602 C> @param[out] KPDS Array containing pds elements.
    +
    603 C> - 1 Id of center
    +
    604 C> - 2 Model identification
    +
    605 C> - 3 Grid identification
    +
    606 C> - 4 Gds/bms flag
    +
    607 C> - 5 Indicator of parameter
    +
    608 C> - 6 Type of level
    +
    609 C> - 7 Height/pressure , etc of level
    +
    610 C> - 8 Year of century
    +
    611 C> - 9 Month of year
    +
    612 C> - 10 Day of month
    +
    613 C> - 11 Hour of day
    +
    614 C> - 12 Minute of hour
    +
    615 C> - 13 Indicator of forecast time unit
    +
    616 C> - 14 Time range 1
    +
    617 C> - 15 Time range 2
    +
    618 C> - 16 Time range flag
    +
    619 C> - 17 Number included in average
    +
    620 C> - 18
    +
    621 C> - 19
    +
    622 C> - 20 Number missing from avgs/accumulations
    +
    623 C> - 21 Century
    +
    624 C> - 22 Units decimal scale factor
    +
    625 C> - 23 Subcenter
    +
    626 C> @param[out] KRET Error return.
    +
    627 C>
    +
    628 C> @note ERROR RETURN:
    +
    629 C> - 0 - NO ERRORS
    +
    630 C> - 8 - TEMP GDS INDICATED, BUT NO GDS
    +
    631 C>
    +
    632 C> @author Bill Cavanaugh @date 1991-09-13
    +
    633 
    +
    634  SUBROUTINE fi632(MSGA,KPTR,KPDS,KRET)
    +
    635 
    +
    636 C
    +
    637 C INCOMING MESSAGE HOLDER
    +
    638  CHARACTER*1 MSGA(*)
    +
    639 C
    +
    640 C ARRAY OF POINTERS AND COUNTERS
    +
    641  INTEGER KPTR(*)
    +
    642 C PRODUCT DESCRIPTION SECTION ENTRIES
    +
    643  INTEGER KPDS(*)
    +
    644 C
    +
    645  INTEGER KRET
    +
    646  kret=0
    +
    647 C ------------------- PROCESS SECTION 1
    +
    648  kptr(8) = kptr(9) + kptr(2) * 8 + 24
    +
    649 C BYTE 4
    +
    650 C PARAMETER TABLE VERSION NR
    +
    651  CALL gbytec (msga,kpds(19),kptr(8),8)
    +
    652  kptr(8) = kptr(8) + 8
    +
    653 C BYTE 5 IDENTIFICATION OF CENTER
    +
    654  CALL gbytec (msga,kpds(1),kptr(8),8)
    +
    655  kptr(8) = kptr(8) + 8
    +
    656 C BYTE 6
    +
    657 C GET GENERATING PROCESS ID NR
    +
    658  CALL gbytec (msga,kpds(2),kptr(8),8)
    +
    659  kptr(8) = kptr(8) + 8
    +
    660 C BYTE 7
    +
    661 C GRID DEFINITION
    +
    662  CALL gbytec (msga,kpds(3),kptr(8),8)
    +
    663  kptr(8) = kptr(8) + 8
    +
    664 C BYTE 8
    +
    665 C GDS/BMS FLAGS
    +
    666 C CALL GBYTEC (MSGA,KPDS(4),KPTR(8),8)
    +
    667  kptr(8) = kptr(8) + 8
    +
    668 C BYTE 9
    +
    669 C INDICATOR OF PARAMETER
    +
    670  CALL gbytec (msga,kpds(5),kptr(8),8)
    +
    671  kptr(8) = kptr(8) + 8
    +
    672 C BYTE 10
    +
    673 C TYPE OF LEVEL
    +
    674  CALL gbytec (msga,kpds(6),kptr(8),8)
    +
    675  kptr(8) = kptr(8) + 8
    +
    676 C BYTE 11,12
    +
    677 C HEIGHT/PRESSURE
    +
    678  CALL gbytec (msga,kpds(7),kptr(8),16)
    +
    679  kptr(8) = kptr(8) + 16
    +
    680 C BYTE 13
    +
    681 C YEAR OF CENTURY
    +
    682  CALL gbytec (msga,kpds(8),kptr(8),8)
    +
    683  kptr(8) = kptr(8) + 8
    +
    684 C BYTE 14
    +
    685 C MONTH OF YEAR
    +
    686  CALL gbytec (msga,kpds(9),kptr(8),8)
    +
    687  kptr(8) = kptr(8) + 8
    +
    688 C BYTE 15
    +
    689 C DAY OF MONTH
    +
    690  CALL gbytec (msga,kpds(10),kptr(8),8)
    +
    691  kptr(8) = kptr(8) + 8
    +
    692 C BYTE 16
    +
    693 C HOUR OF DAY
    +
    694  CALL gbytec (msga,kpds(11),kptr(8),8)
    +
    695  kptr(8) = kptr(8) + 8
    +
    696 C BYTE 17
    +
    697 C MINUTE
    +
    698  CALL gbytec (msga,kpds(12),kptr(8),8)
    +
    699  kptr(8) = kptr(8) + 8
    +
    700 C BYTE 18
    +
    701 C INDICATOR TIME UNIT RANGE
    +
    702  CALL gbytec (msga,kpds(13),kptr(8),8)
    +
    703  kptr(8) = kptr(8) + 8
    +
    704 C BYTE 19
    +
    705 C P1 - PERIOD OF TIME
    +
    706  CALL gbytec (msga,kpds(14),kptr(8),8)
    +
    707  kptr(8) = kptr(8) + 8
    +
    708 C BYTE 20
    +
    709 C P2 - PERIOD OF TIME
    +
    710  CALL gbytec (msga,kpds(15),kptr(8),8)
    +
    711  kptr(8) = kptr(8) + 8
    +
    712 C BYTE 21
    +
    713 C TIME RANGE INDICATOR
    +
    714  CALL gbytec (msga,kpds(16),kptr(8),8)
    +
    715  kptr(8) = kptr(8) + 8
    +
    716 C
    +
    717 C IF TIME RANGE INDICATOR IS 10, P1 IS PACKED IN
    +
    718 C PDS BYTES 19-20
    +
    719 C
    +
    720  IF (kpds(16).EQ.10) THEN
    +
    721  kpds(14) = kpds(14) * 256 + kpds(15)
    +
    722  kpds(15) = 0
    +
    723  END IF
    +
    724 C BYTE 22,23
    +
    725 C NUMBER INCLUDED IN AVERAGE
    +
    726  CALL gbytec (msga,kpds(17),kptr(8),16)
    +
    727  kptr(8) = kptr(8) + 16
    +
    728 C BYTE 24
    +
    729 C NUMBER MISSING FROM AVERAGES/ACCUMULATIONS
    +
    730  CALL gbytec (msga,kpds(20),kptr(8),8)
    +
    731  kptr(8) = kptr(8) + 8
    +
    732 C BYTE 25
    +
    733 C IDENTIFICATION OF CENTURY
    +
    734  CALL gbytec (msga,kpds(21),kptr(8),8)
    +
    735  kptr(8) = kptr(8) + 8
    +
    736  IF (kptr(3).GT.25) THEN
    +
    737 C BYTE 26 SUB CENTER NUMBER
    +
    738  CALL gbytec (msga,kpds(23),kptr(8),8)
    +
    739  kptr(8) = kptr(8) + 8
    +
    740  IF (kptr(3).GE.28) THEN
    +
    741 C BYTE 27-28
    +
    742 C UNITS DECIMAL SCALE FACTOR
    +
    743  CALL gbytec (msga,isign,kptr(8),1)
    +
    744  kptr(8) = kptr(8) + 1
    +
    745  CALL gbytec (msga,idec,kptr(8),15)
    +
    746  kptr(8) = kptr(8) + 15
    +
    747  IF (isign.GT.0) THEN
    +
    748  kpds(22) = - idec
    +
    749  ELSE
    +
    750  kpds(22) = idec
    +
    751  END IF
    +
    752  isiz = kptr(3) - 28
    +
    753  IF (isiz.LE.12) THEN
    +
    754 C BYTE 29
    +
    755  CALL gbytec (msga,kpds(24),kptr(8)+8,8)
    +
    756 C BYTE 30
    +
    757  CALL gbytec (msga,kpds(25),kptr(8)+16,8)
    +
    758 C BYTES 31-40 CURRENTLY RESERVED FOR FUTURE USE
    +
    759  kptr(8) = kptr(8) + isiz * 8
    +
    760  ELSE
    +
    761 C BYTE 29
    +
    762  CALL gbytec (msga,kpds(24),kptr(8)+8,8)
    +
    763 C BYTE 30
    +
    764  CALL gbytec (msga,kpds(25),kptr(8)+16,8)
    +
    765 C BYTES 31-40 CURRENTLY RESERVED FOR FUTURE USE
    +
    766  kptr(8) = kptr(8) + 12 * 8
    +
    767 C BYTES 41 - N LOCAL USE DATA
    +
    768  CALL w3fi01(lw)
    +
    769 C MWDBIT = LW * 8
    +
    770  mwdbit = bit_size(kpds)
    +
    771  isiz = kptr(3) - 40
    +
    772  iter = isiz / lw
    +
    773  IF (mod(isiz,lw).NE.0) iter = iter + 1
    +
    774  CALL gbytesc (msga,kpds(36),kptr(8),mwdbit,0,iter)
    +
    775  kptr(8) = kptr(8) + isiz * 8
    +
    776  END IF
    +
    777  END IF
    +
    778  END IF
    +
    779 C ----------- TEST FOR NEW GRID
    +
    780  IF (iand(kpds(4),128).NE.0) THEN
    +
    781  IF (iand(kpds(4),64).NE.0) THEN
    +
    782  IF (kpds(3).NE.255) THEN
    +
    783  IF (kpds(3).GE.21.AND.kpds(3).LE.26)THEN
    +
    784  RETURN
    +
    785  ELSE IF (kpds(3).GE.37.AND.kpds(3).LE.44)THEN
    +
    786  RETURN
    +
    787  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
    +
    788  RETURN
    +
    789  END IF
    +
    790  IF (kpds(1).EQ.7) THEN
    +
    791  IF (kpds(3).GE.2.AND.kpds(3).LE.3) THEN
    +
    792  ELSE IF (kpds(3).GE.5.AND.kpds(3).LE.6) THEN
    +
    793  ELSE IF (kpds(3).EQ.8) THEN
    +
    794  ELSE IF (kpds(3).EQ.10) THEN
    +
    795  ELSE IF (kpds(3).GE.27.AND.kpds(3).LE.34) THEN
    +
    796  ELSE IF (kpds(3).EQ.50) THEN
    +
    797  ELSE IF (kpds(3).EQ.53) THEN
    +
    798  ELSE IF (kpds(3).GE.70.AND.kpds(3).LE.77) THEN
    +
    799  ELSE IF (kpds(3).EQ.98) THEN
    +
    800  ELSE IF (kpds(3).EQ.99) THEN
    +
    801  ELSE IF (kpds(3).GE.100.AND.kpds(3).LE.105) THEN
    +
    802  ELSE IF (kpds(3).EQ.126) THEN
    +
    803  ELSE IF (kpds(3).EQ.195) THEN
    +
    804  ELSE IF (kpds(3).EQ.196) THEN
    +
    805  ELSE IF (kpds(3).EQ.197) THEN
    +
    806  ELSE IF (kpds(3).EQ.198) THEN
    +
    807  ELSE IF (kpds(3).GE.200.AND.kpds(3).LE.237) THEN
    +
    808  ELSE
    +
    809 C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    810 C * ' NMC WITHOUT A GRID DESCRIPTION SECTION'
    +
    811 C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    812 C PRINT *,' PRODUCTION MANAGEMENT BRANCH'
    +
    813 C PRINT *,' W/NMC42)'
    +
    814  END IF
    +
    815  ELSE IF (kpds(1).EQ.98) THEN
    +
    816  IF (kpds(3).GE.1.AND.kpds(3).LE.16) THEN
    +
    817  ELSE
    +
    818 C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    819 C * ' ECMWF WITHOUT A GRID DESCRIPTION SECTION'
    +
    820 C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    821 C PRINT *,' PRODUCTION MANAGEMENT BRANCH'
    +
    822 C PRINT *,' W/NMC42)'
    +
    823  END IF
    +
    824  ELSE IF (kpds(1).EQ.74) THEN
    +
    825  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
    +
    826  ELSE IF (kpds(3).GE.21.AND.kpds(3).LE.26)THEN
    +
    827  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
    +
    828  ELSE IF (kpds(3).GE.70.AND.kpds(3).LE.77) THEN
    +
    829  ELSE
    +
    830 C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    831 C * ' U.K. MET OFFICE, BRACKNELL',
    +
    832 C * ' WITHOUT A GRID DESCRIPTION SECTION'
    +
    833 C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    834 C PRINT *,' PRODUCTION MANAGEMENT BRANCH'
    +
    835 C PRINT *,' W/NMC42)'
    +
    836  END IF
    +
    837  ELSE IF (kpds(1).EQ.58) THEN
    +
    838  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
    +
    839  ELSE
    +
    840 C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
    +
    841 C * ' FNOC WITHOUT A GRID DESCRIPTION SECTION'
    +
    842 C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
    +
    843 C PRINT *,' PRODUCTION MANAGEMENT BRANCH'
    +
    844 C PRINT *,' W/NMC42)'
    +
    845  END IF
    +
    846  END IF
    +
    847  END IF
    +
    848  END IF
    +
    849  END IF
    +
    850  RETURN
    +
    851  END
    +
    852 
    +
    853 C> @brief Extract info from grib-gds
    +
    854 C> @author Bill Cavanaugh @date 1991-09-13
    +
    855 
    +
    856 C> Extract information on unlisted grid to allow
    +
    857 C> conversion to office note 84 format.
    +
    858 C>
    +
    859 C> Program history log:
    +
    860 C> - Bill Cavanaugh 1991-09-13
    +
    861 C> - M. Baldwin 1995-03-20 fi633 modification to get
    +
    862 C> data rep types [kgds(1)] 201 and 202 to work.
    +
    863 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    864 C> - M. Baldwin 1998-09-08 Add data rep type [kgds(1)] 203
    +
    865 C> - Boi Vuong 2007-04-24 Add data rep type [kgds(1)] 204
    +
    866 C> - George Gayno 2010-07-20 Add data rep type [kgds(1)] 205
    +
    867 C>
    +
    868 C> @param[in] MSGA Array containing grib message
    +
    869 C> @param[inout] KPTR Array containing storage for following parameters
    +
    870 C> - 1 Total length of grib message
    +
    871 C> - 2 Length of indicator (section 0)
    +
    872 C> - 3 Length of pds (section 1)
    +
    873 C> - 4 Length of gds (section 2)
    +
    874 C> - 5 Length of bms (section 3)
    +
    875 C> - 6 Length of bds (section 4)
    +
    876 C> - 7 Value of current byte
    +
    877 C> - 8 Bit pointer
    +
    878 C> - 9 Grib start bit nr
    +
    879 C> - 10 Grib/grid element count
    +
    880 C> - 11 Nr unused bits at end of section 3
    +
    881 C> - 12 Bit map flag
    +
    882 C> - 13 Nr unused bits at end of section 2
    +
    883 C> - 14 Bds flags
    +
    884 C> - 15 Nr unused bits at end of section 4
    +
    885 C> @param[out] KGDS Array containing gds elements.
    +
    886 C> - 1) Data representation type
    +
    887 C> - 19 Number of vertical coordinate parameters
    +
    888 C> - 20 Octet number of the list of vertical coordinate
    +
    889 C> parameters Or Octet number of the list of numbers of points
    +
    890 C> in each row Or 255 if neither are present.
    +
    891 C> - 21 For grids with pl, number of points in grid
    +
    892 C> - 22 Number of words in each row
    +
    893 C> - Longitude grids
    +
    894 C> - 2) N(i) nr points on latitude circle
    +
    895 C> - 3) N(j) nr points on longitude meridian
    +
    896 C> - 4) La(1) latitude of origin
    +
    897 C> - 5) Lo(1) longitude of origin
    +
    898 C> - 6) Resolution flag
    +
    899 C> - 7) La(2) latitude of extreme point
    +
    900 C> - 8) Lo(2) longitude of extreme point
    +
    901 C> - 9) Di longitudinal direction of increment
    +
    902 C> - 10 Dj latitudinal direction increment
    +
    903 C> - 11 Scanning mode flag
    +
    904 C> - Polar stereographic grids
    +
    905 C> - 2) N(i) nr points along lat circle
    +
    906 C> - 3) N(j) nr points along lon circle
    +
    907 C> - 4) La(1) latitude of origin
    +
    908 C> - 5) Lo(1) longitude of origin
    +
    909 C> - 6) Reserved
    +
    910 C> - 7) Lov grid orientation
    +
    911 C> - 8) Dx - x direction increment
    +
    912 C> - 9) Dy - y direction increment
    +
    913 C> - 10 Projection center flag
    +
    914 C> - 11 Scanning mode
    +
    915 C> - Spherical harmonic coefficients
    +
    916 C> - 2 J pentagonal resolution parameter
    +
    917 C> - 3 K pentagonal resolution parameter
    +
    918 C> - 4 M pentagonal resolution parameter
    +
    919 C> - 5 Representation type
    +
    920 C> - 6 Coefficient storage mode
    +
    921 C> - Mercator grids
    +
    922 C> - 2 N(i) nr points on latitude circle
    +
    923 C> - 3 N(j) nr points on longitude meridian
    +
    924 C> - 4 La(1) latitude of origin
    +
    925 C> - 5 Lo(1) longitude of origin
    +
    926 C> - 6 Resolution flag
    +
    927 C> - 7 La(2) latitude of last grid point
    +
    928 C> - 8 Lo(2) longitude of last grid point
    +
    929 C> - 9 Latin - latitude of projection intersection
    +
    930 C> - 10 Reserved
    +
    931 C> - 11 Scanning mode flag
    +
    932 C> - 12 Longitudinal dir grid length
    +
    933 C> - 13 Latitudinal dir grid length
    +
    934 C> - Lambert conformal grids
    +
    935 C> - 2 Nx nr points along x-axis
    +
    936 C> - 3 Ny nr points along y-axis
    +
    937 C> - 4 La1 lat of origin (lower left)
    +
    938 C> - 5 Lo1 lon of origin (lower left)
    +
    939 C> - 6 Resolution (right adj copy of octet 17)
    +
    940 C> - 7 Lov - orientation of grid
    +
    941 C> - 8 Dx - x-dir increment
    +
    942 C> - 9 Dy - y-dir increment
    +
    943 C> - 10 Projection center flag
    +
    944 C> - 11 Scanning mode flag
    +
    945 C> - 12 Latin 1 - first lat from pole of secant cone inter
    +
    946 C> - 13 Latin 2 - second lat from pole of secant cone inter
    +
    947 C> - Staggered arakawa rotated lat/lon grids (203 e stagger)
    +
    948 C> - 2 N(i) nr points on rotated latitude circle
    +
    949 C> - 3 N(j) nr points on rotated longitude meridian
    +
    950 C> - 4 La(1) latitude of origin
    +
    951 C> - 5 Lo(1) longitude of origin
    +
    952 C> - 6 Resolution flag
    +
    953 C> - 7 La(2) latitude of center
    +
    954 C> - 8 Lo(2) longitude of center
    +
    955 C> - 9 Di longitudinal direction of increment
    +
    956 C> - 10 Dj latitudinal direction increment
    +
    957 C> - 11 Scanning mode flag
    +
    958 C> - Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
    +
    959 C> - 2 N(i) nr points on rotated latitude circle
    +
    960 C> - 3 N(j) nr points on rotated longitude meridian
    +
    961 C> - 4 La(1) latitude of origin
    +
    962 C> - 5 Lo(1) longitude of origin
    +
    963 C> - 6 Resolution flag
    +
    964 C> - 7 La(2) latitude of center
    +
    965 C> - 8 Lo(2) longitude of center
    +
    966 C> - 9 Di longitudinal direction of increment
    +
    967 C> - 10 Dj latitudinal direction increment
    +
    968 C> - 11 Scanning mode flag
    +
    969 C> - 12 Latitude of last point
    +
    970 C> - 13 Longitude of last point
    +
    971 C> @param[out] KRET Error return
    +
    972 C>
    +
    973 C> @note
    +
    974 C> - KRET
    +
    975 C> - 0
    +
    976 C> - 4 - Data representation type not currently acceptable
    +
    977 C>
    +
    978 C> @author Bill Cavanaugh @date 1991-09-13
    +
    979 
    +
    980  SUBROUTINE fi633(MSGA,KPTR,KGDS,KRET)
    +
    981 
    +
    982 C ************************************************************
    +
    983 C INCOMING MESSAGE HOLDER
    +
    984  CHARACTER*1 MSGA(*)
    +
    985 C
    +
    986 C ARRAY GDS ELEMENTS
    +
    987  INTEGER KGDS(*)
    +
    988 C ARRAY OF POINTERS AND COUNTERS
    +
    989  INTEGER KPTR(*)
    +
    990 C
    +
    991  INTEGER KRET
    +
    992 C ---------------------------------------------------------------
    +
    993  kret = 0
    +
    994 C PROCESS GRID DEFINITION SECTION (IF PRESENT)
    +
    995 C MAKE SURE BIT POINTER IS PROPERLY SET
    +
    996  kptr(8) = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + 24
    +
    997  nsave = kptr(8) - 24
    +
    998 C BYTE 4
    +
    999 C NV - NR OF VERT COORD PARAMETERS
    +
    1000  CALL gbytec (msga,kgds(19),kptr(8),8)
    +
    1001  kptr(8) = kptr(8) + 8
    +
    1002 C BYTE 5
    +
    1003 C PV - LOCATION - SEE FM92 MANUAL
    +
    1004  CALL gbytec (msga,kgds(20),kptr(8),8)
    +
    1005  kptr(8) = kptr(8) + 8
    +
    1006 C BYTE 6
    +
    1007 C DATA REPRESENTATION TYPE
    +
    1008  CALL gbytec (msga,kgds(1),kptr(8),8)
    +
    1009  kptr(8) = kptr(8) + 8
    +
    1010 C BYTES 7-32 ARE GRID DEFINITION DEPENDING ON
    +
    1011 C DATA REPRESENTATION TYPE
    +
    1012  IF (kgds(1).EQ.0) THEN
    +
    1013  GO TO 1000
    +
    1014  ELSE IF (kgds(1).EQ.1) THEN
    +
    1015  GO TO 4000
    +
    1016  ELSE IF (kgds(1).EQ.2.OR.kgds(1).EQ.5) THEN
    +
    1017  GO TO 2000
    +
    1018  ELSE IF (kgds(1).EQ.3) THEN
    +
    1019  GO TO 5000
    +
    1020  ELSE IF (kgds(1).EQ.4) THEN
    +
    1021  GO TO 1000
    +
    1022 C ELSE IF (KGDS(1).EQ.10) THEN
    +
    1023 C ELSE IF (KGDS(1).EQ.14) THEN
    +
    1024 C ELSE IF (KGDS(1).EQ.20) THEN
    +
    1025 C ELSE IF (KGDS(1).EQ.24) THEN
    +
    1026 C ELSE IF (KGDS(1).EQ.30) THEN
    +
    1027 C ELSE IF (KGDS(1).EQ.34) THEN
    +
    1028  ELSE IF (kgds(1).EQ.50) THEN
    +
    1029  GO TO 3000
    +
    1030 C ELSE IF (KGDS(1).EQ.60) THEN
    +
    1031 C ELSE IF (KGDS(1).EQ.70) THEN
    +
    1032 C ELSE IF (KGDS(1).EQ.80) THEN
    +
    1033  ELSE IF (kgds(1).EQ.201.OR.kgds(1).EQ.202.OR.
    +
    1034  & kgds(1).EQ.203.OR.kgds(1).EQ.204.OR.kgds(1).EQ.205) THEN
    +
    1035  GO TO 1000
    +
    1036  ELSE
    +
    1037 C MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE
    +
    1038  kret = 4
    +
    1039  RETURN
    +
    1040  END IF
    +
    1041 C BYTE 33-N VERTICAL COORDINATE PARAMETERS
    +
    1042 C -----------
    +
    1043 C BYTES 33-42 EXTENSIONS OF GRID DEFINITION FOR ROTATION
    +
    1044 C OR STRETCHING OF THE COORDINATE SYSTEM OR
    +
    1045 C LAMBERT CONFORMAL PROJECTION.
    +
    1046 C BYTE 43-N VERTICAL COORDINATE PARAMETERS
    +
    1047 C -----------
    +
    1048 C BYTES 33-52 EXTENSIONS OF GRID DEFINITION FOR STRETCHED
    +
    1049 C AND ROTATED COORDINATE SYSTEM
    +
    1050 C BYTE 53-N VERTICAL COORDINATE PARAMETERS
    +
    1051 C -----------
    +
    1052 C ************************************************************
    +
    1053 C ------------------- LATITUDE/LONGITUDE GRIDS
    +
    1054 C ------------------- ARAKAWA STAGGERED, SEMI-STAGGERED, OR FILLED
    +
    1055 C ROTATED LAT/LON GRIDS OR CURVILINEAR ORTHIGINAL GRIDS
    +
    1056 C
    +
    1057 C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE
    +
    1058  1000 CONTINUE
    +
    1059  CALL gbytec (msga,kgds(2),kptr(8),16)
    +
    1060  kptr(8) = kptr(8) + 16
    +
    1061 C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
    +
    1062  CALL gbytec (msga,kgds(3),kptr(8),16)
    +
    1063  kptr(8) = kptr(8) + 16
    +
    1064 C ------------------- BYTE 11-13 LATITUDE OF ORIGIN
    +
    1065  CALL gbytec (msga,kgds(4),kptr(8),24)
    +
    1066  kptr(8) = kptr(8) + 24
    +
    1067  IF (iand(kgds(4),8388608).NE.0) THEN
    +
    1068  kgds(4) = iand(kgds(4),8388607) * (-1)
    +
    1069  END IF
    +
    1070 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
    +
    1071  CALL gbytec (msga,kgds(5),kptr(8),24)
    +
    1072  kptr(8) = kptr(8) + 24
    +
    1073  IF (iand(kgds(5),8388608).NE.0) THEN
    +
    1074  kgds(5) = - iand(kgds(5),8388607)
    +
    1075  END IF
    +
    1076 C ------------------- BYTE 17 RESOLUTION FLAG
    +
    1077  CALL gbytec (msga,kgds(6),kptr(8),8)
    +
    1078  kptr(8) = kptr(8) + 8
    +
    1079 C ------------------- BYTE 18-20 LATITUDE OF LAST GRID POINT
    +
    1080  CALL gbytec (msga,kgds(7),kptr(8),24)
    +
    1081  kptr(8) = kptr(8) + 24
    +
    1082  IF (iand(kgds(7),8388608).NE.0) THEN
    +
    1083  kgds(7) = - iand(kgds(7),8388607)
    +
    1084  END IF
    +
    1085 C ------------------- BYTE 21-23 LONGITUDE OF LAST GRID POINT
    +
    1086  CALL gbytec (msga,kgds(8),kptr(8),24)
    +
    1087  kptr(8) = kptr(8) + 24
    +
    1088  IF (iand(kgds(8),8388608).NE.0) THEN
    +
    1089  kgds(8) = - iand(kgds(8),8388607)
    +
    1090  END IF
    +
    1091 C ------------------- BYTE 24-25 LATITUDINAL DIR INCREMENT
    +
    1092  CALL gbytec (msga,kgds(9),kptr(8),16)
    +
    1093  kptr(8) = kptr(8) + 16
    +
    1094 C ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID
    +
    1095 C HAVE LONGIT DIR INCREMENT
    +
    1096 C ELSE IF GAUSSIAN GRID
    +
    1097 C HAVE NR OF LAT CIRCLES
    +
    1098 C BETWEEN POLE AND EQUATOR
    +
    1099  CALL gbytec (msga,kgds(10),kptr(8),16)
    +
    1100  kptr(8) = kptr(8) + 16
    +
    1101 C ------------------- BYTE 28 SCANNING MODE FLAGS
    +
    1102  CALL gbytec (msga,kgds(11),kptr(8),8)
    +
    1103  kptr(8) = kptr(8) + 8
    +
    1104  IF(kgds(1).EQ.205)THEN
    +
    1105 C ------------------- BYTE 29-31 LATITUDE OF LAST GRID POINT
    +
    1106  CALL gbytec (msga,kgds(12),kptr(8),24)
    +
    1107  kptr(8) = kptr(8) + 24
    +
    1108  IF (iand(kgds(12),8388608).NE.0) THEN
    +
    1109  kgds(12) = - iand(kgds(12),8388607)
    +
    1110  END IF
    +
    1111 C ------------------- BYTE 32-34 LONGITUDE OF LAST GRID POINT
    +
    1112  CALL gbytec (msga,kgds(13),kptr(8),24)
    +
    1113  kptr(8) = kptr(8) + 24
    +
    1114  IF (iand(kgds(13),8388608).NE.0) THEN
    +
    1115  kgds(13) = - iand(kgds(13),8388607)
    +
    1116  END IF
    +
    1117  ELSE
    +
    1118 
    +
    1119 C ------------------- BYTE 29-32 RESERVED
    +
    1120 C SKIP TO START OF BYTE 33
    +
    1121  CALL gbytec (msga,kgds(12),kptr(8),32)
    +
    1122  kptr(8) = kptr(8) + 32
    +
    1123  ENDIF
    +
    1124 C -------------------
    +
    1125  GO TO 900
    +
    1126 C ******************************************************************
    +
    1127 C ' POLAR STEREO PROCESSING '
    +
    1128 C
    +
    1129 C ------------------- BYTE 7-8 NR OF POINTS ALONG X=AXIS
    +
    1130  2000 CONTINUE
    +
    1131  CALL gbytec (msga,kgds(2),kptr(8),16)
    +
    1132  kptr(8) = kptr(8) + 16
    +
    1133 C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
    +
    1134  CALL gbytec (msga,kgds(3),kptr(8),16)
    +
    1135  kptr(8) = kptr(8) + 16
    +
    1136 C ------------------- BYTE 11-13 LATITUDE OF ORIGIN
    +
    1137  CALL gbytec (msga,kgds(4),kptr(8),24)
    +
    1138  kptr(8) = kptr(8) + 24
    +
    1139  IF (iand(kgds(4),8388608).NE.0) THEN
    +
    1140  kgds(4) = - iand(kgds(4),8388607)
    +
    1141  END IF
    +
    1142 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
    +
    1143  CALL gbytec (msga,kgds(5),kptr(8),24)
    +
    1144  kptr(8) = kptr(8) + 24
    +
    1145  IF (iand(kgds(5),8388608).NE.0) THEN
    +
    1146  kgds(5) = - iand(kgds(5),8388607)
    +
    1147  END IF
    +
    1148 C ------------------- BYTE 17 RESERVED
    +
    1149  CALL gbytec (msga,kgds(6),kptr(8),8)
    +
    1150  kptr(8) = kptr(8) + 8
    +
    1151 C ------------------- BYTE 18-20 LOV ORIENTATION OF THE GRID
    +
    1152  CALL gbytec (msga,kgds(7),kptr(8),24)
    +
    1153  kptr(8) = kptr(8) + 24
    +
    1154  IF (iand(kgds(7),8388608).NE.0) THEN
    +
    1155  kgds(7) = - iand(kgds(7),8388607)
    +
    1156  END IF
    +
    1157 C ------------------- BYTE 21-23 DX - THE X DIRECTION INCREMENT
    +
    1158  CALL gbytec (msga,kgds(8),kptr(8),24)
    +
    1159  kptr(8) = kptr(8) + 24
    +
    1160  IF (iand(kgds(8),8388608).NE.0) THEN
    +
    1161  kgds(8) = - iand(kgds(8),8388607)
    +
    1162  END IF
    +
    1163 C ------------------- BYTE 24-26 DY - THE Y DIRECTION INCREMENT
    +
    1164  CALL gbytec (msga,kgds(9),kptr(8),24)
    +
    1165  kptr(8) = kptr(8) + 24
    +
    1166  IF (iand(kgds(9),8388608).NE.0) THEN
    +
    1167  kgds(9) = - iand(kgds(9),8388607)
    +
    1168  END IF
    +
    1169 C ------------------- BYTE 27 PROJECTION CENTER FLAG
    +
    1170  CALL gbytec (msga,kgds(10),kptr(8),8)
    +
    1171  kptr(8) = kptr(8) + 8
    +
    1172 C ------------------- BYTE 28 SCANNING MODE
    +
    1173  CALL gbytec (msga,kgds(11),kptr(8),8)
    +
    1174  kptr(8) = kptr(8) + 8
    +
    1175 C ------------------- BYTE 29-32 RESERVED
    +
    1176 C SKIP TO START OF BYTE 33
    +
    1177  CALL gbytec (msga,kgds(12),kptr(8),32)
    +
    1178  kptr(8) = kptr(8) + 32
    +
    1179 C
    +
    1180 C -------------------
    +
    1181  GO TO 900
    +
    1182 C
    +
    1183 C ******************************************************************
    +
    1184 C ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF.
    +
    1185 C
    +
    1186 C ------------------- BYTE 7-8 J PENTAGONAL RESOLUTION PARAMETER
    +
    1187  3000 CONTINUE
    +
    1188  CALL gbytec (msga,kgds(2),kptr(8),16)
    +
    1189  kptr(8) = kptr(8) + 16
    +
    1190 C ------------------- BYTE 9-10 K PENTAGONAL RESOLUTION PARAMETER
    +
    1191  CALL gbytec (msga,kgds(3),kptr(8),16)
    +
    1192  kptr(8) = kptr(8) + 16
    +
    1193 C ------------------- BYTE 11-12 M PENTAGONAL RESOLUTION PARAMETER
    +
    1194  CALL gbytec (msga,kgds(4),kptr(8),16)
    +
    1195  kptr(8) = kptr(8) + 16
    +
    1196 C ------------------- BYTE 13 REPRESENTATION TYPE
    +
    1197  CALL gbytec (msga,kgds(5),kptr(8),8)
    +
    1198  kptr(8) = kptr(8) + 8
    +
    1199 C ------------------- BYTE 14 COEFFICIENT STORAGE MODE
    +
    1200  CALL gbytec (msga,kgds(6),kptr(8),8)
    +
    1201  kptr(8) = kptr(8) + 8
    +
    1202 C ------------------- EMPTY FIELDS - BYTES 15 - 32
    +
    1203 C SET TO START OF BYTE 33
    +
    1204  kptr(8) = kptr(8) + 18 * 8
    +
    1205  GO TO 900
    +
    1206 C ******************************************************************
    +
    1207 C PROCESS MERCATOR GRIDS
    +
    1208 C
    +
    1209 C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE
    +
    1210  4000 CONTINUE
    +
    1211  CALL gbytec (msga,kgds(2),kptr(8),16)
    +
    1212  kptr(8) = kptr(8) + 16
    +
    1213 C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
    +
    1214  CALL gbytec (msga,kgds(3),kptr(8),16)
    +
    1215  kptr(8) = kptr(8) + 16
    +
    1216 C ------------------- BYTE 11-13 LATITUE OF ORIGIN
    +
    1217  CALL gbytec (msga,kgds(4),kptr(8),24)
    +
    1218  kptr(8) = kptr(8) + 24
    +
    1219  IF (iand(kgds(4),8388608).NE.0) THEN
    +
    1220  kgds(4) = - iand(kgds(4),8388607)
    +
    1221  END IF
    +
    1222 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
    +
    1223  CALL gbytec (msga,kgds(5),kptr(8),24)
    +
    1224  kptr(8) = kptr(8) + 24
    +
    1225  IF (iand(kgds(5),8388608).NE.0) THEN
    +
    1226  kgds(5) = - iand(kgds(5),8388607)
    +
    1227  END IF
    +
    1228 C ------------------- BYTE 17 RESOLUTION FLAG
    +
    1229  CALL gbytec (msga,kgds(6),kptr(8),8)
    +
    1230  kptr(8) = kptr(8) + 8
    +
    1231 C ------------------- BYTE 18-20 LATITUDE OF EXTREME POINT
    +
    1232  CALL gbytec (msga,kgds(7),kptr(8),24)
    +
    1233  kptr(8) = kptr(8) + 24
    +
    1234  IF (iand(kgds(7),8388608).NE.0) THEN
    +
    1235  kgds(7) = - iand(kgds(7),8388607)
    +
    1236  END IF
    +
    1237 C ------------------- BYTE 21-23 LONGITUDE OF EXTREME POINT
    +
    1238  CALL gbytec (msga,kgds(8),kptr(8),24)
    +
    1239  kptr(8) = kptr(8) + 24
    +
    1240  IF (iand(kgds(8),8388608).NE.0) THEN
    +
    1241  kgds(8) = - iand(kgds(8),8388607)
    +
    1242  END IF
    +
    1243 C ------------------- BYTE 24-26 LATITUDE OF PROJECTION INTERSECTION
    +
    1244  CALL gbytec (msga,kgds(9),kptr(8),24)
    +
    1245  kptr(8) = kptr(8) + 24
    +
    1246  IF (iand(kgds(9),8388608).NE.0) THEN
    +
    1247  kgds(9) = - iand(kgds(9),8388607)
    +
    1248  END IF
    +
    1249 C ------------------- BYTE 27 RESERVED
    +
    1250  CALL gbytec (msga,kgds(10),kptr(8),8)
    +
    1251  kptr(8) = kptr(8) + 8
    +
    1252 C ------------------- BYTE 28 SCANNING MODE
    +
    1253  CALL gbytec (msga,kgds(11),kptr(8),8)
    +
    1254  kptr(8) = kptr(8) + 8
    +
    1255 C ------------------- BYTE 29-31 LONGITUDINAL DIR INCREMENT
    +
    1256  CALL gbytec (msga,kgds(12),kptr(8),24)
    +
    1257  kptr(8) = kptr(8) + 24
    +
    1258  IF (iand(kgds(12),8388608).NE.0) THEN
    +
    1259  kgds(12) = - iand(kgds(12),8388607)
    +
    1260  END IF
    +
    1261 C ------------------- BYTE 32-34 LATITUDINAL DIR INCREMENT
    +
    1262  CALL gbytec (msga,kgds(13),kptr(8),24)
    +
    1263  kptr(8) = kptr(8) + 24
    +
    1264  IF (iand(kgds(13),8388608).NE.0) THEN
    +
    1265  kgds(13) = - iand(kgds(13),8388607)
    +
    1266  END IF
    +
    1267 C ------------------- BYTE 35-42 RESERVED
    +
    1268 C SKIP TO START OF BYTE 43
    +
    1269  kptr(8) = kptr(8) + 8 * 8
    +
    1270 C -------------------
    +
    1271  GO TO 900
    +
    1272 C ******************************************************************
    +
    1273 C PROCESS LAMBERT CONFORMAL
    +
    1274 C
    +
    1275 C ------------------- BYTE 7-8 NR OF POINTS ALONG X-AXIS
    +
    1276  5000 CONTINUE
    +
    1277  CALL gbytec (msga,kgds(2),kptr(8),16)
    +
    1278  kptr(8) = kptr(8) + 16
    +
    1279 C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
    +
    1280  CALL gbytec (msga,kgds(3),kptr(8),16)
    +
    1281  kptr(8) = kptr(8) + 16
    +
    1282 C ------------------- BYTE 11-13 LATITUDE OF ORIGIN
    +
    1283  CALL gbytec (msga,kgds(4),kptr(8),24)
    +
    1284  kptr(8) = kptr(8) + 24
    +
    1285  IF (iand(kgds(4),8388608).NE.0) THEN
    +
    1286  kgds(4) = - iand(kgds(4),8388607)
    +
    1287  END IF
    +
    1288 C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN (LOWER LEFT)
    +
    1289  CALL gbytec (msga,kgds(5),kptr(8),24)
    +
    1290  kptr(8) = kptr(8) + 24
    +
    1291  IF (iand(kgds(5),8388608).NE.0) THEN
    +
    1292  kgds(5) = - iand(kgds(5),8388607)
    +
    1293  END IF
    +
    1294 C ------------------- BYTE 17 RESOLUTION
    +
    1295  CALL gbytec (msga,kgds(6),kptr(8),8)
    +
    1296  kptr(8) = kptr(8) + 8
    +
    1297 C ------------------- BYTE 18-20 LOV -ORIENTATION OF GRID
    +
    1298  CALL gbytec (msga,kgds(7),kptr(8),24)
    +
    1299  kptr(8) = kptr(8) + 24
    +
    1300  IF (iand(kgds(7),8388608).NE.0) THEN
    +
    1301  kgds(7) = - iand(kgds(7),8388607)
    +
    1302  END IF
    +
    1303 C ------------------- BYTE 21-23 DX - X-DIR INCREMENT
    +
    1304  CALL gbytec (msga,kgds(8),kptr(8),24)
    +
    1305  kptr(8) = kptr(8) + 24
    +
    1306 C ------------------- BYTE 24-26 DY - Y-DIR INCREMENT
    +
    1307  CALL gbytec (msga,kgds(9),kptr(8),24)
    +
    1308  kptr(8) = kptr(8) + 24
    +
    1309 C ------------------- BYTE 27 PROJECTION CENTER FLAG
    +
    1310  CALL gbytec (msga,kgds(10),kptr(8),8)
    +
    1311  kptr(8) = kptr(8) + 8
    +
    1312 C ------------------- BYTE 28 SCANNING MODE
    +
    1313  CALL gbytec (msga,kgds(11),kptr(8),8)
    +
    1314  kptr(8) = kptr(8) + 8
    +
    1315 C ------------------- BYTE 29-31 LATIN1 - 1ST LAT FROM POLE
    +
    1316  CALL gbytec (msga,kgds(12),kptr(8),24)
    +
    1317  kptr(8) = kptr(8) + 24
    +
    1318  IF (iand(kgds(12),8388608).NE.0) THEN
    +
    1319  kgds(12) = - iand(kgds(12),8388607)
    +
    1320  END IF
    +
    1321 C ------------------- BYTE 32-34 LATIN2 - 2ND LAT FROM POLE
    +
    1322  CALL gbytec (msga,kgds(13),kptr(8),24)
    +
    1323  kptr(8) = kptr(8) + 24
    +
    1324  IF (iand(kgds(13),8388608).NE.0) THEN
    +
    1325  kgds(13) = - iand(kgds(13),8388607)
    +
    1326  END IF
    +
    1327 C ------------------- BYTE 35-37 LATITUDE OF SOUTHERN POLE
    +
    1328  CALL gbytec (msga,kgds(14),kptr(8),24)
    +
    1329  kptr(8) = kptr(8) + 24
    +
    1330  IF (iand(kgds(14),8388608).NE.0) THEN
    +
    1331  kgds(14) = - iand(kgds(14),8388607)
    +
    1332  END IF
    +
    1333 C ------------------- BYTE 38-40 LONGITUDE OF SOUTHERN POLE
    +
    1334  CALL gbytec (msga,kgds(15),kptr(8),24)
    +
    1335  kptr(8) = kptr(8) + 24
    +
    1336  IF (iand(kgds(15),8388608).NE.0) THEN
    +
    1337  kgds(15) = - iand(kgds(15),8388607)
    +
    1338  END IF
    +
    1339 C ------------------- BYTE 41-42 RESERVED
    +
    1340  CALL gbytec (msga,kgds(16),kptr(8),16)
    +
    1341  kptr(8) = kptr(8) + 16
    +
    1342 C -------------------
    +
    1343  900 CONTINUE
    +
    1344 C
    +
    1345 C MORE CODE FOR GRIDS WITH PL
    +
    1346 C
    +
    1347  IF (kgds(19).EQ.0.OR.kgds(19).EQ.255) THEN
    +
    1348  IF (kgds(20).NE.255) THEN
    +
    1349  isum = 0
    +
    1350  kptr(8) = nsave + (kgds(20) - 1) * 8
    +
    1351  CALL gbytesc (msga,kgds(22),kptr(8),16,0,kgds(3))
    +
    1352  DO 910 j = 1, kgds(3)
    +
    1353  isum = isum + kgds(21+j)
    +
    1354  910 CONTINUE
    +
    1355  kgds(21) = isum
    +
    1356  END IF
    +
    1357  END IF
    +
    1358  RETURN
    +
    1359  END
    +
    1360 
    +
    1361 
    +
    1362 C> @brief Extract or generate bit map for output
    +
    1363 C> @author Bill Cavanaugh @date 1991-09-13
    +
    1364 
    +
    1365 C> If bit map sec is available in grib message, extract
    +
    1366 C> for program use, otherwise generate an appropriate bit map.
    +
    1367 C>
    +
    1368 C> Program history log:
    +
    1369 C> - Bill Cavanaugh 1991-09-13
    +
    1370 C> - Bill Cavanaugh 1991-11-12 Modified size of ecmwf grids 5 - 8.
    +
    1371 C> - Mark Iredell 1995-10-31 removed saves and prints
    +
    1372 C> - W. Bostelman 1997-02-12 corrects ecmwf us grid 2 processing
    +
    1373 C> - Mark Iredell 1997-09-19 vectorized bitmap decoder
    +
    1374 C> - Stephen Gilbert 1998-09-02 corrected error in map size for u.s. grid 92
    +
    1375 C> - M. Baldwin 1998-09-08 add grids 190,192
    +
    1376 C> - M. Baldwin 1999-01-20 add grids 236,237
    +
    1377 C> - Eric Rogers 2001-10-02 redefined grid #218 for 12 km eta
    +
    1378 C> redefined grid 192 for new 32-km eta grid
    +
    1379 C> - Stephen Gilbert 2003-06-30 added grids 145 and 146 for cmaq
    +
    1380 C> and grid 175 for awips over guam.
    +
    1381 C> - Boi Vuong 2004-09-02 Added awips grids 147, 148, 173 and 254
    +
    1382 C> - Boi Vuong 2006-12-12 Added awips grids 120
    +
    1383 C> - Boi Vuong 2007-04-20 Added awips grids 176
    +
    1384 C> - Boi Vuong 2007-06-11 Added awips grids 11 to 18 and 122 to 125
    +
    1385 C> and 180 to 183
    +
    1386 C> - Boi Vuong 2010-08-05 Added new grid 184, 199, 83 and
    +
    1387 C> redefined grid 90 for new rtma conus 1.27-km
    +
    1388 C> redefined grid 91 for new rtma alaska 2.976-km
    +
    1389 C> redefined grid 92 for new rtma alaska 1.488-km
    +
    1390 C> - Boi Vuong 2012-02-28 Added new grid 200
    +
    1391 C>
    +
    1392 C> @param[in] MSGA Bufr message
    +
    1393 C> @param[inout] KPTR Array containing storage for following parameters
    +
    1394 C> - 1 Total length of grib message
    +
    1395 C> - 2 Length of indicator (section 0)
    +
    1396 C> - 3 Length of pds (section 1)
    +
    1397 C> - 4 Length of gds (section 2)
    +
    1398 C> - 5 Length of bms (section 3)
    +
    1399 C> - 6 Length of bds (section 4)
    +
    1400 C> - 7 Value of current byte
    +
    1401 C> - 8 Bit pointer
    +
    1402 C> - 9 Grib start bit nr
    +
    1403 C> - 10 Grib/grid element count
    +
    1404 C> - 11 Nr unused bits at end of section 3
    +
    1405 C> - 12 Bit map flag
    +
    1406 C> - 13 Nr unused bits at end of section 2
    +
    1407 C> - 14 Bds flags
    +
    1408 C> - 15 Nr unused bits at end of section 4
    +
    1409 C> @param[in] KPDS Array containing pds elements.
    +
    1410 C> - 1 Id of center
    +
    1411 C> - 2 Model identification
    +
    1412 C> - 3 Grid identification
    +
    1413 C> - 4 Gds/bms flag
    +
    1414 C> - 5 Indicator of parameter
    +
    1415 C> - 6 Type of level
    +
    1416 C> - 7 Height/pressure , etc of level
    +
    1417 C> - 8 Year of century
    +
    1418 C> - 9 Month of year
    +
    1419 C> - 10 Day of month
    +
    1420 C> - 11 Hour of day
    +
    1421 C> - 12 Minute of hour
    +
    1422 C> - 13 Indicator of forecast time unit
    +
    1423 C> - 14 Time range 1
    +
    1424 C> - 15 Time range 2
    +
    1425 C> - 16 Time range flag
    +
    1426 C> - 17 Number included in average
    +
    1427 C> @param[in] KGDS Array containing gds elements.
    +
    1428 C> - 1) Data representation type
    +
    1429 C> - 19 Number of vertical coordinate parameters
    +
    1430 C> - 20 Octet number of the list of vertical coordinate
    +
    1431 C> parameters Or Octet number of the list of numbers of points
    +
    1432 C> in each row Or 255 if neither are present.
    +
    1433 C> - 21 For grids with pl, number of points in grid
    +
    1434 C> - 22 Number of words in each row
    +
    1435 C> - Longitude grids
    +
    1436 C> - 2) N(i) nr points on latitude circle
    +
    1437 C> - 3) N(j) nr points on longitude meridian
    +
    1438 C> - 4) La(1) latitude of origin
    +
    1439 C> - 5) Lo(1) longitude of origin
    +
    1440 C> - 6) Resolution flag
    +
    1441 C> - 7) La(2) latitude of extreme point
    +
    1442 C> - 8) Lo(2) longitude of extreme point
    +
    1443 C> - 9) Di longitudinal direction of increment
    +
    1444 C> - 10 Dj latitudinal direction increment
    +
    1445 C> - 11 Scanning mode flag
    +
    1446 C> - Polar stereographic grids
    +
    1447 C> - 2) N(i) nr points along lat circle
    +
    1448 C> - 3) N(j) nr points along lon circle
    +
    1449 C> - 4) La(1) latitude of origin
    +
    1450 C> - 5) Lo(1) longitude of origin
    +
    1451 C> - 6) Reserved
    +
    1452 C> - 7) Lov grid orientation
    +
    1453 C> - 8) Dx - x direction increment
    +
    1454 C> - 9) Dy - y direction increment
    +
    1455 C> - 10 Projection center flag
    +
    1456 C> - 11 Scanning mode
    +
    1457 C> - Spherical harmonic coefficients
    +
    1458 C> - 2 J pentagonal resolution parameter
    +
    1459 C> - 3 K pentagonal resolution parameter
    +
    1460 C> - 4 M pentagonal resolution parameter
    +
    1461 C> - 5 Representation type
    +
    1462 C> - 6 Coefficient storage mode
    +
    1463 C> - Mercator grids
    +
    1464 C> - 2 N(i) nr points on latitude circle
    +
    1465 C> - 3 N(j) nr points on longitude meridian
    +
    1466 C> - 4 La(1) latitude of origin
    +
    1467 C> - 5 Lo(1) longitude of origin
    +
    1468 C> - 6 Resolution flag
    +
    1469 C> - 7 La(2) latitude of last grid point
    +
    1470 C> - 8 Lo(2) longitude of last grid point
    +
    1471 C> - 9 Latin - latitude of projection intersection
    +
    1472 C> - 10 Reserved
    +
    1473 C> - 11 Scanning mode flag
    +
    1474 C> - 12 Longitudinal dir grid length
    +
    1475 C> - 13 Latitudinal dir grid length
    +
    1476 C> - Lambert conformal grids
    +
    1477 C> - 2 Nx nr points along x-axis
    +
    1478 C> - 3 Ny nr points along y-axis
    +
    1479 C> - 4 La1 lat of origin (lower left)
    +
    1480 C> - 5 Lo1 lon of origin (lower left)
    +
    1481 C> - 6 Resolution (right adj copy of octet 17)
    +
    1482 C> - 7 Lov - orientation of grid
    +
    1483 C> - 8 Dx - x-dir increment
    +
    1484 C> - 9 Dy - y-dir increment
    +
    1485 C> - 10 Projection center flag
    +
    1486 C> - 11 Scanning mode flag
    +
    1487 C> - 12 Latin 1 - first lat from pole of secant cone inter
    +
    1488 C> - 13 Latin 2 - second lat from pole of secant cone inter
    +
    1489 C> - Staggered arakawa rotated lat/lon grids (203 e stagger)
    +
    1490 C> - 2 N(i) nr points on rotated latitude circle
    +
    1491 C> - 3 N(j) nr points on rotated longitude meridian
    +
    1492 C> - 4 La(1) latitude of origin
    +
    1493 C> - 5 Lo(1) longitude of origin
    +
    1494 C> - 6 Resolution flag
    +
    1495 C> - 7 La(2) latitude of center
    +
    1496 C> - 8 Lo(2) longitude of center
    +
    1497 C> - 9 Di longitudinal direction of increment
    +
    1498 C> - 10 Dj latitudinal direction increment
    +
    1499 C> - 11 Scanning mode flag
    +
    1500 C> - Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
    +
    1501 C> - 2 N(i) nr points on rotated latitude circle
    +
    1502 C> - 3 N(j) nr points on rotated longitude meridian
    +
    1503 C> - 4 La(1) latitude of origin
    +
    1504 C> - 5 Lo(1) longitude of origin
    +
    1505 C> - 6 Resolution flag
    +
    1506 C> - 7 La(2) latitude of center
    +
    1507 C> - 8 Lo(2) longitude of center
    +
    1508 C> - 9 Di longitudinal direction of increment
    +
    1509 C> - 10 Dj latitudinal direction increment
    +
    1510 C> - 11 Scanning mode flag
    +
    1511 C> - 12 Latitude of last point
    +
    1512 C> - 13 Longitude of last point
    +
    1513 C> @param[out] KBMS Bitmap describing location of output elements.
    +
    1514 C> @param[out] KRET Error return
    +
    1515 C>
    +
    1516 C> @note
    +
    1517 C> - KRET
    +
    1518 C> - 0 - No error
    +
    1519 C> - 5 - Grid not avail for center indicated
    +
    1520 C> - 10 - Incorrect center indicator
    +
    1521 C> - 12 - Bytes 5-6 are not zero in bms, predefined bit map
    +
    1522 C> not provided by this center
    +
    1523 C>
    +
    1524 C> @author Bill Cavanaugh @date 1991-09-13
    +
    1525 
    +
    1526  SUBROUTINE fi634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
    +
    1527 
    +
    1528 C
    +
    1529 C INCOMING MESSAGE HOLDER
    +
    1530  CHARACTER*1 MSGA(*)
    +
    1531 C
    +
    1532 C BIT MAP
    +
    1533  LOGICAL*1 KBMS(*)
    +
    1534 C
    +
    1535 C ARRAY OF POINTERS AND COUNTERS
    +
    1536  INTEGER KPTR(*)
    +
    1537 C ARRAY OF POINTERS AND COUNTERS
    +
    1538  INTEGER KPDS(*)
    +
    1539  INTEGER KGDS(*)
    +
    1540 C
    +
    1541  INTEGER KRET
    +
    1542  INTEGER MASK(8)
    +
    1543 C ----------------------GRID 21 AND GRID 22 ARE THE SAME
    +
    1544  LOGICAL*1 GRD21( 1369)
    +
    1545 C ----------------------GRID 23 AND GRID 24 ARE THE SAME
    +
    1546  LOGICAL*1 GRD23( 1369)
    +
    1547  LOGICAL*1 GRD25( 1368)
    +
    1548  LOGICAL*1 GRD26( 1368)
    +
    1549 C ----------------------GRID 27 AND GRID 28 ARE THE SAME
    +
    1550 C ----------------------GRID 29 AND GRID 30 ARE THE SAME
    +
    1551 C ----------------------GRID 33 AND GRID 34 ARE THE SAME
    +
    1552  LOGICAL*1 GRD50( 1188)
    +
    1553 C -----------------------GRID 61 AND GRID 62 ARE THE SAME
    +
    1554  LOGICAL*1 GRD61( 4186)
    +
    1555 C -----------------------GRID 63 AND GRID 64 ARE THE SAME
    +
    1556  LOGICAL*1 GRD63( 4186)
    +
    1557 C LOGICAL*1 GRD70(16380)/16380*.TRUE./
    +
    1558 C -------------------------------------------------------------
    +
    1559  DATA grd21 /1333*.true.,36*.false./
    +
    1560  DATA grd23 /.true.,36*.false.,1332*.true./
    +
    1561  DATA grd25 /1297*.true.,71*.false./
    +
    1562  DATA grd26 /.true.,71*.false.,1296*.true./
    +
    1563  DATA grd50/
    +
    1564 C LINE 1-4
    +
    1565  & 7*.false.,22*.true.,14*.false.,22*.true.,
    +
    1566  & 14*.false.,22*.true.,14*.false.,22*.true.,7*.false.,
    +
    1567 C LINE 5-8
    +
    1568  & 6*.false.,24*.true.,12*.false.,24*.true.,
    +
    1569  & 12*.false.,24*.true.,12*.false.,24*.true.,6*.false.,
    +
    1570 C LINE 9-12
    +
    1571  & 5*.false.,26*.true.,10*.false.,26*.true.,
    +
    1572  & 10*.false.,26*.true.,10*.false.,26*.true.,5*.false.,
    +
    1573 C LINE 13-16
    +
    1574  & 4*.false.,28*.true., 8*.false.,28*.true.,
    +
    1575  & 8*.false.,28*.true., 8*.false.,28*.true.,4*.false.,
    +
    1576 C LINE 17-20
    +
    1577  & 3*.false.,30*.true., 6*.false.,30*.true.,
    +
    1578  & 6*.false.,30*.true., 6*.false.,30*.true.,3*.false.,
    +
    1579 C LINE 21-24
    +
    1580  & 2*.false.,32*.true., 4*.false.,32*.true.,
    +
    1581  & 4*.false.,32*.true., 4*.false.,32*.true.,2*.false.,
    +
    1582 C LINE 25-28
    +
    1583  & .false.,34*.true., 2*.false.,34*.true.,
    +
    1584  & 2*.false.,34*.true., 2*.false.,34*.true., .false.,
    +
    1585 C LINE 29-33
    +
    1586  & 180*.true./
    +
    1587  DATA grd61 /4096*.true.,90*.false./
    +
    1588  DATA grd63 /.true.,90*.false.,4095*.true./
    +
    1589  DATA mask /128,64,32,16,8,4,2,1/
    +
    1590 C
    +
    1591 C PRINT *,'FI634'
    +
    1592  IF (iand(kpds(4),64).EQ.64) THEN
    +
    1593 C
    +
    1594 C SET UP BIT POINTER
    +
    1595 C SECTION 0 SECTION 1 SECTION 2
    +
    1596  kptr(8) = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + (kptr(4)*8) + 24
    +
    1597 C
    +
    1598 C BYTE 4 NUMBER OF UNUSED BITS AT END OF SECTION 3
    +
    1599 C
    +
    1600  CALL gbytec (msga,kptr(11),kptr(8),8)
    +
    1601  kptr(8) = kptr(8) + 8
    +
    1602 C
    +
    1603 C BYTE 5,6 TABLE REFERENCE IF 0, BIT MAP FOLLOWS
    +
    1604 C
    +
    1605  CALL gbytec (msga,kptr(12),kptr(8),16)
    +
    1606  kptr(8) = kptr(8) + 16
    +
    1607 C IF TABLE REFERENCE = 0, EXTRACT BIT MAP
    +
    1608  IF (kptr(12).EQ.0) THEN
    +
    1609 C CALCULATE NR OF BITS IN BIT MAP
    +
    1610  ibits = (kptr(5) - 6) * 8 - kptr(11)
    +
    1611  kptr(10) = ibits
    +
    1612  IF (kpds(3).EQ.21.OR.kpds(3).EQ.22.OR.kpds(3).EQ.25.
    +
    1613  * or.kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
    +
    1614 C NORTHERN HEMISPHERE 21, 22, 25, 61, 62
    +
    1615  CALL fi634x(ibits,kptr(8),msga,kbms)
    +
    1616  IF (kpds(3).EQ.25) THEN
    +
    1617  kadd = 71
    +
    1618  ELSE IF (kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
    +
    1619  kadd = 90
    +
    1620  ELSE
    +
    1621  kadd = 36
    +
    1622  END IF
    +
    1623  DO 25 i = 1, kadd
    +
    1624  kbms(i+ibits) = .false.
    +
    1625  25 CONTINUE
    +
    1626  kptr(10) = kptr(10) + kadd
    +
    1627  RETURN
    +
    1628  ELSE IF (kpds(3).EQ.23.OR.kpds(3).EQ.24.OR.kpds(3).EQ.26.
    +
    1629  * or.kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
    +
    1630 C SOUTHERN HEMISPHERE 23, 24, 26, 63, 64
    +
    1631  CALL fi634x(ibits,kptr(8),msga,kbms)
    +
    1632  IF (kpds(3).EQ.26) THEN
    +
    1633  kadd = 72
    +
    1634  ELSE IF (kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
    +
    1635  kadd = 91
    +
    1636  ELSE
    +
    1637  kadd = 37
    +
    1638  END IF
    +
    1639  DO 26 i = 1, kadd
    +
    1640  kbms(i+ibits) = .false.
    +
    1641  26 CONTINUE
    +
    1642  kptr(10) = kptr(10) + kadd - 1
    +
    1643  RETURN
    +
    1644  ELSE IF (kpds(3).EQ.50) THEN
    +
    1645  kpad = 7
    +
    1646  kin = 22
    +
    1647  kbits = 0
    +
    1648  DO 55 i = 1, 7
    +
    1649  DO 54 j = 1, 4
    +
    1650  DO 51 k = 1, kpad
    +
    1651  kbits = kbits + 1
    +
    1652  kbms(kbits) = .false.
    +
    1653  51 CONTINUE
    +
    1654  CALL fi634x(kin,kptr(8),msga,kbms(kbits+1))
    +
    1655  kptr(8)=kptr(8)+kin
    +
    1656  kbits=kbits+kin
    +
    1657  DO 53 k = 1, kpad
    +
    1658  kbits = kbits + 1
    +
    1659  kbms(kbits) = .false.
    +
    1660  53 CONTINUE
    +
    1661  54 CONTINUE
    +
    1662  kin = kin + 2
    +
    1663  kpad = kpad - 1
    +
    1664  55 CONTINUE
    +
    1665  DO 57 ii = 1, 5
    +
    1666  CALL fi634x(kin,kptr(8),msga,kbms(kbits+1))
    +
    1667  kptr(8)=kptr(8)+kin
    +
    1668  kbits=kbits+kin
    +
    1669  57 CONTINUE
    +
    1670  ELSE
    +
    1671 C EXTRACT BIT MAP FROM BMS FOR OTHER GRIDS
    +
    1672  CALL fi634x(ibits,kptr(8),msga,kbms)
    +
    1673  END IF
    +
    1674  RETURN
    +
    1675  ELSE
    +
    1676 C PRINT *,'FI634-NO PREDEFINED BIT MAP PROVIDED BY THIS CENTER'
    +
    1677  kret = 12
    +
    1678  RETURN
    +
    1679  END IF
    +
    1680 C
    +
    1681  END IF
    +
    1682  kret = 0
    +
    1683 C -------------------------------------------------------
    +
    1684 C PROCESS NON-STANDARD GRID
    +
    1685 C -------------------------------------------------------
    +
    1686  IF (kpds(3).EQ.255) THEN
    +
    1687 C PRINT *,'NON STANDARD GRID, CENTER = ',KPDS(1)
    +
    1688  j = kgds(2) * kgds(3)
    +
    1689  kptr(10) = j
    +
    1690  DO 600 i = 1, j
    +
    1691  kbms(i) = .true.
    +
    1692  600 CONTINUE
    +
    1693  RETURN
    +
    1694  END IF
    +
    1695 C -------------------------------------------------------
    +
    1696 C CHECK INTERNATIONAL SET
    +
    1697 C -------------------------------------------------------
    +
    1698  IF (kpds(3).EQ.21.OR.kpds(3).EQ.22) THEN
    +
    1699 C ----- INT'L GRIDS 21, 22 - MAP SIZE 1369
    +
    1700  j = 1369
    +
    1701  kptr(10) = j
    +
    1702  CALL fi637(j,kpds,kgds,kret)
    +
    1703  IF(kret.NE.0) GO TO 820
    +
    1704  DO 3021 i = 1, 1369
    +
    1705  kbms(i) = grd21(i)
    +
    1706  3021 CONTINUE
    +
    1707  RETURN
    +
    1708  ELSE IF (kpds(3).EQ.23.OR.kpds(3).EQ.24) THEN
    +
    1709 C ----- INT'L GRIDS 23, 24 - MAP SIZE 1369
    +
    1710  j = 1369
    +
    1711  kptr(10) = j
    +
    1712  CALL fi637(j,kpds,kgds,kret)
    +
    1713  IF(kret.NE.0) GO TO 820
    +
    1714  DO 3023 i = 1, 1369
    +
    1715  kbms(i) = grd23(i)
    +
    1716  3023 CONTINUE
    +
    1717  RETURN
    +
    1718  ELSE IF (kpds(3).EQ.25) THEN
    +
    1719 C ----- INT'L GRID 25 - MAP SIZE 1368
    +
    1720  j = 1368
    +
    1721  kptr(10) = j
    +
    1722  CALL fi637(j,kpds,kgds,kret)
    +
    1723  IF(kret.NE.0) GO TO 820
    +
    1724  DO 3025 i = 1, 1368
    +
    1725  kbms(i) = grd25(i)
    +
    1726  3025 CONTINUE
    +
    1727  RETURN
    +
    1728  ELSE IF (kpds(3).EQ.26) THEN
    +
    1729 C ----- INT'L GRID 26 - MAP SIZE 1368
    +
    1730  j = 1368
    +
    1731  kptr(10) = j
    +
    1732  CALL fi637(j,kpds,kgds,kret)
    +
    1733  IF(kret.NE.0) GO TO 820
    +
    1734  DO 3026 i = 1, 1368
    +
    1735  kbms(i) = grd26(i)
    +
    1736  3026 CONTINUE
    +
    1737  RETURN
    +
    1738  ELSE IF (kpds(3).GE.37.AND.kpds(3).LE.44) THEN
    +
    1739 C ----- INT'L GRID 37-44 - MAP SIZE 3447
    +
    1740  j = 3447
    +
    1741  GO TO 800
    +
    1742  ELSE IF (kpds(1).EQ.7.AND.kpds(3).EQ.50) THEN
    +
    1743 C ----- INT'L GRIDS 50 - MAP SIZE 964
    +
    1744  j = 1188
    +
    1745  kptr(10) = j
    +
    1746  CALL fi637(j,kpds,kgds,kret)
    +
    1747  IF(kret.NE.0) GO TO 890
    +
    1748  DO 3050 i = 1, j
    +
    1749  kbms(i) = grd50(i)
    +
    1750  3050 CONTINUE
    +
    1751  RETURN
    +
    1752  ELSE IF (kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
    +
    1753 C ----- INT'L GRIDS 61, 62 - MAP SIZE 4186
    +
    1754  j = 4186
    +
    1755  kptr(10) = j
    +
    1756  CALL fi637(j,kpds,kgds,kret)
    +
    1757  IF(kret.NE.0) GO TO 820
    +
    1758  DO 3061 i = 1, 4186
    +
    1759  kbms(i) = grd61(i)
    +
    1760  3061 CONTINUE
    +
    1761  RETURN
    +
    1762  ELSE IF (kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
    +
    1763 C ----- INT'L GRIDS 63, 64 - MAP SIZE 4186
    +
    1764  j = 4186
    +
    1765  kptr(10) = j
    +
    1766  CALL fi637(j,kpds,kgds,kret)
    +
    1767  IF(kret.NE.0) GO TO 820
    +
    1768  DO 3063 i = 1, 4186
    +
    1769  kbms(i) = grd63(i)
    +
    1770  3063 CONTINUE
    +
    1771  RETURN
    +
    1772  END IF
    +
    1773 C -------------------------------------------------------
    +
    1774 C CHECK UNITED STATES SET
    +
    1775 C -------------------------------------------------------
    +
    1776  IF (kpds(1).EQ.7) THEN
    +
    1777  IF (kpds(3).LT.100) THEN
    +
    1778  IF (kpds(3).EQ.1) THEN
    +
    1779 C ----- U.S. GRID 1 - MAP SIZE 1679
    +
    1780  j = 1679
    +
    1781  GO TO 800
    +
    1782  END IF
    +
    1783  IF (kpds(3).EQ.2) THEN
    +
    1784 C ----- U.S. GRID 2 - MAP SIZE 10512
    +
    1785  j = 10512
    +
    1786  GO TO 800
    +
    1787  ELSE IF (kpds(3).EQ.3) THEN
    +
    1788 C ----- U.S. GRID 3 - MAP SIZE 65160
    +
    1789  j = 65160
    +
    1790  GO TO 800
    +
    1791  ELSE IF (kpds(3).EQ.4) THEN
    +
    1792 C ----- U.S. GRID 4 - MAP SIZE 259920
    +
    1793  j = 259920
    +
    1794  GO TO 800
    +
    1795  ELSE IF (kpds(3).EQ.5) THEN
    +
    1796 C ----- U.S. GRID 5 - MAP SIZE 3021
    +
    1797  j = 3021
    +
    1798  GO TO 800
    +
    1799  ELSE IF (kpds(3).EQ.6) THEN
    +
    1800 C ----- U.S. GRID 6 - MAP SIZE 2385
    +
    1801  j = 2385
    +
    1802  GO TO 800
    +
    1803  ELSE IF (kpds(3).EQ.8) THEN
    +
    1804 C ----- U.S. GRID 8 - MAP SIZE 5104
    +
    1805  j = 5104
    +
    1806  GO TO 800
    +
    1807  ELSE IF (kpds(3).EQ.10) THEN
    +
    1808 C ----- U.S. GRID 10 - MAP SIZE 25020
    +
    1809  j = 25020
    +
    1810  GO TO 800
    +
    1811  ELSE IF (kpds(3).EQ.11) THEN
    +
    1812 C ----- U.S. GRID 11 - MAP SIZE 223920
    +
    1813  j = 223920
    +
    1814  GO TO 800
    +
    1815  ELSE IF (kpds(3).EQ.12) THEN
    +
    1816 C ----- U.S. GRID 12 - MAP SIZE 99631
    +
    1817  j = 99631
    +
    1818  GO TO 800
    +
    1819  ELSE IF (kpds(3).EQ.13) THEN
    +
    1820 C ----- U.S. GRID 13 - MAP SIZE 36391
    +
    1821  j = 36391
    +
    1822  GO TO 800
    +
    1823  ELSE IF (kpds(3).EQ.14) THEN
    +
    1824 C ----- U.S. GRID 14 - MAP SIZE 153811
    +
    1825  j = 153811
    +
    1826  GO TO 800
    +
    1827  ELSE IF (kpds(3).EQ.15) THEN
    +
    1828 C ----- U.S. GRID 15 - MAP SIZE 74987
    +
    1829  j = 74987
    +
    1830  GO TO 800
    +
    1831  ELSE IF (kpds(3).EQ.16) THEN
    +
    1832 C ----- U.S. GRID 16 - MAP SIZE 214268
    +
    1833  j = 214268
    +
    1834  GO TO 800
    +
    1835  ELSE IF (kpds(3).EQ.17) THEN
    +
    1836 C ----- U.S. GRID 17 - MAP SIZE 387136
    +
    1837  j = 387136
    +
    1838  GO TO 800
    +
    1839  ELSE IF (kpds(3).EQ.18) THEN
    +
    1840 C ----- U.S. GRID 18 - MAP SIZE 281866
    +
    1841  j = 281866
    +
    1842  GO TO 800
    +
    1843  ELSE IF (kpds(3).EQ.27.OR.kpds(3).EQ.28) THEN
    +
    1844 C ----- U.S. GRIDS 27, 28 - MAP SIZE 4225
    +
    1845  j = 4225
    +
    1846  GO TO 800
    +
    1847  ELSE IF (kpds(3).EQ.29.OR.kpds(3).EQ.30) THEN
    +
    1848 C ----- U.S. GRIDS 29,30 - MAP SIZE 5365
    +
    1849  j = 5365
    +
    1850  GO TO 800
    +
    1851  ELSE IF (kpds(3).EQ.33.OR.kpds(3).EQ.34) THEN
    +
    1852 C ----- U.S GRID 33, 34 - MAP SIZE 8326
    +
    1853  j = 8326
    +
    1854  GO TO 800
    +
    1855  ELSE IF (kpds(3).GE.37.AND.kpds(3).LE.44) THEN
    +
    1856 C ----- U.S. GRID 37-44 - MAP SIZE 3447
    +
    1857  j = 3447
    +
    1858  GO TO 800
    +
    1859  ELSE IF (kpds(3).EQ.45) THEN
    +
    1860 C ----- U.S. GRID 45 - MAP SIZE 41760
    +
    1861  j = 41760
    +
    1862  GO TO 800
    +
    1863  ELSE IF (kpds(3).EQ.53) THEN
    +
    1864 C ----- U.S. GRID 53 - MAP SIZE 5967
    +
    1865  j = 5967
    +
    1866  GO TO 800
    +
    1867  ELSE IF (kpds(3).EQ.55.OR.kpds(3).EQ.56) THEN
    +
    1868 C ----- U.S GRID 55, 56 - MAP SIZE 6177
    +
    1869  j = 6177
    +
    1870  GO TO 800
    +
    1871  ELSE IF (kpds(3).GE.67.AND.kpds(3).LE.71) THEN
    +
    1872 C ----- U.S GRID 67-71 - MAP SIZE 13689
    +
    1873  j = 13689
    +
    1874  GO TO 800
    +
    1875  ELSE IF (kpds(3).EQ.72) THEN
    +
    1876 C ----- U.S GRID 72 - MAP SIZE 406
    +
    1877  j = 406
    +
    1878  GO TO 800
    +
    1879  ELSE IF (kpds(3).EQ.73) THEN
    +
    1880 C ----- U.S GRID 73 - MAP SIZE 13056
    +
    1881  j = 13056
    +
    1882  GO TO 800
    +
    1883  ELSE IF (kpds(3).EQ.74) THEN
    +
    1884 C ----- U.S GRID 74 - MAP SIZE 10800
    +
    1885  j = 10800
    +
    1886  GO TO 800
    +
    1887  ELSE IF (kpds(3).GE.75.AND.kpds(3).LE.77) THEN
    +
    1888 C ----- U.S GRID 75-77 - MAP SIZE 12321
    +
    1889  j = 12321
    +
    1890  GO TO 800
    +
    1891  ELSE IF (kpds(3).EQ.83) THEN
    +
    1892 C ----- U.S GRID 83 - MAP SIZE 429786
    +
    1893  j = 429786
    +
    1894  GO TO 800
    +
    1895  ELSE IF (kpds(3).EQ.85.OR.kpds(3).EQ.86) THEN
    +
    1896 C ----- U.S GRID 85,86 - MAP SIZE 32400
    +
    1897  j = 32400
    +
    1898  GO TO 800
    +
    1899  ELSE IF (kpds(3).EQ.87) THEN
    +
    1900 C ----- U.S GRID 87 - MAP SIZE 5022
    +
    1901  j = 5022
    +
    1902  GO TO 800
    +
    1903  ELSE IF (kpds(3).EQ.88) THEN
    +
    1904 C ----- U.S GRID 88 - MAP SIZE 317840
    +
    1905  j = 317840
    +
    1906  GO TO 800
    +
    1907  ELSE IF (kpds(3).EQ.90) THEN
    +
    1908 C ----- U.S GRID 90 - MAP SIZE 11807617
    +
    1909  j = 11807617
    +
    1910  GO TO 800
    +
    1911  ELSE IF (kpds(3).EQ.91) THEN
    +
    1912 C ----- U.S GRID 91 - MAP SIZE 1822145
    +
    1913  j = 1822145
    +
    1914  GO TO 800
    +
    1915  ELSE IF (kpds(3).EQ.92) THEN
    +
    1916 C ----- U.S GRID 92 - MAP SIZE 7283073
    +
    1917  j = 7283073
    +
    1918  GO TO 800
    +
    1919  ELSE IF (kpds(3).EQ.93) THEN
    +
    1920 C ----- U.S GRID 93 - MAP SIZE 111723
    +
    1921  j = 111723
    +
    1922  GO TO 800
    +
    1923  ELSE IF (kpds(3).EQ.94) THEN
    +
    1924 C ----- U.S GRID 94 - MAP SIZE 371875
    +
    1925  j = 371875
    +
    1926  GO TO 800
    +
    1927  ELSE IF (kpds(3).EQ.95) THEN
    +
    1928 C ----- U.S GRID 95 - MAP SIZE 130325
    +
    1929  j = 130325
    +
    1930  GO TO 800
    +
    1931  ELSE IF (kpds(3).EQ.96) THEN
    +
    1932 C ----- U.S GRID 96 - MAP SIZE 209253
    +
    1933  j = 209253
    +
    1934  GO TO 800
    +
    1935  ELSE IF (kpds(3).EQ.97) THEN
    +
    1936 C ----- U.S GRID 97 - MAP SIZE 1508100
    +
    1937  j = 1508100
    +
    1938  GO TO 800
    +
    1939  ELSE IF (kpds(3).EQ.98) THEN
    +
    1940 C ----- U.S GRID 98 - MAP SIZE 18048
    +
    1941  j = 18048
    +
    1942  GO TO 800
    +
    1943  ELSE IF (kpds(3).EQ.99) THEN
    +
    1944 C ----- U.S GRID 99 - MAP SIZE 779385
    +
    1945  j = 779385
    +
    1946  GO TO 800
    +
    1947  END IF
    +
    1948  ELSE IF (kpds(3).GE.100.AND.kpds(3).LT.200) THEN
    +
    1949  IF (kpds(3).EQ.100) THEN
    +
    1950 C ----- U.S. GRID 100 - MAP SIZE 6889
    +
    1951  j = 6889
    +
    1952  GO TO 800
    +
    1953  ELSE IF (kpds(3).EQ.101) THEN
    +
    1954 C ----- U.S. GRID 101 - MAP SIZE 10283
    +
    1955  j = 10283
    +
    1956  GO TO 800
    +
    1957  ELSE IF (kpds(3).EQ.103) THEN
    +
    1958 C ----- U.S. GRID 103 - MAP SIZE 3640
    +
    1959  j = 3640
    +
    1960  GO TO 800
    +
    1961  ELSE IF (kpds(3).EQ.104) THEN
    +
    1962 C ----- U.S. GRID 104 - MAP SIZE 16170
    +
    1963  j = 16170
    +
    1964  GO TO 800
    +
    1965  ELSE IF (kpds(3).EQ.105) THEN
    +
    1966 C ----- U.S. GRID 105 - MAP SIZE 6889
    +
    1967  j = 6889
    +
    1968  GO TO 800
    +
    1969  ELSE IF (kpds(3).EQ.106) THEN
    +
    1970 C ----- U.S. GRID 106 - MAP SIZE 19305
    +
    1971  j = 19305
    +
    1972  GO TO 800
    +
    1973  ELSE IF (kpds(3).EQ.107) THEN
    +
    1974 C ----- U.S. GRID 107 - MAP SIZE 11040
    +
    1975  j = 11040
    +
    1976  GO TO 800
    +
    1977  ELSE IF (kpds(3).EQ.110) THEN
    +
    1978 C ----- U.S. GRID 110 - MAP SIZE 103936
    +
    1979  j = 103936
    +
    1980  GO TO 800
    +
    1981  ELSE IF (kpds(3).EQ.120) THEN
    +
    1982 C ----- U.S. GRID 120 - MAP SIZE 2020800
    +
    1983  j = 2020800
    +
    1984  GO TO 800
    +
    1985  ELSE IF (kpds(3).EQ.122) THEN
    +
    1986 C ----- U.S. GRID 122 - MAP SIZE 162750
    +
    1987  j = 162750
    +
    1988  GO TO 800
    +
    1989  ELSE IF (kpds(3).EQ.123) THEN
    +
    1990 C ----- U.S. GRID 123 - MAP SIZE 100800
    +
    1991  j = 100800
    +
    1992  GO TO 800
    +
    1993  ELSE IF (kpds(3).EQ.124) THEN
    +
    1994 C ----- U.S. GRID 124 - MAP SIZE 75360
    +
    1995  j = 75360
    +
    1996  GO TO 800
    +
    1997  ELSE IF (kpds(3).EQ.125) THEN
    +
    1998 C ----- U.S. GRID 125 - MAP SIZE 102000
    +
    1999  j = 102000
    +
    2000  GO TO 800
    +
    2001  ELSE IF (kpds(3).EQ.126) THEN
    +
    2002 C ----- U.S. GRID 126 - MAP SIZE 72960
    +
    2003  j = 72960
    +
    2004  GO TO 800
    +
    2005  ELSE IF (kpds(3).EQ.127) THEN
    +
    2006 C ----- U.S. GRID 127 - MAP SIZE 294912
    +
    2007  j = 294912
    +
    2008  GO TO 800
    +
    2009  ELSE IF (kpds(3).EQ.128) THEN
    +
    2010 C ----- U.S. GRID 128 - MAP SIZE 663552
    +
    2011  j = 663552
    +
    2012  GO TO 800
    +
    2013  ELSE IF (kpds(3).EQ.129) THEN
    +
    2014 C ----- U.S. GRID 129 - MAP SIZE 1548800
    +
    2015  j = 1548800
    +
    2016  GO TO 800
    +
    2017  ELSE IF (kpds(3).EQ.130) THEN
    +
    2018 C ----- U.S. GRID 130 - MAP SIZE 151987
    +
    2019  j = 151987
    +
    2020  GO TO 800
    +
    2021  ELSE IF (kpds(3).EQ.132) THEN
    +
    2022 C ----- U.S. GRID 132 - MAP SIZE 385441
    +
    2023  j = 385441
    +
    2024  GO TO 800
    +
    2025  ELSE IF (kpds(3).EQ.138) THEN
    +
    2026 C ----- U.S. GRID 138 - MAP SIZE 134784
    +
    2027  j = 134784
    +
    2028  GO TO 800
    +
    2029  ELSE IF (kpds(3).EQ.139) THEN
    +
    2030 C ----- U.S. GRID 139 - MAP SIZE 4160
    +
    2031  j = 4160
    +
    2032  GO TO 800
    +
    2033  ELSE IF (kpds(3).EQ.140) THEN
    +
    2034 C ----- U.S. GRID 140 - MAP SIZE 32437
    +
    2035  j = 32437
    +
    2036  GO TO 800
    +
    2037 C
    +
    2038  ELSE IF (kpds(3).EQ.145) THEN
    +
    2039 C ----- U.S. GRID 145 - MAP SIZE 24505
    +
    2040  j = 24505
    +
    2041  GO TO 800
    +
    2042  ELSE IF (kpds(3).EQ.146) THEN
    +
    2043 C ----- U.S. GRID 146 - MAP SIZE 23572
    +
    2044  j = 23572
    +
    2045  GO TO 800
    +
    2046  ELSE IF (kpds(3).EQ.147) THEN
    +
    2047 C ----- U.S. GRID 147 - MAP SIZE 69412
    +
    2048  j = 69412
    +
    2049  GO TO 800
    +
    2050  ELSE IF (kpds(3).EQ.148) THEN
    +
    2051 C ----- U.S. GRID 148 - MAP SIZE 117130
    +
    2052  j = 117130
    +
    2053  GO TO 800
    +
    2054  ELSE IF (kpds(3).EQ.150) THEN
    +
    2055 C ----- U.S. GRID 150 - MAP SIZE 806010
    +
    2056  j = 806010
    +
    2057  GO TO 800
    +
    2058  ELSE IF (kpds(3).EQ.151) THEN
    +
    2059 C ----- U.S. GRID 151 - MAP SIZE 205062
    +
    2060  j = 205062
    +
    2061  GO TO 800
    +
    2062  ELSE IF (kpds(3).EQ.160) THEN
    +
    2063 C ----- U.S. GRID 160 - MAP SIZE 28080
    +
    2064  j = 28080
    +
    2065  GO TO 800
    +
    2066  ELSE IF (kpds(3).EQ.161) THEN
    +
    2067 C ----- U.S. GRID 161 - MAP SIZE 14111
    +
    2068  j = 14111
    +
    2069  GO TO 800
    +
    2070  ELSE IF (kpds(3).EQ.163) THEN
    +
    2071 C ----- U.S. GRID 163 - MAP SIZE 727776
    +
    2072  j = 727776
    +
    2073  GO TO 800
    +
    2074  ELSE IF (kpds(3).EQ.170) THEN
    +
    2075 C ----- U.S. GRID 170 - MAP SIZE 131072
    +
    2076  j = 131072
    +
    2077  GO TO 800
    +
    2078  ELSE IF (kpds(3).EQ.171) THEN
    +
    2079 C ----- U.S. GRID 171 - MAP SIZE 716100
    +
    2080  j = 716100
    +
    2081  GO TO 800
    +
    2082  ELSE IF (kpds(3).EQ.172) THEN
    +
    2083 C ----- U.S. GRID 172 - MAP SIZE 489900
    +
    2084  j = 489900
    +
    2085  GO TO 800
    +
    2086  ELSE IF (kpds(3).EQ.173) THEN
    +
    2087 C ----- U.S. GRID 173 - MAP SIZE 9331200
    +
    2088  j = 9331200
    +
    2089  GO TO 800
    +
    2090  ELSE IF (kpds(3).EQ.174) THEN
    +
    2091 C ----- U.S. GRID 174 - MAP SIZE 4147200
    +
    2092  j = 4147200
    +
    2093  GO TO 800
    +
    2094  ELSE IF (kpds(3).EQ.175) THEN
    +
    2095 C ----- U.S. GRID 175 - MAP SIZE 185704
    +
    2096  j = 185704
    +
    2097  GO TO 800
    +
    2098  ELSE IF (kpds(3).EQ.176) THEN
    +
    2099 C ----- U.S. GRID 176 - MAP SIZE 76845
    +
    2100  j = 76845
    +
    2101  GO TO 800
    +
    2102  ELSE IF (kpds(3).EQ.179) THEN
    +
    2103 C ----- U.S. GRID 179 - MAP SIZE 977132
    +
    2104  j = 977132
    +
    2105  GO TO 800
    +
    2106  ELSE IF (kpds(3).EQ.180) THEN
    +
    2107 C ----- U.S. GRID 180 - MAP SIZE 267168
    +
    2108  j = 267168
    +
    2109  GO TO 800
    +
    2110  ELSE IF (kpds(3).EQ.181) THEN
    +
    2111 C ----- U.S. GRID 181 - MAP SIZE 102860
    +
    2112  j = 102860
    +
    2113  GO TO 800
    +
    2114  ELSE IF (kpds(3).EQ.182) THEN
    +
    2115 C ----- U.S. GRID 182 - MAP SIZE 64218
    +
    2116  j = 64218
    +
    2117  GO TO 800
    +
    2118  ELSE IF (kpds(3).EQ.183) THEN
    +
    2119 C ----- U.S. GRID 183 - MAP SIZE 180144
    +
    2120  j = 180144
    +
    2121  GO TO 800
    +
    2122  ELSE IF (kpds(3).EQ.184) THEN
    +
    2123 C ----- U.S. GRID 184 - MAP SIZE 2953665
    +
    2124  j = 2953665
    +
    2125  GO TO 800
    +
    2126  ELSE IF (kpds(3).EQ.187) THEN
    +
    2127 C ----- U.S. GRID 187 - MAP SIZE 3425565
    +
    2128  j = 3425565
    +
    2129  GO TO 800
    +
    2130  ELSE IF (kpds(3).EQ.188) THEN
    +
    2131 C ----- U.S. GRID 188 - MAP SIZE 563655
    +
    2132  j = 563655
    +
    2133  GO TO 800
    +
    2134  ELSE IF (kpds(3).EQ.189) THEN
    +
    2135 C ----- U.S. GRID 189 - MAP SIZE 560025
    +
    2136  j = 560025
    +
    2137  GO TO 800
    +
    2138  ELSE IF (kpds(3).EQ.190) THEN
    +
    2139 C ----- U.S GRID 190 - MAP SIZE 796590
    +
    2140  j = 796590
    +
    2141  GO TO 800
    +
    2142  ELSE IF (kpds(3).EQ.192) THEN
    +
    2143 C ----- U.S GRID 192 - MAP SIZE 91719
    +
    2144  j = 91719
    +
    2145  GO TO 800
    +
    2146  ELSE IF (kpds(3).EQ.193) THEN
    +
    2147 C ----- U.S GRID 193 - MAP SIZE 1038240
    +
    2148  j = 1038240
    +
    2149  GO TO 800
    +
    2150  ELSE IF (kpds(3).EQ.194) THEN
    +
    2151 C ----- U.S GRID 194 - MAP SIZE 168640
    +
    2152  j = 168640
    +
    2153  GO TO 800
    +
    2154  ELSE IF (kpds(3).EQ.195) THEN
    +
    2155 C ----- U.S. GRID 195 - MAP SIZE 22833
    +
    2156  j = 22833
    +
    2157  GO TO 800
    +
    2158  ELSE IF (kpds(3).EQ.196) THEN
    +
    2159 C ----- U.S. GRID 196 - MAP SIZE 72225
    +
    2160  j = 72225
    +
    2161  GO TO 800
    +
    2162  ELSE IF (kpds(3).EQ.197) THEN
    +
    2163 C ----- U.S. GRID 197 - MAP SIZE 739297
    +
    2164  j = 739297
    +
    2165  GO TO 800
    +
    2166  ELSE IF (kpds(3).EQ.198) THEN
    +
    2167 C ----- U.S. GRID 198 - MAP SIZE 456225
    +
    2168  j = 456225
    +
    2169  GO TO 800
    +
    2170  ELSE IF (kpds(3).EQ.199) THEN
    +
    2171 C ----- U.S. GRID 199 - MAP SIZE 37249
    +
    2172  j = 37249
    +
    2173  GO TO 800
    +
    2174  ELSE IF (iand(kpds(4),128).EQ.128) THEN
    +
    2175 C ----- U.S. NON-STANDARD GRID
    +
    2176  GO TO 895
    +
    2177  END IF
    +
    2178  ELSE IF (kpds(3).GE.200) THEN
    +
    2179  IF (kpds(3).EQ.200) THEN
    +
    2180  j = 10152
    +
    2181  GO TO 800
    +
    2182  ELSE IF (kpds(3).EQ.201) THEN
    +
    2183  j = 4225
    +
    2184  GO TO 800
    +
    2185  ELSE IF (kpds(3).EQ.202) THEN
    +
    2186  j = 2795
    +
    2187  GO TO 800
    +
    2188  ELSE IF (kpds(3).EQ.203.OR.kpds(3).EQ.205) THEN
    +
    2189  j = 1755
    +
    2190  GO TO 800
    +
    2191  ELSE IF (kpds(3).EQ.204) THEN
    +
    2192  j = 6324
    +
    2193  GO TO 800
    +
    2194  ELSE IF (kpds(3).EQ.206) THEN
    +
    2195  j = 2091
    +
    2196  GO TO 800
    +
    2197  ELSE IF (kpds(3).EQ.207) THEN
    +
    2198  j = 1715
    +
    2199  GO TO 800
    +
    2200  ELSE IF (kpds(3).EQ.208) THEN
    +
    2201  j = 783
    +
    2202  GO TO 800
    +
    2203  ELSE IF (kpds(3).EQ.209) THEN
    +
    2204  j = 61325
    +
    2205  GO TO 800
    +
    2206  ELSE IF (kpds(3).EQ.210) THEN
    +
    2207  j = 625
    +
    2208  GO TO 800
    +
    2209  ELSE IF (kpds(3).EQ.211) THEN
    +
    2210  j = 6045
    +
    2211  GO TO 800
    +
    2212  ELSE IF (kpds(3).EQ.212) THEN
    +
    2213  j = 23865
    +
    2214  GO TO 800
    +
    2215  ELSE IF (kpds(3).EQ.213) THEN
    +
    2216  j = 10965
    +
    2217  GO TO 800
    +
    2218  ELSE IF (kpds(3).EQ.214) THEN
    +
    2219  j = 6693
    +
    2220  GO TO 800
    +
    2221  ELSE IF (kpds(3).EQ.215) THEN
    +
    2222  j = 94833
    +
    2223  GO TO 800
    +
    2224  ELSE IF (kpds(3).EQ.216) THEN
    +
    2225  j = 14873
    +
    2226  GO TO 800
    +
    2227  ELSE IF (kpds(3).EQ.217) THEN
    +
    2228  j = 59001
    +
    2229  GO TO 800
    +
    2230  ELSE IF (kpds(3).EQ.218) THEN
    +
    2231  j = 262792
    +
    2232  GO TO 800
    +
    2233  ELSE IF (kpds(3).EQ.219) THEN
    +
    2234  j = 179025
    +
    2235  GO TO 800
    +
    2236  ELSE IF (kpds(3).EQ.220) THEN
    +
    2237  j = 122475
    +
    2238  GO TO 800
    +
    2239  ELSE IF (kpds(3).EQ.221) THEN
    +
    2240  j = 96673
    +
    2241  GO TO 800
    +
    2242  ELSE IF (kpds(3).EQ.222) THEN
    +
    2243  j = 15456
    +
    2244  GO TO 800
    +
    2245  ELSE IF (kpds(3).EQ.223) THEN
    +
    2246  j = 16641
    +
    2247  GO TO 800
    +
    2248  ELSE IF (kpds(3).EQ.224) THEN
    +
    2249  j = 4225
    +
    2250  GO TO 800
    +
    2251  ELSE IF (kpds(3).EQ.225) THEN
    +
    2252  j = 24975
    +
    2253  GO TO 800
    +
    2254  ELSE IF (kpds(3).EQ.226) THEN
    +
    2255  j = 381029
    +
    2256  GO TO 800
    +
    2257  ELSE IF (kpds(3).EQ.227) THEN
    +
    2258  j = 1509825
    +
    2259  GO TO 800
    +
    2260  ELSE IF (kpds(3).EQ.228) THEN
    +
    2261  j = 10512
    +
    2262  GO TO 800
    +
    2263  ELSE IF (kpds(3).EQ.229) THEN
    +
    2264  j = 65160
    +
    2265  GO TO 800
    +
    2266  ELSE IF (kpds(3).EQ.230) THEN
    +
    2267  j = 259920
    +
    2268  GO TO 800
    +
    2269  ELSE IF (kpds(3).EQ.231) THEN
    +
    2270  j = 130320
    +
    2271  GO TO 800
    +
    2272  ELSE IF (kpds(3).EQ.232) THEN
    +
    2273  j = 32760
    +
    2274  GO TO 800
    +
    2275  ELSE IF (kpds(3).EQ.233) THEN
    +
    2276  j = 45216
    +
    2277  GO TO 800
    +
    2278  ELSE IF (kpds(3).EQ.234) THEN
    +
    2279  j = 16093
    +
    2280  GO TO 800
    +
    2281  ELSE IF (kpds(3).EQ.235) THEN
    +
    2282  j = 259200
    +
    2283  GO TO 800
    +
    2284  ELSE IF (kpds(3).EQ.236) THEN
    +
    2285  j = 17063
    +
    2286  GO TO 800
    +
    2287  ELSE IF (kpds(3).EQ.237) THEN
    +
    2288  j = 2538
    +
    2289  GO TO 800
    +
    2290  ELSE IF (kpds(3).EQ.238) THEN
    +
    2291  j = 55825
    +
    2292  GO TO 800
    +
    2293  ELSE IF (kpds(3).EQ.239) THEN
    +
    2294  j = 19065
    +
    2295  GO TO 800
    +
    2296  ELSE IF (kpds(3).EQ.240) THEN
    +
    2297  j = 987601
    +
    2298  GO TO 800
    +
    2299  ELSE IF (kpds(3).EQ.241) THEN
    +
    2300  j = 244305
    +
    2301  GO TO 800
    +
    2302  ELSE IF (kpds(3).EQ.242) THEN
    +
    2303  j = 235025
    +
    2304  GO TO 800
    +
    2305  ELSE IF (kpds(3).EQ.243) THEN
    +
    2306  j = 12726
    +
    2307  GO TO 800
    +
    2308  ELSE IF (kpds(3).EQ.244) THEN
    +
    2309  j = 55825
    +
    2310  GO TO 800
    +
    2311  ELSE IF (kpds(3).EQ.245) THEN
    +
    2312  j = 124992
    +
    2313  GO TO 800
    +
    2314  ELSE IF (kpds(3).EQ.246) THEN
    +
    2315  j = 123172
    +
    2316  GO TO 800
    +
    2317  ELSE IF (kpds(3).EQ.247) THEN
    +
    2318  j = 124992
    +
    2319  GO TO 800
    +
    2320  ELSE IF (kpds(3).EQ.248) THEN
    +
    2321  j = 13635
    +
    2322  GO TO 800
    +
    2323  ELSE IF (kpds(3).EQ.249) THEN
    +
    2324  j = 125881
    +
    2325  GO TO 800
    +
    2326  ELSE IF (kpds(3).EQ.250) THEN
    +
    2327  j = 13635
    +
    2328  GO TO 800
    +
    2329  ELSE IF (kpds(3).EQ.251) THEN
    +
    2330  j = 69720
    +
    2331  GO TO 800
    +
    2332  ELSE IF (kpds(3).EQ.252) THEN
    +
    2333  j = 67725
    +
    2334  GO TO 800
    +
    2335  ELSE IF (kpds(3).EQ.253) THEN
    +
    2336  j = 83552
    +
    2337  GO TO 800
    +
    2338  ELSE IF (kpds(3).EQ.254) THEN
    +
    2339  j = 110700
    +
    2340  GO TO 800
    +
    2341  ELSE IF (iand(kpds(4),128).EQ.128) THEN
    +
    2342  GO TO 895
    +
    2343  END IF
    +
    2344  kret = 5
    +
    2345  RETURN
    +
    2346  END IF
    +
    2347  END IF
    +
    2348 C -------------------------------------------------------
    +
    2349 C CHECK JAPAN METEOROLOGICAL AGENCY SET
    +
    2350 C -------------------------------------------------------
    +
    2351  IF (kpds(1).EQ.34) THEN
    +
    2352  IF (iand(kpds(4),128).EQ.128) THEN
    +
    2353 C PRINT *,'JMA MAP IS NOT PREDEFINED, THE GDS WILL'
    +
    2354 C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3)
    +
    2355  GO TO 900
    +
    2356  END IF
    +
    2357  END IF
    +
    2358 C -------------------------------------------------------
    +
    2359 C CHECK CANADIAN SET
    +
    2360 C -------------------------------------------------------
    +
    2361  IF (kpds(1).EQ.54) THEN
    +
    2362  IF (iand(kpds(4),128).EQ.128) THEN
    +
    2363 C PRINT *,'CANADIAN MAP IS NOT PREDEFINED, THE GDS WILL'
    +
    2364 C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3)
    +
    2365  GO TO 900
    +
    2366  END IF
    +
    2367  END IF
    +
    2368 C -------------------------------------------------------
    +
    2369 C CHECK FNOC SET
    +
    2370 C -------------------------------------------------------
    +
    2371  IF (kpds(1).EQ.58) THEN
    +
    2372  IF (kpds(3).EQ.220.OR.kpds(3).EQ.221) THEN
    +
    2373 C FNOC GRID 220, 221 - MAPSIZE 3969 (63 * 63)
    +
    2374  j = 3969
    +
    2375  kptr(10) = j
    +
    2376  DO i = 1, j
    +
    2377  kbms(i) = .true.
    +
    2378  END DO
    +
    2379  RETURN
    +
    2380  END IF
    +
    2381  IF (kpds(3).EQ.223) THEN
    +
    2382 C FNOC GRID 223 - MAPSIZE 10512 (73 * 144)
    +
    2383  j = 10512
    +
    2384  kptr(10) = j
    +
    2385  DO i = 1, j
    +
    2386  kbms(i) = .true.
    +
    2387  END DO
    +
    2388  RETURN
    +
    2389  END IF
    +
    2390  IF (iand(kpds(4),128).EQ.128) THEN
    +
    2391 C PRINT *,'FNOC MAP IS NOT PREDEFINED, THE GDS WILL'
    +
    2392 C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3)
    +
    2393  GO TO 900
    +
    2394  END IF
    +
    2395  END IF
    +
    2396 C -------------------------------------------------------
    +
    2397 C CHECK UKMET SET
    +
    2398 C -------------------------------------------------------
    +
    2399  IF (kpds(1).EQ.74) THEN
    +
    2400  IF (iand(kpds(4),128).EQ.128) THEN
    +
    2401  GO TO 820
    +
    2402  END IF
    +
    2403  END IF
    +
    2404 C -------------------------------------------------------
    +
    2405 C CHECK ECMWF SET
    +
    2406 C -------------------------------------------------------
    +
    2407  IF (kpds(1).EQ.98) THEN
    +
    2408  IF (kpds(3).GE.1.AND.kpds(3).LE.12) THEN
    +
    2409  IF (kpds(3).GE.5.AND.kpds(3).LE.8) THEN
    +
    2410  j = 1073
    +
    2411  ELSE
    +
    2412  j = 1369
    +
    2413  END IF
    +
    2414  kptr(10) = j
    +
    2415  CALL fi637(j,kpds,kgds,kret)
    +
    2416  IF(kret.NE.0) GO TO 810
    +
    2417  kptr(10) = j ! Reset For Modified J
    +
    2418  DO 1000 i = 1, j
    +
    2419  kbms(i) = .true.
    +
    2420  1000 CONTINUE
    +
    2421  RETURN
    +
    2422  ELSE IF (kpds(3).GE.13.AND.kpds(3).LE.16) THEN
    +
    2423  j = 361
    +
    2424  kptr(10) = j
    +
    2425  CALL fi637(j,kpds,kgds,kret)
    +
    2426  IF(kret.NE.0) GO TO 810
    +
    2427  DO 1013 i = 1, j
    +
    2428  kbms(i) = .true.
    +
    2429  1013 CONTINUE
    +
    2430  RETURN
    +
    2431  ELSE IF (iand(kpds(4),128).EQ.128) THEN
    +
    2432  GO TO 810
    +
    2433  ELSE
    +
    2434  kret = 5
    +
    2435  RETURN
    +
    2436  END IF
    +
    2437  ELSE
    +
    2438 C PRINT *,'CENTER ',KPDS(1),' IS NOT DEFINED'
    +
    2439  IF (iand(kpds(4),128).EQ.128) THEN
    +
    2440 C PRINT *,'GDS WILL BE USED TO UNPACK THE DATA',
    +
    2441 C * ' MAP = ',KPDS(3)
    +
    2442  GO TO 900
    +
    2443  ELSE
    +
    2444  kret = 10
    +
    2445  RETURN
    +
    2446  END IF
    +
    2447  END IF
    +
    2448 C =======================================
    +
    2449 C
    +
    2450  800 CONTINUE
    +
    2451  kptr(10) = j
    +
    2452  CALL fi637 (j,kpds,kgds,kret)
    +
    2453  IF(kret.NE.0) GO TO 801
    +
    2454  DO 2201 i = 1, j
    +
    2455  kbms(i) = .true.
    +
    2456  2201 CONTINUE
    +
    2457  RETURN
    +
    2458  801 CONTINUE
    +
    2459 C
    +
    2460 C ----- THE MAP HAS A GDS, BYTE 7 OF THE (PDS) THE GRID IDENTIFICATION
    +
    2461 C ----- IS NOT 255, THE SIZE OF THE GRID IS NOT THE SAME AS THE
    +
    2462 C ----- PREDEFINED SIZES OF THE U.S. GRIDS, OR KNOWN GRIDS OF THE
    +
    2463 C ----- OF THE OTHER CENTERS. THE GRID CAN BE UNKNOWN, OR FROM AN
    +
    2464 C ----- UNKNOWN CENTER, WE WILL USE THE INFORMATION IN THE GDS TO MAKE
    +
    2465 C ----- A BIT MAP.
    +
    2466 C
    +
    2467  810 CONTINUE
    +
    2468 C PRINT *,'ECMWF PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
    +
    2469  GO TO 895
    +
    2470 C
    +
    2471  820 CONTINUE
    +
    2472 C PRINT *,'U.K. MET PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
    +
    2473  GO TO 895
    +
    2474 C
    +
    2475  890 CONTINUE
    +
    2476 C PRINT *,'PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
    +
    2477  895 CONTINUE
    +
    2478 C PRINT *,'THE GDS TO UNPACK THE DATA, MAP TYPE = ',KPDS(3)
    +
    2479 C
    +
    2480  900 CONTINUE
    +
    2481  j = kgds(2) * kgds(3)
    +
    2482 C AFOS AFOS AFOS SPECIAL CASE
    +
    2483 C INVOLVES NEXT SINGLE STATEMENT ONLY
    +
    2484  IF (kpds(3).EQ.211) kret = 0
    +
    2485  kptr(10) = j
    +
    2486  DO 2203 i = 1, j
    +
    2487  kbms(i) = .true.
    +
    2488  2203 CONTINUE
    +
    2489 C PRINT *,'EXIT FI634'
    +
    2490  RETURN
    +
    2491  END
    +
    2492 C-----------------------------------------------------------------------
    +
    2493 
    +
    2494 C> @brief Extract bit map.
    +
    2495 C> @author Mark Iredell @date 1997-09-19
    +
    2496 
    +
    2497 C> Extract the packed bitmap into a logical array.
    +
    2498 C>
    +
    2499 C> Program history log:
    +
    2500 C> 97-09-19 Vectorized bitmap decoder.
    +
    2501 C>
    +
    2502 C> @param[in] NPTS XInteger number of points in the bitmap field
    +
    2503 C> @param[in] NSKP Integer number of bits to skip in grib message
    +
    2504 C> @param[in] MSGA Character*1 grib message
    +
    2505 C> @param[out] KBMS Logical*1 bitmap
    +
    2506 C>
    +
    2507 C> @note Subprogram can be called from a multiprocessing environment.
    +
    2508 C>
    +
    2509 C> @author Mark Iredell @date 1997-09-19
    +
    2510 
    +
    2511  SUBROUTINE fi634x(NPTS,NSKP,MSGA,KBMS)
    +
    2512 
    +
    2513  CHARACTER*1 MSGA(*)
    +
    2514  LOGICAL*1 KBMS(NPTS)
    +
    2515  INTEGER ICHK(NPTS)
    +
    2516 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    2517  CALL gbytesc(msga,ichk,nskp,1,0,npts)
    +
    2518  kbms=ichk.NE.0
    +
    2519 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    2520  END
    +
    2521 
    +
    2522 
    +
    2523 C> @brief Extract grib data elements from bds
    +
    2524 C> @author Bill Cavanaugh @date 1991-09-13
    +
    2525 
    +
    2526 C> Extract grib data from binary data section and place
    +
    2527 C> into output array in proper position.
    +
    2528 C>
    +
    2529 C> Program history log:
    +
    2530 C> - Bill Cavanaugh 1991-09-13
    +
    2531 C> - Bill Cavanaugh 1994-04-01 Modified code to include decimal scaling when
    +
    2532 C> calculating the value of data points specified
    +
    2533 C> as being equal to the reference value
    +
    2534 C> - Farley 1994-11-10 Increased mxsize from 72960 to 260000
    +
    2535 C> for .5 degree sst analysis fields.
    +
    2536 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    2537 C> - Mark Iredell 1998-08-31 Eliminated need for mxsize
    +
    2538 C>
    +
    2539 C> @param[in] MSGA Array containing grib message
    +
    2540 C> @param[inout] KPTR Array containing storage for following parameters
    +
    2541 C> - 1 Total length of grib message
    +
    2542 C> - 2 Length of indicator (section 0)
    +
    2543 C> - 3 Length of pds (section 1)
    +
    2544 C> - 4 Length of gds (section 2)
    +
    2545 C> - 5 Length of bms (section 3)
    +
    2546 C> - 6 Length of bds (section 4)
    +
    2547 C> - 7 Value of current byte
    +
    2548 C> - 8 Bit pointer
    +
    2549 C> - 9 Grib start bit nr
    +
    2550 C> - 10 Grib/grid element count
    +
    2551 C> - 11 Nr unused bits at end of section 3
    +
    2552 C> - 12 Bit map flag
    +
    2553 C> - 13 Nr unused bits at end of section 2
    +
    2554 C> - 14 Bds flags
    +
    2555 C> - 15 Nr unused bits at end of section 4
    +
    2556 C> - 16 Reserved
    +
    2557 C> - 17 Reserved
    +
    2558 C> - 18 Reserved
    +
    2559 C> - 19 Binary scale factor
    +
    2560 C> - 20 Num bits used to pack each datum
    +
    2561 C> @param[in] KPDS Array containing pds elements.
    +
    2562 C> See initial routine
    +
    2563 C> @param[in] KGDS Array containing gds elements.
    +
    2564 C> - 1) Data representation type
    +
    2565 C> - 19 Number of vertical coordinate parameters
    +
    2566 C> - 20 Octet number of the list of vertical coordinate
    +
    2567 C> parameters Or Octet number of the list of numbers of points
    +
    2568 C> in each row Or 255 if neither are present.
    +
    2569 C> - 21 For grids with pl, number of points in grid
    +
    2570 C> - 22 Number of words in each row
    +
    2571 C> - Longitude grids
    +
    2572 C> - 2) N(i) nr points on latitude circle
    +
    2573 C> - 3) N(j) nr points on longitude meridian
    +
    2574 C> - 4) La(1) latitude of origin
    +
    2575 C> - 5) Lo(1) longitude of origin
    +
    2576 C> - 6) Resolution flag
    +
    2577 C> - 7) La(2) latitude of extreme point
    +
    2578 C> - 8) Lo(2) longitude of extreme point
    +
    2579 C> - 9) Di longitudinal direction of increment
    +
    2580 C> - 10 Dj latitudinal direction increment
    +
    2581 C> - 11 Scanning mode flag
    +
    2582 C> - Polar stereographic grids
    +
    2583 C> - 2) N(i) nr points along lat circle
    +
    2584 C> - 3) N(j) nr points along lon circle
    +
    2585 C> - 4) La(1) latitude of origin
    +
    2586 C> - 5) Lo(1) longitude of origin
    +
    2587 C> - 6) Reserved
    +
    2588 C> - 7) Lov grid orientation
    +
    2589 C> - 8) Dx - x direction increment
    +
    2590 C> - 9) Dy - y direction increment
    +
    2591 C> - 10 Projection center flag
    +
    2592 C> - 11 Scanning mode
    +
    2593 C> - Spherical harmonic coefficients
    +
    2594 C> - 2 J pentagonal resolution parameter
    +
    2595 C> - 3 K pentagonal resolution parameter
    +
    2596 C> - 4 M pentagonal resolution parameter
    +
    2597 C> - 5 Representation type
    +
    2598 C> - 6 Coefficient storage mode
    +
    2599 C> - Mercator grids
    +
    2600 C> - 2 N(i) nr points on latitude circle
    +
    2601 C> - 3 N(j) nr points on longitude meridian
    +
    2602 C> - 4 La(1) latitude of origin
    +
    2603 C> - 5 Lo(1) longitude of origin
    +
    2604 C> - 6 Resolution flag
    +
    2605 C> - 7 La(2) latitude of last grid point
    +
    2606 C> - 8 Lo(2) longitude of last grid point
    +
    2607 C> - 9 Latin - latitude of projection intersection
    +
    2608 C> - 10 Reserved
    +
    2609 C> - 11 Scanning mode flag
    +
    2610 C> - 12 Longitudinal dir grid length
    +
    2611 C> - 13 Latitudinal dir grid length
    +
    2612 C> - Lambert conformal grids
    +
    2613 C> - 2 Nx nr points along x-axis
    +
    2614 C> - 3 Ny nr points along y-axis
    +
    2615 C> - 4 La1 lat of origin (lower left)
    +
    2616 C> - 5 Lo1 lon of origin (lower left)
    +
    2617 C> - 6 Resolution (right adj copy of octet 17)
    +
    2618 C> - 7 Lov - orientation of grid
    +
    2619 C> - 8 Dx - x-dir increment
    +
    2620 C> - 9 Dy - y-dir increment
    +
    2621 C> - 10 Projection center flag
    +
    2622 C> - 11 Scanning mode flag
    +
    2623 C> - 12 Latin 1 - first lat from pole of secant cone inter
    +
    2624 C> - 13 Latin 2 - second lat from pole of secant cone inter
    +
    2625 C> - Staggered arakawa rotated lat/lon grids (203 e stagger)
    +
    2626 C> - 2 N(i) nr points on rotated latitude circle
    +
    2627 C> - 3 N(j) nr points on rotated longitude meridian
    +
    2628 C> - 4 La(1) latitude of origin
    +
    2629 C> - 5 Lo(1) longitude of origin
    +
    2630 C> - 6 Resolution flag
    +
    2631 C> - 7 La(2) latitude of center
    +
    2632 C> - 8 Lo(2) longitude of center
    +
    2633 C> - 9 Di longitudinal direction of increment
    +
    2634 C> - 10 Dj latitudinal direction increment
    +
    2635 C> - 11 Scanning mode flag
    +
    2636 C> - Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
    +
    2637 C> - 2 N(i) nr points on rotated latitude circle
    +
    2638 C> - 3 N(j) nr points on rotated longitude meridian
    +
    2639 C> - 4 La(1) latitude of origin
    +
    2640 C> - 5 Lo(1) longitude of origin
    +
    2641 C> - 6 Resolution flag
    +
    2642 C> - 7 La(2) latitude of center
    +
    2643 C> - 8 Lo(2) longitude of center
    +
    2644 C> - 9 Di longitudinal direction of increment
    +
    2645 C> - 10 Dj latitudinal direction increment
    +
    2646 C> - 11 Scanning mode flag
    +
    2647 C> - 12 Latitude of last point
    +
    2648 C> - 13 Longitude of last point
    +
    2649 C> @param[in] KBMS Bitmap describing location of output elements.
    +
    2650 C> -KBDS Information extracted from binary data section
    +
    2651 C> - KBDS(1) - N1
    +
    2652 C> - KBDS(2) - N2
    +
    2653 C> - KBDS(3) - P1
    +
    2654 C> - KBDS(4) - P2
    +
    2655 C> - KBDS(5) - Bit pointer to 2nd order widths
    +
    2656 C> - KBDS(6) - Bit pointer to 2nd order bit maps
    +
    2657 C> - KBDS(7) - Bit pointer to first order values
    +
    2658 C> - KBDS(8) - Bit pointer to second order values
    +
    2659 C> - KBDS(9) - Bit pointer start of bds
    +
    2660 C> - KBDS(10) - Bit pointer main bit map
    +
    2661 C> - KBDS(11) - Binary scaling
    +
    2662 C> - KBDS(12) - Decimal scaling
    +
    2663 C> - KBDS(13) - Bit width of first order values
    +
    2664 C> - KBDS(14) - Bit map flag
    +
    2665 C> 0 = no second order bit map
    +
    2666 C> 1 = second order bit map present
    +
    2667 C> - KBDS(15) - Second order bit width
    +
    2668 C> - KBDS(16) - Constant / different widths
    +
    2669 C> 0 = constant widths
    +
    2670 C> 1 = different widths
    +
    2671 C> - KBDS(17) - Single datum / matrix
    +
    2672 C> - 0 = single datum at each grid point
    +
    2673 C> - 1 = matrix of values at each grid point
    +
    2674 C> - (18-20) - Unused
    +
    2675 C> @param[out] DATA Real*4 array of gridded elements in grib message.
    +
    2676 C> @param[out] KRET Error return
    +
    2677 C>
    +
    2678 C> @note
    +
    2679 C> - Error return
    +
    2680 C> - 3 = Unpacked field is larger than 65160
    +
    2681 C> - 6 = Does not match nr of entries for this grib/grid
    +
    2682 C> - 7 = Number of bits in fill too large
    +
    2683 C>
    +
    2684 C> @author Bill Cavanaugh @date 1991-09-13
    +
    2685  SUBROUTINE fi635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET)
    +
    2686 
    +
    2687 C
    +
    2688  CHARACTER*1 MSGA(*)
    +
    2689 C
    +
    2690  LOGICAL*1 KBMS(*)
    +
    2691 C
    +
    2692  INTEGER KPDS(*)
    +
    2693  INTEGER KGDS(*)
    +
    2694  INTEGER KBDS(20)
    +
    2695  INTEGER KPTR(*)
    +
    2696  INTEGER NRBITS
    +
    2697  INTEGER,ALLOCATABLE:: KSAVE(:)
    +
    2698  INTEGER KSCALE
    +
    2699 C
    +
    2700  REAL DATA(*)
    +
    2701  REAL REFNCE
    +
    2702  REAL SCALE
    +
    2703  REAL REALKK
    +
    2704 C
    +
    2705 C
    +
    2706 C CHANGED HEX VALUES TO DECIMAL TO MAKE CODE MORE PORTABLE
    +
    2707 C
    +
    2708 C *************************************************************
    +
    2709 C PRINT *,'ENTER FI635'
    +
    2710 C SET UP BIT POINTER
    +
    2711  kptr(8) = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + (kptr(4)*8)
    +
    2712  * + (kptr(5)*8) + 24
    +
    2713 C ------------- EXTRACT FLAGS
    +
    2714 C BYTE 4
    +
    2715  CALL gbytec(msga,kptr(14),kptr(8),4)
    +
    2716  kptr(8) = kptr(8) + 4
    +
    2717 C --------- NR OF UNUSED BITS IN SECTION 4
    +
    2718  CALL gbytec(msga,kptr(15),kptr(8),4)
    +
    2719  kptr(8) = kptr(8) + 4
    +
    2720  kend = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + (kptr(4)*8)
    +
    2721  * + (kptr(5)*8) + kptr(6) * 8 - kptr(15)
    +
    2722 C ------------- GET SCALE FACTOR
    +
    2723 C BYTES 5,6
    +
    2724 C CHECK SIGN
    +
    2725  CALL gbytec (msga,ksign,kptr(8),1)
    +
    2726  kptr(8) = kptr(8) + 1
    +
    2727 C GET ABSOLUTE SCALE VALUE
    +
    2728  CALL gbytec (msga,kscale,kptr(8),15)
    +
    2729  kptr(8) = kptr(8) + 15
    +
    2730  IF (ksign.GT.0) THEN
    +
    2731  kscale = - kscale
    +
    2732  END IF
    +
    2733  scale = 2.0**kscale
    +
    2734  kptr(19)=kscale
    +
    2735 C ------------ GET REFERENCE VALUE
    +
    2736 C BYTES 7,10
    +
    2737 C CALL GBYTE (MSGA,KREF,KPTR(8),32)
    +
    2738  call gbytec(msga,jsgn,kptr(8),1)
    +
    2739  call gbytec(msga,jexp,kptr(8)+1,7)
    +
    2740  call gbytec(msga,ifr,kptr(8)+8,24)
    +
    2741  kptr(8) = kptr(8) + 32
    +
    2742 C
    +
    2743 C THE NEXT CODE WILL CONVERT THE IBM370 FLOATING POINT
    +
    2744 C TO THE FLOATING POINT USED ON YOUR COMPUTER.
    +
    2745 C
    +
    2746 C
    +
    2747 C PRINT *,109,JSGN,JEXP,IFR
    +
    2748 C 109 FORMAT (' JSGN,JEXP,IFR = ',3(1X,Z8))
    +
    2749  IF (ifr.EQ.0) THEN
    +
    2750  refnce = 0.0
    +
    2751  ELSE IF (jexp.EQ.0.AND.ifr.EQ.0) THEN
    +
    2752  refnce = 0.0
    +
    2753  ELSE
    +
    2754  refnce = float(ifr) * 16.0 ** (jexp - 64 - 6)
    +
    2755  IF (jsgn.NE.0) refnce = - refnce
    +
    2756  END IF
    +
    2757 C PRINT *,'SCALE ',SCALE,' REF VAL ',REFNCE
    +
    2758 C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
    +
    2759 C BYTE 11
    +
    2760  CALL gbytec (msga,kbits,kptr(8),8)
    +
    2761  kptr(8) = kptr(8) + 8
    +
    2762  kbds(4) = kbits
    +
    2763 C KBDS(13) = KBITS
    +
    2764  kptr(20) = kbits
    +
    2765  ibyt12 = kptr(8)
    +
    2766 C ------------------ IF THERE ARE NO EXTENDED FLAGS PRESENT
    +
    2767 C THIS IS WHERE DATA BEGINS AND AND THE PROCESSING
    +
    2768 C INCLUDED IN THE FOLLOWING IF...END IF
    +
    2769 C WILL BE SKIPPED
    +
    2770 C PRINT *,'BASIC FLAGS =',KPTR(14) ,IAND(KPTR(14),1)
    +
    2771  IF (iand(kptr(14),1).EQ.0) THEN
    +
    2772 C PRINT *,'NO EXTENDED FLAGS'
    +
    2773  ELSE
    +
    2774 C BYTES 12,13
    +
    2775  CALL gbytec (msga,koctet,kptr(8),16)
    +
    2776  kptr(8) = kptr(8) + 16
    +
    2777 C --------------------------- EXTENDED FLAGS
    +
    2778 C BYTE 14
    +
    2779  CALL gbytec (msga,kxflag,kptr(8),8)
    +
    2780 C PRINT *,'HAVE EXTENDED FLAGS',KXFLAG
    +
    2781  kptr(8) = kptr(8) + 8
    +
    2782  IF (iand(kxflag,16).EQ.0) THEN
    +
    2783 C SECOND ORDER VALUES CONSTANT WIDTHS
    +
    2784  kbds(16) = 0
    +
    2785  ELSE
    +
    2786 C SECOND ORDER VALUES DIFFERENT WIDTHS
    +
    2787  kbds(16) = 1
    +
    2788  END IF
    +
    2789  IF (iand(kxflag,32).EQ.0) THEN
    +
    2790 C NO SECONDARY BIT MAP
    +
    2791  kbds(14) = 0
    +
    2792  ELSE
    +
    2793 C HAVE SECONDARY BIT MAP
    +
    2794  kbds(14) = 1
    +
    2795  END IF
    +
    2796  IF (iand(kxflag,64).EQ.0) THEN
    +
    2797 C SINGLE DATUM AT GRID POINT
    +
    2798  kbds(17) = 0
    +
    2799  ELSE
    +
    2800 C MATRIX OF VALUES AT GRID POINT
    +
    2801  kbds(17) = 1
    +
    2802  END IF
    +
    2803 C ---------------------- NR - FIRST DIMENSION (ROWS) OF EACH MATRIX
    +
    2804 C BYTES 15,16
    +
    2805  CALL gbytec (msga,nr,kptr(8),16)
    +
    2806  kptr(8) = kptr(8) + 16
    +
    2807 C ---------------------- NC - SECOND DIMENSION (COLS) OF EACH MATRIX
    +
    2808 C BYTES 17,18
    +
    2809  CALL gbytec (msga,nc,kptr(8),16)
    +
    2810  kptr(8) = kptr(8) + 16
    +
    2811 C ---------------------- NRV - FIRST DIM COORD VALS
    +
    2812 C BYTE 19
    +
    2813  CALL gbytec (msga,nrv,kptr(8),8)
    +
    2814  kptr(8) = kptr(8) + 8
    +
    2815 C ---------------------- NC1 - NR COEFF'S OR VALUES
    +
    2816 C BYTE 20
    +
    2817  CALL gbytec (msga,nc1,kptr(8),8)
    +
    2818  kptr(8) = kptr(8) + 8
    +
    2819 C ---------------------- NCV - SECOND DIM COORD OR VALUE
    +
    2820 C BYTE 21
    +
    2821  CALL gbytec (msga,ncv,kptr(8),8)
    +
    2822  kptr(8) = kptr(8) + 8
    +
    2823 C ---------------------- NC2 - NR COEFF'S OR VALS
    +
    2824 C BYTE 22
    +
    2825  CALL gbytec (msga,nc2,kptr(8),8)
    +
    2826  kptr(8) = kptr(8) + 8
    +
    2827 C ---------------------- KPHYS1 - FIRST DIM PHYSICAL SIGNIF
    +
    2828 C BYTE 23
    +
    2829  CALL gbytec (msga,kphys1,kptr(8),8)
    +
    2830  kptr(8) = kptr(8) + 8
    +
    2831 C ---------------------- KPHYS2 - SECOND DIM PHYSICAL SIGNIF
    +
    2832 C BYTE 24
    +
    2833  CALL gbytec (msga,kphys2,kptr(8),8)
    +
    2834  kptr(8) = kptr(8) + 8
    +
    2835 C BYTES 25-N
    +
    2836  END IF
    +
    2837  IF (kbits.EQ.0) THEN
    +
    2838 C HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE
    +
    2839  scal10 = 10.0 ** kpds(22)
    +
    2840  scal10 = 1.0 / scal10
    +
    2841  refn10 = refnce * scal10
    +
    2842  kentry = kptr(10)
    +
    2843  DO 210 i = 1, kentry
    +
    2844  DATA(i) = 0.0
    +
    2845  IF (kbms(i)) THEN
    +
    2846  DATA(i) = refn10
    +
    2847  END IF
    +
    2848  210 CONTINUE
    +
    2849  GO TO 900
    +
    2850  END IF
    +
    2851 C PRINT *,'KEND ',KEND,' KPTR(8) ',KPTR(8),'KBITS ',KBITS
    +
    2852  knr = (kend - kptr(8)) / kbits
    +
    2853 C PRINT *,'NUMBER OF ENTRIES IN DATA ARRAY',KNR
    +
    2854 C --------------------
    +
    2855 C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
    +
    2856 C ENTRIES.
    +
    2857 C ------------- UNUSED BITS IN DATA AREA
    +
    2858 C NUMBER OF BYTES IN DATA AREA
    +
    2859  nrbyte = kptr(6) - 11
    +
    2860 C ------------- TOTAL NR OF USABLE BITS
    +
    2861  nrbits = nrbyte * 8 - kptr(15)
    +
    2862 C ------------- TOTAL NR OF ENTRIES
    +
    2863  kentry = nrbits / kbits
    +
    2864 C ALLOCATE KSAVE
    +
    2865  ALLOCATE(ksave(kentry))
    +
    2866 C
    +
    2867 C IF (IAND(KPTR(14),2).EQ.0) THEN
    +
    2868 C PRINT *,'SOURCE VALUES IN FLOATING POINT'
    +
    2869 C ELSE
    +
    2870 C PRINT *,'SOURCE VALUES IN INTEGER'
    +
    2871 C END IF
    +
    2872 C
    +
    2873  IF (iand(kptr(14),8).EQ.0) THEN
    +
    2874 C PRINT *,'PROCESSING GRID POINT DATA'
    +
    2875  IF (iand(kptr(14),4).EQ.0) THEN
    +
    2876 C PRINT *,' WITH SIMPLE PACKING'
    +
    2877  IF (iand(kptr(14),1).EQ.0) THEN
    +
    2878 C PRINT *,' WITH NO ADDITIONAL FLAGS'
    +
    2879  GO TO 4000
    +
    2880  ELSE IF (iand(kptr(14),1).NE.0) THEN
    +
    2881 C PRINT *,' WITH ADDITIONAL FLAGS',KXFLAG
    +
    2882  IF (kbds(17).EQ.0) THEN
    +
    2883 C PRINT *,' SINGLE DATUM EACH GRID PT'
    +
    2884  IF (kbds(14).EQ.0) THEN
    +
    2885 C PRINT *,' NO SEC BIT MAP'
    +
    2886  IF (kbds(16).EQ.0) THEN
    +
    2887 C PRINT *,' SECOND ORDER',
    +
    2888 C * ' VALUES CONSTANT WIDTH'
    +
    2889  ELSE IF (kbds(16).NE.0) THEN
    +
    2890 C PRINT *,' SECOND ORDER',
    +
    2891 C * ' VALUES DIFFERENT WIDTHS'
    +
    2892  END IF
    +
    2893  ELSE IF (kbds(14).NE.0) THEN
    +
    2894 C PRINT *,' SEC BIT MAP'
    +
    2895  IF (kbds(16).EQ.0) THEN
    +
    2896 C PRINT *,' SECOND ORDER',
    +
    2897 C * ' VALUES CONSTANT WIDTH'
    +
    2898  ELSE IF (kbds(16).NE.0) THEN
    +
    2899 C PRINT *,' SECOND ORDER',
    +
    2900 C * ' VALUES DIFFERENT WIDTHS'
    +
    2901  END IF
    +
    2902  END IF
    +
    2903  ELSE IF (kbds(17).NE.0) THEN
    +
    2904 C PRINT *,' MATRIX OF VALS EACH PT'
    +
    2905  IF (kbds(14).EQ.0) THEN
    +
    2906 C PRINT *,' NO SEC BIT MAP'
    +
    2907  IF (kbds(16).EQ.0) THEN
    +
    2908 C PRINT *,' SECOND ORDER',
    +
    2909 C * ' VALUES CONSTANT WIDTH'
    +
    2910  ELSE IF (kbds(16).NE.0) THEN
    +
    2911 C PRINT *,' SECOND ORDER',
    +
    2912 C * ' VALUES DIFFERENT WIDTHS'
    +
    2913  END IF
    +
    2914  ELSE IF (kbds(14).NE.0) THEN
    +
    2915 C PRINT *,' SEC BIT MAP'
    +
    2916  IF (kbds(16).EQ.0) THEN
    +
    2917 C PRINT *,' SECOND ORDER',
    +
    2918 C * ' VALUES CONSTANT WIDTH'
    +
    2919  ELSE IF (kbds(16).NE.0) THEN
    +
    2920 C PRINT *,' SECOND ORDER',
    +
    2921 C * ' VALUES DIFFERENT WIDTHS'
    +
    2922  END IF
    +
    2923  END IF
    +
    2924  END IF
    +
    2925  END IF
    +
    2926  ELSE IF (iand(kptr(14),4).NE.0) THEN
    +
    2927 C PRINT *,' WITH COMPLEX/SECOND ORDER PACKING'
    +
    2928  IF (iand(kptr(14),1).EQ.0) THEN
    +
    2929 C PRINT *,' WITH NO ADDITIONAL FLAGS'
    +
    2930  ELSE IF (iand(kptr(14),1).NE.0) THEN
    +
    2931 C PRINT *,' WITH ADDITIONAL FLAGS'
    +
    2932  IF (kbds(17).EQ.0) THEN
    +
    2933 C PRINT *,' SINGLE DATUM AT EACH PT'
    +
    2934  IF (kbds(14).EQ.0) THEN
    +
    2935 C PRINT *,' NO SEC BIT MAP'
    +
    2936  IF (kbds(16).EQ.0) THEN
    +
    2937 C PRINT *,' SECOND ORDER',
    +
    2938 C * ' VALUES CONSTANT WIDTH'
    +
    2939  ELSE IF (kbds(16).NE.0) THEN
    +
    2940 C PRINT *,' SECOND ORDER',
    +
    2941 C * ' VALUES DIFFERENT WIDTHS'
    +
    2942  END IF
    +
    2943 C ROW BY ROW - COL BY COL
    +
    2944  CALL fi636 (DATA,msga,kbms,
    +
    2945  * refnce,kptr,kpds,kgds)
    +
    2946  GO TO 900
    +
    2947  ELSE IF (kbds(14).NE.0) THEN
    +
    2948 C PRINT *,' SEC BIT MAP'
    +
    2949  IF (kbds(16).EQ.0) THEN
    +
    2950 C PRINT *,' SECOND ORDER',
    +
    2951 C * ' VALUES CONSTANT WIDTH'
    +
    2952  ELSE IF (kbds(16).NE.0) THEN
    +
    2953 C PRINT *,' SECOND ORDER',
    +
    2954 C * ' VALUES DIFFERENT WIDTHS'
    +
    2955  END IF
    +
    2956  CALL fi636 (DATA,msga,kbms,
    +
    2957  * refnce,kptr,kpds,kgds)
    +
    2958  GO TO 900
    +
    2959  END IF
    +
    2960  ELSE IF (kbds(17).NE.0) THEN
    +
    2961 C PRINT *,' MATRIX OF VALS EACH PT'
    +
    2962  IF (kbds(14).EQ.0) THEN
    +
    2963 C PRINT *,' NO SEC BIT MAP'
    +
    2964  IF (kbds(16).EQ.0) THEN
    +
    2965 C PRINT *,' SECOND ORDER',
    +
    2966 C * ' VALUES CONSTANT WIDTH'
    +
    2967  ELSE IF (kbds(16).NE.0) THEN
    +
    2968 C PRINT *,' SECOND ORDER',
    +
    2969 C * ' VALUES DIFFERENT WIDTHS'
    +
    2970  END IF
    +
    2971  ELSE IF (kbds(14).NE.0) THEN
    +
    2972 C PRINT *,' SEC BIT MAP'
    +
    2973  IF (kbds(16).EQ.0) THEN
    +
    2974 C PRINT *,' SECOND ORDER',
    +
    2975 C * ' VALUES CONSTANT WIDTH'
    +
    2976  ELSE IF (kbds(16).NE.0) THEN
    +
    2977 C PRINT *,' SECOND ORDER',
    +
    2978 C * ' VALUES DIFFERENT WIDTHS'
    +
    2979  END IF
    +
    2980  END IF
    +
    2981  END IF
    +
    2982  END IF
    +
    2983  END IF
    +
    2984  ELSE IF (iand(kptr(14),8).NE.0) THEN
    +
    2985 C PRINT *,'PROCESSING SPHERICAL HARMONIC COEFFICIENTS'
    +
    2986  IF (iand(kptr(14),4).EQ.0) THEN
    +
    2987 C PRINT *,' WITH SIMPLE PACKING'
    +
    2988  IF (iand(kptr(14),1).EQ.0) THEN
    +
    2989 C PRINT *,' WITH NO ADDITIONAL FLAGS'
    +
    2990  GO TO 5000
    +
    2991  ELSE IF (iand(kptr(14),1).NE.0) THEN
    +
    2992 C PRINT *,' WITH ADDITIONAL FLAGS'
    +
    2993  IF (kbds(17).EQ.0) THEN
    +
    2994 C PRINT *,' SINGLE DATUM EACH GRID PT'
    +
    2995  IF (kbds(14).EQ.0) THEN
    +
    2996 C PRINT *,' NO SEC BIT MAP'
    +
    2997  IF (kbds(16).EQ.0) THEN
    +
    2998 C PRINT *,' SECOND ORDER',
    +
    2999 C * ' VALUES CONSTANT WIDTH'
    +
    3000  ELSE IF (kbds(16).NE.0) THEN
    +
    3001 C PRINT *,' SECOND ORDER',
    +
    3002 C * ' VALUES DIFFERENT WIDTHS'
    +
    3003  END IF
    +
    3004  ELSE IF (kbds(14).NE.0) THEN
    +
    3005 C PRINT *,' SEC BIT MAP'
    +
    3006  IF (kbds(16).EQ.0) THEN
    +
    3007 C PRINT *,' SECOND ORDER',
    +
    3008 C * ' VALUES CONSTANT WIDTH'
    +
    3009  ELSE IF (kbds(16).NE.0) THEN
    +
    3010 C PRINT *,' SECOND ORDER',
    +
    3011 C * ' VALUES DIFFERENT WIDTHS'
    +
    3012  END IF
    +
    3013  END IF
    +
    3014  ELSE IF (kbds(17).NE.0) THEN
    +
    3015 C PRINT *,' MATRIX OF VALS EACH PT'
    +
    3016  IF (kbds(14).EQ.0) THEN
    +
    3017 C PRINT *,' NO SEC BIT MAP'
    +
    3018  IF (kbds(16).EQ.0) THEN
    +
    3019 C PRINT *,' SECOND ORDER',
    +
    3020 C * ' VALUES CONSTANT WIDTH'
    +
    3021  ELSE IF (kbds(16).NE.0) THEN
    +
    3022 C PRINT *,' SECOND ORDER',
    +
    3023 C * ' VALUES DIFFERENT WIDTHS'
    +
    3024  END IF
    +
    3025  ELSE IF (kbds(14).NE.0) THEN
    +
    3026 C PRINT *,' SEC BIT MAP'
    +
    3027  IF (kbds(16).EQ.0) THEN
    +
    3028 C PRINT *,' SECOND ORDER',
    +
    3029 C * ' VALUES CONSTANT WIDTH'
    +
    3030  ELSE IF (kbds(16).NE.0) THEN
    +
    3031 C PRINT *,' SECOND ORDER',
    +
    3032 C * ' VALUES DIFFERENT WIDTHS'
    +
    3033  END IF
    +
    3034  END IF
    +
    3035  END IF
    +
    3036  END IF
    +
    3037  ELSE IF (iand(kptr(14),4).NE.0) THEN
    +
    3038 C COMPLEX/SECOND ORDER PACKING
    +
    3039 C PRINT *,' WITH COMPLEX/SECOND ORDER PACKING'
    +
    3040  IF (iand(kptr(14),1).EQ.0) THEN
    +
    3041 C PRINT *,' WITH NO ADDITIONAL FLAGS'
    +
    3042  ELSE IF (iand(kptr(14),1).NE.0) THEN
    +
    3043 C PRINT *,' WITH ADDITIONAL FLAGS'
    +
    3044  IF (kbds(17).EQ.0) THEN
    +
    3045 C PRINT *,' SINGLE DATUM EACH GRID PT'
    +
    3046  IF (kbds(14).EQ.0) THEN
    +
    3047 C PRINT *,' NO SEC BIT MAP'
    +
    3048  IF (kbds(16).EQ.0) THEN
    +
    3049 C PRINT *,' SECOND ORDER',
    +
    3050 C * ' VALUES CONSTANT WIDTH'
    +
    3051  ELSE IF (kbds(16).NE.0) THEN
    +
    3052 C PRINT *,' SECOND ORDER',
    +
    3053 C * ' VALUES DIFFERENT WIDTHS'
    +
    3054  END IF
    +
    3055  ELSE IF (kbds(14).NE.0) THEN
    +
    3056 C PRINT *,' SEC BIT MAP'
    +
    3057  IF (kbds(16).EQ.0) THEN
    +
    3058 C PRINT *,' SECOND ORDER',
    +
    3059 C * ' VALUES CONSTANT WIDTH'
    +
    3060  ELSE IF (kbds(16).NE.0) THEN
    +
    3061 C PRINT *,' SECOND ORDER',
    +
    3062 C * ' VALUES DIFFERENT WIDTHS'
    +
    3063  END IF
    +
    3064  END IF
    +
    3065  ELSE IF (kbds(17).NE.0) THEN
    +
    3066 C PRINT *,' MATRIX OF VALS EACH PT'
    +
    3067  IF (kbds(14).EQ.0) THEN
    +
    3068 C PRINT *,' NO SEC BIT MAP'
    +
    3069  IF (kbds(16).EQ.0) THEN
    +
    3070 C PRINT *,' SECOND ORDER',
    +
    3071 C * ' VALUES CONSTANT WIDTH'
    +
    3072  ELSE IF (kbds(16).NE.0) THEN
    +
    3073 C PRINT *,' SECOND ORDER',
    +
    3074 C * ' VALUES DIFFERENT WIDTHS'
    +
    3075  END IF
    +
    3076  ELSE IF (kbds(14).NE.0) THEN
    +
    3077 C PRINT *,' SEC BIT MAP'
    +
    3078  IF (kbds(16).EQ.0) THEN
    +
    3079 C PRINT *,' SECOND ORDER',
    +
    3080 C * ' VALUES CONSTANT WIDTH'
    +
    3081  ELSE IF (kbds(16).NE.0) THEN
    +
    3082 C PRINT *,' SECOND ORDER',
    +
    3083 C * ' VALUES DIFFERENT WIDTHS'
    +
    3084  END IF
    +
    3085  END IF
    +
    3086  END IF
    +
    3087  END IF
    +
    3088  END IF
    +
    3089  END IF
    +
    3090  IF(ALLOCATED(ksave)) DEALLOCATE(ksave)
    +
    3091 C PRINT *,' NOT PROCESSED - NOT PROCESSED - NOT PROCESSED'
    +
    3092  kret = 11
    +
    3093  RETURN
    +
    3094  4000 CONTINUE
    +
    3095 C ****************************************************************
    +
    3096 C
    +
    3097 C GRID POINT DATA, SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS
    +
    3098 C
    +
    3099  scal10 = 10.0 ** kpds(22)
    +
    3100  scal10 = 1.0 / scal10
    +
    3101  IF (kpds(3).EQ.23.OR.kpds(3).EQ.24.OR.kpds(3).EQ.26.
    +
    3102  * or.kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
    +
    3103  IF (kpds(3).EQ.26) THEN
    +
    3104  kadd = 72
    +
    3105  ELSE IF (kpds(3).EQ.63.OR.kpds(3).EQ.64) THEN
    +
    3106  kadd = 91
    +
    3107  ELSE
    +
    3108  kadd = 37
    +
    3109  END IF
    +
    3110  CALL gbytesc (msga,ksave,kptr(8),kbits,0,knr)
    +
    3111  kptr(8) = kptr(8) + kbits * knr
    +
    3112  ii = 1
    +
    3113  kentry = kptr(10)
    +
    3114  DO 4001 i = 1, kentry
    +
    3115  IF (kbms(i)) THEN
    +
    3116  DATA(i) = (refnce+float(ksave(ii))*scale)*scal10
    +
    3117  ii = ii + 1
    +
    3118  ELSE
    +
    3119  DATA(i) = 0.0
    +
    3120  END IF
    +
    3121  4001 CONTINUE
    +
    3122  DO 4002 i = 2, kadd
    +
    3123  DATA(i) = DATA(1)
    +
    3124  4002 CONTINUE
    +
    3125  ELSE IF (kpds(3).EQ.21.OR.kpds(3).EQ.22.OR.kpds(3).EQ.25.
    +
    3126  * or.kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
    +
    3127  CALL gbytesc (msga,ksave,kptr(8),kbits,0,knr)
    +
    3128  ii = 1
    +
    3129  kentry = kptr(10)
    +
    3130  DO 4011 i = 1, kentry
    +
    3131  IF (kbms(i)) THEN
    +
    3132  DATA(i) = (refnce + float(ksave(ii)) * scale) * scal10
    +
    3133  ii = ii + 1
    +
    3134  ELSE
    +
    3135  DATA(i) = 0.0
    +
    3136  END IF
    +
    3137  4011 CONTINUE
    +
    3138  IF (kpds(3).EQ.25) THEN
    +
    3139  kadd = 71
    +
    3140  ELSE IF (kpds(3).EQ.61.OR.kpds(3).EQ.62) THEN
    +
    3141  kadd = 90
    +
    3142  ELSE
    +
    3143  kadd = 36
    +
    3144  END IF
    +
    3145  lastp = kentry - kadd
    +
    3146  DO 4012 i = lastp+1, kentry
    +
    3147  DATA(i) = DATA(lastp)
    +
    3148  4012 CONTINUE
    +
    3149  ELSE
    +
    3150  CALL gbytesc (msga,ksave,kptr(8),kbits,0,knr)
    +
    3151  ii = 1
    +
    3152  kentry = kptr(10)
    +
    3153  DO 500 i = 1, kentry
    +
    3154  IF (kbms(i)) THEN
    +
    3155  DATA(i) = (refnce + float(ksave(ii)) * scale) * scal10
    +
    3156  ii = ii + 1
    +
    3157  ELSE
    +
    3158  DATA(i) = 0.0
    +
    3159  END IF
    +
    3160  500 CONTINUE
    +
    3161  END IF
    +
    3162  GO TO 900
    +
    3163 C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS,
    +
    3164 C SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS
    +
    3165  5000 CONTINUE
    +
    3166 C PRINT *,'CHECK POINT SPECTRAL COEFF'
    +
    3167  kptr(8) = ibyt12
    +
    3168 C CALL GBYTE (MSGA,KKK,KPTR(8),32)
    +
    3169  call gbytec(msga,jsgn,kptr(8),1)
    +
    3170  call gbytec(msga,jexp,kptr(8)+1,7)
    +
    3171  call gbytec(msga,ifr,kptr(8)+8,24)
    +
    3172  kptr(8) = kptr(8) + 32
    +
    3173 C
    +
    3174 C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
    +
    3175 C TO THE FLOATING POINT USED ON YOUR MACHINE.
    +
    3176 C
    +
    3177  IF (ifr.EQ.0) THEN
    +
    3178  realkk = 0.0
    +
    3179  ELSE IF (jexp.EQ.0.AND.ifr.EQ.0) THEN
    +
    3180  realkk = 0.0
    +
    3181  ELSE
    +
    3182  realkk = float(ifr) * 16.0 ** (jexp - 64 - 6)
    +
    3183  IF (jsgn.NE.0) realkk = -realkk
    +
    3184  END IF
    +
    3185  DATA(1) = realkk
    +
    3186  CALL gbytesc (msga,ksave,kptr(8),kbits,0,knr)
    +
    3187 C --------------
    +
    3188  DO 6000 i = 1, kentry
    +
    3189  DATA(i+1) = refnce + float(ksave(i)) * scale
    +
    3190  6000 CONTINUE
    +
    3191  900 CONTINUE
    +
    3192  IF(ALLOCATED(ksave)) DEALLOCATE(ksave)
    +
    3193 C PRINT *,'EXIT FI635'
    +
    3194  RETURN
    +
    3195  END
    +
    3196 
    +
    3197 C> @brief Process second order packing.
    +
    3198 C> @author Bill Cavanaugh @date 1992-09-22
    +
    3199 
    +
    3200 C> Process second order packing from the binary data section
    +
    3201 C> (bds) for single data items grid point data.
    +
    3202 C>
    +
    3203 C> Program history log:
    +
    3204 C> - Bill Cavanaugh 1993-06-08
    +
    3205 C> - Bill Cavanaugh 1993-12-15 Modified second order pointers to first order
    +
    3206 C> values and second order values correctly.
    +
    3207 C> - Ralph Jones 1995-04-26 Fi636 corection for 2nd order complex
    +
    3208 C> Unpacking.
    +
    3209 C> - Mark Iredell 1995-10-31 Saves and prints.
    +
    3210 C>
    +
    3211 C> @param[in] MSGA Array containing grib message
    +
    3212 C> @param[in] REFNCE Reference value
    +
    3213 C> @param[in] KPTR Work array
    +
    3214 C> @param[out] DATA Location of output array
    +
    3215 C> - KBDS Working array
    +
    3216 C> - KBDS(1) N1
    +
    3217 C> - KBDS(2) N2
    +
    3218 C> - KBDS(3) P1
    +
    3219 C> - KBDS(4) P2
    +
    3220 C> - KBDS(5) Bit pointer to 2nd order widths
    +
    3221 C> - KBDS(6) Bit pointer to 2nd order bit maps
    +
    3222 C> - KBDS(7) Bit pointer to first order values
    +
    3223 C> - KBDS(8) Bit pointer to second order values
    +
    3224 C> - KBDS(9) Bit pointer start of bds
    +
    3225 C> - KBDS(10) Bit pointer main bit map
    +
    3226 C> - KBDS(11) Binary scaling
    +
    3227 C> - KBDS(12) Decimal scaling
    +
    3228 C> - KBDS(13) Bit width of first order values
    +
    3229 C> - KBDS(14) Bit map flag
    +
    3230 C> - 0 = No second order bit map
    +
    3231 C> - 1 = Second order bit map present
    +
    3232 C> - KBDS(15) Second order bit width
    +
    3233 C> - KBDS(16) Constant / different widths
    +
    3234 C> - 0 = Constant widths
    +
    3235 C> - 1 = Different widths
    +
    3236 C> - KBDS(17) Single datum / matrix
    +
    3237 C> - 0 = Single datum at each grid point
    +
    3238 C> - 1 = Matrix of values at each grid point
    +
    3239 C> - KBDS(18-20) Unused
    +
    3240 C> @param[in] KBMS
    +
    3241 C> @param[in] KPDS
    +
    3242 C> @param[in] KGDS Array containing gds elements.
    +
    3243 C> - 1) Data representation type
    +
    3244 C> - 19 Number of vertical coordinate parameters
    +
    3245 C> - 20 Octet number of the list of vertical coordinate
    +
    3246 C> parameters Or Octet number of the list of numbers of points
    +
    3247 C> in each row Or 255 if neither are present.
    +
    3248 C> - 21 For grids with pl, number of points in grid
    +
    3249 C> - 22 Number of words in each row
    +
    3250 C> - Longitude grids
    +
    3251 C> - 2) N(i) nr points on latitude circle
    +
    3252 C> - 3) N(j) nr points on longitude meridian
    +
    3253 C> - 4) La(1) latitude of origin
    +
    3254 C> - 5) Lo(1) longitude of origin
    +
    3255 C> - 6) Resolution flag
    +
    3256 C> - 7) La(2) latitude of extreme point
    +
    3257 C> - 8) Lo(2) longitude of extreme point
    +
    3258 C> - 9) Di longitudinal direction of increment
    +
    3259 C> - 10 Dj latitudinal direction increment
    +
    3260 C> - 11 Scanning mode flag
    +
    3261 C> - Polar stereographic grids
    +
    3262 C> - 2) N(i) nr points along lat circle
    +
    3263 C> - 3) N(j) nr points along lon circle
    +
    3264 C> - 4) La(1) latitude of origin
    +
    3265 C> - 5) Lo(1) longitude of origin
    +
    3266 C> - 6) Reserved
    +
    3267 C> - 7) Lov grid orientation
    +
    3268 C> - 8) Dx - x direction increment
    +
    3269 C> - 9) Dy - y direction increment
    +
    3270 C> - 10 Projection center flag
    +
    3271 C> - 11 Scanning mode
    +
    3272 C> - Spherical harmonic coefficients
    +
    3273 C> - 2 J pentagonal resolution parameter
    +
    3274 C> - 3 K pentagonal resolution parameter
    +
    3275 C> - 4 M pentagonal resolution parameter
    +
    3276 C> - 5 Representation type
    +
    3277 C> - 6 Coefficient storage mode
    +
    3278 C> - Mercator grids
    +
    3279 C> - 2 N(i) nr points on latitude circle
    +
    3280 C> - 3 N(j) nr points on longitude meridian
    +
    3281 C> - 4 La(1) latitude of origin
    +
    3282 C> - 5 Lo(1) longitude of origin
    +
    3283 C> - 6 Resolution flag
    +
    3284 C> - 7 La(2) latitude of last grid point
    +
    3285 C> - 8 Lo(2) longitude of last grid point
    +
    3286 C> - 9 Latin - latitude of projection intersection
    +
    3287 C> - 10 Reserved
    +
    3288 C> - 11 Scanning mode flag
    +
    3289 C> - 12 Longitudinal dir grid length
    +
    3290 C> - 13 Latitudinal dir grid length
    +
    3291 C> - Lambert conformal grids
    +
    3292 C> - 2 Nx nr points along x-axis
    +
    3293 C> - 3 Ny nr points along y-axis
    +
    3294 C> - 4 La1 lat of origin (lower left)
    +
    3295 C> - 5 Lo1 lon of origin (lower left)
    +
    3296 C> - 6 Resolution (right adj copy of octet 17)
    +
    3297 C> - 7 Lov - orientation of grid
    +
    3298 C> - 8 Dx - x-dir increment
    +
    3299 C> - 9 Dy - y-dir increment
    +
    3300 C> - 10 Projection center flag
    +
    3301 C> - 11 Scanning mode flag
    +
    3302 C> - 12 Latin 1 - first lat from pole of secant cone inter
    +
    3303 C> - 13 Latin 2 - second lat from pole of secant cone inter
    +
    3304 C> - Staggered arakawa rotated lat/lon grids (203 e stagger)
    +
    3305 C> - 2 N(i) nr points on rotated latitude circle
    +
    3306 C> - 3 N(j) nr points on rotated longitude meridian
    +
    3307 C> - 4 La(1) latitude of origin
    +
    3308 C> - 5 Lo(1) longitude of origin
    +
    3309 C> - 6 Resolution flag
    +
    3310 C> - 7 La(2) latitude of center
    +
    3311 C> - 8 Lo(2) longitude of center
    +
    3312 C> - 9 Di longitudinal direction of increment
    +
    3313 C> - 10 Dj latitudinal direction increment
    +
    3314 C> - 11 Scanning mode flag
    +
    3315 C> - Staggered arakawa rotated lat/lon grids (205 a,b,c,d staggers)
    +
    3316 C> - 2 N(i) nr points on rotated latitude circle
    +
    3317 C> - 3 N(j) nr points on rotated longitude meridian
    +
    3318 C> - 4 La(1) latitude of origin
    +
    3319 C> - 5 Lo(1) longitude of origin
    +
    3320 C> - 6 Resolution flag
    +
    3321 C> - 7 La(2) latitude of center
    +
    3322 C> - 8 Lo(2) longitude of center
    +
    3323 C> - 9 Di longitudinal direction of increment
    +
    3324 C> - 10 Dj latitudinal direction increment
    +
    3325 C> - 11 Scanning mode flag
    +
    3326 C> - 12 Latitude of last point
    +
    3327 C> - 13 Longitude of last point
    +
    3328 C>
    +
    3329 C> @author Bill Cavanaugh @date 1992-09-22
    +
    3330  SUBROUTINE fi636 (DATA,MSGA,KBMS,REFNCE,KPTR,KPDS,KGDS)
    +
    3331 
    +
    3332  REAL DATA(*)
    +
    3333  REAL REFN
    +
    3334  REAL REFNCE
    +
    3335 C
    +
    3336  INTEGER KBDS(20)
    +
    3337  INTEGER KPTR(*)
    +
    3338  character(len=1) BMAP2(1000000)
    +
    3339  INTEGER I,IBDS
    +
    3340  INTEGER KBIT,IFOVAL,ISOVAL
    +
    3341  INTEGER KPDS(*),KGDS(*)
    +
    3342 C
    +
    3343  LOGICAL*1 KBMS(*)
    +
    3344 C
    +
    3345  CHARACTER*1 MSGA(*)
    +
    3346 C
    +
    3347 C ******************* SETUP ******************************
    +
    3348 C PRINT *,'ENTER FI636'
    +
    3349 C START OF BMS (BIT POINTER)
    +
    3350  DO i = 1,20
    +
    3351  kbds(i) = 0
    +
    3352  END DO
    +
    3353 C BYTE START OF BDS
    +
    3354  ibds = kptr(2) + kptr(3) + kptr(4) + kptr(5)
    +
    3355 C PRINT *,'KPTR(2-5) ',KPTR(2),KPTR(3),KPTR(4),KPTR(5)
    +
    3356 C BIT START OF BDS
    +
    3357  jptr = ibds * 8
    +
    3358 C PRINT *,'JPTR ',JPTR
    +
    3359  kbds(9) = jptr
    +
    3360 C PRINT *,'START OF BDS ',KBDS(9)
    +
    3361 C BINARY SCALE VALUE BDS BYTES 5-6
    +
    3362  CALL gbytec (msga,isign,jptr+32,1)
    +
    3363  CALL gbytec (msga,kbds(11),jptr+33,15)
    +
    3364  IF (isign.GT.0) THEN
    +
    3365  kbds(11) = - kbds(11)
    +
    3366  END IF
    +
    3367 C PRINT *,'BINARY SCALE VALUE =',KBDS(11)
    +
    3368 C EXTRACT REFERENCE VALUE
    +
    3369 C CALL GBYTEC(MSGA,JREF,JPTR+48,32)
    +
    3370  call gbytec(msga,jsgn,kptr(8),1)
    +
    3371  call gbytec(msga,jexp,kptr(8)+1,7)
    +
    3372  call gbytec(msga,ifr,kptr(8)+8,24)
    +
    3373  IF (ifr.EQ.0) THEN
    +
    3374  refnce = 0.0
    +
    3375  ELSE IF (jexp.EQ.0.AND.ifr.EQ.0) THEN
    +
    3376  refnce = 0.0
    +
    3377  ELSE
    +
    3378  refnce = float(ifr) * 16.0 ** (jexp - 64 - 6)
    +
    3379  IF (jsgn.NE.0) refnce = - refnce
    +
    3380  END IF
    +
    3381 C PRINT *,'DECODED REFERENCE VALUE =',REFN,REFNCE
    +
    3382 C F O BIT WIDTH
    +
    3383  CALL gbytec(msga,kbds(13),jptr+80,8)
    +
    3384  jptr = jptr + 88
    +
    3385 C AT START OF BDS BYTE 12
    +
    3386 C EXTRACT N1
    +
    3387  CALL gbytec (msga,kbds(1),jptr,16)
    +
    3388 C PRINT *,'N1 = ',KBDS(1)
    +
    3389  jptr = jptr + 16
    +
    3390 C EXTENDED FLAGS
    +
    3391  CALL gbytec (msga,kflag,jptr,8)
    +
    3392 C ISOLATE BIT MAP FLAG
    +
    3393  IF (iand(kflag,32).NE.0) THEN
    +
    3394  kbds(14) = 1
    +
    3395  ELSE
    +
    3396  kbds(14) = 0
    +
    3397  END IF
    +
    3398  IF (iand(kflag,16).NE.0) THEN
    +
    3399  kbds(16) = 1
    +
    3400  ELSE
    +
    3401  kbds(16) = 0
    +
    3402  END IF
    +
    3403  IF (iand(kflag,64).NE.0) THEN
    +
    3404  kbds(17) = 1
    +
    3405  ELSE
    +
    3406  kbds(17) = 0
    +
    3407  END IF
    +
    3408  jptr = jptr + 8
    +
    3409 C EXTRACT N2
    +
    3410  CALL gbytec (msga,kbds(2),jptr,16)
    +
    3411 C PRINT *,'N2 = ',KBDS(2)
    +
    3412  jptr = jptr + 16
    +
    3413 C EXTRACT P1
    +
    3414  CALL gbytec (msga,kbds(3),jptr,16)
    +
    3415 C PRINT *,'P1 = ',KBDS(3)
    +
    3416  jptr = jptr + 16
    +
    3417 C EXTRACT P2
    +
    3418  CALL gbytec (msga,kbds(4),jptr,16)
    +
    3419 C PRINT *,'P2 = ',KBDS(4)
    +
    3420  jptr = jptr + 16
    +
    3421 C SKIP RESERVED BYTE
    +
    3422  jptr = jptr + 8
    +
    3423 C START OF SECOND ORDER BIT WIDTHS
    +
    3424  kbds(5) = jptr
    +
    3425 C COMPUTE START OF SECONDARY BIT MAP
    +
    3426  IF (kbds(14).NE.0) THEN
    +
    3427 C FOR INCLUDED SECONDARY BIT MAP
    +
    3428  jptr = jptr + (kbds(3) * 8)
    +
    3429  kbds(6) = jptr
    +
    3430  ELSE
    +
    3431 C FOR CONSTRUCTED SECONDARY BIT MAP
    +
    3432  kbds(6) = 0
    +
    3433  END IF
    +
    3434 C CREATE POINTER TO START OF FIRST ORDER VALUES
    +
    3435  kbds(7) = kbds(9) + kbds(1) * 8 - 8
    +
    3436 C PRINT *,'BIT POINTER TO START OF FOVALS',KBDS(7)
    +
    3437 C CREATE POINTER TO START OF SECOND ORDER VALUES
    +
    3438  kbds(8) = kbds(9) + kbds(2) * 8 - 8
    +
    3439 C PRINT *,'BIT POINTER TO START OF SOVALS',KBDS(8)
    +
    3440 C PRINT *,'KBDS( 1) - N1 ',KBDS( 1)
    +
    3441 C PRINT *,'KBDS( 2) - N2 ',KBDS( 2)
    +
    3442 C PRINT *,'KBDS( 3) - P1 ',KBDS( 3)
    +
    3443 C PRINT *,'KBDS( 4) - P2 ',KBDS( 4)
    +
    3444 C PRINT *,'KBDS( 5) - BIT PTR - 2ND ORDER WIDTHS ',KBDS( 5)
    +
    3445 C PRINT *,'KBDS( 6) - " " " " BIT MAPS ',KBDS( 6)
    +
    3446 C PRINT *,'KBDS( 7) - " " F O VALS ',KBDS( 7)
    +
    3447 C PRINT *,'KBDS( 8) - " " S O VALS ',KBDS( 8)
    +
    3448 C PRINT *,'KBDS( 9) - " " START OF BDS ',KBDS( 9)
    +
    3449 C PRINT *,'KBDS(10) - " " MAIN BIT MAP ',KBDS(10)
    +
    3450 C PRINT *,'KBDS(11) - BINARY SCALING ',KBDS(11)
    +
    3451 C PRINT *,'KPDS(22) - DECIMAL SCALING ',KPDS(22)
    +
    3452 C PRINT *,'KBDS(13) - FO BIT WIDTH ',KBDS(13)
    +
    3453 C PRINT *,'KBDS(14) - 2ND ORDER BIT MAP FLAG ',KBDS(14)
    +
    3454 C PRINT *,'KBDS(15) - 2ND ORDER BIT WIDTH ',KBDS(15)
    +
    3455 C PRINT *,'KBDS(16) - CONSTANT/DIFFERENT WIDTHS ',KBDS(16)
    +
    3456 C PRINT *,'KBDS(17) - SINGLE DATUM/MATRIX ',KBDS(17)
    +
    3457 C PRINT *,'REFNCE VAL ',REFNCE
    +
    3458 C ************************* PROCESS DATA **********************
    +
    3459  ij = 0
    +
    3460 C ========================================================
    +
    3461  IF (kbds(14).EQ.0) THEN
    +
    3462 C NO BIT MAP, MUST CONSTRUCT ONE
    +
    3463  IF (kgds(2).EQ.65535) THEN
    +
    3464  IF (kgds(20).EQ.255) THEN
    +
    3465 C PRINT *,'CANNOT BE USED HERE'
    +
    3466  ELSE
    +
    3467 C POINT TO PL
    +
    3468  lp = kptr(9) + kptr(2)*8 + kptr(3)*8 + kgds(20)*8 - 8
    +
    3469 C PRINT *,'LP = ',LP
    +
    3470  jt = 0
    +
    3471  DO 2000 jz = 1, kgds(3)
    +
    3472 C GET NUMBER IN CURRENT ROW
    +
    3473  CALL gbytec (msga,number,lp,16)
    +
    3474 C INCREMENT TO NEXT ROW NUMBER
    +
    3475  lp = lp + 16
    +
    3476 C PRINT *,'NUMBER IN ROW',JZ,' = ',NUMBER
    +
    3477  DO 1500 jq = 1, number
    +
    3478  IF (jq.EQ.1) THEN
    +
    3479  CALL sbytec (bmap2,1,jt,1)
    +
    3480  ELSE
    +
    3481  CALL sbytec (bmap2,0,jt,1)
    +
    3482  END IF
    +
    3483  jt = jt + 1
    +
    3484  1500 CONTINUE
    +
    3485  2000 CONTINUE
    +
    3486  END IF
    +
    3487  ELSE
    +
    3488  IF (iand(kgds(11),32).EQ.0) THEN
    +
    3489 C ROW BY ROW
    +
    3490 C PRINT *,' ROW BY ROW'
    +
    3491  kout = kgds(3)
    +
    3492  kin = kgds(2)
    +
    3493  ELSE
    +
    3494 C COL BY COL
    +
    3495 C PRINT *,' COL BY COL'
    +
    3496  kin = kgds(3)
    +
    3497  kout = kgds(2)
    +
    3498  END IF
    +
    3499 C PRINT *,'KIN=',KIN,' KOUT= ',KOUT
    +
    3500  DO 200 i = 1, kout
    +
    3501  DO 150 j = 1, kin
    +
    3502  IF (j.EQ.1) THEN
    +
    3503  CALL sbytec (bmap2,1,ij,1)
    +
    3504  ELSE
    +
    3505  CALL sbytec (bmap2,0,ij,1)
    +
    3506  END IF
    +
    3507  ij = ij + 1
    +
    3508  150 CONTINUE
    +
    3509  200 CONTINUE
    +
    3510  END IF
    +
    3511  END IF
    +
    3512 C ========================================================
    +
    3513 C PRINT 99,(BMAP2(J),J=1,110)
    +
    3514 C99 FORMAT ( 10(1X,Z8.8))
    +
    3515 C CALL BINARY (BMAP2,2)
    +
    3516 C FOR EACH GRID POINT ENTRY
    +
    3517 C
    +
    3518  scale2 = 2.0**kbds(11)
    +
    3519  scal10 = 10.0**kpds(22)
    +
    3520 C PRINT *,'SCALE VALUES - ',SCALE2,SCAL10
    +
    3521  DO 1000 i = 1, kptr(10)
    +
    3522 C GET NEXT MASTER BIT MAP BIT POSITION
    +
    3523 C IF NEXT MASTER BIT MAP BIT POSITION IS 'ON' (1)
    +
    3524  IF (kbms(i)) THEN
    +
    3525 C WRITE(6,900)I,KBMS(I)
    +
    3526 C 900 FORMAT (1X,I4,3X,14HMAIN BIT IS ON,3X,L4)
    +
    3527  IF (kbds(14).NE.0) THEN
    +
    3528  CALL gbytec (msga,kbit,kbds(6),1)
    +
    3529  ELSE
    +
    3530  CALL gbytec (bmap2,kbit,kbds(6),1)
    +
    3531  END IF
    +
    3532 C PRINT *,'KBDS(6) =',KBDS(6),' KBIT =',KBIT
    +
    3533  kbds(6) = kbds(6) + 1
    +
    3534  IF (kbit.NE.0) THEN
    +
    3535 C PRINT *,' SOB ON'
    +
    3536 C GET NEXT FIRST ORDER PACKED VALUE
    +
    3537  CALL gbytec (msga,ifoval,kbds(7),kbds(13))
    +
    3538  kbds(7) = kbds(7) + kbds(13)
    +
    3539 C PRINT *,'FOVAL =',IFOVAL
    +
    3540 C GET SECOND ORDER BIT WIDTH
    +
    3541  CALL gbytec (msga,kbds(15),kbds(5),8)
    +
    3542  kbds(5) = kbds(5) + 8
    +
    3543 C PRINT *,KBDS(7)-KBDS(13),' FOVAL =',IFOVAL,' KBDS(5)=',
    +
    3544 C * ,KBDS(5), 'ISOWID =',KBDS(15)
    +
    3545  ELSE
    +
    3546 C PRINT *,' SOB NOT ON'
    +
    3547  END IF
    +
    3548  isoval = 0
    +
    3549  IF (kbds(15).EQ.0) THEN
    +
    3550 C IF SECOND ORDER BIT WIDTH = 0
    +
    3551 C THEN SECOND ORDER VALUE IS 0
    +
    3552 C SO CALCULATE DATA VALUE FOR THIS POINT
    +
    3553 C DATA(I) = (REFNCE + (FLOAT(IFOVAL) * SCALE2)) / SCAL10
    +
    3554  ELSE
    +
    3555  CALL gbytec (msga,isoval,kbds(8),kbds(15))
    +
    3556  kbds(8) = kbds(8) + kbds(15)
    +
    3557  END IF
    +
    3558  DATA(i) = (refnce + (float(ifoval + isoval) *
    +
    3559  * scale2)) / scal10
    +
    3560 C PRINT *,I,DATA(I),REFNCE,IFOVAL,ISOVAL,SCALE2,SCAL10
    +
    3561  ELSE
    +
    3562 C WRITE(6,901) I,KBMS(I)
    +
    3563 C 901 FORMAT (1X,I4,3X,15HMAIN BIT NOT ON,3X,L4)
    +
    3564  DATA(i) = 0.0
    +
    3565  END IF
    +
    3566 C PRINT *,I,DATA(I),IFOVAL,ISOVAL,KBDS(5),KBDS(15)
    +
    3567  1000 CONTINUE
    +
    3568 C **************************************************************
    +
    3569 C PRINT *,'EXIT FI636'
    +
    3570  RETURN
    +
    3571  END
    +
    3572 
    +
    3573 C> @brief Grib grid/size test.
    +
    3574 C> @author Bill Cavanaugh @date 1991-09-13
    +
    3575 
    +
    3576 C> To test when gds is available to see if size mismatch
    +
    3577 C> on existing grids (by center) is indicated.
    +
    3578 C>
    +
    3579 C> Program history log:
    +
    3580 C> - Bill Cavanaugh 1991-09-13
    +
    3581 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    3582 C> - M. Bostelman 1997-02-12 Corrects ecmwf us grid 2 processing
    +
    3583 C> - Mark Iredell 1998-06-17 Removed alternate return
    +
    3584 C> - M. Baldwin 1999-01-20 Modify to handle grid 237
    +
    3585 C> - Boi Vuong 1909-05-21 Modify to handle grid 45
    +
    3586 C>
    +
    3587 C> @param[inout] J Size for indicated grid modified for ecmwf-us 2
    +
    3588 C> @param[in] KPDS
    +
    3589 C> @param[in] KGDS
    +
    3590 C> @param[out] KRET Error return (a mismatch was detected if kret is not zero)
    +
    3591 C>
    +
    3592 C> @note
    +
    3593 C> - KRET:
    +
    3594 C> - 9 - Gds indicates size mismatch with std grid
    +
    3595 C>
    +
    3596 C> @author Bill Cavanaugh @date 1991-09-13
    +
    3597  SUBROUTINE fi637(J,KPDS,KGDS,KRET)
    +
    3598 
    +
    3599  INTEGER KPDS(*)
    +
    3600  INTEGER KGDS(*)
    +
    3601  INTEGER J
    +
    3602  INTEGER I
    +
    3603 C ---------------------------------------
    +
    3604 C ---------------------------------------
    +
    3605 C IF GDS NOT INDICATED, RETURN
    +
    3606 C ----------------------------------------
    +
    3607  kret=0
    +
    3608  IF (iand(kpds(4),128).EQ.0) RETURN
    +
    3609 C ---------------------------------------
    +
    3610 C GDS IS INDICATED, PROCEED WITH TESTING
    +
    3611 C ---------------------------------------
    +
    3612  IF (kgds(2).EQ.65535) THEN
    +
    3613  RETURN
    +
    3614  END IF
    +
    3615  kret=1
    +
    3616  i = kgds(2) * kgds(3)
    +
    3617 C ---------------------------------------
    +
    3618 C INTERNATIONAL SET
    +
    3619 C ---------------------------------------
    +
    3620  IF (kpds(3).GE.21.AND.kpds(3).LE.26) THEN
    +
    3621  IF (i.NE.j) THEN
    +
    3622  RETURN
    +
    3623  END IF
    +
    3624  ELSE IF (kpds(3).GE.37.AND.kpds(3).LE.44) THEN
    +
    3625  IF (i.NE.j) THEN
    +
    3626  RETURN
    +
    3627  END IF
    +
    3628  ELSE IF (kpds(3).EQ.50) THEN
    +
    3629  IF (i.NE.j) THEN
    +
    3630  RETURN
    +
    3631  END IF
    +
    3632  ELSE IF (kpds(3).GE.61.AND.kpds(3).LE.64) THEN
    +
    3633  IF (i.NE.j) THEN
    +
    3634  RETURN
    +
    3635  END IF
    +
    3636 C ---------------------------------------
    +
    3637 C TEST ECMWF CONTENT
    +
    3638 C ---------------------------------------
    +
    3639  ELSE IF (kpds(1).EQ.98) THEN
    +
    3640  kret = 9
    +
    3641  IF (kpds(3).GE.1.AND.kpds(3).LE.16) THEN
    +
    3642  IF (i.NE.j) THEN
    +
    3643  IF (kpds(3) .NE. 2) THEN
    +
    3644  RETURN
    +
    3645  ELSEIF (i .NE. 10512) THEN ! Test for US Grid 2
    +
    3646  RETURN
    +
    3647  END IF
    +
    3648  j = i ! Set to US Grid 2, 2.5 Global
    +
    3649  END IF
    +
    3650  ELSE
    +
    3651  kret = 5
    +
    3652  RETURN
    +
    3653  END IF
    +
    3654 C ---------------------------------------
    +
    3655 C U.K. MET OFFICE, BRACKNELL
    +
    3656 C ---------------------------------------
    +
    3657  ELSE IF (kpds(1).EQ.74) THEN
    +
    3658  kret = 9
    +
    3659  IF (kpds(3).GE.25.AND.kpds(3).LE.26) THEN
    +
    3660  IF (i.NE.j) THEN
    +
    3661  RETURN
    +
    3662  END IF
    +
    3663  ELSE
    +
    3664  kret = 5
    +
    3665  RETURN
    +
    3666  END IF
    +
    3667 C ---------------------------------------
    +
    3668 C CANADA
    +
    3669 C ---------------------------------------
    +
    3670  ELSE IF (kpds(1).EQ.54) THEN
    +
    3671 C PRINT *,' NO CURRENT LISTING OF CANADIAN GRIDS'
    +
    3672  RETURN
    +
    3673 C ---------------------------------------
    +
    3674 C JAPAN METEOROLOGICAL AGENCY
    +
    3675 C ---------------------------------------
    +
    3676  ELSE IF (kpds(1).EQ.34) THEN
    +
    3677 C PRINT *,' NO CURRENT LISTING OF JMA GRIDS'
    +
    3678  RETURN
    +
    3679 C ---------------------------------------
    +
    3680 C NAVY - FNOC
    +
    3681 C ---------------------------------------
    +
    3682  ELSE IF (kpds(1).EQ.58) THEN
    +
    3683  IF (kpds(3).GE.37.AND.kpds(3).LE.44) THEN
    +
    3684  IF (i.NE.j) THEN
    +
    3685  RETURN
    +
    3686  END IF
    +
    3687  ELSE IF (kpds(3).GE.220.AND.kpds(3).LE.221) THEN
    +
    3688  IF (i.NE.j) THEN
    +
    3689  RETURN
    +
    3690  END IF
    +
    3691  ELSE IF (kpds(3).EQ.223) THEN
    +
    3692  IF (i.NE.j) THEN
    +
    3693  RETURN
    +
    3694  END IF
    +
    3695  ELSE
    +
    3696  kret = 5
    +
    3697  RETURN
    +
    3698  END IF
    +
    3699 C ---------------------------------------
    +
    3700 C U.S. GRIDS
    +
    3701 C ---------------------------------------
    +
    3702  ELSE IF (kpds(1).EQ.7) THEN
    +
    3703  kret = 9
    +
    3704  IF (kpds(3).GE.1.AND.kpds(3).LE.6) THEN
    +
    3705  IF (i.NE.j) THEN
    +
    3706  RETURN
    +
    3707  END IF
    +
    3708  ELSE IF (kpds(3).EQ.8) THEN
    +
    3709  IF (i.NE.j) THEN
    +
    3710  RETURN
    +
    3711  END IF
    +
    3712  ELSE IF (kpds(3).EQ.10) THEN
    +
    3713  IF (i.NE.j) THEN
    +
    3714  RETURN
    +
    3715  END IF
    +
    3716  ELSE IF (kpds(3).GE.11.AND.kpds(3).LE.18) THEN
    +
    3717  IF (i.NE.j) THEN
    +
    3718  RETURN
    +
    3719  END IF
    +
    3720  ELSE IF (kpds(3).GE.27.AND.kpds(3).LE.30) THEN
    +
    3721  IF (i.NE.j) THEN
    +
    3722  RETURN
    +
    3723  END IF
    +
    3724  ELSE IF (kpds(3).GE.33.AND.kpds(3).LE.34) THEN
    +
    3725  IF (i.NE.j) THEN
    +
    3726  RETURN
    +
    3727  END IF
    +
    3728  ELSE IF (kpds(3).GE.37.AND.kpds(3).LE.45) THEN
    +
    3729  IF (i.NE.j) THEN
    +
    3730  RETURN
    +
    3731  END IF
    +
    3732  ELSE IF (kpds(3).EQ.53) THEN
    +
    3733  IF (i.NE.j) THEN
    +
    3734  RETURN
    +
    3735  END IF
    +
    3736  ELSE IF (kpds(3).GE.55.AND.kpds(3).LE.56) THEN
    +
    3737  IF (i.NE.j) THEN
    +
    3738  RETURN
    +
    3739  END IF
    +
    3740  ELSE IF (kpds(3).GE.67.AND.kpds(3).LE.77) THEN
    +
    3741  IF (i.NE.j) THEN
    +
    3742  RETURN
    +
    3743  END IF
    +
    3744  ELSE IF (kpds(3).GE.85.AND.kpds(3).LE.88) THEN
    +
    3745  IF (i.NE.j) THEN
    +
    3746  RETURN
    +
    3747  END IF
    +
    3748  ELSE IF (kpds(3).GE.90.AND.kpds(3).LE.99) THEN
    +
    3749  IF (i.NE.j) THEN
    +
    3750  RETURN
    +
    3751  END IF
    +
    3752  ELSE IF (kpds(3).EQ.100.OR.kpds(3).EQ.101) THEN
    +
    3753  IF (i.NE.j) THEN
    +
    3754  RETURN
    +
    3755  END IF
    +
    3756  ELSE IF (kpds(3).GE.103.AND.kpds(3).LE.107) THEN
    +
    3757  IF (i.NE.j) THEN
    +
    3758  RETURN
    +
    3759  END IF
    +
    3760  ELSE IF (kpds(3).EQ.110) THEN
    +
    3761  IF (i.NE.j) THEN
    +
    3762  RETURN
    +
    3763  END IF
    +
    3764  ELSE IF (kpds(3).EQ.120) THEN
    +
    3765  IF (i.NE.j) THEN
    +
    3766  RETURN
    +
    3767  END IF
    +
    3768  ELSE IF (kpds(3).GE.122.AND.kpds(3).LE.130) THEN
    +
    3769  IF (i.NE.j) THEN
    +
    3770  RETURN
    +
    3771  END IF
    +
    3772  ELSE IF (kpds(3).EQ.132) THEN
    +
    3773  IF (i.NE.j) THEN
    +
    3774  RETURN
    +
    3775  END IF
    +
    3776  ELSE IF (kpds(3).EQ.138) THEN
    +
    3777  IF (i.NE.j) THEN
    +
    3778  RETURN
    +
    3779  END IF
    +
    3780  ELSE IF (kpds(3).EQ.139) THEN
    +
    3781  IF (i.NE.j) THEN
    +
    3782  RETURN
    +
    3783  END IF
    +
    3784  ELSE IF (kpds(3).EQ.140) THEN
    +
    3785  IF (i.NE.j) THEN
    +
    3786  RETURN
    +
    3787  END IF
    +
    3788  ELSE IF (kpds(3).GE.145.AND.kpds(3).LE.148) THEN
    +
    3789  IF (i.NE.j) THEN
    +
    3790  RETURN
    +
    3791  END IF
    +
    3792  ELSE IF (kpds(3).EQ.150.OR.kpds(3).EQ.151) THEN
    +
    3793  IF (i.NE.j) THEN
    +
    3794  RETURN
    +
    3795  END IF
    +
    3796  ELSE IF (kpds(3).EQ.160.OR.kpds(3).EQ.161) THEN
    +
    3797  IF (i.NE.j) THEN
    +
    3798  RETURN
    +
    3799  END IF
    +
    3800  ELSE IF (kpds(3).EQ.163) THEN
    +
    3801  IF (i.NE.j) THEN
    +
    3802  RETURN
    +
    3803  END IF
    +
    3804  ELSE IF (kpds(3).GE.170.AND.kpds(3).LE.176) THEN
    +
    3805  IF (i.NE.j) THEN
    +
    3806  RETURN
    +
    3807  END IF
    +
    3808  ELSE IF (kpds(3).GE.179.AND.kpds(3).LE.184) THEN
    +
    3809  IF (i.NE.j) THEN
    +
    3810  RETURN
    +
    3811  END IF
    +
    3812  ELSE IF (kpds(3).EQ.187) THEN
    +
    3813  IF (i.NE.j) THEN
    +
    3814  RETURN
    +
    3815  END IF
    +
    3816  ELSE IF (kpds(3).EQ.188) THEN
    +
    3817  IF (i.NE.j) THEN
    +
    3818  RETURN
    +
    3819  END IF
    +
    3820  ELSE IF (kpds(3).EQ.189) THEN
    +
    3821  IF (i.NE.j) THEN
    +
    3822  RETURN
    +
    3823  END IF
    +
    3824  ELSE IF (kpds(3).EQ.190.OR.kpds(3).EQ.192) THEN
    +
    3825  IF (i.NE.j) THEN
    +
    3826  RETURN
    +
    3827  END IF
    +
    3828  ELSE IF (kpds(3).GE.193.AND.kpds(3).LE.199) THEN
    +
    3829  IF (i.NE.j) THEN
    +
    3830  RETURN
    +
    3831  END IF
    +
    3832  ELSE IF (kpds(3).GE.200.AND.kpds(3).LE.254) THEN
    +
    3833  IF (i.NE.j) THEN
    +
    3834  RETURN
    +
    3835  END IF
    +
    3836  ELSE
    +
    3837  kret = 5
    +
    3838  RETURN
    +
    3839  END IF
    +
    3840  ELSE
    +
    3841  kret = 10
    +
    3842  RETURN
    +
    3843  END IF
    +
    3844 C ------------------------------------
    +
    3845 C NORMAL EXIT
    +
    3846 C ------------------------------------
    +
    3847  kret = 0
    +
    3848  RETURN
    +
    3849  END
    +
    +
    +
    gbytesc
    subroutine gbytesc(IN, IOUT, ISKIP, NBYTE, NSKIP, N)
    Extract arbitrary size values from a packed bit string, right justifying each value in the unpacked a...
    Definition: gbytesc.f:16
    +
    fi632
    subroutine fi632(MSGA, KPTR, KPDS, KRET)
    Gather info from product definition sec.
    Definition: w3fi63.f:635
    +
    fi634
    subroutine fi634(MSGA, KPTR, KPDS, KGDS, KBMS, KRET)
    Extract or generate bit map for output.
    Definition: w3fi63.f:1527
    +
    fi637
    subroutine fi637(J, KPDS, KGDS, KRET)
    Grib grid/size test.
    Definition: w3fi63.f:3598
    +
    fi631
    subroutine fi631(MSGA, KPTR, KPDS, KRET)
    Find 'grib' chars & reset pointers.
    Definition: w3fi63.f:478
    +
    gbytec
    subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
    Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
    Definition: gbytec.f:14
    +
    w3fi83
    subroutine w3fi83(DATA, NPTS, FVAL1, FDIFF1, ISCAL2, ISC10, KPDS, KGDS)
    Restore delta packed data to original values restore from boustrephedonic alignment.
    Definition: w3fi83.f:33
    +
    fi634x
    subroutine fi634x(NPTS, NSKP, MSGA, KBMS)
    Extract bit map.
    Definition: w3fi63.f:2512
    +
    fi635
    subroutine fi635(MSGA, KPTR, KPDS, KGDS, KBMS, DATA, KRET)
    Extract grib data elements from bds.
    Definition: w3fi63.f:2686
    +
    w3fi63
    subroutine w3fi63(MSGA, KPDS, KGDS, KBMS, DATA, KPTR, KRET)
    Unpack a GRIB (edition 1) field to the exact grid specified in the GRIB message, isolate the bit map,...
    Definition: w3fi63.f:243
    +
    fi633
    subroutine fi633(MSGA, KPTR, KGDS, KRET)
    Extract info from grib-gds.
    Definition: w3fi63.f:981
    +
    fi636
    subroutine fi636(DATA, MSGA, KBMS, REFNCE, KPTR, KPDS, KGDS)
    Process second order packing.
    Definition: w3fi63.f:3331
    +
    sbytec
    subroutine sbytec(OUT, IN, ISKIP, NBYTE)
    This is a wrapper for sbytesc()
    Definition: sbytec.f:14
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    + + + + diff --git a/ver-2.10.0/w3fi64_8f.html b/ver-2.10.0/w3fi64_8f.html new file mode 100644 index 00000000..ffb7e526 --- /dev/null +++ b/ver-2.10.0/w3fi64_8f.html @@ -0,0 +1,685 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi64.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi64.f File Reference
    +
    +
    + +

    NMC office note 29 report unpacker. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi64 (COCBUF, LOCRPT, NEXT)
     Unpacks an array of upper-air reports that are packed in the format described by NMC office note 29, or unpacks an array of surface reports that are packed in the format described by NMC office note 124. More...
     
    +

    Detailed Description

    +

    NMC office note 29 report unpacker.

    +
    Author
    L. Marx
    +
    Date
    1990-01
    + +

    Definition in file w3fi64.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi64()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi64 (character*10, dimension(*) COCBUF,
    integer, dimension(*) LOCRPT,
     NEXT 
    )
    +
    + +

    Unpacks an array of upper-air reports that are packed in the format described by NMC office note 29, or unpacks an array of surface reports that are packed in the format described by NMC office note 124.

    +

    Input character data are converted to integer, real or character type as specified in the category tables below. Missing integer data are replaced with 99999, missing real data are replaced with 99999.0 and missing character data are replaced with blanks. This library is similar to w3ai02() except w3ai02() was written in assembler and could not handle internal read errors (program calling w3ai02() would fail in this case w/o explanation).

    +

    Program history log:

      +
    • L. Marx 1990-01 Converted code from assembler to vs fortran; Expanded error return codes in 'NEXT'
      • +
    • Dennis Keyser 1991-07-22 Use same arguments as w3ai02() ; Streamlined code; Docblocked and commented; Diag- nostic print for errors; Attempts to skip to NEXT report in same record rather than exiting record.
      • +
    • Dennis Keyser 1991-08-12 Slight changes to make sub- program more portable; Test for absence of end- of-record indicator, will gracefully exit record.
      • +
    • Dennis Keyser 1992-06-29 Convert to cray cft77 fortran
      • +
    • Dennis Keyser 1992-08-06 Corrected error which could lead to the length for a concatenation operator being less than 1 when an input parameter spans across two 10-character words.
      • +
    +
    Parameters
    + + + + +
    [in]COCBUFCharacter*10 array containing a block of packed reports in nmc office note 29/124 format.
    [in]NEXTMarker indicating relative location (in bytes) of end of last report in COCBUF. Exception: NEXT must be set to zero prior to unpacking the first report of a new block of reports. subsequently, the value of NEXT returned by the previous call to w3fi64 should be used as input. (see output argument list below.) if NEXT is negative, w3fi64 will return immediately without action.
    [out]LOCRPTArray containing one unpacked report with pointers and counters to direct the user. Locrpt() must begin on a fullword boundary. Format is mixed, user must equivalence real and character arrays to this array (see below and remarks for content).
    +
    +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    word content unit format
    1 latitude 0.01 degrees real
    2 longitude 0.01 degrees west real
    3 unused
    4 observation time 0.01 hours (utc) real
    5 reserved (3rd byte is 4-characters char*8
    on29 "25'th char.; 4th</td> <td class="markdownTableBodyLeft"> left-justified</td> <td class="markdownTableBodyLeft"> </td> </tr> +<tr class="markdownTableRowOdd"> <td class="markdownTableBodyLeft"> </td> <td class="markdownTableBodyLeft"> byte is on29 "26'th
    char." (see on29)</td> <td class="markdownTableBodyLeft"> </td> <td class="markdownTableBodyLeft"> </td> </tr> +<tr class="markdownTableRowOdd"> <td class="markdownTableBodyLeft"> 6</td> <td class="markdownTableBodyLeft"> reserved (3rd byte is</td> <td class="markdownTableBodyLeft"> 3-characters</td> <td class="markdownTableBodyLeft"> char*8</td> </tr> +<tr class="markdownTableRowEven"> <td class="markdownTableBodyLeft"> </td> <td class="markdownTableBodyLeft"> on29 "27'th char. (see left-justified
    on29)
    7 station elevation meters real
    8 instrument type on29 table r.2 integer
    9 report type on29 table r.1 or integer
    on124 table s.3
    10 ununsed
    11 stn. id. (first 4 char.) 4-characters char*8
    left-justified
    12 stn. id. (last 2 char.) 2-characters char*8
    left-justified
    13 category 1, no. levels count integer
    14 category 1, data index count integer
    15 category 2, no. levels count integer
    16 category 2, data index count integer
    17 category 3, no. levels count integer
    18 category 3, data index count integer
    19 category 4, no. levels count integer
    20 category 4, data index count integer
    21 category 5, no. levels count integer
    22 category 5, data index count integer
    23 category 6, no. levels count integer
    24 category 6, data index count integer
    25 category 7, no. levels count integer
    26 category 7, data index count integer
    27 category 8, no. levels count integer
    28 category 8, data index count integer
    29 category 51, no. levels count integer
    30 category 51, data index count integer
    31 category 52, no. levels count integer
    32 category 52, data index count integer
    33 category 9, no. levels count integer
    34 category 9, data index count integer
    35-42 zeroed out - not used integer
    43-end unpacked data groups (see remarks) mixed
    +
    +

    NEXT: Marker indicating relative location (in bytes) of end of current report in COCBUF. NEXT will be set to -1 if w3fi64() encounters string 'end record' in place of the NEXT report. This is the end of the block. No unpacking takes place. NEXT is set to-2 when internal (logic) errors have been detected. NEXT is set to -3 when data count check fails. In both of the latter cases some data (e.g., header information) may be unpacked into LOCRPT.

    +
    Note
    After first reading and processing the office note 85 (first) date record, the user's fortran program begins a read loop as follows. For each iteration a blocked input report is read into array COCBUF. Now test the first ten characters in COCBUF for the string 'endof file' (sic). This string signals the end of input. Otherwise, set the marker 'NEXT' to zero and begin the unpacking loop.
    +

    Each iteration of the unpacking loop consists of a call to w3fi64() with the current value of 'NEXT'. If 'NEXT' is -1 upon returning from w3fi64(), it has reached the end of the input record, and the user's program should read the next record as above. If 'NEXT' is -2 or -3 upon returning, there is a grievous error in the current packed input record, and the user's program should print it for examination by automation division personnel. If 'NEXT' is positive, the output structure locrpt contains an unpacked report, and the user's program should process it at this point, subsequently repeating the unpacking loop.

    +

    EXAMPLE:

    CHARACTER*10 COCBUF(644)
    +
    CHARACTER*8 COCRPT(1608)
    +
    CHARACTER*3 CQUMAN(20)
    +
    INTEGER LOCRPT(1608)
    +
    REAL ROCRPT(1608),GEOMAN(20),TMPMAN(20),DPDMAN(20),
    +
    $ wdrman(20),wspman(20)
    +
    equivalence(cocrpt,locrpt,rocrpt)
    +
    +
    c READ and process the office note 85 date record
    +
    ..........
    +
    c --- begin READ loop
    +
    10 CONTINUE
    +
    READ (unit=inp, iostat=ios, num=nbuf) cocbuf
    +
    IF(ios .LT. 0) GO TO (END OF INPUT)
    +
    IF(ios .GT. 0) GO TO (input error)
    +
    IF(nbuf .GT. 6432) GO TO (buffer overflow)
    +
    IF(cocbuf(1).EQ.'ENDOF FILE') GO TO (END OF INPUT)
    +
    next = 0
    +
    c ------ begin unpacking loop
    +
    20 CONTINUE
    +
    CALL w3fi64(cocbuf, locrpt, next)
    +
    IF(next .EQ. -1) GO TO 10
    +
    IF(next .LT. -1) GO TO (office note 29/124 error)
    +
    rlat = 0.01 * rocrpt(1) (latitude)
    +
    ..... etc .....
    +
    c --- begin category 1 fetch -- mandatory level DATA
    +
    IF(locrpt(13) .GT. 0) THEN
    +
    nlvls = min(20,locrpt(13))
    +
    indx = locrpt(14)
    +
    DO 66 i = 1,nlvls
    +
    geoman(i) = rocrpt(indx)
    +
    tmpman(i) = 0.1 * rocrpt(indx+1)
    +
    dpdman(i) = 0.1 * rocrpt(indx+2)
    +
    wdrman(i) = rocrpt(indx+3)
    +
    wspman(i) = rocrpt(indx+4)
    +
    cquman(i) = cocrpt(indx+5)
    +
    indx = indx + 6
    +
    66 CONTINUE
    +
    END IF
    +
    ..... etc .....
    +
    GO TO 20
    +
    ...............
    +

    Data from the on29/124 record is unpacked into fixed locations in words 1-12 and into indexed locations in word 43 and following. Study on29 appendix c/on124 appendix s.2 carefully. Each category (or group of fields) in the packed report has a corresponding layout in locations in array LOCRPT that may be found by using the corresponding index amount from words 14, 16, ..., 34, in array LOCRPT. For instance, if a report contains one or more packed category 3 data groups (wind data at variable pressure levels) that data will be unpacked into binary and and character fields in one or more unpacked category 3 data groups as described below. The number of levels will be stored in word 17 and the index in fullwords of the first level of unpacked data in the output array will be stored in word 18. The second level, if any, will be stored beginning four words further on, and so forth until the count in word 17 is exhausted. The field layout in each category is given below...

    +
    +
      +
    • CATEGORY 1 - MANDATORY LEVEL DATA + + + + + + + + + + + + + + + + + + + + + + + + +
      WORD PARAMETER UNITS FORMAT
      1 GEOPOTENTIAL METERS REAL
      2 TEMPERATURE 0.1 DEGREES C REAL
      3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL
      4 WIND DIRECTION DEGREES REAL
      5 WIND SPEED KNOTS REAL
      6 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8
      LEFT-JUSTIFIED
      GEOPOTENTIAL ON29 TABLE Q.A
      TEMPERATURE ON29 TABLE Q.A
      DEWPOINT DEPR. ON29 TABLE Q.C
      WIND ON29 TABLE Q.A
      +
      • +
    +
    +
      +
    • CATEGORY 2 - TEMPERATURE AT VARIABLE PRESSURE + + + + + + + + + + + + + + + + + + + + +
      WORD PARAMETER UNITS FORMAT
      1 PRESSURE 0.1 MILLIBARS REAL
      2 TEMPERATURE 0.1 DEGREES C REAL
      3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL
      4 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8
      LEFT-JUSTIFIED
      PRESSURE ON29 TABLE Q.B
      TEMPERATURE ON29 TABLE Q.A
      DEWPOINT DEPR. ON29 TABLE Q.C
      NOT USED BLANK
      +
      • +
    +
    +
      +
    • CATEGORY 3 - WINDS AT VARIABLE PRESSURE + + + + + + + + + + + + + + + + + + + + +
      WORD PARAMETER UNITS FORMAT
      1 PRESSURE 0.1 MILLIBARS REAL
      2 WIND DIRECTION DEGREES REAL
      3 WIND SPEED KNOTS REAL
      4 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8
      LEFT-JUSTIFIED
      PRESSURE ON29 TABLE Q.B
      WIND ON29 TABLE Q.A
      NOT USED BLANK
      NOT USED BLANK
      +
      • +
    +
    +
      +
    • CATEGORY 4 - WINDS AT VARIABLE HEIGHTS + + + + + + + + + + + + + + + + + + + + +
      WORD PARAMETER UNITS FORMAT
      1 GEOPOTENTIAL METERS REAL
      2 WIND DIRECTION DEGREES REAL
      3 WIND SPEED KNOTS REAL
      4 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8
      LEFT-JUSTIFIED
      GEOPOTENTIAL ON29 TABLE Q.B
      WIND ON29 TABLE Q.A
      NOT USED BLANK
      NOT USED BLANK
      +
      • +
    +
    +
      +
    • CATEGORY 5 - TROPOPAUSE DATA + + + + + + + + + + + + + + + + + + + + + + + + +
      WORD PARAMETER UNITS FORMAT
      1 GEOPOTENTIAL METERS REAL
      2 TEMPERATURE 0.1 DEGREES C REAL
      3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL
      4 WIND DIRECTION DEGREES REAL
      5 WIND SPEED KNOTS REAL
      6 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8
      LEFT-JUSTIFIED
      PRESSURE ON29 TABLE Q.B
      TEMPERATURE ON29 TABLE Q.A
      DEWPOINT DEPR. ON29 TABLE Q.C
      WIND ON29 TABLE Q.A
      +
      • +
    +
    +
      +
    • CATEGORY 6 - CONSTANT-LEVEL DATA (AIRCRAFT, SAT. CLOUD-DRIFT) + + + + + + + + + + + + + + + + + + + + + + + + +
      WORD PARAMETER UNITS FORMAT
      1 PRESSURE ALTITUDE METERS REAL
      2 TEMPERATURE 0.1 DEGREES C REAL
      3 DEWPOINT DEPRESSION 0.1 DEGREES C REAL
      4 WIND DIRECTION DEGREES REAL
      5 WIND SPEED KNOTS REAL
      6 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8
      LEFT-JUSTIFIED
      PRESSURE ON29 TABLE Q.6
      TEMPERATURE ON29 TABLE Q.6
      DEWPOINT DEPR. ON29 TABLE Q.6
      WIND ON29 TABLE Q.6C
      +
      • +
    +
    +
      +
    • CATEGORY 7 - CLOUD COVER + + + + + + + + + + + + + + + + + + +
      WORD PARAMETER UNITS FORMAT
      1 PRESSURE 0.1 MILLIBARS REAL
      2 AMOUNT OF CLOUDS PER CENT REAL
      3 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8
      LEFT-JUSTIFIED
      PRESSURE ON29 TABLE Q.7
      CLOUD AMOUNT ON29 TABLE Q.7
      NOT USED BLANK
      NOT USED BLANK
      +
      • +
    +
    +
      +
    • CATEGORY 8 - ADDITIONAL DATA + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
      WORD PARAMETER UNITS FORMAT
      1 SPECIFIED IN ON29 VARIABLE REAL
      TABLE 101.1 OR
      ON124 TABLE SM.8A.1
      2 FORM OF ADD'L DATA CODE FIGURE FROM REAL
      ON29 TABLE 101 OR
      ON124 TABLE SM.8A
      3 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8
      LEFT-JUSTIFIED
      VALUE 1 ON29 TABLE Q.8 OR
      ON124 TABLE SM.8B
      VALUE 2 ON29 TABLE Q.8A OR
      ON124 TABLE SM.8C
      NOT USED BLANK
      NOT USED BLANK
      +
      • +
    +
    +
      +
    • CATEGORY 51 - SURFACE DATA + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
      WORD PARAMETER UNITS FORMAT
      1 SEA-LEVEL PRESSURE 0.1 MILLIBARS REAL
      2 STATION PRESSURE 0.1 MILLIBARS REAL
      3 WIND DIRECTION DEGREES REAL
      4 WIND SPEED KNOTS REAL
      5 AIR TEMPERATURE 0.1 DEGREES C REAL
      6 DEWPOINT DEPRESSION 0.1 DEGREES C REAL
      7 MAXIMUM TEMPERATURE 0.1 DEGREES C REAL
      8 MINIMUM TEMPERATURE 0.1 DEGREES C REAL
      9 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8
      LEFT-JUSTIFIED
      S-LEVEL PRESS. ON124 TABLE SM.51
      STATION PRESS. ON124 TABLE SM.51
      WIND ON124 TABLE SM.51
      AIR TEMPERATURE ON124 TABLE SM.51
      10 QUALITY MARKERS: EACH 1-CHARACTER CHAR*8
      LEFT-JUSTIFIED
      DEWPOINT DEPR. ON124 TABLE SM.51
      NOT USED BLANK
      NOT USED BLANK
      NOT USED BLANK
      11 HORIZ. VISIBILITY WMO CODE TABLE 4300 INTEGER
      12 PRESENT WEATHER WMO CODE TABLE 4677 INTEGER
      13 PAST WEATHER WMO CODE TABLE 4561 INTEGER
      14 TOTAL CLOUD COVER N WMO CODE TABLE 2700 INTEGER
      15 CLOUD COVER OF C/LN WMO CODE TABLE 2700 INTEGER
      16 CLOUD TYPE OF C/L WMO CODE TABLE 0513 INTEGER
      17 CLOUD HEIGHT OF C/L WMO CODE TABLE 1600 INTEGER
      18 CLOUD TYPE OF C/M WMO CODE TABLE 0515 INTEGER
      19 CLOUD TYPE OF C/H WMO CODE TABLE 0509 INTEGER
      20 CHARACTERISTIC OF WMO CODE TABLE 0200 INTEGER
      3-HR PRESS TENDENCY
      21 AMT. PRESS TENDENCY 0.1 MILLIBARS REAL
      (50.0 WILL BE ADDED TO INDICATE 24-HR TENDENCY)
      +
      • +
    +
    +
      +
    • CATEGORY 52 - ADDITIONAL SURFACE DATA + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
      WORD PARAMETER UNITS FORMAT
      1 6-HR PRECIPITATION 0.01 INCH INTEGER
      2 SNOW DEPTH INCH INTEGER
      3 24-HR PRECIPITATION 0.01 INCH INTEGER
      4 DURATION OF PRECIP. NO. 6-HR PERIODS INTEGER
      5 PERIOD OF WAVES SECONDS INTEGER
      6 HEIGHT OF WAVES 0.5 METERS INTEGER
      7 SWELL DIRECTION WMO CODE TABLE 0877 INTEGER
      8 SWELL PERIOD SECONDS INTEGER
      9 SWELL HEIGHT 0.5 METERS INTEGER
      10 SEA SFC TEMPERATURE 0.1 DEGREES C INTEGER
      11 SPECIAL PHEN, GEN'L INTEGER
      12 SPECIAL PHEN, DET'L INTEGER
      13 SHIP'S COURSE WMO CODE TABLE 0700 INTEGER
      14 SHIP'S AVERAGE SPEED WMO CODE TABLE 4451 INTEGER
      15 WATER EQUIVALENT OF 0.01 INCH INTEGER
      SNOW AND/OR ICE
      +
      • +
    +
    +
      +
    • CATEGORY 9 - PLAIN LANGUAGE DATA (ALPHANUMERIC TEXT) + + + + + + + + + + + + + + + + + + +
      WORD BYTES PARAMETER FORMAT
      1 1 INDICATOR OF CONTENT (ON124 TABLE SM.9) CHAR*8
      (1 CHARACTER)
      2-4 PLAIN LANGUAGE DATA, TEXT CHARACTERS 1-3
      4-8 NOT USED (BLANK)
      2 1-4 PLAIN LANGUAGE DATA, TEXT CHARACTERS 4-7 CHAR*8
      4-8 NOT USED (BLANK)
      3 1-4 PLAIN LANGUAGE DATA, TEXT CHARACTERS 8-11 CHAR*8
      4-8 NOT USED (BLANK)
      +
      • +
    +
    Note
    One report may unpack into more than one category having multiple levels. The unused portion of LOCRPT is not cleared.
    +
    +Entry w3ai02() duplicates processing in w3fi64() since no assembly language code in cray w3lib.
    +
    Author
    L. Marx
    +
    Date
    1990-01
    + +

    Definition at line 393 of file w3fi64.f.

    + +
    +
    +
    +
    +
    w3fi64
    subroutine w3fi64(COCBUF, LOCRPT, NEXT)
    Unpacks an array of upper-air reports that are packed in the format described by NMC office note 29,...
    Definition: w3fi64.f:393
    + + + + diff --git a/ver-2.10.0/w3fi64_8f.js b/ver-2.10.0/w3fi64_8f.js new file mode 100644 index 00000000..e0556170 --- /dev/null +++ b/ver-2.10.0/w3fi64_8f.js @@ -0,0 +1,4 @@ +var w3fi64_8f = +[ + [ "w3fi64", "w3fi64_8f.html#abd64595a92fa11f1d11661e1e94b9dcc", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi64_8f_source.html b/ver-2.10.0/w3fi64_8f_source.html new file mode 100644 index 00000000..24eb899c --- /dev/null +++ b/ver-2.10.0/w3fi64_8f_source.html @@ -0,0 +1,866 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi64.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi64.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief NMC office note 29 report unpacker.
    +
    3 C> @author L. Marx @date 1990-01
    +
    4 
    +
    5 C> Unpacks an array of upper-air reports that are packed in
    +
    6 C> the format described by NMC office note 29, or unpacks an array
    +
    7 C> of surface reports that are packed in the format described by NMC
    +
    8 C> office note 124. Input character data are converted to integer,
    +
    9 C> real or character type as specified in the category tables below.
    +
    10 C> Missing integer data are replaced with 99999, missing real data
    +
    11 C> are replaced with 99999.0 and missing character data are replaced
    +
    12 C> with blanks. This library is similar to w3ai02() except w3ai02()
    +
    13 C> was written in assembler and could not handle internal read errors
    +
    14 C> (program calling w3ai02() would fail in this case w/o explanation).
    +
    15 C>
    +
    16 C> Program history log:
    +
    17 C> - L. Marx 1990-01 Converted code from assembler
    +
    18 C> to vs fortran; Expanded error return codes in 'NEXT'
    +
    19 C> - Dennis Keyser 1991-07-22 Use same arguments as w3ai02() ;
    +
    20 C> Streamlined code; Docblocked and commented; Diag-
    +
    21 C> nostic print for errors; Attempts to skip to NEXT
    +
    22 C> report in same record rather than exiting record.
    +
    23 C> - Dennis Keyser 1991-08-12 Slight changes to make sub-
    +
    24 C> program more portable; Test for absence of end-
    +
    25 C> of-record indicator, will gracefully exit record.
    +
    26 C> - Dennis Keyser 1992-06-29 Convert to cray cft77 fortran
    +
    27 C> - Dennis Keyser 1992-08-06 Corrected error which could
    +
    28 C> lead to the length for a concatenation operator
    +
    29 C> being less than 1 when an input parameter spans
    +
    30 C> across two 10-character words.
    +
    31 C>
    +
    32 C> @param[in] COCBUF Character*10 array containing a block of packed
    +
    33 C> reports in nmc office note 29/124 format.
    +
    34 C> @param[in] NEXT Marker indicating relative location (in bytes) of
    +
    35 C> end of last report in COCBUF. Exception: NEXT must
    +
    36 C> be set to zero prior to unpacking the first report of
    +
    37 C> a new block of reports. subsequently, the value of
    +
    38 C> NEXT returned by the previous call to w3fi64 should
    +
    39 C> be used as input. (see output argument list below.)
    +
    40 C> if NEXT is negative, w3fi64 will return immediately
    +
    41 C> without action.
    +
    42 C> @param[out] LOCRPT Array containing one unpacked report with pointers
    +
    43 C> and counters to direct the user. Locrpt() must begin
    +
    44 C> on a fullword boundary. Format is mixed, user must
    +
    45 C> equivalence real and character arrays to this array
    +
    46 C> (see below and remarks for content).
    +
    47 C>
    +
    48 C> ***************************************************************
    +
    49 C>
    +
    50 C> |word | content | unit | format |
    +
    51 C> | :---- | :---------------------- | :------------------- | :----- |
    +
    52 C> | 1 | latitude | 0.01 degrees | real |
    +
    53 C> | 2 | longitude | 0.01 degrees west | real |
    +
    54 C> | 3 | unused | | |
    +
    55 C> | 4 | observation time | 0.01 hours (utc) | real |
    +
    56 C> | 5 | reserved (3rd byte is | 4-characters | char*8 |
    +
    57 C> | | on29 "25'th char.; 4th | left-justified | |
    +
    58 C> | |byte is on29 "26'th | | |
    +
    59 C> | |char." (see on29) | | |
    +
    60 C> | 6 |reserved (3rd byte is | 3-characters | char*8 |
    +
    61 C> | |on29 "27'th char. (see |left-justified | |
    +
    62 C> | |on29) | | |
    +
    63 C> | 7 |station elevation |meters | real |
    +
    64 C> | 8 |instrument type |on29 table r.2 | integer|
    +
    65 C> | 9 |report type |on29 table r.1 or | integer|
    +
    66 C> | |on124 table s.3 | | |
    +
    67 C> | 10 |ununsed | | |
    +
    68 C> | 11 |stn. id. (first 4 char.) | 4-characters | char*8 |
    +
    69 C> | |left-justified | | |
    +
    70 C> | 12 |stn. id. (last 2 char.) | 2-characters | char*8 |
    +
    71 C> | |left-justified | | |
    +
    72 C> | 13 |category 1, no. levels | count | integer|
    +
    73 C> | 14 |category 1, data index | count | integer|
    +
    74 C> | 15 |category 2, no. levels | count | integer|
    +
    75 C> | 16 |category 2, data index | count | integer|
    +
    76 C> | 17 |category 3, no. levels | count | integer|
    +
    77 C> | 18 |category 3, data index | count | integer|
    +
    78 C> | 19 |category 4, no. levels | count | integer|
    +
    79 C> | 20 |category 4, data index | count | integer|
    +
    80 C> | 21 |category 5, no. levels | count | integer|
    +
    81 C> | 22 |category 5, data index | count | integer|
    +
    82 C> | 23 |category 6, no. levels | count | integer|
    +
    83 C> | 24 |category 6, data index | count | integer|
    +
    84 C> | 25 |category 7, no. levels | count | integer|
    +
    85 C> | 26 |category 7, data index | count | integer|
    +
    86 C> | 27 |category 8, no. levels | count | integer|
    +
    87 C> | 28 |category 8, data index | count | integer|
    +
    88 C> | 29 |category 51, no. levels | count | integer|
    +
    89 C> | 30 |category 51, data index | count | integer|
    +
    90 C> | 31 |category 52, no. levels | count | integer|
    +
    91 C> | 32 |category 52, data index | count | integer|
    +
    92 C> | 33 |category 9, no. levels | count | integer|
    +
    93 C> | 34 |category 9, data index | count | integer|
    +
    94 C> | 35-42 | zeroed out - not used | | integer|
    +
    95 C> | 43-end| unpacked data groups |(see remarks) | mixed|
    +
    96 C>
    +
    97 C> ***************************************************************
    +
    98 C>
    +
    99 C> NEXT: Marker indicating relative location (in bytes)
    +
    100 C> of end of current report in COCBUF. NEXT will be
    +
    101 C> set to -1 if w3fi64() encounters string 'end record'
    +
    102 C> in place of the NEXT report. This is the end of the
    +
    103 C> block. No unpacking takes place. NEXT is set to-2
    +
    104 C> when internal (logic) errors have been detected.
    +
    105 C> NEXT is set to -3 when data count check fails. In
    +
    106 C> both of the latter cases some data (e.g., header
    +
    107 C> information) may be unpacked into LOCRPT.
    +
    108 C>
    +
    109 C> @note After first reading and processing the office note 85
    +
    110 C> (first) date record, the user's fortran program begins a read
    +
    111 C> loop as follows. For each iteration a blocked input report is
    +
    112 C> read into array COCBUF. Now test the first ten characters in
    +
    113 C> COCBUF for the string 'endof file' (sic). This string signals
    +
    114 C> the end of input. Otherwise, set the marker 'NEXT' to zero and
    +
    115 C> begin the unpacking loop.
    +
    116 C>
    +
    117 C> Each iteration of the unpacking loop consists of a call to
    +
    118 C> w3fi64() with the current value of 'NEXT'. If 'NEXT' is -1 upon
    +
    119 C> returning from w3fi64(), it has reached the end of the input
    +
    120 C> record, and the user's program should read the next record as
    +
    121 C> above. If 'NEXT' is -2 or -3 upon returning, there is a grievous
    +
    122 C> error in the current packed input record, and the user's program
    +
    123 C> should print it for examination by automation division personnel.
    +
    124 C> If 'NEXT' is positive, the output structure locrpt contains
    +
    125 C> an unpacked report, and the user's program should process it at
    +
    126 C> this point, subsequently repeating the unpacking loop.
    +
    127 C>
    +
    128 C> EXAMPLE:
    +
    129 C> @code{.F}
    +
    130 C> CHARACTER*10 COCBUF(644)
    +
    131 C> CHARACTER*8 COCRPT(1608)
    +
    132 C> CHARACTER*3 CQUMAN(20)
    +
    133 C> INTEGER LOCRPT(1608)
    +
    134 C> REAL ROCRPT(1608),GEOMAN(20),TMPMAN(20),DPDMAN(20),
    +
    135 C> $ WDRMAN(20),WSPMAN(20)
    +
    136 C> EQUIVALENCE (COCRPT,LOCRPT,ROCRPT)
    +
    137 C>
    +
    138 C> C READ AND PROCESS THE OFFICE NOTE 85 DATE RECORD
    +
    139 C> ..........
    +
    140 C> C --- BEGIN READ LOOP
    +
    141 C> 10 CONTINUE
    +
    142 C> READ (UNIT=INP, IOSTAT=IOS, NUM=NBUF) COCBUF
    +
    143 C> IF(IOS .LT. 0) GO TO (END OF INPUT)
    +
    144 C> IF(IOS .GT. 0) GO TO (INPUT ERROR)
    +
    145 C> IF(NBUF .GT. 6432) GO TO (BUFFER OVERFLOW)
    +
    146 C> IF(COCBUF(1).EQ.'ENDOF FILE') GO TO (END OF INPUT)
    +
    147 C> NEXT = 0
    +
    148 C> C ------ BEGIN UNPACKING LOOP
    +
    149 C> 20 CONTINUE
    +
    150 C> CALL W3FI64(COCBUF, LOCRPT, NEXT)
    +
    151 C> IF(NEXT .EQ. -1) GO TO 10
    +
    152 C> IF(NEXT .LT. -1) GO TO (OFFICE NOTE 29/124 ERROR)
    +
    153 C> RLAT = 0.01 * ROCRPT(1) (LATITUDE)
    +
    154 C> ..... ETC .....
    +
    155 C> C --- BEGIN CATEGORY 1 FETCH -- MANDATORY LEVEL DATA
    +
    156 C> IF(LOCRPT(13) .GT. 0) THEN
    +
    157 C> NLVLS = MIN(20,LOCRPT(13))
    +
    158 C> INDX = LOCRPT(14)
    +
    159 C> DO 66 I = 1,NLVLS
    +
    160 C> GEOMAN(I) = ROCRPT(INDX)
    +
    161 C> TMPMAN(I) = 0.1 * ROCRPT(INDX+1)
    +
    162 C> DPDMAN(I) = 0.1 * ROCRPT(INDX+2)
    +
    163 C> WDRMAN(I) = ROCRPT(INDX+3)
    +
    164 C> WSPMAN(I) = ROCRPT(INDX+4)
    +
    165 C> CQUMAN(I) = COCRPT(INDX+5)
    +
    166 C> INDX = INDX + 6
    +
    167 C> 66 CONTINUE
    +
    168 C> END IF
    +
    169 C> ..... ETC .....
    +
    170 C> GO TO 20
    +
    171 C> ...............
    +
    172 C> @endcode
    +
    173 C>
    +
    174 C> Data from the on29/124 record is unpacked into fixed locations
    +
    175 C> in words 1-12 and into indexed locations in word 43 and
    +
    176 C> following. Study on29 appendix c/on124 appendix s.2 carefully.
    +
    177 C> Each category (or group of fields) in the packed report has a
    +
    178 C> corresponding layout in locations in array LOCRPT that may be
    +
    179 C> found by using the corresponding index amount from words 14, 16,
    +
    180 C> ..., 34, in array LOCRPT. For instance, if a report contains
    +
    181 C> one or more packed category 3 data groups (wind data at variable
    +
    182 C> pressure levels) that data will be unpacked into binary and
    +
    183 C> and character fields in one or more unpacked category 3 data
    +
    184 C> groups as described below. The number of levels will be stored
    +
    185 C> in word 17 and the index in fullwords of the first level of
    +
    186 C> unpacked data in the output array will be stored in word 18.
    +
    187 C> The second level, if any, will be stored beginning four words
    +
    188 C> further on, and so forth until the count in word 17 is
    +
    189 C> exhausted. The field layout in each category is given below...
    +
    190 C>
    +
    191 C> ***************************************************************
    +
    192 C> - CATEGORY 1 - MANDATORY LEVEL DATA
    +
    193 C> |WORD |PARAMETER |UNITS |FORMAT
    +
    194 C> |:---- |:--------- |:----------------- |:-------------|
    +
    195 C> | 1 |GEOPOTENTIAL |METERS |REAL|
    +
    196 C> | 2 |TEMPERATURE |0.1 DEGREES C |REAL|
    +
    197 C> | 3 |DEWPOINT DEPRESSION |0.1 DEGREES C |REAL|
    +
    198 C> | 4 |WIND DIRECTION |DEGREES |REAL|
    +
    199 C> | 5 |WIND SPEED |KNOTS |REAL|
    +
    200 C> | 6 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    201 C> | | |LEFT-JUSTIFIED| |
    +
    202 C> | | GEOPOTENTIAL |ON29 TABLE Q.A| |
    +
    203 C> | | TEMPERATURE |ON29 TABLE Q.A| |
    +
    204 C> | | DEWPOINT DEPR. |ON29 TABLE Q.C| |
    +
    205 C> | | WIND |ON29 TABLE Q.A| |
    +
    206 C>
    +
    207 C> ***************************************************************
    +
    208 C> - CATEGORY 2 - TEMPERATURE AT VARIABLE PRESSURE
    +
    209 C> |WORD |PARAMETER |UNITS | FORMAT|
    +
    210 C> |---- |--------- |----------------- | -------------|
    +
    211 C> | 1 |PRESSURE |0.1 MILLIBARS | REAL|
    +
    212 C> | 2 |TEMPERATURE |0.1 DEGREES C | REAL|
    +
    213 C> | 3 |DEWPOINT DEPRESSION |0.1 DEGREES C | REAL|
    +
    214 C> | 4 |QUALITY MARKERS: |EACH 1-CHARACTER | CHAR*8|
    +
    215 C> | | |LEFT-JUSTIFIED| |
    +
    216 C> | | PRESSURE |ON29 TABLE Q.B| |
    +
    217 C> | | TEMPERATURE |ON29 TABLE Q.A| |
    +
    218 C> | | DEWPOINT DEPR. |ON29 TABLE Q.C| |
    +
    219 C> | | NOT USED |BLANK| |
    +
    220 C>
    +
    221 C> ***************************************************************
    +
    222 C> - CATEGORY 3 - WINDS AT VARIABLE PRESSURE
    +
    223 C> |WORD |PARAMETER | UNITS | FORMAT|
    +
    224 C> |---- |--------- | ----------------- | -------------|
    +
    225 C> | 1 |PRESSURE | 0.1 MILLIBARS | REAL|
    +
    226 C> | 2 |WIND DIRECTION | DEGREES | REAL|
    +
    227 C> | 3 |WIND SPEED | KNOTS | REAL|
    +
    228 C> | 4 |QUALITY MARKERS: | EACH 1-CHARACTER | CHAR*8|
    +
    229 C> | | | LEFT-JUSTIFIED| |
    +
    230 C> | | PRESSURE | ON29 TABLE Q.B| |
    +
    231 C> | | WIND | ON29 TABLE Q.A| |
    +
    232 C> | | NOT USED | BLANK| |
    +
    233 C> | | NOT USED | BLANK| |
    +
    234 C>
    +
    235 C> ***************************************************************
    +
    236 C> - CATEGORY 4 - WINDS AT VARIABLE HEIGHTS
    +
    237 C> |WORD |PARAMETER |UNITS |FORMAT|
    +
    238 C> |---- |--------- |----------------- |-------------|
    +
    239 C> | 1 |GEOPOTENTIAL |METERS |REAL|
    +
    240 C> | 2 |WIND DIRECTION |DEGREES |REAL|
    +
    241 C> | 3 |WIND SPEED |KNOTS |REAL|
    +
    242 C> | 4 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    243 C> | | |LEFT-JUSTIFIED| |
    +
    244 C> | | GEOPOTENTIAL |ON29 TABLE Q.B| |
    +
    245 C> | | WIND |ON29 TABLE Q.A| |
    +
    246 C> | | NOT USED |BLANK| |
    +
    247 C> | | NOT USED |BLANK| |
    +
    248 C>
    +
    249 C> ***************************************************************
    +
    250 C> - CATEGORY 5 - TROPOPAUSE DATA
    +
    251 C> |WORD |PARAMETER |UNITS |FORMAT|
    +
    252 C> |---- |--------- |----------------- |-------------|
    +
    253 C> | 1 |GEOPOTENTIAL |METERS |REAL|
    +
    254 C> | 2 |TEMPERATURE |0.1 DEGREES C |REAL|
    +
    255 C> | 3 |DEWPOINT DEPRESSION |0.1 DEGREES C |REAL|
    +
    256 C> | 4 |WIND DIRECTION |DEGREES |REAL|
    +
    257 C> | 5 |WIND SPEED |KNOTS |REAL|
    +
    258 C> | 6 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    259 C> | | |LEFT-JUSTIFIED| |
    +
    260 C> | | PRESSURE |ON29 TABLE Q.B| |
    +
    261 C> | | TEMPERATURE |ON29 TABLE Q.A| |
    +
    262 C> | | DEWPOINT DEPR. |ON29 TABLE Q.C| |
    +
    263 C> | | WIND |ON29 TABLE Q.A| |
    +
    264 C>
    +
    265 C> ***************************************************************
    +
    266 C> - CATEGORY 6 - CONSTANT-LEVEL DATA (AIRCRAFT, SAT. CLOUD-DRIFT)
    +
    267 C> |WORD | PARAMETER |UNITS |FORMAT|
    +
    268 C> |---- | --------- |----------------- |-------------|
    +
    269 C> | 1 | PRESSURE ALTITUDE |METERS |REAL|
    +
    270 C> | 2 | TEMPERATURE |0.1 DEGREES C |REAL|
    +
    271 C> | 3 | DEWPOINT DEPRESSION |0.1 DEGREES C |REAL|
    +
    272 C> | 4 | WIND DIRECTION |DEGREES |REAL|
    +
    273 C> | 5 | WIND SPEED |KNOTS |REAL|
    +
    274 C> | 6 | QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    275 C> | | |LEFT-JUSTIFIED| |
    +
    276 C> | | PRESSURE |ON29 TABLE Q.6| |
    +
    277 C> | | TEMPERATURE |ON29 TABLE Q.6| |
    +
    278 C> | | DEWPOINT DEPR. |ON29 TABLE Q.6| |
    +
    279 C> | | WIND |ON29 TABLE Q.6C | |
    +
    280 C>
    +
    281 C> ***************************************************************
    +
    282 C> - CATEGORY 7 - CLOUD COVER
    +
    283 C> |WORD |PARAMETER |UNITS |FORMAT|
    +
    284 C> |---- |--------- |----------------- |-------------|
    +
    285 C> | 1 |PRESSURE |0.1 MILLIBARS |REAL|
    +
    286 C> | 2 |AMOUNT OF CLOUDS |PER CENT |REAL|
    +
    287 C> | 3 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    288 C> | | |LEFT-JUSTIFIED| |
    +
    289 C> | | PRESSURE |ON29 TABLE Q.7| |
    +
    290 C> | | CLOUD AMOUNT |ON29 TABLE Q.7| |
    +
    291 C> | | NOT USED |BLANK| |
    +
    292 C> | | NOT USED |BLANK| |
    +
    293 C>
    +
    294 C> ***************************************************************
    +
    295 C> - CATEGORY 8 - ADDITIONAL DATA
    +
    296 C> |WORD |PARAMETER | UNITS |FORMAT|
    +
    297 C> |---- |--------- | ----------------- |-------------|
    +
    298 C> | 1 |SPECIFIED IN ON29 | VARIABLE |REAL|
    +
    299 C> | |TABLE 101.1 OR | | |
    +
    300 C> | |ON124 TABLE SM.8A.1 | | |
    +
    301 C> | 2 |FORM OF ADD'L DATA |CODE FIGURE FROM |REAL|
    +
    302 C> | | |ON29 TABLE 101 OR | |
    +
    303 C> | | |ON124 TABLE SM.8A | |
    +
    304 C> | 3 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    305 C> | | |LEFT-JUSTIFIED | |
    +
    306 C> | | VALUE 1 |ON29 TABLE Q.8 OR | |
    +
    307 C> | | |ON124 TABLE SM.8B | |
    +
    308 C> | | VALUE 2 |ON29 TABLE Q.8A OR | |
    +
    309 C> | | |ON124 TABLE SM.8C | |
    +
    310 C> | | NOT USED |BLANK | |
    +
    311 C> | | NOT USED |BLANK | |
    +
    312 C>
    +
    313 C> ***************************************************************
    +
    314 C> - CATEGORY 51 - SURFACE DATA
    +
    315 C> |WORD |PARAMETER |UNITS |FORMAT|
    +
    316 C> |---- |--------- |----------------- |-------------|
    +
    317 C> | 1 |SEA-LEVEL PRESSURE |0.1 MILLIBARS |REAL|
    +
    318 C> | 2 |STATION PRESSURE |0.1 MILLIBARS |REAL|
    +
    319 C> | 3 |WIND DIRECTION |DEGREES |REAL|
    +
    320 C> | 4 |WIND SPEED |KNOTS |REAL|
    +
    321 C> | 5 |AIR TEMPERATURE |0.1 DEGREES C |REAL|
    +
    322 C> | 6 |DEWPOINT DEPRESSION |0.1 DEGREES C |REAL|
    +
    323 C> | 7 |MAXIMUM TEMPERATURE |0.1 DEGREES C |REAL|
    +
    324 C> | 8 |MINIMUM TEMPERATURE |0.1 DEGREES C |REAL|
    +
    325 C> | 9 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    326 C> | | |LEFT-JUSTIFIED| |
    +
    327 C> | | S-LEVEL PRESS. |ON124 TABLE SM.51| |
    +
    328 C> | | STATION PRESS. |ON124 TABLE SM.51| |
    +
    329 C> | | WIND |ON124 TABLE SM.51| |
    +
    330 C> | | AIR TEMPERATURE |ON124 TABLE SM.51| |
    +
    331 C> | 10 |QUALITY MARKERS: |EACH 1-CHARACTER |CHAR*8|
    +
    332 C> | | |LEFT-JUSTIFIED| |
    +
    333 C> | | DEWPOINT DEPR. |ON124 TABLE SM.51| |
    +
    334 C> | | NOT USED |BLANK| |
    +
    335 C> | | NOT USED |BLANK| |
    +
    336 C> | | NOT USED |BLANK| |
    +
    337 C> | 11 |HORIZ. VISIBILITY |WMO CODE TABLE 4300 |INTEGER|
    +
    338 C> | 12 |PRESENT WEATHER |WMO CODE TABLE 4677 |INTEGER|
    +
    339 C> | 13 |PAST WEATHER |WMO CODE TABLE 4561 |INTEGER|
    +
    340 C> | 14 |TOTAL CLOUD COVER N |WMO CODE TABLE 2700 |INTEGER|
    +
    341 C> | 15 |CLOUD COVER OF C/LN |WMO CODE TABLE 2700 |INTEGER|
    +
    342 C> | 16 |CLOUD TYPE OF C/L |WMO CODE TABLE 0513 |INTEGER|
    +
    343 C> | 17 |CLOUD HEIGHT OF C/L |WMO CODE TABLE 1600 |INTEGER|
    +
    344 C> | 18 |CLOUD TYPE OF C/M |WMO CODE TABLE 0515 |INTEGER|
    +
    345 C> | 19 |CLOUD TYPE OF C/H |WMO CODE TABLE 0509 |INTEGER|
    +
    346 C> | 20 |CHARACTERISTIC OF |WMO CODE TABLE 0200 |INTEGER|
    +
    347 C> | |3-HR PRESS TENDENCY | | |
    +
    348 C> | 21 |AMT. PRESS TENDENCY |0.1 MILLIBARS | REAL|
    +
    349 C> | |(50.0 WILL BE ADDED TO INDICATE 24-HR TENDENCY)| | |
    +
    350 C>
    +
    351 C> ***************************************************************
    +
    352 C> - CATEGORY 52 - ADDITIONAL SURFACE DATA
    +
    353 C> |WORD | PARAMETER |UNITS |FORMAT|
    +
    354 C> |---- | --------- |----------------- |-------------|
    +
    355 C> | 1 | 6-HR PRECIPITATION |0.01 INCH |INTEGER|
    +
    356 C> | 2 | SNOW DEPTH |INCH |INTEGER|
    +
    357 C> | 3 | 24-HR PRECIPITATION |0.01 INCH |INTEGER|
    +
    358 C> | 4 | DURATION OF PRECIP. |NO. 6-HR PERIODS |INTEGER|
    +
    359 C> | 5 | PERIOD OF WAVES |SECONDS |INTEGER|
    +
    360 C> | 6 | HEIGHT OF WAVES |0.5 METERS |INTEGER|
    +
    361 C> | 7 | SWELL DIRECTION |WMO CODE TABLE 0877 |INTEGER|
    +
    362 C> | 8 | SWELL PERIOD |SECONDS |INTEGER|
    +
    363 C> | 9 | SWELL HEIGHT |0.5 METERS |INTEGER|
    +
    364 C> | 10 | SEA SFC TEMPERATURE |0.1 DEGREES C |INTEGER|
    +
    365 C> | 11 | SPECIAL PHEN, GEN'L | |INTEGER|
    +
    366 C> | 12 | SPECIAL PHEN, DET'L | |INTEGER|
    +
    367 C> | 13 | SHIP'S COURSE |WMO CODE TABLE 0700 |INTEGER|
    +
    368 C> | 14 | SHIP'S AVERAGE SPEED |WMO CODE TABLE 4451 |INTEGER|
    +
    369 C> | 15 | WATER EQUIVALENT OF 0.01 INCH | |INTEGER|
    +
    370 C> | | SNOW AND/OR ICE| | |
    +
    371 C>
    +
    372 C> ***************************************************************
    +
    373 C> - CATEGORY 9 - PLAIN LANGUAGE DATA (ALPHANUMERIC TEXT)
    +
    374 C> |WORD |BYTES |PARAMETER |FORMAT |
    +
    375 C> |---- |----- |--------------------------------------- |-------- |
    +
    376 C> | 1 | 1 |INDICATOR OF CONTENT (ON124 TABLE SM.9) |CHAR*8 |
    +
    377 C> | | | (1 CHARACTER)| |
    +
    378 C> | | 2-4 |PLAIN LANGUAGE DATA, TEXT CHARACTERS 1-3| |
    +
    379 C> | | 4-8 |NOT USED (BLANK) | |
    +
    380 C> | 2 | 1-4 |PLAIN LANGUAGE DATA, TEXT CHARACTERS 4-7 |CHAR*8 |
    +
    381 C> | | 4-8 |NOT USED (BLANK)| |
    +
    382 C> | 3 | 1-4 |PLAIN LANGUAGE DATA, TEXT CHARACTERS 8-11 |CHAR*8 |
    +
    383 C> | | 4-8 |NOT USED (BLANK)| |
    +
    384 C>
    +
    385 C> @note One report may unpack into more than one category having
    +
    386 C> multiple levels. The unused portion of LOCRPT is not cleared.
    +
    387 C>
    +
    388 C> @note Entry w3ai02() duplicates processing in w3fi64() since no
    +
    389 C> assembly language code in cray w3lib.
    +
    390 C>
    +
    391 C> @author L. Marx @date 1990-01
    +
    392  SUBROUTINE w3fi64(COCBUF,LOCRPT,NEXT)
    +
    393 C
    +
    394  CHARACTER*12 HOLD
    +
    395  CHARACTER*10 COCBUF(*)
    +
    396  CHARACTER*7 CNINES
    +
    397  CHARACTER*4 COCRPT(10000),BLANK
    +
    398  CHARACTER*2 KAT(11)
    +
    399 C
    +
    400  INTEGER LOCRPT(*),KATGC(20,11),KATGL(20,11),KATL(11),KATO(11),
    +
    401  $ MOCRPT(5000)
    +
    402 C
    +
    403  REAL ROCRPT(5000)
    +
    404 C
    +
    405  equivalence(rocrpt,mocrpt,cocrpt)
    +
    406 C
    +
    407  SAVE
    +
    408 C
    +
    409  DATA blank/' '/,cnines/'9999999'/,imsg/99999/,xmsg/99999./
    +
    410  DATA katl/6,4,4,4,6,6,3,3,1,20,15/,kato/13,15,17,19,21,23,25,27,
    +
    411  $ 33,29,31/,irec/2/
    +
    412  DATA kat/'01','02','03','04','05','06','07','08','09','51','52'/
    +
    413  DATA katgc/ 5*2,4,14*0, 3*2,4,16*0, 3*2,4,16*0, 3*2,4,16*0,
    +
    414  $ 5*2,4,14*0, 5*2,4,14*0, 2*2,4,17*0, 2*2,4,17*0, 4,19*0,
    +
    415  $ 8*2,4,10*1,2, 15*1,5*0/
    +
    416  DATA katgl/ 5,4,3*3,4,14*0, 5,4,2*3,16*0, 5,2*3,2,16*0,
    +
    417  $ 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,
    +
    418  $ 5,3,2,17*0, 12,19*0,
    +
    419  $ 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/
    +
    420  DATA lwflag/0/
    +
    421 C
    +
    422  entry w3ai02(cocbuf,locrpt,next)
    +
    423 C
    +
    424  IF (lwflag.EQ.0) THEN
    +
    425 C FIRST TIME CALLED, DETERMINE MACHINE WORD LG IN BYTES (=8 FOR CRAY)
    +
    426 C DEPENDING ON WORD SIZE LW2*I-LW1 INDEXES THRU COCRPT
    +
    427 C EITHER AS 1,2,3...I FOR LW = 4 OR
    +
    428 C AS 1,3,5..2*I-1 FOR LW = 8 <------ HERE
    +
    429 C NECESSITATED BY LEFT JUSTIFICATION OF EQUIVALENCE
    +
    430  CALL w3fi01(lw)
    +
    431  lw2 = lw/4
    +
    432  lw1 = lw/8
    +
    433  lwflag = 1
    +
    434  END IF
    +
    435  7000 CONTINUE
    +
    436  IF(next.LT.0) RETURN
    +
    437  nexto = next/10
    +
    438  n = next/10 + 1
    +
    439 C
    +
    440  IF(cocbuf(n).EQ.'END RECORD'.OR.cocbuf(n).EQ.'XXXXXXXXXX') THEN
    +
    441 C HIT END-OF-RECORD; RETURN WITH NEXT = -1
    +
    442  IF(cocbuf(n).EQ.'XXXXXXXXXX') print 109, irec
    +
    443  irec = irec + 1
    +
    444  next = -1
    +
    445  RETURN
    +
    446  END IF
    +
    447 C INITIALIZE REPORT ID AS MISSING OR 0 FOR RESERVED WORDS
    +
    448  rocrpt(1) = xmsg
    +
    449  rocrpt(2) = xmsg
    +
    450  rocrpt(3) = 0.
    +
    451  rocrpt(4) = xmsg
    +
    452  cocrpt(lw2*5-lw1) = ' '
    +
    453  cocrpt(lw2*6-lw1) = ' '
    +
    454  rocrpt(7) = xmsg
    +
    455  mocrpt(8) = 99
    +
    456  mocrpt(9) = imsg
    +
    457  mocrpt(10) = 0.
    +
    458  cocrpt(lw2*11-lw1) = ' '
    +
    459  cocrpt(lw2*12-lw1) = ' '
    +
    460 C INITIALIZE CATEGORY WORD PAIRS AS ZEROES
    +
    461  DO 100 mb = 13,42
    +
    462  mocrpt(mb) = 0
    +
    463  100 CONTINUE
    +
    464 C WRITE OUT LATITUDE INTO WORD 1 (REAL)
    +
    465  m = 1
    +
    466  IF(cocbuf(n)(1:5).NE.'99999') READ(cocbuf(n)(1:5),51) rocrpt(m)
    +
    467 C WRITE OUT LONGITUDE INTO WORD 2 (REAL)
    +
    468  m = 2
    +
    469  IF(cocbuf(n)(6:10).NE.'99999') READ(cocbuf(n)(6:10),51) rocrpt(m)
    +
    470 C WORD 3 IS RESERVED (KEEP AS A REAL NUMBER OF 0.)
    +
    471 C WRITE OUT STATION ID TO WORDS 11 AND 12 (CHAR*8)
    +
    472 C (CHAR. 1-4 OF ID IN WORD 11, CHAR. 5-6 OF ID IN WORD 12, LEFT-JUSTIF.)
    +
    473  m = 11
    +
    474  n = n + 1
    +
    475  cocrpt(lw2*m-lw1) = cocbuf(n)(1:4)
    +
    476  m = 12
    +
    477  cocrpt(lw2*m-lw1) = cocbuf(n)(5:6)//' '
    +
    478 C WRITE OUT OBSERVATION TIME INTO WORD 4 (REAL)
    +
    479  m = 4
    +
    480  IF(cocbuf(n)(7:10).NE.'9999') READ(cocbuf(n)(7:10),41) rocrpt(m)
    +
    481 C WORD 5 IS RESERVED (CHAR*8) (4 CHARACTERS, LEFT-JUSTIF.)
    +
    482  m = 5
    +
    483  n = n + 1
    +
    484  cocrpt(lw2*m-lw1) = cocbuf(n)(3:6)
    +
    485 C WORD 6 IS RESERVED (CHAR*8) (3 CHARACTERS, LEFT-JUSTIF.)
    +
    486  m = 6
    +
    487  cocrpt(lw2*m-lw1) = cocbuf(n)(1:2)//cocbuf(n)(7:7)//' '
    +
    488 C WRITE OUT REPORT TYPE INTO WORD 9 (INTEGER)
    +
    489  m = 9
    +
    490  READ(cocbuf(n)(8:10),30) mocrpt(m)
    +
    491 C WRITE OUT STATION ELEVATION INTO WORD 7 (REAL)
    +
    492  n = n + 1
    +
    493  m = 7
    +
    494  IF(cocbuf(n)(1:5).NE.'99999') READ(cocbuf(n)(1:5),51) rocrpt(m)
    +
    495 C WRITE OUT INSTRUMENT TYPE INTO WORD 8 (INTEGER)
    +
    496  m = 8
    +
    497  IF(cocbuf(n)(6:7).NE.'99') READ(cocbuf(n)(6:7),20) mocrpt(m)
    +
    498 C READ IN NWDS, THE TOTAL NO. OF 10-CHARACTER WORDS IN ENTIRE REPORT
    +
    499  READ(cocbuf(n)(8:10),30) nwds
    +
    500 C 'MO' WILL BE STARTING LOCATION IN MOCRPT FOR THE DATA
    +
    501  mo = 43
    +
    502  n = n + 1
    +
    503  700 CONTINUE
    +
    504  IF(cocbuf(n).EQ.'END REPORT') THEN
    +
    505 C-----------------------------------------------------------------------
    +
    506 C HAVE HIT THE END OF THE REPORT
    +
    507  IF(n-nexto.EQ.nwds) THEN
    +
    508 C EVERYTHING LOOKS GOOD, RETURN WITH NEXT SET TO LAST BYTE IN REPORT
    +
    509  next = n * 10
    +
    510  ELSE
    +
    511 C PROBLEM, MAY EXIT WITH NEXT = -3
    +
    512  nextx = -3
    +
    513  print 101,
    +
    514  & cocrpt(lw2*11-lw1),cocrpt(lw2*12-lw1)(1:2),n-nexto,nwds
    +
    515  GO TO 99
    +
    516  END IF
    +
    517  mwords = mo - 1
    +
    518  DO 1001 i =1, mwords
    +
    519  locrpt(i) = mocrpt(i)
    +
    520  1001 CONTINUE
    +
    521  RETURN
    +
    522 C-----------------------------------------------------------------------
    +
    523  END IF
    +
    524 C READ IN NWDSC, THE RELATIVE POSITION IN RPT OF THE NEXT CATEGORY
    +
    525  READ(cocbuf(n)(3:5),30) nwdsc
    +
    526 C READ IN LVLS, THE NUMBER OF LEVELS IN THE CURRENT CATEGORY
    +
    527  READ(cocbuf(n)(6:7),20) lvls
    +
    528 C DETERMINE THE CATEGORY NUMBER OF THE CURRENT CATEGORY
    +
    529  DO 800 ncat = 1,11
    +
    530  IF(cocbuf(n)(1:2).EQ.kat(ncat)) GO TO 1000
    +
    531  800 CONTINUE
    +
    532 C-----------------------------------------------------------------------
    +
    533 C PROBLEM, CAT. CODE IN INPUT NOT VALID; MAY EXIT WITH NEXT = -2
    +
    534  nextx = -2
    +
    535  print 102,
    +
    536  $ cocrpt(lw2*11-lw1),cocrpt(lw2*12-lw1)(1:2),cocbuf(n)(1:2)
    +
    537  GO TO 99
    +
    538 C-----------------------------------------------------------------------
    +
    539  1000 CONTINUE
    +
    540 C 'M' IS THE WORD IN MOCRPT WHERE THE NO. OF LEVELS WILL BE WRITTEN
    +
    541  m = kato(ncat)
    +
    542 C WRITE THIS CATEGORY WORD PAIR OUT
    +
    543  mocrpt(m) = lvls
    +
    544  mocrpt(m+1) = mo
    +
    545  n = n + 1
    +
    546  i = 1
    +
    547 C***********************************************************************
    +
    548 C LOOP THROUGH ALL THE LEVELS IN THE CURRENT CATEGORY
    +
    549 C***********************************************************************
    +
    550  DO 2000 l = 1,lvls
    +
    551 C NDG IS NO. OF OUTPUT PARAMETERS PER LEVEL IN THIS CATEGORY
    +
    552  ndg = katl(ncat)
    +
    553 C-----------------------------------------------------------------------
    +
    554 C LOOP THROUGH ALL THE PARAMETERS IN THE CURRENT LEVEL
    +
    555 C-----------------------------------------------------------------------
    +
    556  DO 1800 k = 1,ndg
    +
    557 C 'LL' IS THE NUMBER OF INPUT CHARACTERS PER PARAMETER FOR THIS CATEGORY
    +
    558  ll = katgl(k,ncat)
    +
    559 C 'I' IS POINTER FOR BEGINNING BYTE IN C*10 WORD FOR NEXT PARAMETER
    +
    560 C 'J' IS POINTER FOR ENDING BYTE IN C*10 WORD FOR NEXT PARAMETER
    +
    561  j = i + ll - 1
    +
    562  IF(j.GT.10) THEN
    +
    563 C COME HERE IF INPUT PARAMETER SPANS ACROSS TWO C*10 WORDS
    +
    564  hold(1:ll) = cocbuf(n)(i:10)//cocbuf(n+1)(1:j-10)
    +
    565  n = n + 1
    +
    566  i = j - 9
    +
    567  IF(i.GE.11) THEN
    +
    568  n = n + 1
    +
    569  i = 1
    +
    570  END IF
    +
    571  ELSE
    +
    572  hold(1:ll) = cocbuf(n)(i:j)
    +
    573  i = j + 1
    +
    574  IF(i.GE.11) THEN
    +
    575  n = n + 1
    +
    576  i = 1
    +
    577  END IF
    +
    578  END IF
    +
    579 C KATGC IS AN INDICATOR FOR THE OUTPUT FORMAT OF EACH INPUT PARAMETER
    +
    580 C (=2 - REAL, =1 - INTEGER, =4 - CHARACTER*8)
    +
    581  IF(katgc(k,ncat).EQ.4) GO TO 1500
    +
    582  IF(katgc(k,ncat).NE.1.AND.katgc(k,ncat).NE.2) THEN
    +
    583 C.......................................................................
    +
    584 C PROBLEM IN INTERNAL READ; MAY EXIT WITH NEXT = -2
    +
    585  nextx = -2
    +
    586  print 104, cocrpt(lw2*11-lw1),cocrpt(lw2*12)(1:2)
    +
    587  GO TO 99
    +
    588 C.......................................................................
    +
    589  END IF
    +
    590  IF(hold(1:ll).EQ.cnines(1:ll)) THEN
    +
    591 C INPUT PARAMETER IS MISSING OR NOT APPLICABLE -- OUTPUT IT AS SUCH
    +
    592  IF(katgc(k,ncat).EQ.1) mocrpt(mo) = imsg
    +
    593  IF(katgc(k,ncat).EQ.2) rocrpt(mo) = xmsg
    +
    594  GO TO 1750
    +
    595  END IF
    +
    596  IF(ll.EQ.1) THEN
    +
    597 C INPUT PARAMETER CONSISTS OF ONE CHARACTER
    +
    598  IF(katgc(k,ncat).EQ.1) READ(hold(1:ll),10) mocrpt(mo)
    +
    599  IF(katgc(k,ncat).EQ.2) READ(hold(1:ll),11) rocrpt(mo)
    +
    600  ELSE IF(ll.EQ.2) THEN
    +
    601 C INPUT PARAMETER CONSISTS OF TWO CHARACTERS
    +
    602  IF(katgc(k,ncat).EQ.1) READ(hold(1:ll),20) mocrpt(mo)
    +
    603  IF(katgc(k,ncat).EQ.2) READ(hold(1:ll),21) rocrpt(mo)
    +
    604  ELSE IF(ll.EQ.3) THEN
    +
    605 C INPUT PARAMETER CONSISTS OF THREE CHARACTERS
    +
    606  IF(katgc(k,ncat).EQ.1) READ(hold(1:ll),30) mocrpt(mo)
    +
    607  IF(katgc(k,ncat).EQ.2) READ(hold(1:ll),31) rocrpt(mo)
    +
    608  ELSE IF(ll.EQ.4) THEN
    +
    609 C INPUT PARAMETER CONSISTS OF FOUR CHARACTERS
    +
    610  IF(katgc(k,ncat).EQ.1) READ(hold(1:ll),40) mocrpt(mo)
    +
    611  IF(katgc(k,ncat).EQ.2) READ(hold(1:ll),41) rocrpt(mo)
    +
    612  ELSE IF(ll.EQ.5) THEN
    +
    613 C INPUT PARAMETER CONSISTS OF FIVE CHARACTERS
    +
    614  IF(katgc(k,ncat).EQ.1) READ(hold(1:ll),50) mocrpt(mo)
    +
    615  IF(katgc(k,ncat).EQ.2) READ(hold(1:ll),51) rocrpt(mo)
    +
    616  ELSE IF(ll.EQ.6) THEN
    +
    617 C INPUT PARAMETER CONSISTS OF SIX CHARACTERS
    +
    618  IF(katgc(k,ncat).EQ.1) READ(hold(1:ll),60) mocrpt(mo)
    +
    619  IF(katgc(k,ncat).EQ.2) READ(hold(1:ll),61) rocrpt(mo)
    +
    620  ELSE IF(ll.EQ.7) THEN
    +
    621 C INPUT PARAMETER CONSISTS OF SEVEN CHARACTERS
    +
    622  IF(katgc(k,ncat).EQ.1) READ(hold(1:ll),70) mocrpt(mo)
    +
    623  IF(katgc(k,ncat).EQ.2) READ(hold(1:ll),71) rocrpt(mo)
    +
    624  ELSE
    +
    625 C.......................................................................
    +
    626 C INPUT PARAMETER CONSISTS OF MORE THAN SEVEN CHARACTERS (NOT PERMITTED)
    +
    627  nextx = -2
    +
    628  print 108, cocrpt(lw2*11-lw1),cocrpt(lw2*12-lw1)(1:2)
    +
    629  GO TO 99
    +
    630 C.......................................................................
    +
    631  END IF
    +
    632  GO TO 1750
    +
    633  1500 CONTINUE
    +
    634 C.......................................................................
    +
    635 C OUTPUT CHARACTER (MARKER) PROCESSING COMES HERE
    +
    636  IF(ll.LT.4) THEN
    +
    637 C THERE ARE ONE, TWO OR THREE MARKERS IN THE INPUT WORD
    +
    638  cocrpt(lw2*mo-lw1)(1:4)=hold(1:ll)//blank(1:4-ll)
    +
    639  ELSE IF(ll.EQ.4) THEN
    +
    640 C THERE ARE FOUR MARKERS IN THE INPUT WORD
    +
    641  cocrpt(lw2*mo-lw1)(1:4) = hold(1:ll)
    +
    642  ELSE
    +
    643 C THERE ARE MORE THAN FOUR MARKERS IN THE INPUT WORD
    +
    644  ip = 1
    +
    645  1610 CONTINUE
    +
    646  jp = ip + 3
    +
    647  IF(jp.LT.ll) THEN
    +
    648 C FILL FIRST FOUR MARKERS TO OUTPUT WORD
    +
    649  cocrpt(lw2*mo-lw1)(1:4) = hold(ip:jp)
    +
    650  mo = mo + 1
    +
    651  ip = jp + 1
    +
    652  GO TO 1610
    +
    653  ELSE IF(jp.EQ.ll) THEN
    +
    654 C FILL FOUR REMAINING MARKERS TO NEXT OUTPUT WORD
    +
    655  cocrpt(lw2*mo-lw1)(1:4) = hold(ip:jp)
    +
    656  ELSE
    +
    657 C FILL ONE, TWO, OR THREE REMAINING MARKERS TO NEXT OUTPUT WORD
    +
    658  cocrpt(lw2*mo-lw1)(1:4) = hold(ip:ll)//blank(1:jp-ll)
    +
    659  END IF
    +
    660  END IF
    +
    661 C.......................................................................
    +
    662  1750 CONTINUE
    +
    663  mo = mo + 1
    +
    664  1800 CONTINUE
    +
    665 C-----------------------------------------------------------------------
    +
    666  2000 CONTINUE
    +
    667 C***********************************************************************
    +
    668  IF(i.GT.1) n = n + 1
    +
    669  IF(n-nexto.NE.nwdsc) THEN
    +
    670 C-----------------------------------------------------------------------
    +
    671 C PROBLEM, REL. LOCATION OF NEXT CAT. NOT WHAT'S EXPECTED; MAY EXIT
    +
    672 C WITH NEXT = -3
    +
    673 C ERROR - RELATIVE LOCATION OF NEXT CATEGORY NOT WHAT'S EXPECTED
    +
    674  nextx = -3
    +
    675  print 105, cocrpt(lw2*11-lw1),cocrpt(lw2*12-lw1)(1:2),
    +
    676  $ kat(ncat),n-nexto-1,
    +
    677  $ nwdsc-1
    +
    678  GO TO 99
    +
    679 C-----------------------------------------------------------------------
    +
    680  END IF
    +
    681 C GO ON TO NEXT CATEGORY
    +
    682  GO TO 700
    +
    683 C-----------------------------------------------------------------------
    +
    684 C ALL OF THE PROBLEM REPORTS END UP HERE -- ATTEMPT TO MOVE AHEAD TO
    +
    685 C NEXT REPORT, IF NOT POSSIBLE THEN EXIT WITH NEXT = -2 OR -3 MEANING
    +
    686 C THE REST OF THE RECORD IS BAD, GO ON TO NEXT RECORD
    +
    687  99 CONTINUE
    +
    688  DO 98 i = 1,644
    +
    689  n = n + 1
    +
    690  IF(n.GT.644) GO TO 97
    +
    691  IF(cocbuf(n).EQ.'END RECORD') GO TO 97
    +
    692  IF(cocbuf(n).EQ.'END REPORT') THEN
    +
    693 C WE'VE MADE IT TO THE END OF THIS PROBLEM REPORT - START OVER WITH
    +
    694 C NEXT ONE
    +
    695  print 106
    +
    696  next = n * 10
    +
    697  GO TO 7000
    +
    698  END IF
    +
    699  98 CONTINUE
    +
    700  97 CONTINUE
    +
    701 C COULDN'T GET TO THE END OF THIS PROBLEM REPORT - RETURN WITH ORIGINAL
    +
    702 C NEXT VALUE (-2 OR -3) MEANING USER MUST GO ON TO NEXT RECORD
    +
    703  next = nextx
    +
    704  print 107, next
    +
    705  mwords = mo - 1
    +
    706  DO 1002 i =1, mwords
    +
    707  locrpt(i) = mocrpt(i)
    +
    708  1002 CONTINUE
    +
    709  RETURN
    +
    710 C-----------------------------------------------------------------------
    +
    711  10 FORMAT(i1)
    +
    712  11 FORMAT(f1.0)
    +
    713  20 FORMAT(i2)
    +
    714  21 FORMAT(f2.0)
    +
    715  30 FORMAT(i3)
    +
    716  31 FORMAT(f3.0)
    +
    717  40 FORMAT(i4)
    +
    718  41 FORMAT(f4.0)
    +
    719  50 FORMAT(i5)
    +
    720  51 FORMAT(f5.0)
    +
    721  60 FORMAT(i6)
    +
    722  61 FORMAT(f6.0)
    +
    723  70 FORMAT(i7)
    +
    724  71 FORMAT(f7.0)
    +
    725  101 FORMAT(/' *** W3FI64 ERROR- REPORT: ',a4,a2,'; ACTUAL NO. 10-CHAR'
    +
    726  $,' WORDS:',i10,' NOT EQUAL TO VALUE READ IN WITH REPORT:',i10/6x,
    +
    727  $ '- MAY BE DUE TO INTERNAL READ PROBLEM ASSOC. W/ EITHER ORIG. ',
    +
    728  $ 'PACKING OR TRANSFER OF FILE RESULTING IN UNPROCESSABLE INFO.'/6x
    +
    729  $,'- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ',
    +
    730  $ 'WILL EXIT RECORD WITH NEXT = -3'/)
    +
    731  102 FORMAT(/' *** W3FI64 ERROR- REPORT: ',a4,a2,'; PACKED CATEGORY '
    +
    732  $,'CODE: ',a2,' IS NOT A VALID O.N. 29 CATEGORY'/6x,
    +
    733  $ '- MAY BE DUE TO INTERNAL READ PROBLEM ASSOC. W/ EITHER ORIG. ',
    +
    734  $ 'PACKING OR TRANSFER OF FILE RESULTING IN UNPROCESSABLE INFO.'/6x
    +
    735  $,'- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ',
    +
    736  $ 'WILL EXIT RECORD WITH NEXT = -2'/)
    +
    737  104 FORMAT(/' *** W3FI64 ERROR- REPORT: ',a4,a2,'; INTERNAL READ ',
    +
    738  $ 'PROBLEM'/6x,'- EITHER ORIGINAL PACKING OF FILE OR TRANSFER ',
    +
    739  $ 'OF FILE HAS RESULTED IN UNPROCESSABLE INFORMATION'/6x,
    +
    740  $ '- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ',
    +
    741  $ 'WILL EXIT RECORD WITH NEXT = -2'/)
    +
    742  105 FORMAT(/' *** W3FI64 ERROR- REPORT: ',a4,a2,'; ACTUAL NO. 10-CHAR'
    +
    743  $,' WORDS IN CAT. ',a2,',',i10,.NE.' TO VALUE READ IN WITH ',
    +
    744  $ 'REPORT:',i10/6x,
    +
    745  $ '- MAY BE DUE TO INTERNAL READ PROBLEM ASSOC. W/ EITHER ORIG. ',
    +
    746  $ 'PACKING OR TRANSFER OF FILE RESULTING IN UNPROCESSABLE INFO.'/6x
    +
    747  $,'- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ',
    +
    748  $ 'WILL EXIT RECORD WITH NEXT = -3'/)
    +
    749  106 FORMAT(/' +++ IT WAS POSSIBLE TO MOVE TO NEXT REPORT IN THIS ',
    +
    750  $ 'RECORD -- CONTINUE WITH THE UNPACKING OF THIS NEW REPORT'/)
    +
    751  107 FORMAT(/' *** IT WAS NOT POSSIBLE TO MOVE TO NEXT REPORT IN THIS',
    +
    752  $ ' RECORD -- MUST EXIT THIS RECORD WITH NEXT =',i3/)
    +
    753  108 FORMAT(/' *** W3FI64 ERROR- REPORT: ',a4,a2,'; AN INPUT ',
    +
    754  $ 'PARAMETER CONSISTS OF MORE THAN SEVEN CHARACTERS'/6x,
    +
    755  $ '- MAY BE DUE TO INTERNAL READ PROBLEM ASSOC. W/ EITHER ORIG. ',
    +
    756  $ 'PACKING OR TRANSFER OF FILE RESULTING IN UNPROCESSABLE INFO.'/6x
    +
    757  $,'- WILL ATTEMPT TO MOVE AHEAD TO NEXT REPORT, IF NOT POSSIBLE ',
    +
    758  $ 'WILL EXIT RECORD WITH NEXT = -2'/)
    +
    759  109 FORMAT(/' *** W3FI64 ERROR- RECORD ',i4,' DOES NOT END WITH ',
    +
    760  $ '"END RECORD" BUT INSTEAD CONTAINS "X" FILLERS AFTER LAST ',
    +
    761  $ 'REPORT IN RECORD'/6x,'- WILL EXIT RECORD WITH NEXT = -1, NO ',
    +
    762  $ 'REPORTS SHOULD BE LOST'/)
    +
    763  END
    +
    +
    +
    w3fi64
    subroutine w3fi64(COCBUF, LOCRPT, NEXT)
    Unpacks an array of upper-air reports that are packed in the format described by NMC office note 29,...
    Definition: w3fi64.f:393
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    + + + + diff --git a/ver-2.10.0/w3fi65_8f.html b/ver-2.10.0/w3fi65_8f.html new file mode 100644 index 00000000..407078b3 --- /dev/null +++ b/ver-2.10.0/w3fi65_8f.html @@ -0,0 +1,182 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi65.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi65.f File Reference
    +
    +
    + +

    NMC office note 29 report packer. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi65 (LOCRPT, COCBUF)
     Packs an array of upper-air reports into the format described by NMC office note 29, or packs an array of surface reports into the format described by NMC office note 124. More...
     
    +

    Detailed Description

    +

    NMC office note 29 report packer.

    +
    Author
    L. Marx
    +
    Date
    1990-01
    + +

    Definition in file w3fi65.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi65()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3fi65 (integer, dimension(*) LOCRPT,
    character*10, dimension(*) COCBUF 
    )
    +
    + +

    Packs an array of upper-air reports into the format described by NMC office note 29, or packs an array of surface reports into the format described by NMC office note 124.

    +

    Input integer, real or character type as specified in the category tables in the write-up for w3fi64() (the office note 29 report packer) are converted to character data. Missing character data are specified as strings of 9's except for that converted from input character type which are generally specified as blanks. This library is similar to w3ai03() except w3ai03() was written in assembler.

    +

    Program history log:

      +
    • L. Marx 1990-01 Converted code from assembler to vs fortran.
      • +
    • Dennis Keyser 1991-08-23 Use same arguments as w3ai03() ; Streamlined code; Docblocked and commented.
      • +
    • Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
      • +
    • Dennis Keyser 1992-07-09 Checks the number of characters used by each variable prior to conversion from integer to character format; If this number is greater than the number of characters allocated for the variable the variable is packed as "missing" (i.e., stores as all 9's).
      • +
    • Dennis Keyser 1993-06-28 Initializes number of words in report to 42 in case "strange" report with no data in any category encountered (used to be zero, but such "strange" reports caused code to fail).
      • +
    • Dennis Keyser 1993-12-22 Corrected error which resulted in storage of 0's in place of actual data in a category when that category was the only one with data.
      • +
    • Dennis Keyser 1998-08-07 Fortran 90-compliant - split an if statement into 2-parts to prevent f90 floating point exception error that can now occur in some cases (did not occur in f77).
      • +
    +
    Parameters
    + + + +
    [in]LOCRPTInteger array containing one unpacked report. LOCRPT must begin on a fullword boundary. Format is mixed, user must equivalence real and character arrays to this array (see w3fi64 write-up for content).
    [out]COCBUFCHARACTER*10 Array containing a packed report in NMC office note 29/124 format.
    +
    +
    +
    Note
    After first creating and writing out the office note 85 (first) date record, the user's fortran program begins a packing loop as follows.. Each iteration of the packing loop consists of a call first to w3fi65() to pack the report into COCBUF, then a call to w3fi66() with the current value of 'NFLAG' (set to zero for first call) to block the packed report into a record (see w3fi66() write- up). if 'NFLAG' is -1 upon returning from w3fi66(), the remaining portion of the record is not large enough to hold the current packed report. The user should write out the record, set 'NFLAG' to zero, call w3fi66() to write the packed report to the beginning of the next record, and repeat the packing loop. If 'NFLAG' is positive, a packed report has been blocked into the record and the user should continue the packing loop. When all reports have been packed and blocked, the user should write out this last record (which is not full but contains fill information supplied by w3fi66()). One final record containing the string 'endof file' (sic) followed by blank fill must be written out to signal the end of the data set.
    +
    +1: The packed report will have the categories ordered as follows: 1, 2, 3, 4, 5, 6, 7, 51, 52, 8, 9.
    +
    +2: The input unpacked report must be in the format spec- ified in the w3fi64() office note 29 report unpacker write-up.
    +
    +3: The unused porion of cocbuf is not cleared.
    +
    +Entry w3ai03() duplicates processing in w3fi65() since no assembly language code in cray w3lib.
    +
    Author
    L. Marx
    +
    Date
    1990-01
    + +

    Definition at line 79 of file w3fi65.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi65_8f.js b/ver-2.10.0/w3fi65_8f.js new file mode 100644 index 00000000..6bb60734 --- /dev/null +++ b/ver-2.10.0/w3fi65_8f.js @@ -0,0 +1,4 @@ +var w3fi65_8f = +[ + [ "w3fi65", "w3fi65_8f.html#a1651042ec008fbdb77f6b66ee9643d0e", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi65_8f_source.html b/ver-2.10.0/w3fi65_8f_source.html new file mode 100644 index 00000000..db412613 --- /dev/null +++ b/ver-2.10.0/w3fi65_8f_source.html @@ -0,0 +1,484 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi65.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi65.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief NMC office note 29 report packer.
    +
    3 C> @author L. Marx @date 1990-01
    +
    4 
    +
    5 C> Packs an array of upper-air reports into the format
    +
    6 C> described by NMC office note 29, or packs an array of surface
    +
    7 C> reports into the format described by NMC office note 124. Input
    +
    8 C> integer, real or character type as specified in the category
    +
    9 C> tables in the write-up for w3fi64() (the office note 29 report
    +
    10 C> packer) are converted to character data. Missing character data
    +
    11 C> are specified as strings of 9's except for that converted from
    +
    12 C> input character type which are generally specified as blanks.
    +
    13 C> This library is similar to w3ai03() except w3ai03() was written in
    +
    14 C> assembler.
    +
    15 C>
    +
    16 C> Program history log:
    +
    17 C> - L. Marx 1990-01 Converted code from assembler
    +
    18 C> to vs fortran.
    +
    19 C> - Dennis Keyser 1991-08-23 Use same arguments as w3ai03() ;
    +
    20 C> Streamlined code; Docblocked and commented.
    +
    21 C> - Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
    +
    22 C> - Dennis Keyser 1992-07-09 Checks the number of characters
    +
    23 C> used by each variable prior to conversion from
    +
    24 C> integer to character format; If this number is
    +
    25 C> greater than the number of characters allocated for
    +
    26 C> the variable the variable is packed as "missing"
    +
    27 C> (i.e., stores as all 9's).
    +
    28 C> - Dennis Keyser 1993-06-28 Initializes number of words in
    +
    29 C> report to 42 in case "strange" report with no data
    +
    30 C> in any category encountered (used to be zero, but
    +
    31 C> such "strange" reports caused code to fail).
    +
    32 C> - Dennis Keyser 1993-12-22 Corrected error which resulted
    +
    33 C> in storage of 0's in place of actual data in a
    +
    34 C> category when that category was the only one with
    +
    35 C> data.
    +
    36 C> - Dennis Keyser 1998-08-07 Fortran 90-compliant - split an
    +
    37 C> if statement into 2-parts to prevent f90 floating
    +
    38 C> point exception error that can now occur in some
    +
    39 C> cases (did not occur in f77).
    +
    40 C>
    +
    41 C> @param[in] LOCRPT Integer array containing one unpacked report.
    +
    42 C> LOCRPT must begin on a fullword boundary. Format
    +
    43 C> is mixed, user must equivalence real and character
    +
    44 C> arrays to this array (see w3fi64 write-up for
    +
    45 C> content).
    +
    46 C> @param[out] COCBUF CHARACTER*10 Array containing a packed report in
    +
    47 C> NMC office note 29/124 format.
    +
    48 C>
    +
    49 C> @note After first creating and writing out the office note 85
    +
    50 C> (first) date record, the user's fortran program begins a packing
    +
    51 C> loop as follows.. Each iteration of the packing loop consists of
    +
    52 C> a call first to w3fi65() to pack the report into COCBUF, then a call
    +
    53 C> to w3fi66() with the current value of 'NFLAG' (set to zero for first
    +
    54 C> call) to block the packed report into a record (see w3fi66() write-
    +
    55 C> up). if 'NFLAG' is -1 upon returning from w3fi66(), the remaining
    +
    56 C> portion of the record is not large enough to hold the current
    +
    57 C> packed report. The user should write out the record, set 'NFLAG'
    +
    58 C> to zero, call w3fi66() to write the packed report to the beginning
    +
    59 C> of the next record, and repeat the packing loop. If 'NFLAG' is
    +
    60 C> positive, a packed report has been blocked into the record and
    +
    61 C> the user should continue the packing loop.
    +
    62 C> When all reports have been packed and blocked, the user
    +
    63 C> should write out this last record (which is not full but contains
    +
    64 C> fill information supplied by w3fi66()). One final record containing
    +
    65 C> the string 'endof file' (sic) followed by blank fill must be
    +
    66 C> written out to signal the end of the data set.
    +
    67 C>
    +
    68 C> @note 1: The packed report will have the categories ordered as
    +
    69 C> follows: 1, 2, 3, 4, 5, 6, 7, 51, 52, 8, 9.
    +
    70 C> @note 2: The input unpacked report must be in the format spec-
    +
    71 C> ified in the w3fi64() office note 29 report unpacker write-up.
    +
    72 C> @note 3: The unused porion of cocbuf is not cleared.
    +
    73 
    +
    74 C> @note Entry w3ai03() duplicates processing in w3fi65() since no
    +
    75 C> assembly language code in cray w3lib.
    +
    76 C>
    +
    77 C> @author L. Marx @date 1990-01
    +
    78  SUBROUTINE w3fi65(LOCRPT,COCBUF)
    +
    79 C
    +
    80  CHARACTER*12 HOLD
    +
    81  CHARACTER*10 COCBUF(*),FILL
    +
    82  CHARACTER*7 CNINES
    +
    83  CHARACTER*4 COCRPT(10000)
    +
    84  CHARACTER*2 KAT(11)
    +
    85 C
    +
    86  INTEGER LOCRPT(*),KATL(11),KATO(11),KATGC(20,11),KATGL(20,11),
    +
    87  $ MOCRPT(5000),KATLL(11)
    +
    88 C
    +
    89  REAL ROCRPT(5000)
    +
    90 C
    +
    91  equivalence(rocrpt,mocrpt,cocrpt)
    +
    92 C
    +
    93  SAVE
    +
    94 C
    +
    95  DATA katl/6,4,4,4,6,6,3,20,15,3,1/,kato/13,15,17,19,21,23,25,29,
    +
    96  $ 31,27,33/,imsg/99999/,fill/'XXXXXXXXXX'/,kat/'01','02','03','04',
    +
    97  $'05','06','07','51','52','08','09'/,cnines/'9999999'/,xmsg/99999./
    +
    98  DATA katgc/ 5*2,4,14*0, 3*2,4,16*0, 3*2,4,16*0, 3*2,4,16*0,
    +
    99  $ 5*2,4,14*0, 5*2,4,14*0, 2*2,4,17*0, 8*2,4,10*1,2, 15*1,5*0,
    +
    100  $ 2*2,4,17*0, 4,19*0/
    +
    101  DATA katgl/ 5,4,3*3,4,14*0, 5,4,2*3,16*0, 5,2*3,2,16*0,
    +
    102  $ 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,
    +
    103  $ 2*5,2*3,4,3,2*4,5,2*3,7*2,1,3,
    +
    104  $ 4,3,4,1,5*2,4,2*2,1,2,7,5*0, 5,3,2,17*0, 12,19*0/
    +
    105  DATA katll/6,4,4,4,6,6,3,21,15,3,3/
    +
    106  DATA lwflag/0/
    +
    107 C
    +
    108  entry w3ai03(locrpt,cocbuf)
    +
    109 C
    +
    110  IF (lwflag.EQ.0) THEN
    +
    111 C FIRST TIME CALLED, DETERMINE MACHINE WORD LG IN BYTES (=8 FOR CRAY)
    +
    112 C DEPENDING ON WORD SIZE LW2*I-LW1 INDEXES THRU COCRPT
    +
    113 C EITHER AS 1,2,3...I FOR LW = 4 OR
    +
    114 C AS 1,3,5..2*I-1 FOR LW = 8 <------ HERE
    +
    115 C NECESSITATED BY LEFT JUSTIFICATION OF EQUIVALENCE
    +
    116  CALL w3fi01(lw)
    +
    117  lw2 = lw/4
    +
    118  lw1 = lw/8
    +
    119  lwflag = 1
    +
    120  END IF
    +
    121  mi = 43
    +
    122  kk = 0
    +
    123  lvls = 0
    +
    124 C DETERMINE THE TRUE NUMBER OF BYTES IN THE INPUT REPORT
    +
    125  DO 100 ncat = 1,11
    +
    126  m = kato(ncat)
    +
    127  IF(locrpt(m+1).GE.mi) kk = ncat
    +
    128  mi = max(mi,locrpt(m+1))
    +
    129  100 CONTINUE
    +
    130  IF(kk.GT.0) THEN
    +
    131  m = kato(kk)
    +
    132  lvls = locrpt(m)
    +
    133  END IF
    +
    134 cvvvvvy2k
    +
    135 cdak MBYTES = LW * ((MI - 1) + (LVLS * KATLL(KK)))
    +
    136  mwords = (mi - 1) + (lvls * katll(kk))
    +
    137 C TRANSFER LOCRPT TO MOCRPT IN ORDER TO EQUIVALENCE TO REAL AND CHAR.
    +
    138 cdak CALL XMOVEX(MOCRPT,LOCRPT,MBYTES)
    +
    139  mocrpt(1:mwords) = locrpt(1:mwords)
    +
    140 caaaaay2k
    +
    141 C INITIALIZE REPORT ID AS MISSING OR NOT APPLICABLE
    +
    142  cocbuf(1) = '9999999999'
    +
    143  cocbuf(2)(7:10) = '9999'
    +
    144  cocbuf(3)(8:10) = '999'
    +
    145  cocbuf(4)(1:7) = '9999999'
    +
    146 C READ IN LATITUDE FROM WORD 1 (REAL)
    +
    147 C WRITE OUT IN FIRST 5 CHARACTERS OF WORD 1 (C*5)
    +
    148  m = 1
    +
    149  n = 1
    +
    150  IF(rocrpt(m).LT.xmsg) THEN
    +
    151  IF(int(rocrpt(m)).GE.0) WRITE(cocbuf(n)(1:5),50)int(rocrpt(m))
    +
    152  IF(int(rocrpt(m)).LT.0) WRITE(cocbuf(n)(1:5),55)int(rocrpt(m))
    +
    153  END IF
    +
    154 C READ IN LONGITUDE FROM WORD 2 (REAL)
    +
    155 C WRITE OUT IN LAST 5 CHARACTERS OF WORD 1 (C*5)
    +
    156  m = 2
    +
    157  IF(rocrpt(m).LT.xmsg) THEN
    +
    158  IF(int(rocrpt(m)).GE.0) WRITE(cocbuf(n)(6:10),50)int(rocrpt(m))
    +
    159  IF(int(rocrpt(m)).LT.0) WRITE(cocbuf(n)(6:10),55)int(rocrpt(m))
    +
    160  END IF
    +
    161 C READ IN STATION ID FROM WORDS 11 AND 12 (C*8)
    +
    162 C (CHAR. 1-4 OF ID IN WORD 11, CHAR. 5-6 OF ID IN WORD 12, LEFT-JUSTIF.)
    +
    163 C WRITE OUT IN FIRST 6 CHARACTERS OF WORD 2 (C*6)
    +
    164  m = 11
    +
    165  n = n + 1
    +
    166  cocbuf(n)(1:6) = cocrpt(lw2*m-lw1)(1:4)//
    +
    167  $ cocrpt(lw2*(m+1)-lw1)(1:2)
    +
    168 C READ IN OBSERVATION TIME FROM WORD 4 (REAL)
    +
    169 C WRITE OUT IN LAST 4 CHARACTERS OF WORD 2 (C*4)
    +
    170  m = 4
    +
    171  IF(rocrpt(m).LT.xmsg) WRITE(cocbuf(n)(7:10),40) int(rocrpt(m))
    +
    172 C READ IN RESERVED CHARACTERS FROM WORDS 5 AND 6 (C*8)
    +
    173 C (4 CHAR., LEFT-JUSTIF.)
    +
    174 C WRITE OUT IN FIRST 7 CHARACTERS OF WORD 3 (C*7)
    +
    175  m = 5
    +
    176  n = n + 1
    +
    177  cocbuf(n)(1:7) =cocrpt(lw2*(m+1)-lw1)(1:2)//
    +
    178  $ cocrpt(lw2*m-lw1)(1:4)//cocrpt(lw2*(m+1)-lw1)(3:3)
    +
    179 C READ IN OFFICE NOTE 29 REPORT TYPE FROM WORD 9 (INTEGER)
    +
    180 C WRITE OUT IN LAST 3 CHARACTERS OF WORD 3 (C*3)
    +
    181  m = 9
    +
    182  IF(mocrpt(m).LT.imsg) WRITE(cocbuf(n)(8:10),30) mocrpt(m)
    +
    183 C READ IN STATION ELEVATION FROM WORD 7 (REAL)
    +
    184 C WRITE OUT IN FIRST 5 CHARACTERS OF WORD 4 (C*4)
    +
    185  m = 7
    +
    186  n = n + 1
    +
    187  IF(rocrpt(m).LT.xmsg) THEN
    +
    188  IF(int(rocrpt(m)).GE.0) WRITE(cocbuf(n)(1:5),50)int(rocrpt(m))
    +
    189  IF(int(rocrpt(m)).LT.0) WRITE(cocbuf(n)(1:5),55)int(rocrpt(m))
    +
    190  END IF
    +
    191 C READ IN INSTRUMENT TYPE FROM WORD 8 (INTEGER)
    +
    192 C WRITE OUT IN NEXT 2 CHARACTERS OF WORD 4 (C*2)
    +
    193  m = 8
    +
    194  IF(mocrpt(m).LT.99) WRITE(cocbuf(n)(6:7),20) mocrpt(m)
    +
    195  no = n
    +
    196  n = n + 1
    +
    197 CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    198 C LOOP THROUGH ALL THE CATEGORIES WHICH HAVE VALID DATA
    +
    199 CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    200  DO 3000 ncat = 1,11
    +
    201 C 'M' IS THE WORD IN MOCRPT WHERE THE NO. OF LEVELS IS READ FROM
    +
    202  m = kato(ncat)
    +
    203  lvls = mocrpt(m)
    +
    204 C 'MI' IS THE STARTING LOCATION IN MOCRPT FOR READING DATA FROM THIS CAT
    +
    205  mi = mocrpt(m+1)
    +
    206  IF(lvls.EQ.0.OR.mi.EQ.0) GO TO 3000
    +
    207 C CATEGORY WITH VALID CATEGORY ENCOUNTERED - WRITE OUT IN FIRST 2
    +
    208 C CHARACTERS OF CATEGORY/COUNTER GROUP FOR THIS CATEGORY (C*2)
    +
    209  cocbuf(n)(1:2) = kat(ncat)
    +
    210 C NUMBER OF LEVELS WRITTEN OUT TO CHAR. 6 & 7 OF CAT/CNTR GROUP (C*2)
    +
    211  WRITE(cocbuf(n)(6:7),20) lvls
    +
    212  nc = n
    +
    213  n = n + 1
    +
    214 C NWDSC COUNTS THE NUMBER OF 10-CHAR. WORDS IN THIS CATEGORY
    +
    215  nwdsc = 1
    +
    216  i = 1
    +
    217 C***********************************************************************
    +
    218 C LOOP THROUGH ALL THE LEVELS IN THE CURRENT CATEGORY
    +
    219 C***********************************************************************
    +
    220  DO 2000 l = 1,lvls
    +
    221 C NDG IS NO. OF INPUT PARAMETERS PER LEVEL IN THIS CATEGORY
    +
    222  ndg = katl(ncat)
    +
    223 C-----------------------------------------------------------------------
    +
    224 C LOOP THROUGH ALL THE PARAMETERS IN THE CURRENT LEVEL
    +
    225 C-----------------------------------------------------------------------
    +
    226  DO 1800 k = 1,ndg
    +
    227 C 'LL' IS THE NUMBER OF OUTPUT CHARACTERS PER PARAMETER FOR THIS CAT.
    +
    228  ll = katgl(k,ncat)
    +
    229 C KATGC IS AN INDICATOR FOR THE INPUT FORMAT OF EACH OUTPUT PARAMETER
    +
    230 C (=2 - REAL, =1 - INTEGER, =4 - CHARACTER*8)
    +
    231  IF(katgc(k,ncat).EQ.4) GO TO 1500
    +
    232 C OUTPUT PARAMETER IS MISSING OR NOT APPLICABLE (BASED ON MISSING INPUT)
    +
    233  IF(katgc(k,ncat).EQ.1) THEN
    +
    234  IF(mocrpt(mi).GE.imsg) THEN
    +
    235  hold(1:ll) = cnines(1:ll)
    +
    236 C SPECIAL CASE FOR INPUT PARAMETER 15, CAT. 52 -- MISSING IS '0099999'
    +
    237  IF(k.EQ.15.AND.ncat.EQ.9) hold(1:7) = '0099999'
    +
    238  GO TO 1750
    +
    239  END IF
    +
    240  ELSE IF(katgc(k,ncat).EQ.2) THEN
    +
    241  IF(rocrpt(mi).GE.xmsg) THEN
    +
    242  hold(1:ll) = cnines(1:ll)
    +
    243 C SPECIAL CASE FOR INPUT PARAMETER 15, CAT. 52 -- MISSING IS '0099999'
    +
    244  IF(k.EQ.15.AND.ncat.EQ.9) hold(1:7) = '0099999'
    +
    245  GO TO 1750
    +
    246  END IF
    +
    247  END IF
    +
    248  ivalue = mocrpt(mi)
    +
    249  IF(katgc(k,ncat).EQ.2) ivalue = int(rocrpt(mi))
    +
    250 C INITIALIZE ALL OUTPUT PARAMETERS HERE AS MISSING
    +
    251 C (WILL REMAIN MISSING IF "IVALUE" SOMEHOW WOULD FILL-UP TOO
    +
    252 C MANY CHARACTERS)
    +
    253  hold(1:ll) = cnines(1:ll)
    +
    254  IF(ll.EQ.1) THEN
    +
    255 C OUTPUT PARAMETER CONSISTS OF ONE CHARACTER
    +
    256  IF(ivalue.LE.9.AND.ivalue.GE.0)
    +
    257  $ WRITE(hold(1:ll),10) ivalue
    +
    258  ELSE IF(ll.EQ.2) THEN
    +
    259 C OUTPUT PARAMETER CONSISTS OF TWO CHARACTERS
    +
    260  IF(ivalue.LE.99.AND.ivalue.GE.-9) THEN
    +
    261  IF(ivalue.GE.0) WRITE(hold(1:ll),20) ivalue
    +
    262  IF(ivalue.LT.0) WRITE(hold(1:ll),25) ivalue
    +
    263  END IF
    +
    264  ELSE IF(ll.EQ.3) THEN
    +
    265 C OUTPUT PARAMETER CONSISTS OF THREE CHARACTERS
    +
    266  IF(ivalue.LE.999.AND.ivalue.GE.-99) THEN
    +
    267  IF(ivalue.GE.0) WRITE(hold(1:ll),30) ivalue
    +
    268  IF(ivalue.LT.0) WRITE(hold(1:ll),35) ivalue
    +
    269  END IF
    +
    270  ELSE IF(ll.EQ.4) THEN
    +
    271 C OUTPUT PARAMETER CONSISTS OF FOUR CHARACTERS
    +
    272  IF(ivalue.LE.9999.AND.ivalue.GE.-999) THEN
    +
    273  IF(ivalue.GE.0) WRITE(hold(1:ll),40) ivalue
    +
    274  IF(ivalue.LT.0) WRITE(hold(1:ll),45) ivalue
    +
    275  END IF
    +
    276  ELSE IF(ll.EQ.5) THEN
    +
    277 C OUTPUT PARAMETER CONSISTS OF FIVE CHARACTERS
    +
    278  IF(ivalue.LE.99999.AND.ivalue.GE.-9999) THEN
    +
    279  IF(ivalue.GE.0) WRITE(hold(1:ll),50) ivalue
    +
    280  IF(ivalue.LT.0) WRITE(hold(1:ll),55) ivalue
    +
    281  END IF
    +
    282  ELSE IF(ll.EQ.6) THEN
    +
    283 C OUTPUT PARAMETER CONSISTS OF SIX CHARACTERS
    +
    284  IF(ivalue.LE.999999.AND.ivalue.GE.-99999) THEN
    +
    285  IF(ivalue.GE.0) WRITE(hold(1:ll),60) ivalue
    +
    286  IF(ivalue.LT.0) WRITE(hold(1:ll),65) ivalue
    +
    287  END IF
    +
    288  ELSE IF(ll.EQ.7) THEN
    +
    289 C OUTPUT PARAMETER CONSISTS OF SEVEN CHARACTERS
    +
    290  IF(ivalue.LE.9999999.AND.ivalue.GE.-999999) THEN
    +
    291  IF(ivalue.GE.0) WRITE(hold(1:ll),70) ivalue
    +
    292  IF(ivalue.LT.0) WRITE(hold(1:ll),75) ivalue
    +
    293  END IF
    +
    294  END IF
    +
    295  GO TO 1750
    +
    296  1500 CONTINUE
    +
    297 C.......................................................................
    +
    298 C INPUT CHARACTER (MARKER) PROCESSING COMES HERE
    +
    299  IF(ll.LE.4) THEN
    +
    300 C THERE ARE BETWEEN ONE AND FOUR MARKERS IN OUTPUT PARAMETER
    +
    301  hold(1:ll) = cocrpt(lw2*mi-lw1)(1:ll)
    +
    302  ELSE
    +
    303 C THERE ARE MORE THAN FOUR MARKERS IN OUTPUT PARAMETER
    +
    304  ip = 1
    +
    305  1610 CONTINUE
    +
    306  jp = ip + 3
    +
    307  IF(jp.LT.ll) THEN
    +
    308 C GET FIRST FOUR MARKERS FROM INPUT WORD
    +
    309  hold(ip:jp) = cocrpt(lw2*mi-lw1)(1:4)
    +
    310  mi = mi + 1
    +
    311  ip = jp + 1
    +
    312  GO TO 1610
    +
    313  ELSE IF(jp.EQ.ll) THEN
    +
    314 C GET FOUR REMAINING MARKERS FROM NEXT INPUT WORD
    +
    315  hold(ip:jp) = cocrpt(lw2*mi-lw1)(1:4)
    +
    316  ELSE
    +
    317 C GET ONE, TWO, OR THREE REMAINING MARKERS FROM NEXT INPUT WORD
    +
    318  hold(ip:ll) = cocrpt(lw2*mi-lw1)(1:ll-jp+4)
    +
    319  END IF
    +
    320  END IF
    +
    321 C.......................................................................
    +
    322  1750 CONTINUE
    +
    323 C 'I' IS POINTER FOR BEGINNING BYTE IN C*10 WORD FOR OUTPUT PARAMETER
    +
    324 C 'J' IS POINTER FOR ENDING BYTE IN C*10 WORD FOR OUTPUT PARAMETER
    +
    325  j = i + ll - 1
    +
    326  IF(j.GT.10) THEN
    +
    327 C COME HERE IF OUTPUT PARAMETER SPANS ACROSS TWO C*10 WORDS
    +
    328  cocbuf(n)(i:10) = hold(1:11-i)
    +
    329  cocbuf(n+1)(1:j-10) = hold(12-i:ll)
    +
    330  n = n + 1
    +
    331  nwdsc = nwdsc + 1
    +
    332  i = j - 9
    +
    333  ELSE
    +
    334  cocbuf(n)(i:j) = hold(1:ll)
    +
    335  i = j + 1
    +
    336  IF(i.GE.11) THEN
    +
    337  n = n + 1
    +
    338  nwdsc = nwdsc + 1
    +
    339  i = 1
    +
    340  END IF
    +
    341  END IF
    +
    342 C GO ON TO NEXT INPUT WORD IN THIS LEVEL
    +
    343  mi = mi + 1
    +
    344  1800 CONTINUE
    +
    345 C-----------------------------------------------------------------------
    +
    346  2000 CONTINUE
    +
    347 C***********************************************************************
    +
    348 C FILL REMAINING PART OF LAST OUTPUT WORD IN THIS CATEGORY WITH X'S
    +
    349  IF(i.GT.1) cocbuf(n)(i:10) = fill(i:10)
    +
    350 C TOTAL NO. CHARACTERS IN CATEGORY (EXCL. FILLS) (NCHAR) WRITTEN OUT TO
    +
    351 C LAST 3 CHARACTERS OF CATEGORY/COUNTER GROUP (C*3)
    +
    352  nchar = ((nwdsc - 1) * 10) + i - 1
    +
    353  WRITE(cocbuf(nc)(8:10),30) nchar
    +
    354  IF(i.GT.1) n = n + 1
    +
    355 C RELATIVE POSITION IN REPORT OF NEXT CAT/CNTR GROUP (N) WRITTEN OUT TO
    +
    356 C CHAR. 3 - 5 OF CURRENT CATEGORY/COUNTER GROUP (C*3)
    +
    357  WRITE(cocbuf(nc)(3:5),30) n
    +
    358 C GO ON TO THE NEXT CATEGORY
    +
    359  3000 CONTINUE
    +
    360 CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    361 C WRITE OUT THE TOTAL LENGTH OF THE REPORT -- NO. OF 10-CHARACTER WORDS
    +
    362 C -- (N) IN LAST THREE CHARACTERS OF WORD 4 (C*3)
    +
    363  WRITE(cocbuf(no)(8:10),30) n
    +
    364 C WRITE OUT 'END REPORT' TO LOCATE THE END OF THIS REPORT IN THE BLOCK
    +
    365  cocbuf(n) = 'END REPORT'
    +
    366  RETURN
    +
    367  10 FORMAT(i1.1)
    +
    368  15 FORMAT(i1.0)
    +
    369  20 FORMAT(i2.2)
    +
    370  25 FORMAT(i2.1)
    +
    371  30 FORMAT(i3.3)
    +
    372  35 FORMAT(i3.2)
    +
    373  40 FORMAT(i4.4)
    +
    374  45 FORMAT(i4.3)
    +
    375  50 FORMAT(i5.5)
    +
    376  55 FORMAT(i5.4)
    +
    377  60 FORMAT(i6.6)
    +
    378  65 FORMAT(i6.5)
    +
    379  70 FORMAT(i7.7)
    +
    380  75 FORMAT(i7.6)
    +
    381  END
    +
    +
    +
    w3fi65
    subroutine w3fi65(LOCRPT, COCBUF)
    Packs an array of upper-air reports into the format described by NMC office note 29,...
    Definition: w3fi65.f:79
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    + + + + diff --git a/ver-2.10.0/w3fi66_8f.html b/ver-2.10.0/w3fi66_8f.html new file mode 100644 index 00000000..419f3e12 --- /dev/null +++ b/ver-2.10.0/w3fi66_8f.html @@ -0,0 +1,188 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi66.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi66.f File Reference
    +
    +
    + +

    Office note 29 report blocker. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi66 (COCBUF, COCBLK, NFLAG, NSIZE)
     Blocks reports which have been packed into nmc office note 29 character format into fixed-length records. More...
     
    +

    Detailed Description

    +

    Office note 29 report blocker.

    +
    Author
    L. Marx
    +
    Date
    1990-01
    + +

    Definition in file w3fi66.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi66()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi66 (character*10, dimension(*) COCBUF,
    character*10, dimension(*) COCBLK,
     NFLAG,
     NSIZE 
    )
    +
    + +

    Blocks reports which have been packed into nmc office note 29 character format into fixed-length records.

    +

    A report cannot span two records; If there is not enough room to fit the current report in the record, the subroutine returns to the calling program without any movement of data.

    +

    Program history log:

      +
    • L. Marx 1990-01 Converted code from assembler to vs fortran; Expanded error return codes in 'NFLAG'.
      • +
    • Dennis Keyser 1991-08-23 Use same arguments as w3ai05(); streamlined code; Docblocked and commented; diag- nostic print for errors.
      • +
    • Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + +
    [in]COCBUFArray containing a single packed report in office note 29/124 format.
    [in]NFLAGMarker indicating relative location (in bytes) of end of last report in COCBLK. Exception: NFLAG must be set to zero prior to blocking the first packed report into a new block. Subsequently, the value of NFLAG returned by the previous call to w3fi66() should be used as input. (see output argument list below.) If NFLAG is negative, w3fi66() will return immediately without action.
    [in]NSIZEMaximum number of characters in COCBLK array (should be a multiple of 4)
    [in,out]COCBLKArray holding a block of packed reports up to and including the previous (IN) / current (OUT) one ag marker indicating relative location (in bytes) of end of current report in COCBLK. NFLAG will be set to -1 if w3fi66() cannot fit the current packed report into the remainder of the block (i.e., the block is full). NFLAG will not change from its input argument value if the string "end report" is not found at the end of the current report. (current packed report has invalid length and is not blocked)
    +
    +
    +
    Note
    The user must set NFLAG to zero each time the array is to be filled with packed reports in office note 29/124 format. w3fi66() will then insert the first report and fill the remainder of the output array COCBLK with the string 'end record'.
    +

    An attempt is made to insert a report in the output array each time w3fi66() is called. If the remaining portion of the output array is not large enough to hold the current report, w3fi66() sets NFLAG to -1. The user should then output the blocked record, set NFLAG to zero, and call w3fi66() again with the same report in the input array.

    +

    After a given report is successfully blocked into COCBLK, w3fi66() sets NFLAG as a pointer for the next report to be blocked. this pointer is a relative address and a character count.

    +

    The three characters specifying the length of the report are checked for valid character numbers and the value is tested for pointing to the end of the report (string "end report"). If invalid, the report is not inserted into the block and there is an immediate return to the user. In this case, the value of NFLAG does not change from its input value.

    +
    Note
    Entry w3ai05() duplicates processing in w3fi66() since no assembly language code in cray w3lib.
    +
    Author
    L. Marx
    +
    Date
    1990-01
    + +

    Definition at line 70 of file w3fi66.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi66_8f.js b/ver-2.10.0/w3fi66_8f.js new file mode 100644 index 00000000..66695d8a --- /dev/null +++ b/ver-2.10.0/w3fi66_8f.js @@ -0,0 +1,4 @@ +var w3fi66_8f = +[ + [ "w3fi66", "w3fi66_8f.html#af8839a41e56c22bda1be01a7f877eb5e", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi66_8f_source.html b/ver-2.10.0/w3fi66_8f_source.html new file mode 100644 index 00000000..84edcf05 --- /dev/null +++ b/ver-2.10.0/w3fi66_8f_source.html @@ -0,0 +1,225 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi66.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi66.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Office note 29 report blocker.
    +
    3 C> @author L. Marx @date 1990-01
    +
    4 
    +
    5 C> Blocks reports which have been packed into nmc office
    +
    6 C> note 29 character format into fixed-length records. A report
    +
    7 C> cannot span two records; If there is not enough room to fit
    +
    8 C> the current report in the record, the subroutine returns to
    +
    9 C> the calling program without any movement of data.
    +
    10 C>
    +
    11 C> Program history log:
    +
    12 C> - L. Marx 1990-01 Converted code from assembler
    +
    13 C> to vs fortran; Expanded error return codes in 'NFLAG'.
    +
    14 C> - Dennis Keyser 1991-08-23 Use same arguments as w3ai05();
    +
    15 C> streamlined code; Docblocked and commented; diag-
    +
    16 C> nostic print for errors.
    +
    17 C> - Dennis Keyser 1992-06-29 Convert to cray cft77 fortran.
    +
    18 C>
    +
    19 C> @param[in] COCBUF Array containing a single packed report
    +
    20 C> in office note 29/124 format.
    +
    21 C> @param[in] NFLAG Marker indicating relative location (in bytes)
    +
    22 C> of end of last report in COCBLK. Exception:
    +
    23 C> NFLAG must be set to zero prior to blocking the first
    +
    24 C> packed report into a new block. Subsequently, the
    +
    25 C> value of NFLAG returned by the previous call to w3fi66()
    +
    26 C> should be used as input. (see output argument list
    +
    27 C> below.) If NFLAG is negative, w3fi66() will return
    +
    28 C> immediately without action.
    +
    29 C> @param[in] NSIZE Maximum number of characters in COCBLK array
    +
    30 C> (should be a multiple of 4)
    +
    31 C> @param[inout] COCBLK Array holding a block of packed reports
    +
    32 C> up to and including the previous (IN) / current (OUT) one
    +
    33 C> ag marker indicating relative location (in bytes)
    +
    34 C> of end of current report in COCBLK. NFLAG
    +
    35 C> will be set to -1 if w3fi66() cannot fit the current
    +
    36 C> packed report into the remainder of the block (i.e.,
    +
    37 C> the block is full). NFLAG will not change from its
    +
    38 C> input argument value if the string "end report" is
    +
    39 C> not found at the end of the current report. (current
    +
    40 C> packed report has invalid length and is not blocked)
    +
    41 C>
    +
    42 C> @note The user must set NFLAG to zero each time the array is
    +
    43 C> to be filled with packed reports in office note 29/124 format.
    +
    44 C> w3fi66() will then insert the first report and fill the remainder
    +
    45 C> of the output array COCBLK with the string 'end record'.
    +
    46 C>
    +
    47 C> An attempt is made to insert a report in the output array
    +
    48 C> each time w3fi66() is called. If the remaining portion of the
    +
    49 C> output array is not large enough to hold the current report,
    +
    50 C> w3fi66() sets NFLAG to -1. The user should then output the
    +
    51 C> blocked record, set NFLAG to zero, and call w3fi66() again with
    +
    52 C> the same report in the input array.
    +
    53 C>
    +
    54 C> After a given report is successfully blocked into COCBLK,
    +
    55 C> w3fi66() sets NFLAG as a pointer for the next report to be blocked.
    +
    56 C> this pointer is a relative address and a character count.
    +
    57 C>
    +
    58 C> The three characters specifying the length of the report
    +
    59 C> are checked for valid character numbers and the value is tested
    +
    60 C> for pointing to the end of the report (string "end report"). If
    +
    61 C> invalid, the report is not inserted into the block and there is
    +
    62 C> an immediate return to the user. In this case, the value of
    +
    63 C> NFLAG does not change from its input value.
    +
    64 C>
    +
    65 C> @note Entry w3ai05() duplicates processing in w3fi66() since no
    +
    66 C> assembly language code in cray w3lib.
    +
    67 C>
    +
    68 C> @author L. Marx @date 1990-01
    +
    69  SUBROUTINE w3fi66(COCBUF,COCBLK,NFLAG,NSIZE)
    +
    70 C
    +
    71  CHARACTER*10 COCBUF(*),COCBLK(*)
    +
    72 C
    +
    73  SAVE
    +
    74 C
    +
    75  entry w3ai05(cocbuf,cocblk,nflag,nsize)
    +
    76 C
    +
    77  IF (nflag.LT.0) THEN
    +
    78  print 101
    +
    79  RETURN
    +
    80  END IF
    +
    81 C N10WRD IS THE MAXIMUM NUMBER OF 10-CHARACTER WORDS AVAILABLE IN BLOCK
    +
    82  n10wrd = nsize/10
    +
    83 C-----------------------------------------------------------------------
    +
    84  IF (nflag.EQ.0) THEN
    +
    85 C 1ST TIME INTO NEW BLOCK, INTIALIZE ALL 10-CHAR. WORDS AS 'END RECORD'
    +
    86  DO 25 m = 1,n10wrd
    +
    87  cocblk(m) = 'END RECORD'
    +
    88  25 CONTINUE
    +
    89  END IF
    +
    90 C-----------------------------------------------------------------------
    +
    91 C READ IN THE NUMBER OF 10-CHARACTER WORDS IN THIS REPORT (NWDS)
    +
    92  READ(cocbuf(4)(8:10),30) nwds
    +
    93  30 FORMAT(i3)
    +
    94 C NOW GET THE NUMBER OF CHARACTERS IN THIS REPORT (NCHARS)
    +
    95  nchars = nwds * 10
    +
    96 C N01BYT IS THE MAXIMUM NUMBER OF CHARACTERS AVAILABLE FOR DATA IN BLOCK
    +
    97  n01byt = (n10wrd * 10) - 10
    +
    98  IF (nflag+nchars.GT.n01byt) THEN
    +
    99 C THE REMAINING PORTION OF THE BLOCK IS NOT LARGE ENOUGH TO HOLD THIS
    +
    100 C REPORT, RETURN WITH NFLAG = -1
    +
    101  nflag = -1
    +
    102  RETURN
    +
    103  END IF
    +
    104  IF (cocbuf(nwds).NE.'END REPORT') THEN
    +
    105 C LAST 10-CHARACTER WORD IN REPORT IS NOT SET TO THE STRING "END REPORT"
    +
    106 C -- INVALID RPT LENGTH, NOTE THIS AND RETURN TO USER W/O BLOCKING RPT
    +
    107  print 102, cocbuf(2)(1:6)
    +
    108  RETURN
    +
    109  END IF
    +
    110 C TRANSFER PACKED REPORT INTO BLOCK
    +
    111  DO 100 n = 1,nwds
    +
    112  cocblk((nflag/10)+n) = cocbuf(n)
    +
    113  100 CONTINUE
    +
    114 C RESET NFLAG
    +
    115  nflag = nflag + (nwds * 10)
    +
    116  RETURN
    +
    117  101 FORMAT(/' *** W3FI66 ERROR- INPUT ARGUMENT "NEXT" (NFLAG) IS ',
    +
    118  $ 'LESS THAN ZERO - RECORD IS FULL, WRITE IT OUT AND START FILLING'
    +
    119  $,' A NEW RECORD WITH CURRENT REPORT'/)
    +
    120  102 FORMAT(/' *** W3FI66 ERROR- REPORT: ',a6,' DOES NOT END WITH THE',
    +
    121  $ ' STRING "END REPORT" - INVALID REPORT LENGTH'/6x,'- CODE WILL ',
    +
    122  $ 'MOVE AHEAD TO NEXT REPORT WITHOUT BLOCKING THIS REPORT'/)
    +
    123  END
    +
    +
    +
    w3fi66
    subroutine w3fi66(COCBUF, COCBLK, NFLAG, NSIZE)
    Blocks reports which have been packed into nmc office note 29 character format into fixed-length reco...
    Definition: w3fi66.f:70
    + + + + diff --git a/ver-2.10.0/w3fi67_8f.html b/ver-2.10.0/w3fi67_8f.html new file mode 100644 index 00000000..187ad9c6 --- /dev/null +++ b/ver-2.10.0/w3fi67_8f.html @@ -0,0 +1,1484 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi67.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi67.f File Reference
    +
    +
    + +

    BUFR message decoder. +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

    +Functions/Subroutines

    subroutine fi6701 (IPTR, IDENT, MSGA, ISTACK, IWORK, ANAME, KDATA, IVALS, MSTACK, AUNITS, KDESC, MWIDTH, MREF, MSCALE, KNR, INDEX)
     Data extraction. More...
     
    subroutine fi6702 (IPTR, IDENT, MSGA, KDATA, KDESC, LL, MSTACK, AUNITS, MWIDTH, MREF, MSCALE, JDESC, IVALS, J)
     Process standard descriptor. More...
     
    subroutine fi6703 (IPTR, IDENT, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, JDESC)
     Process compressed data and place individual elements into output array. More...
     
    subroutine fi6704 (IPTR, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, LL, JDESC)
     Process data that is not compressed. More...
     
    subroutine fi6705 (IPTR, IDENT, MSGA, IWORK, LX, LY, KDATA, LL, KNR, MSTACK)
     Process a replication descriptor, must extract number of replications of n descriptors from the data stream. More...
     
    subroutine fi6706 (IPTR, LX, LY, IDENT, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, LL, KDESC, IWORK, JDESC)
     Process operator descriptors. More...
     
    subroutine fi6707 (IPTR, IWORK, ITBLD, JDESC)
     Substitute descriptor queue for queue descriptor. More...
     
    subroutine fi6708 (IPTR, IWORK, LF, LX, LY, JDESC)
     Subroutine FI6708. More...
     
    subroutine fi6709 (IDENT, MSTACK, KDATA, IPTR)
     Reformat decoded profiler data to show heights instead of height increments. More...
     
    subroutine fi6710 (IDENT, MSTACK, KDATA, IPTR)
     Reformat profiler edition 2 data. More...
     
    subroutine w3fi67 (IPTR, IDENT, MSGA, ISTACK, MSTACK, KDATA, KNR, INDEX)
     This set of routines will decode a BUFR message and place information extracted from the BUFR message into selected arrays for the user. More...
     
    +

    Detailed Description

    +

    BUFR message decoder.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-08-31
    + +

    Definition in file w3fi67.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ fi6701()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi6701 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(*) ISTACK,
    integer, dimension(*) IWORK,
    character*40, dimension(*) ANAME,
    integer, dimension(500,*) KDATA,
    integer, dimension(*) IVALS,
    integer, dimension(2,*) MSTACK,
    character*24, dimension(*) AUNITS,
    integer, dimension(*) KDESC,
    integer, dimension(*) MWIDTH,
    integer, dimension(700,3) MREF,
    integer, dimension(*) MSCALE,
    integer, dimension(*) KNR,
    integer INDEX 
    )
    +
    + +

    Data extraction.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Control the extraction of data from section 4 based on data descriptors.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed data.
      • +
    • Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with delayed replication.
      • +
    • Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + + + +
    [in]IPTRSee w5fi67 routine docblock.
    [in]IDENTSee w3fi67 routine docblock.
    [in]MSGAArray containing bufr message.
    [in,out]ISTACK[in] Original array of descriptors extracted from source bufr message. [out] Arrays containing data from table b.
    [in]MSTACKWorking array of descriptors (expanded)and scaling factor.
    [in,out]KDESCImage of current descriptor.
    [in]INDEX
    KNR
    [out]IWORKWorking descriptor list
    IVALS
    [out]KDATAArray containing decoded reports from bufr message kdata(report number,parameter number).
    [out]ANAMEDescriptor name..
    [out]AUNITSUnits for descriptor.
    [out]MSCALEScale for value of descriptor.
    [out]MREFReference value for descriptor.
    [out]MWIDTHBit width for value of descriptor.
    +
    +
    +
    Note
    Error return:
      +
    • IPTR(1)
        +
      • = 8 ERROR READING TABLE B
        • +
      • = 9 ERROR READING TABLE D
        • +
      • = 11 ERROR OPENING TABLE B
        • +
      +
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 640 of file w3fi67.f.

    + +
    +
    + +

    ◆ fi6702()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi6702 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(500,*) KDATA,
    integer, dimension(*) KDESC,
     LL,
    integer, dimension(2,*) MSTACK,
    character*24, dimension(*) AUNITS,
    integer, dimension(*) MWIDTH,
    integer, dimension(700,3) MREF,
    integer, dimension(*) MSCALE,
    integer JDESC,
    integer, dimension(*) IVALS,
    integer J 
    )
    +
    + +

    Process standard descriptor.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Process a standard descriptor (f = 0) and store data in output array.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-04-04 Changed to pass width of text fields in bytes.
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + +
    [in]IPTRSee w3fi67 routine docblock.
    [in]IDENTSee w3fi67 routine docblock.
    [in]MSGAArray containing bufr message.
    [in,out]KDATAArray containing decoded reports from bufr message. KDATA(Report number, parameter number)
    [in,out]KDESCImage of current descriptor.
    [in]MSTACK
    LL
    [out]AUNITSUnits for descriptor.
    [out]MSCALEScale for value of descriptor.
    [out]MREFReference value for descriptor.
    [out]MWIDTHBit width for value of descriptor.
    JDESC
    [in]IVALSArray of single parameter values.
    J
    +
    +
    +
    Note
    Error return: IPTR(1) = 3 - Message contains a descriptor with f=0 that does not exist in table b.
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 942 of file w3fi67.f.

    + +
    +
    + +

    ◆ fi6703()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi6703 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(500,*) KDATA,
    integer, dimension(*) IVALS,
    integer, dimension(2,*) MSTACK,
    integer, dimension(*) MWIDTH,
    integer, dimension(700,3) MREF,
    integer, dimension(*) MSCALE,
    integer J,
    integer JDESC 
    )
    +
    + +

    Process compressed data and place individual elements into output array.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Program history log:
      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-04-04 Text handling portion of this routine modified to hanle width of fields in bytes.
      • +
    • Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed and uncompressed form gave different results. This has been corrected.
      • +
    • Bill Cavanaugh 1991-06-21 Processing of text data has been changed to provide exact reproduction of all characters.
      • +
    +
    +
    Parameters
    + + + + + + + + + + + + +
    [in]IPTRSee w3fi67() routine docblock.
    [in]IDENTSee w3fi67() routine docblock.
    [in]MSGAArray containing bufr message, mstack.
    [in]MSTACK
    [in]IVALSArray of single parameter values.
    [in,out]J
    [out]KDATAArray containing decoded reports from bufr message. kdata(report number,parameter number).
    JDESCArrays Containing data from table b.
    [out]MSCALEScale for value of descriptor.
    [out]MREFReference value for descriptor.
    [out]MWIDTHBit width for value of descriptor.
    +
    +
    +
    Note
    List caveats, other helpful hints or information.
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1092 of file w3fi67.f.

    + +
    +
    + +

    ◆ fi6704()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi6704 (integer, dimension(*) IPTR,
    integer, dimension(*) MSGA,
    integer, dimension(500,*) KDATA,
    integer, dimension(*) IVALS,
    integer, dimension(2,*) MSTACK,
    integer, dimension(*) MWIDTH,
    integer, dimension(700,3) MREF,
    integer, dimension(*) MSCALE,
    integer J,
    integer LL,
    integer JDESC 
    )
    +
    + +

    Process data that is not compressed.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Program history log:
      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-01-18 Modified to properly handle non-compressed data.
      • +
    • Bill Cavanaugh 1991-04-04 Text handling portion of this routine modified to handle field width in bytes.
      • +
    • Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed and uncompressed form gave different results. This has been corrected.
      • +
    +
    +
    Parameters
    + + + + + + + + + + + + +
    [in]IPTRSee w3fi67 routine docblock
    [in]MSGAArray containing bufr message
    [in,out]IVALSArray of single parameter values
    [out]KDATAArray containing decoded reports from bufr message. kdata(report number,parameter number)
    [in,out]J[in] ? [out] arrays containing data from table b
    [out]MSCALEScale for value of descriptor
    [in]MSTACK
    LL
    JDESC
    [out]MREFReference value for descriptor
    [out]MWIDTHBit width for value of descriptor
    +
    +
    +
    Note
    Error return:
      +
    • IPTR(1) = 13 - Bit width on ASCII chars not a multiple of 8.
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1349 of file w3fi67.f.

    + +
    +
    + +

    ◆ fi6705()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi6705 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(*) IWORK,
    integer LX,
    integer LY,
    integer, dimension(500,*) KDATA,
    integer LL,
    integer, dimension(*) KNR,
    integer, dimension(2,*) MSTACK 
    )
    +
    + +

    Process a replication descriptor, must extract number of replications of n descriptors from the data stream.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Process a replication descriptor, must extract number of replications of n descriptors from the data stream.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    +
    Parameters
    + + + + + + + + + + + +
    [in]IWORKWorking descriptor list
    [in]IPTRSee w3fi67 routine docblock
    [in]IDENTSee w3fi67 routine docblock
    [in,out]LXX portion of current descriptor
    [in,out]LYY portion of current descriptor
    [out]KDATAArray containing decoded reports from bufr message. kdata(report number,parameter number)
    LL
    KNR
    MSTACK
    MSGA
    +
    +
    +
    Note
    Error return:
      +
    • IPTR(1)
        +
      • = 12 Data descriptor qualifier does not follow delayed replication descriptor.
        • +
      • = 20 Exceeded count for delayed replication pass.
        • +
      +
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1511 of file w3fi67.f.

    + +
    +
    + +

    ◆ fi6706()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi6706 (integer, dimension(*) IPTR,
    integer LX,
    integer LY,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(500,*) KDATA,
    integer, dimension(*) IVALS,
    integer, dimension(2,*) MSTACK,
    integer, dimension(*) MWIDTH,
    integer, dimension(700,3) MREF,
    integer, dimension(*) MSCALE,
    integer J,
    integer LL,
    integer, dimension(*) KDESC,
    integer, dimension(*) IWORK,
    integer JDESC 
    )
    +
    + +

    Process operator descriptors.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Extract and save indicated change values for use until changes are rescinded, or extract text strings indicated through 2 05 yyy.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
      • +
    • Bill Cavanaugh 1991-05-10 Coding has been added to process proposed table c descriptor 2 06 yyy.
      • +
    • Bill Cavanaugh 1991-11-21 Coding has been added to properly process table c descriptor 2 03 yyy, the change to new reference value for selected descriptors.
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + + + +
    [in]IPTRSee w3fi67 routine docblock.
    [in]LXX portion of current descriptor.
    [in]LYY portion of current descriptor.
    [out]KDATAArray containing decoded reports from bufr message. kdata(report number,parameter number) arrays containing data from table b
    [out]MSCALEScale for value of descriptor
    [out]MREFReference value for descriptor
    [out]MWIDTHBit width for value of descriptor
    IDENT
    MSGA
    IVALS
    MSTACK
    J
    LL
    KDESC
    IWORK
    JDESC
    +
    +
    +
    Note
    Error return:
      +
    • IPTR(1) = 5 - Erroneous x value in data descriptor operator
      • +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1674 of file w3fi67.f.

    + +
    +
    + +

    ◆ fi6707()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi6707 (integer, dimension(*) IPTR,
    integer, dimension(*) IWORK,
    integer, dimension(500,11) ITBLD,
    integer JDESC 
    )
    +
    + +

    Substitute descriptor queue for queue descriptor.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Substitute descriptor queue for queue descriptor
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors.
      • +
    • Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors. based on tests with live data.
      • +
    +
    Parameters
    + + + + + +
    [in]IWORKWorking descriptor list.
    [in]IPTRSee w3fi67 routine docblock.
    [in]ITBLDArray containing descriptor queues.
    [in]JDESCQueue descriptor to be expanded.
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1815 of file w3fi67.f.

    + +
    +
    + +

    ◆ fi6708()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi6708 (integer, dimension(*) IPTR,
    integer, dimension(*) IWORK,
    integer LF,
    integer LX,
    integer LY,
    integer JDESC 
    )
    +
    + +

    Subroutine FI6708.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1989-01-17 Program history log:
      +
    • Bill Cavanaugh 1988-09-01
      • +
    +
    +
    Parameters
    + + + + + + + +
    [in,out]IPTRSee w3fi67() routine docblock.
    [in]IWORKWorking descriptor list.
    LF
    LX
    LY
    [in]JDESCQueue descriptor to be expanded.
    +
    +
    +
    Note
    List caveats, other helpful hints or information.
    +
    Author
    Bill Cavanaugh
    +
    Date
    1989-01-17
    + +

    Definition at line 1922 of file w3fi67.f.

    + +
    +
    + +

    ◆ fi6709()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi6709 (integer, dimension(*) IDENT,
    integer, dimension(2,*) MSTACK,
    integer, dimension(500,*) KDATA,
    integer, dimension(*) IPTR 
    )
    +
    + +

    Reformat decoded profiler data to show heights instead of height increments.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1990-02-14 Reformat decoded profiler data to show heights instead of height increments.
    +

    Program history log:

      +
    • Bill Cavanaugh 1990-02-14
      • +
    +
    Parameters
    + + + + + +
    [in]IDENTArray contains message information extracted from BUFR message:
      +
    • IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1)
      • +
    • IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1)
      • +
    • IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1)
      • +
    • IDENT( 4)- (BYTE 8, SECTION 1)
      • +
    • IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1)
      • +
    • IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1)
      • +
    • IDENT( 7)- (BYTES 11-12, SECTION 1)
      • +
    • IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1)
      • +
    • IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1)
      • +
    • IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1)
      • +
    • IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1)
      • +
    • IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1)
      • +
    • IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1)
      • +
    • IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3)
      • +
    • IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3)
      • +
    • IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3)
      • +
    +
    [in]MSTACKWorking descriptor list and scaling factor
    [in]KDATAArray containing decoded reports
    [in]IPTRSee w3fi67
    +
    +
    +
    Note
    List caveats, other helpful hints or information.
    +
    Author
    Bill Cavanaugh
    +
    Date
    1990-02-14
    + +

    Definition at line 1974 of file w3fi67.f.

    + +
    +
    + +

    ◆ fi6710()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi6710 (integer, dimension(*) IDENT,
    integer, dimension(2,1600) MSTACK,
    integer, dimension(500,1600) KDATA,
    integer, dimension(*) IPTR 
    )
    +
    + +

    Reformat profiler edition 2 data.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-01-27 Reformat profiler data in edition 2
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-01-27
      • +
    +
    Parameters
    + + + + + +
    [in]IDENTArray contains message information extracted from BUFR message:
      +
    • IDENT( 1)-Edition number (byte 4, section 1)
      • +
    • IDENT( 2)-Originating center (bytes 5-6, section 1)
      • +
    • IDENT( 3)-Update sequence (byte 7, section 1)
      • +
    • IDENT( 4)- (byte 8, section 1)
      • +
    • IDENT( 5)-BUFR message type (byte 9, section 1)
      • +
    • IDENT( 6)-BUFR msg sub-type (byte 10, section 1)
      • +
    • IDENT( 7)- (bytes 11-12, section 1)
      • +
    • IDENT( 8)-Year of century (byte 13, section 1)
      • +
    • IDENT( 9)-Month of year (byte 14, section 1)
      • +
    • IDENT(10)-Day of month (byte 15, section 1)
      • +
    • IDENT(11)-Hour of day (byte 16, section 1)
      • +
    • IDENT(12)-Minute of hour (byte 17, section 1)
      • +
    • IDENT(13)-Rsvd by adp centers(byte 18, section 1)
      • +
    • IDENT(14)-Nr of data subsets (byte 5-6, section 3)
      • +
    • IDENT(15)-Observed flag (byte 7, bit 1, section 3)
      • +
    • IDENT(16)-Compression flag (byte 7, bit 2, section 3)
      • +
    +
    [in]MSTACKWorking descriptor list and scaling factor
    [in]KDATAArray containing decoded reports from bufr message. kdata(report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd)
    [in]IPTRSee w3fi67
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-01-27
    + +

    Definition at line 2361 of file w3fi67.f.

    + +
    +
    + +

    ◆ w3fi67()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi67 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(*) ISTACK,
    integer, dimension(2,*) MSTACK,
    integer, dimension(500,*) KDATA,
    integer, dimension(*) KNR,
    integer INDEX 
    )
    +
    + +

    This set of routines will decode a BUFR message and place information extracted from the BUFR message into selected arrays for the user.

    +

    Those arrays are described in the output argument list. This routine does not include ifod processing.

    +

    Program history log:

      +
    • Bill Cavanaugh 1988-08-31
      • +
    • Bill Cavanaugh 1990-12-07 Now utilizing gbyte routines to gather and separate bit fields. This should improve (decrease) the time it takes to decode any BUFR message. Have entered coding that will permit processing BUFR editions 1 and 2. Improved and corrected the conversion into ifod format of decoded BUFR messages.
      • +
    • Bill Cavanaugh 1991-01-18 Program/routines modified to properly handle serial profiler data.
      • +
    • Bill Cavanaugh 1991-04-04 Modified to handle text supplied thru descriptor 2 05 yyy.
      • +
    • Bill Cavanaugh 1991-04-17 Errors in extracting and scaling data corrected. Improved handling of nested queue descriptors is added.
      • +
    • Bill Cavanaugh 1991-05-10 Array 'data' has been enlarged to real*8 to better contain very large numbers more accurately. The preious size real*4 could not contain sufficient significant digits. Coding has been introduced to process new table c descriptor 2 06 yyy which permits in line processing of a local descriptor even if the descriptor is not contained in the users table b. A second routine to process ifod messages (ifod0) has been removed in favor of the improved processing of the one remaining (ifod1). New coding has been introduced to permit processing of BUFR messages based on BUFR edition up to and including edition 2. Please note increased size requirements for arrays ident(20) and iptr(40).
      • +
    • Bill Cavanaugh 1991-07-26 Add array mtime to calling sequence to permit inclusion of receipt/transfer times to ifod messages.
      • +
    • Bill Cavanaugh 1991-09-25 All processing of decoded BUFR data into ifod (a local use reformat of BUFR data) has been isolated from this set of routines. For those interested in the ifod form, see w3fl05 in the w3lib routines.
      • +
    • Processing of BUFR messages containing delayed replication has been altered so that single subsets (reports) and and a matching descriptor list for that particular subset will be passed to the user will be passed to the user one at a time to assure that each subset can be fully defined with a minimum of reprocessing.
      • +
    • Processing of associated fields has been tested with messages containing non-compressed data.
      • +
    • In order to facilitate user processing a matching list of scale factors are included with the expanded descriptor list (mstack).
      • +
    • Bill Cavanaugh 1991-11-21 Processing of descriptor 2 03 yyy has corrected to agree with fm94 standards.
      • +
    • Bill Cavanaugh 1991-12-19 Calls to fi6703() and fi6704() have been corrected to agree called program argument list. Some additional entries have been included for communicating with data access routines. Additional error exit provided for the case where table b is damaged.
      • +
    • Bill Cavanaugh 1992-01-24 Routines fi6701(), fi6703() and fi6704() have been modified to handle associated fields all descriptors are set to echo to mstack(1,n)
      • +
    • Bill Cavanaugh 1992-05-21 Further expansion of information collected from within upper air soundings has produced the necessity to expand some of the processing and output arrays. (see remarks below)
      • +
    • Bill Cavanaugh 1992-06-29 Corrected descriptor denoting height of each wind level for profiler conversions.
      • +
    • Bill Cavanaugh 1992-07-23 Expansion of table b requires adjustment of arrays to contain table b values needed to assist in the decoding process.
      • +
    • Arrays containing data from table b:
        +
      • kdesc descriptor
        • +
      • aname descriptor name
        • +
      • aunits units for descriptor
        • +
      • mscale scale for value of descriptor
        • +
      • mref reference value for descriptor
        • +
      • mwidth bit width for value of descriptor
        • +
      • Bill Cavanaugh 1992-09-09 First encounter with operator descriptor 2 05 yyy showed error in decoding. That error is corrected with this implementation. Further testing of upper air data has encountered the condition of large (many level) soundings arrays in the decoder have been expanded (again) to allow for this condition.
        • +
      +
      • +
    • Bill Cavanaugh 1992-10-02 Modified routine to reformat profiler data (fi6709) to show descriptors, scale value and data in proper order. Corrected an error that prevented user from assigning the second dimension of kdata(500,*).
      • +
    • Bill Cavanaugh 1992-10-20 Removed error that prevented full implementation of previous corrections and made corrections to table b to bring it up to date. Changes include proper reformat of profiler data and user capability for assigning second dimension of kdata array.
      • +
    • Bill Cavanaugh 1993-01-26 Added routine fi6710() to permit reformatting profiler data in BUFR edition 2.
      • +
    +
    Parameters
    + + + + + + + + + +
    [in]MSGAArray containing supposed bufr message.
    [out]ISTACKOriginal array of descriptors extracted from source bufr message.
    [out]MSTACK(A,B)
      +
    • LEVEL B - Descriptor number
      • +
    • LEVEL A = 1 Descriptor
        +
      • = 2 10**N Scaling to return to original value
        • +
      +
      • +
    +
    [out]IPTRUtility array.
      +
    • IPTR( 1)- Error return.
      • +
    • IPTR( 2)- Byte count section 1.
      • +
    • IPTR( 3)- Pointer to start of section 1.
      • +
    • IPTR( 4)- Byte count section 2.
      • +
    • IPTR( 5)- Pointer to start of section 2.
      • +
    • IPTR( 6)- Byte count section 3.
      • +
    • IPTR( 7)- Pointer to start of section 3.
      • +
    • IPTR( 8)- Byte count section 4.
      • +
    • IPTR( 9)- Pointer to start of section 4.
      • +
    • IPTR(10)- Start of requested subset, reserved for dar.
      • +
    • IPTR(11)- Current descriptor ptr in iwork.
      • +
    • IPTR(12)- Last descriptor pos in iwork.
      • +
    • IPTR(13)- Last descriptor pos in istack.
      • +
    • IPTR(14)- Number of table b entries.
      • +
    • IPTR(15)- Requested subset pointer, reserved for dar.
      • +
    • IPTR(16)- Indicator for existance of section 2.
      • +
    • IPTR(17)- Number of reports processed.
      • +
    • IPTR(18)- Ascii/text event.
      • +
    • IPTR(19)- Pointer to start of bufr message.
      • +
    • IPTR(20)- Number of lines from table d.
      • +
    • IPTR(21)- Table b switch.
      • +
    • IPTR(22)- Table d switch.
      • +
    • IPTR(23)- Code/flag table switch.
      • +
    • IPTR(24)- Aditional words added by text info.
      • +
    • IPTR(25)- Current bit number.
      • +
    • IPTR(26)- Data width change.
      • +
    • IPTR(27)- Data scale change.
      • +
    • IPTR(28)- Data reference value change.
      • +
    • IPTR(29)- Add data associated field.
      • +
    • IPTR(30)- Signify characters.
      • +
    • IPTR(31)- Number of expanded descriptors in mstack.
      • +
    • IPTR(32)- Current descriptor segment f.
      • +
    • IPTR(33)- Current descriptor segment x.
      • +
    • IPTR(34)- Current descriptor segment y.
      • +
    • IPTR(35)- Unused.
      • +
    • IPTR(36)- Next descriptor may be undecipherable.
      • +
    • IPTR(37)- Unused.
      • +
    • IPTR(38)- Unused.
      • +
    • IPTR(39)- Delayed replication flag.
        +
      • 0 - No delayed replication.
        • +
      • 1 - Message contains delayed replication.
        • +
      +
      • +
    • IPTR(40)- Number of characters in text for curr descriptor.
      • +
    +
    [out]IDENTArray contains message information extracted from bufr message
      +
    • IDENT( 1)-Edition number (byte 4, section 1).
      • +
    • IDENT( 2)-Originating center (bytes 5-6, section 1).
      • +
    • IDENT( 3)-Update sequence (byte 7, section 1).
      • +
    • IDENT( 4)-Optional section (byte 8, section 1).
      • +
    • IDENT( 5)-Bufr message type (byte 9, section 1).
        +
      • 0 = Surface (land)
        • +
      • 1 = Surface (ship)
        • +
      • 2 = Vertical soundings other than satellite
        • +
      • 3 = Vertical soundings (satellite)
        • +
      • 4 = Sngl lvl upper-air other than satellite
        • +
      • 5 = Sngl lvl upper-air (satellite)
        • +
      • 6 = Radar
        • +
      +
      • +
    • IDENT( 6)-Bufr msg sub-type (byte 10, section 1) + + + + +
      type sbtyp
      2 7 = profiler
      +
      • +
    • IDENT(7) - bytes 11-12, section 1).
      • +
    • IDENT(8) - Year of century (byte 13, section 1).
      • +
    • IDENT(9) - Month of year (byte 14, section 1).
      • +
    • IDENT(10) - Day of month (byte 15, section 1).
      • +
    • IDENT(11) - Hour of day (byte 16, section 1).
      • +
    • IDENT(12) - Minute of hour (byte 17, section 1).
      • +
    • IDENT(13) - Rsvd by adp centers (byte 18, section 1).
      • +
    • IDENT(14) - Nr of data subsets (byte 5-6, section 3).
      • +
    • IDENT(15) - Observed flag (byte 7, bit 1, section 3).
      • +
    • IDENT(16) - Compression flag (byte 7, bit 2, section 3).
      • +
    • IDENT(17) - Master table number (byte 4, section 1, ed 2 or gtr).
      • +
    +
    [out]KDATAArray containing decoded reports from bufr message.
    [in]KNRkdata(report number,parameter number) arrays containing data from table b
      +
    • ANAME Descriptor name.
      • +
    • AUNITS Units for descriptor.
      • +
    • MSCALE Scale for value of descriptor.
      • +
    • MREF Reference value for descriptor.
      • +
    • MWIDTH Bit width for value of descriptor.
      • +
    +
    [out]INDEXPointer to available subset.
    +
    +
    +
    Note
    Error returns:
      +

    • IPTR(1):

        +
      • = 1 'BUFR' Not found in first 125 characters.
        • +
      • = 2 '7777' Not found in location determined by by using counts found in each section. one or more sections have an erroneous byte count or characters '7777' are not in test message.
        • +
      • = 3 Message contains a descriptor with f=0 that does not exist in table b.
        • +
      • = 4 Message contains a descriptor with f=3 that does not exist in table d.
        • +
      • = 5 Message contains a descriptor with f=2 with the value of x outside the range 1-5.
        • +
      • = 6 Descriptor element indicated to have a flag value does not have an entry in the flag table (to be activated).
        • +
      • = 7 Descriptor indicated to have a code value does not have an entry in the code table (to be activated).
        • +
      • = 8 Error reading table d.
        • +
      • = 9 Error reading table b.
        • +
      • = 10 Error reading code/flag table.
        • +
      • = 11 Descriptor 2 04 004 not followed by 0 31 021.
        • +
      • = 12 Data descriptor operator qualifier does not follow delayed replication descriptor.
        • +
      • = 13 Bit width on ascii characters not a multiple of 8.
        • +
      • = 14 Subsets = 0, no content bulletin.
        • +
      • = 20 Exceeded count for delayed replication pass.
        • +
      • = 21 Exceeded count for non-delayed replication pass.
        • +
      • = 22 Section 1 count exceeds 10000.
        • +
      • = 23 Section 2 count exceeds 10000.
        • +
      • = 24 Section 3 count exceeds 10000.
        • +
      • = 25 Section 4 count exceeds 10000.
        • +
      • = 27 Non zero lowest on text data.
        • +
      • = 28 Nbinc not nr of characters.
        • +
      • = 29 Table b appears to be damaged.
        • +
      • = 99 No more subsets (reports) available in current bufr mesage.
        • +
      • = 400 Number of subsets exceeds capability of routine.
        • +
      • = 401 Number of parameters (and associated fields) exceeds limits of this program.
        • +
      • = 500 Value for nbinc has been found that exceeds standard width plus any bit width change check all bit widths up to point of error.
        • +
      • = 501 Corrected width for descriptor is 0 or less.
        • +
      +

      On the initial call to w3fi67() with a bufr message the argument index must be set to zero (index = 0). on the return from w3fi67() 'index' will be set to the next available subset/report. when there are no more subsets available a 99 err return will occur.

      +

      If the original bufr message does not contain delayed replication the bufr message will be completely decoded and 'index' will point to the first decoded subset. The users will then have the option of indexing through the subsets on their own or by recalling this routine (without resetting 'index') to have the routine do the indexing.

      +

      If the original bufr message does contain delayed replication one subset/report will be decoded at a time and passed back to the user. this is not an option.

      +
      • +
    +
    +
    +

    +TO USE THIS ROUTINE

    +
      +
    1. READ IN BUFR MESSAGE
      2. +
    2. SET INDEX = 0
      3. +
    3. CALL W3FI67( )
      4. +
    4. IF (IPTR(1).EQ.99) THEN NO MORE SUBSETS EITHER GO TO 1 OR TERMINATE IN NO MORE BUFR MESSAGES END IF
      5. +
    5. IF (IPTR(1).NE.0) THEN ERROR CONDITION EITHER GO TO 1 OR TERMINATE IN NO MORE BUFR MESSAGES END IF
      6. +
    6. THE VALUE OF INDEX INDICATES THE ACTIVE SUBSET SO IF INTERESTED IN GENERATING AN IFOD MESSAGE CALL W3FL05 ( ) ELSE PROCESS DECODED INFORMATION AS REQUIRED END IF
      7. +
    7. GO TO 3
      8. +
    +
    +

    THE ARRAYS TO CONTAIN THE OUTPUT INFORMATION ARE DEFINED AS FOLLOWS: KDATA(A,B) IS THE A DATA ENTRY (INTEGER VALUE) WHERE A IS THE MAXIMUM NUMBER OF REPORTS/SUBSETS (FOR THIS VERSION OF THE DECODER A=500) THAT MAY BE CONTAINED IN THE BUFR MESSAGE, AND WHERE B IS THE MAXIMUM NUMBER OF DESCRIPTOR COMBINATIONS THAT MAY BE PROCESSED. UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE A VALUE FOR B OF 1600, BUT FOR MOST OTHER DATA A VALUE FOR B OF 500 WILL SUFFICE MSTACK(1,B) CONTAINS THE DESCRIPTOR THAT MATCHES THE DATA ENTRY MSTACK(2,B) IS THE SCALE (POWER OF 10) TO BE APPLIED TO THE DATA

    +

    ATTRIBUTES: LANGUAGE: FORTRAN 77 MACHINE: NAS

    + +

    Definition at line 285 of file w3fi67.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi67_8f.js b/ver-2.10.0/w3fi67_8f.js new file mode 100644 index 00000000..343e5ae0 --- /dev/null +++ b/ver-2.10.0/w3fi67_8f.js @@ -0,0 +1,14 @@ +var w3fi67_8f = +[ + [ "fi6701", "w3fi67_8f.html#af1838e0792e8dacd4ba70b0b844065c6", null ], + [ "fi6702", "w3fi67_8f.html#ab4efc955f13221a830e6c653fbe8326b", null ], + [ "fi6703", "w3fi67_8f.html#a85264d1d80f2dcd1c5aef6998179ed21", null ], + [ "fi6704", "w3fi67_8f.html#ad13befc6a11f1be63345c169e4e2c21a", null ], + [ "fi6705", "w3fi67_8f.html#ac00ebd799c167d32ad1e8d2ccf77d8ed", null ], + [ "fi6706", "w3fi67_8f.html#aa8975059a9c80ae0909d0942907c5b04", null ], + [ "fi6707", "w3fi67_8f.html#a0ba8ee313bbaa81c2d31552c8ba447dd", null ], + [ "fi6708", "w3fi67_8f.html#afc00645e835f1bb662852727afb41980", null ], + [ "fi6709", "w3fi67_8f.html#a450eb49ae26957e0bcadb573ffbcbab2", null ], + [ "fi6710", "w3fi67_8f.html#a2f44d69247df49460acaabe30f7cabb9", null ], + [ "w3fi67", "w3fi67_8f.html#af1ebc9eb3165bf0f76af6472109fb4db", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi67_8f_source.html b/ver-2.10.0/w3fi67_8f_source.html new file mode 100644 index 00000000..5fad8afe --- /dev/null +++ b/ver-2.10.0/w3fi67_8f_source.html @@ -0,0 +1,2769 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi67.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi67.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief BUFR message decoder.
    +
    3 C> @author Bill Cavanaugh @date 1988-08-31
    +
    4 
    +
    5 C> This set of routines will decode a BUFR message and
    +
    6 C> place information extracted from the BUFR message into selected
    +
    7 C> arrays for the user. Those arrays are described in the output
    +
    8 C> argument list. This routine does not include ifod processing.
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - Bill Cavanaugh 1988-08-31
    +
    12 C> - Bill Cavanaugh 1990-12-07 Now utilizing gbyte routines to gather
    +
    13 C> and separate bit fields. This should improve
    +
    14 C> (decrease) the time it takes to decode any
    +
    15 C> BUFR message. Have entered coding that will
    +
    16 C> permit processing BUFR editions 1 and 2.
    +
    17 C> Improved and corrected the conversion into
    +
    18 C> ifod format of decoded BUFR messages.
    +
    19 C> - Bill Cavanaugh 1991-01-18 Program/routines modified to properly handle
    +
    20 C> serial profiler data.
    +
    21 C> - Bill Cavanaugh 1991-04-04 Modified to handle text supplied thru
    +
    22 C> descriptor 2 05 yyy.
    +
    23 C> - Bill Cavanaugh 1991-04-17 Errors in extracting and scaling data
    +
    24 C> corrected. Improved handling of nested queue descriptors is added.
    +
    25 C> - Bill Cavanaugh 1991-05-10 Array 'data' has been enlarged to real*8
    +
    26 C> to better contain very large numbers more accurately. The preious size
    +
    27 C> real*4 could not contain sufficient significant digits. Coding has been
    +
    28 C> introduced to process new table c descriptor 2 06 yyy which permits in
    +
    29 C> line processing of a local descriptor even if the descriptor is not
    +
    30 C> contained in the users table b. A second routine to process ifod messages
    +
    31 C> (ifod0) has been removed in favor of the improved processing of the one
    +
    32 C> remaining (ifod1). New coding has been introduced to permit processing of
    +
    33 C> BUFR messages based on BUFR edition up to and including edition 2. Please
    +
    34 C> note increased size requirements for arrays ident(20) and iptr(40).
    +
    35 C> - Bill Cavanaugh 1991-07-26 Add array mtime to calling sequence to
    +
    36 C> permit inclusion of receipt/transfer times to ifod messages.
    +
    37 C> - Bill Cavanaugh 1991-09-25 All processing of decoded BUFR data into
    +
    38 C> ifod (a local use reformat of BUFR data) has been isolated from this set of
    +
    39 C> routines. For those interested in the ifod form, see w3fl05 in the w3lib
    +
    40 C> routines.
    +
    41 C> - Processing of BUFR messages containing delayed replication has been
    +
    42 C> altered so that single subsets (reports) and and a matching descriptor list
    +
    43 C> for that particular subset will be passed to the user will be passed to the
    +
    44 C> user one at a time to assure that each subset can be fully defined with a
    +
    45 C> minimum of reprocessing.
    +
    46 C> - Processing of associated fields has been tested with messages containing
    +
    47 C> non-compressed data.
    +
    48 C> - In order to facilitate user processing a matching list of scale factors
    +
    49 C> are included with the expanded descriptor list (mstack).
    +
    50 C> - Bill Cavanaugh 1991-11-21 Processing of descriptor 2 03 yyy
    +
    51 C> has corrected to agree with fm94 standards.
    +
    52 C> - Bill Cavanaugh 1991-12-19 Calls to fi6703() and fi6704() have been
    +
    53 C> corrected to agree called program argument list. Some additional entries
    +
    54 C> have been included for communicating with data access routines. Additional
    +
    55 C> error exit provided for the case where table b is damaged.
    +
    56 C> - Bill Cavanaugh 1992-01-24 Routines fi6701(), fi6703() and fi6704()
    +
    57 C> have been modified to handle associated fields all descriptors are set to
    +
    58 C> echo to mstack(1,n)
    +
    59 C> - Bill Cavanaugh 1992-05-21 Further expansion of information collected from
    +
    60 C> within upper air soundings has produced the necessity to expand some of the
    +
    61 C> processing and output arrays. (see remarks below)
    +
    62 C> - Bill Cavanaugh 1992-06-29 Corrected descriptor denoting height of
    +
    63 C> each wind level for profiler conversions.
    +
    64 C> - Bill Cavanaugh 1992-07-23 Expansion of table b requires adjustment
    +
    65 C> of arrays to contain table b values needed to assist in the decoding process.
    +
    66 C> - Arrays containing data from table b:
    +
    67 C> - kdesc descriptor
    +
    68 C> - aname descriptor name
    +
    69 C> - aunits units for descriptor
    +
    70 C> - mscale scale for value of descriptor
    +
    71 C> - mref reference value for descriptor
    +
    72 C> - mwidth bit width for value of descriptor
    +
    73 C> - Bill Cavanaugh 1992-09-09 First encounter with operator descriptor
    +
    74 C> 2 05 yyy showed error in decoding. That error is corrected with this
    +
    75 C> implementation. Further testing of upper air data has encountered the
    +
    76 C> condition of large (many level) soundings arrays in the decoder have been
    +
    77 C> expanded (again) to allow for this condition.
    +
    78 C> - Bill Cavanaugh 1992-10-02 Modified routine to reformat profiler data
    +
    79 C> (fi6709) to show descriptors, scale value and data in proper order.
    +
    80 C> Corrected an error that prevented user from assigning the second dimension
    +
    81 C> of kdata(500,*).
    +
    82 C> - Bill Cavanaugh 1992-10-20 Removed error that prevented full implementation
    +
    83 C> of previous corrections and made corrections to table b to bring it up to
    +
    84 C> date. Changes include proper reformat of profiler data and user capability
    +
    85 C> for assigning second dimension of kdata array.
    +
    86 C> - Bill Cavanaugh 1993-01-26 Added routine fi6710() to permit reformatting
    +
    87 C> profiler data in BUFR edition 2.
    +
    88 C>
    +
    89 C> @param[in] MSGA Array containing supposed bufr message.
    +
    90 C> @param[out] ISTACK Original array of descriptors extracted from
    +
    91 C> source bufr message.
    +
    92 C> @param[out] MSTACK (A,B)
    +
    93 C> - LEVEL B - Descriptor number
    +
    94 C> - LEVEL A = 1 Descriptor
    +
    95 C> - = 2 10**N Scaling to return to original value
    +
    96 C> @param[out] IPTR Utility array.
    +
    97 C> - IPTR( 1)- Error return.
    +
    98 C> - IPTR( 2)- Byte count section 1.
    +
    99 C> - IPTR( 3)- Pointer to start of section 1.
    +
    100 C> - IPTR( 4)- Byte count section 2.
    +
    101 C> - IPTR( 5)- Pointer to start of section 2.
    +
    102 C> - IPTR( 6)- Byte count section 3.
    +
    103 C> - IPTR( 7)- Pointer to start of section 3.
    +
    104 C> - IPTR( 8)- Byte count section 4.
    +
    105 C> - IPTR( 9)- Pointer to start of section 4.
    +
    106 C> - IPTR(10)- Start of requested subset, reserved for dar.
    +
    107 C> - IPTR(11)- Current descriptor ptr in iwork.
    +
    108 C> - IPTR(12)- Last descriptor pos in iwork.
    +
    109 C> - IPTR(13)- Last descriptor pos in istack.
    +
    110 C> - IPTR(14)- Number of table b entries.
    +
    111 C> - IPTR(15)- Requested subset pointer, reserved for dar.
    +
    112 C> - IPTR(16)- Indicator for existance of section 2.
    +
    113 C> - IPTR(17)- Number of reports processed.
    +
    114 C> - IPTR(18)- Ascii/text event.
    +
    115 C> - IPTR(19)- Pointer to start of bufr message.
    +
    116 C> - IPTR(20)- Number of lines from table d.
    +
    117 C> - IPTR(21)- Table b switch.
    +
    118 C> - IPTR(22)- Table d switch.
    +
    119 C> - IPTR(23)- Code/flag table switch.
    +
    120 C> - IPTR(24)- Aditional words added by text info.
    +
    121 C> - IPTR(25)- Current bit number.
    +
    122 C> - IPTR(26)- Data width change.
    +
    123 C> - IPTR(27)- Data scale change.
    +
    124 C> - IPTR(28)- Data reference value change.
    +
    125 C> - IPTR(29)- Add data associated field.
    +
    126 C> - IPTR(30)- Signify characters.
    +
    127 C> - IPTR(31)- Number of expanded descriptors in mstack.
    +
    128 C> - IPTR(32)- Current descriptor segment f.
    +
    129 C> - IPTR(33)- Current descriptor segment x.
    +
    130 C> - IPTR(34)- Current descriptor segment y.
    +
    131 C> - IPTR(35)- Unused.
    +
    132 C> - IPTR(36)- Next descriptor may be undecipherable.
    +
    133 C> - IPTR(37)- Unused.
    +
    134 C> - IPTR(38)- Unused.
    +
    135 C> - IPTR(39)- Delayed replication flag.
    +
    136 C> - 0 - No delayed replication.
    +
    137 C> - 1 - Message contains delayed replication.
    +
    138 C> - IPTR(40)- Number of characters in text for curr descriptor.
    +
    139 C> @param[out] IDENT Array contains message information extracted from bufr message
    +
    140 C> - IDENT( 1)-Edition number (byte 4, section 1).
    +
    141 C> - IDENT( 2)-Originating center (bytes 5-6, section 1).
    +
    142 C> - IDENT( 3)-Update sequence (byte 7, section 1).
    +
    143 C> - IDENT( 4)-Optional section (byte 8, section 1).
    +
    144 C> - IDENT( 5)-Bufr message type (byte 9, section 1).
    +
    145 C> - 0 = Surface (land)
    +
    146 C> - 1 = Surface (ship)
    +
    147 C> - 2 = Vertical soundings other than satellite
    +
    148 C> - 3 = Vertical soundings (satellite)
    +
    149 C> - 4 = Sngl lvl upper-air other than satellite
    +
    150 C> - 5 = Sngl lvl upper-air (satellite)
    +
    151 C> - 6 = Radar
    +
    152 C> - IDENT( 6)-Bufr msg sub-type (byte 10, section 1)
    +
    153 C> | type | sbtyp |
    +
    154 C> | :--- | :---- |
    +
    155 C> | 2 | 7 = profiler |
    +
    156 C> - IDENT(7) - bytes 11-12, section 1).
    +
    157 C> - IDENT(8) - Year of century (byte 13, section 1).
    +
    158 C> - IDENT(9) - Month of year (byte 14, section 1).
    +
    159 C> - IDENT(10) - Day of month (byte 15, section 1).
    +
    160 C> - IDENT(11) - Hour of day (byte 16, section 1).
    +
    161 C> - IDENT(12) - Minute of hour (byte 17, section 1).
    +
    162 C> - IDENT(13) - Rsvd by adp centers (byte 18, section 1).
    +
    163 C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3).
    +
    164 C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3).
    +
    165 C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3).
    +
    166 C> - IDENT(17) - Master table number (byte 4, section 1, ed 2 or gtr).
    +
    167 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    168 C> @param[in] KNR
    +
    169 C> kdata(report number,parameter number) arrays containing data from table b
    +
    170 C> - ANAME Descriptor name.
    +
    171 C> - AUNITS Units for descriptor.
    +
    172 C> - MSCALE Scale for value of descriptor.
    +
    173 C> - MREF Reference value for descriptor.
    +
    174 C> - MWIDTH Bit width for value of descriptor.
    +
    175 C> @param[out] INDEX Pointer to available subset.
    +
    176 C>
    +
    177 C> @note Error returns:
    +
    178 C> - IPTR(1):
    +
    179 C> - = 1 'BUFR' Not found in first 125 characters.
    +
    180 C> - = 2 '7777' Not found in location determined by
    +
    181 C> by using counts found in each section. one or
    +
    182 C> more sections have an erroneous byte count or
    +
    183 C> characters '7777' are not in test message.
    +
    184 C> - = 3 Message contains a descriptor with f=0 that does
    +
    185 C> not exist in table b.
    +
    186 C> - = 4 Message contains a descriptor with f=3 that does
    +
    187 C> not exist in table d.
    +
    188 C> - = 5 Message contains a descriptor with f=2 with the
    +
    189 C> value of x outside the range 1-5.
    +
    190 C> - = 6 Descriptor element indicated to have a flag value
    +
    191 C> does not have an entry in the flag table
    +
    192 C> (to be activated).
    +
    193 C> - = 7 Descriptor indicated to have a code value does
    +
    194 C> not have an entry in the code table
    +
    195 C> (to be activated).
    +
    196 C> - = 8 Error reading table d.
    +
    197 C> - = 9 Error reading table b.
    +
    198 C> - = 10 Error reading code/flag table.
    +
    199 C> - = 11 Descriptor 2 04 004 not followed by 0 31 021.
    +
    200 C> - = 12 Data descriptor operator qualifier does not follow
    +
    201 C> delayed replication descriptor.
    +
    202 C> - = 13 Bit width on ascii characters not a multiple of 8.
    +
    203 C> - = 14 Subsets = 0, no content bulletin.
    +
    204 C> - = 20 Exceeded count for delayed replication pass.
    +
    205 C> - = 21 Exceeded count for non-delayed replication pass.
    +
    206 C> - = 22 Section 1 count exceeds 10000.
    +
    207 C> - = 23 Section 2 count exceeds 10000.
    +
    208 C> - = 24 Section 3 count exceeds 10000.
    +
    209 C> - = 25 Section 4 count exceeds 10000.
    +
    210 C> - = 27 Non zero lowest on text data.
    +
    211 C> - = 28 Nbinc not nr of characters.
    +
    212 C> - = 29 Table b appears to be damaged.
    +
    213 C> - = 99 No more subsets (reports) available in current
    +
    214 C> bufr mesage.
    +
    215 C> - = 400 Number of subsets exceeds capability of routine.
    +
    216 C> - = 401 Number of parameters (and associated fields)
    +
    217 C> exceeds limits of this program.
    +
    218 C> - = 500 Value for nbinc has been found that exceeds
    +
    219 C> standard width plus any bit width change
    +
    220 C> check all bit widths up to point of error.
    +
    221 C> - = 501 Corrected width for descriptor is 0 or less.
    +
    222 C>
    +
    223 C> On the initial call to w3fi67() with a bufr message the argument
    +
    224 C> index must be set to zero (index = 0). on the return from w3fi67()
    +
    225 C> 'index' will be set to the next available subset/report. when
    +
    226 C> there are no more subsets available a 99 err return will occur.
    +
    227 C>
    +
    228 C> If the original bufr message does not contain delayed replication
    +
    229 C> the bufr message will be completely decoded and 'index' will point
    +
    230 C> to the first decoded subset. The users will then have the option
    +
    231 C> of indexing through the subsets on their own or by recalling this
    +
    232 C> routine (without resetting 'index') to have the routine do the
    +
    233 C> indexing.
    +
    234 C>
    +
    235 C> If the original bufr message does contain delayed replication
    +
    236 C> one subset/report will be decoded at a time and passed back to
    +
    237 C> the user. this is not an option.
    +
    238 C>
    +
    239 C> =============================================
    +
    240 C> TO USE THIS ROUTINE
    +
    241 C> --------------------------------
    +
    242 C> 1. READ IN BUFR MESSAGE
    +
    243 C> 2. SET INDEX = 0
    +
    244 C> 3. CALL W3FI67( )
    +
    245 C> 4. IF (IPTR(1).EQ.99) THEN
    +
    246 C> NO MORE SUBSETS
    +
    247 C> EITHER GO TO 1
    +
    248 C> OR TERMINATE IN NO MORE BUFR MESSAGES
    +
    249 C> END IF
    +
    250 C> 5. IF (IPTR(1).NE.0) THEN
    +
    251 C> ERROR CONDITION
    +
    252 C> EITHER GO TO 1
    +
    253 C> OR TERMINATE IN NO MORE BUFR MESSAGES
    +
    254 C> END IF
    +
    255 C> 6. THE VALUE OF INDEX INDICATES THE ACTIVE SUBSET SO
    +
    256 C> IF INTERESTED IN GENERATING AN IFOD MESSAGE
    +
    257 C> CALL W3FL05 ( )
    +
    258 C> ELSE
    +
    259 C> PROCESS DECODED INFORMATION AS REQUIRED
    +
    260 C> END IF
    +
    261 C> 7. GO TO 3
    +
    262 C>
    +
    263 C> =============================================
    +
    264 C> THE ARRAYS TO CONTAIN THE OUTPUT INFORMATION ARE DEFINED
    +
    265 C> AS FOLLOWS:
    +
    266 C> KDATA(A,B) IS THE A DATA ENTRY (INTEGER VALUE)
    +
    267 C> WHERE A IS THE MAXIMUM NUMBER OF REPORTS/SUBSETS
    +
    268 C> (FOR THIS VERSION OF THE DECODER A=500)
    +
    269 C> THAT MAY BE CONTAINED IN THE BUFR MESSAGE, AND
    +
    270 C> WHERE B IS THE MAXIMUM NUMBER OF DESCRIPTOR
    +
    271 C> COMBINATIONS THAT MAY BE PROCESSED.
    +
    272 C> UPPER AIR DATA AND SOME SATELLITE DATA REQUIRE
    +
    273 C> A VALUE FOR B OF 1600, BUT FOR MOST OTHER DATA
    +
    274 C> A VALUE FOR B OF 500 WILL SUFFICE
    +
    275 C> MSTACK(1,B) CONTAINS THE DESCRIPTOR THAT MATCHES THE
    +
    276 C> DATA ENTRY
    +
    277 C> MSTACK(2,B) IS THE SCALE (POWER OF 10) TO BE APPLIED TO
    +
    278 C> THE DATA
    +
    279 C>
    +
    280 C> ATTRIBUTES:
    +
    281 C> LANGUAGE: FORTRAN 77
    +
    282 C> MACHINE: NAS
    +
    283 C>
    +
    284  SUBROUTINE w3fi67(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX)
    +
    285 C
    +
    286  CHARACTER*40 ANAME(700)
    +
    287  CHARACTER*24 AUNITS(700)
    +
    288 C
    +
    289 C
    +
    290  INTEGER MSGA(*),KDATA(500,*)
    +
    291  INTEGER IPTR(*),MSTACK(2,*)
    +
    292  INTEGER IVALS(500),KNR(*)
    +
    293  INTEGER IDENT(*)
    +
    294  INTEGER KDESC(1600)
    +
    295  INTEGER ISTACK(*),IWORK(1600)
    +
    296  INTEGER MSCALE(700)
    +
    297  INTEGER MREF(700,3)
    +
    298  INTEGER MWIDTH(700)
    +
    299  INTEGER INDEX
    +
    300 C
    +
    301  CHARACTER*4 DIRID(2)
    +
    302 C
    +
    303  LOGICAL SEC2
    +
    304 C
    +
    305  SAVE
    +
    306 C
    +
    307 C PRINT *,' W3FI67 DECODER'
    +
    308 C INITIALIZE ERROR RETURN
    +
    309  iptr(1) = 0
    +
    310  IF (index.GT.0) THEN
    +
    311 C HAVE RE-ENTRY
    +
    312  index = index + 1
    +
    313 C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX
    +
    314  IF (index.GT.ident(14)) THEN
    +
    315 C ALL SUBSETS PROCESSED
    +
    316  iptr(1) = 99
    +
    317  iptr(39) = 0
    +
    318  ELSE IF (index.LE.ident(14)) THEN
    +
    319  IF (iptr(39).NE.0) THEN
    +
    320  CALL fi6701(iptr,ident,msga,istack,iwork,aname,kdata,
    +
    321  * ivals,
    +
    322  * mstack,aunits,kdesc,mwidth,mref,mscale,knr,index)
    +
    323  END IF
    +
    324  END IF
    +
    325  RETURN
    +
    326  ELSE
    +
    327  index = 1
    +
    328 C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE'
    +
    329  END IF
    +
    330  iptr(39) = 0
    +
    331 C FIND 'BUFR' IN FIRST 125 CHARACTERS
    +
    332  DO 1000 knofst = 0, 999, 8
    +
    333  inofst = knofst
    +
    334  CALL gbyte (msga,ivals,inofst,8)
    +
    335  IF (ivals(1).EQ.66) THEN
    +
    336  iptr(19) = inofst
    +
    337  inofst = inofst + 8
    +
    338  CALL gbyte (msga,ivals,inofst,24)
    +
    339  IF (ivals(1).EQ.5588562) THEN
    +
    340 C PRINT *,'FOUND BUFR AT',IPTR(19)
    +
    341  inofst = inofst + 24
    +
    342  GO TO 1500
    +
    343  END IF
    +
    344  END IF
    +
    345  1000 CONTINUE
    +
    346  print *,'BUFR - START OF BUFR MESSAGE NOT FOUND'
    +
    347  iptr(1) = 1
    +
    348  RETURN
    +
    349  1500 CONTINUE
    +
    350  ident(1) = 0
    +
    351 C TEST FOR EDITION NUMBER
    +
    352 C ======================
    +
    353  CALL gbyte (msga,ident(1),inofst+24,8)
    +
    354 C PRINT *,'THIS IS AN EDITION ',IDENT(1),' BUFR MESSAGE'
    +
    355  IF (ident(1).GE.2) THEN
    +
    356  CALL gbyte (msga,ivals,inofst,24)
    +
    357  itotal = ivals(1)
    +
    358  kender = itotal * 8 - 32 + iptr(19)
    +
    359  CALL gbyte (msga,ilast,kender,32)
    +
    360  IF (ilast.EQ.926365495) THEN
    +
    361 C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1)
    +
    362  inofst = inofst + 32
    +
    363  END IF
    +
    364  iptr(3) = inofst
    +
    365 C SECTION 1 COUNT
    +
    366  CALL gbyte (msga,ivals,inofst,24)
    +
    367 C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
    +
    368  inofst = inofst + 24
    +
    369  iptr( 2) = ivals(1)
    +
    370  IF (ivals(1).GT.10000) THEN
    +
    371  iptr(1) = 22
    +
    372  RETURN
    +
    373  END IF
    +
    374 C GET BUFR MASTER TABLE
    +
    375  CALL gbyte (msga,ivals,inofst,8)
    +
    376  inofst = inofst + 8
    +
    377  ident(17) = ivals(1)
    +
    378 C PRINT *,'BUFR MASTER TABLE NR',IDENT(17)
    +
    379  ELSE
    +
    380  iptr(3) = inofst
    +
    381 C SECTION 1 COUNT
    +
    382  CALL gbyte (msga,ivals,inofst,24)
    +
    383 C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
    +
    384  inofst = inofst + 32
    +
    385  iptr( 2) = ivals(1)
    +
    386  IF (ivals(1).GT.10000) THEN
    +
    387  iptr(1) = 22
    +
    388  RETURN
    +
    389  END IF
    +
    390  END IF
    +
    391 C ======================
    +
    392 C ORIGINATING CENTER
    +
    393  CALL gbyte (msga,ivals,inofst,16)
    +
    394  inofst = inofst + 16
    +
    395  ident(2) = ivals(1)
    +
    396 C UPDATE SEQUENCE
    +
    397  CALL gbyte (msga,ivals,inofst,8)
    +
    398  inofst = inofst + 8
    +
    399  ident(3) = ivals(1)
    +
    400 C OPTIONAL SECTION FLAG
    +
    401  CALL gbyte (msga,ivals,inofst,1)
    +
    402  ident(4) = ivals(1)
    +
    403  IF (ident(4).GT.0) THEN
    +
    404  sec2 = .true.
    +
    405  ELSE
    +
    406 C PRINT *,' NO OPTIONAL SECTION 2'
    +
    407  sec2 = .false.
    +
    408  END IF
    +
    409  inofst = inofst + 8
    +
    410 C MESSAGE TYPE
    +
    411  CALL gbyte (msga,ivals,inofst,8)
    +
    412  ident(5) = ivals(1)
    +
    413  inofst = inofst + 8
    +
    414 C MESSAGE SUB-TYPE
    +
    415  CALL gbyte (msga,ivals,inofst,8)
    +
    416  ident(6) = ivals(1)
    +
    417  inofst = inofst + 8
    +
    418 C IF BUFR EDITION 0 OR 1 THEN
    +
    419 C NEXT 2 BYTES ARE BUFR TABLE VERSION
    +
    420 C ELSE
    +
    421 C BYTE 11 IS VER NR OF MASTER TABLE
    +
    422 C BYTE 12 IS VER NR OF LOCAL TABLE
    +
    423  IF (ident(1).LT.2) THEN
    +
    424  CALL gbyte (msga,ivals,inofst,16)
    +
    425  ident(7) = ivals(1)
    +
    426  inofst = inofst + 16
    +
    427  ELSE
    +
    428 C BYTE 11 IS VER NR OF MASTER TABLE
    +
    429  CALL gbyte (msga,ivals,inofst,8)
    +
    430  ident(18) = ivals(1)
    +
    431  inofst = inofst + 8
    +
    432 C BYTE 12 IS VER NR OF LOCAL TABLE
    +
    433  CALL gbyte (msga,ivals,inofst,8)
    +
    434  ident(19) = ivals(1)
    +
    435  inofst = inofst + 8
    +
    436 
    +
    437  END IF
    +
    438 C YEAR OF CENTURY
    +
    439  CALL gbyte (msga,ivals,inofst,8)
    +
    440  ident(8) = ivals(1)
    +
    441  inofst = inofst + 8
    +
    442 C MONTH
    +
    443  CALL gbyte (msga,ivals,inofst,8)
    +
    444  ident(9) = ivals(1)
    +
    445  inofst = inofst + 8
    +
    446 C DAY
    +
    447  CALL gbyte (msga,ivals,inofst,8)
    +
    448  ident(10) = ivals(1)
    +
    449  inofst = inofst + 8
    +
    450 C HOUR
    +
    451  CALL gbyte (msga,ivals,inofst,8)
    +
    452  ident(11) = ivals(1)
    +
    453  inofst = inofst + 8
    +
    454 C MINUTE
    +
    455  CALL gbyte (msga,ivals,inofst,8)
    +
    456  ident(12) = ivals(1)
    +
    457 C RESET POINTER (INOFST) TO START OF
    +
    458 C NEXT SECTION
    +
    459 C (SECTION 2 OR SECTION 3)
    +
    460  inofst = iptr(3) + iptr(2) * 8
    +
    461  iptr(4) = 0
    +
    462  iptr(5) = inofst
    +
    463  IF (sec2) THEN
    +
    464  iptr(5) = inofst
    +
    465 C SECTION 2 COUNT
    +
    466  CALL gbyte (msga,iptr(4),inofst,24)
    +
    467  inofst = inofst + 32
    +
    468 C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4)
    +
    469  kentry = (iptr(4) - 4) / 14
    +
    470 C PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS'
    +
    471  IF (ident(2).EQ.7) THEN
    +
    472  DO 2000 i = 1, kentry
    +
    473  CALL gbyte (msga,kdspl ,inofst,16)
    +
    474  inofst = inofst + 16
    +
    475  CALL gbyte (msga,lat ,inofst,16)
    +
    476  inofst = inofst + 16
    +
    477  CALL gbyte (msga,lon ,inofst,16)
    +
    478  inofst = inofst + 16
    +
    479  CALL gbyte (msga,kdahr ,inofst,16)
    +
    480  inofst = inofst + 16
    +
    481  CALL gbyte (msga,dirid(1),inofst,32)
    +
    482  inofst = inofst + 32
    +
    483  CALL gbyte (msga,dirid(2),inofst,16)
    +
    484  inofst = inofst + 16
    +
    485 C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2)
    +
    486  2000 CONTINUE
    +
    487  END IF
    +
    488 C RESET POINTER (INOFST) TO START OF
    +
    489 C SECTION 3
    +
    490  inofst = iptr(5) + iptr(4) * 8
    +
    491  END IF
    +
    492 C BIT OFFSET TO START OF SECTION 3
    +
    493  iptr( 7) = inofst
    +
    494 C SECTION 3 COUNT
    +
    495  CALL gbyte (msga,iptr(6),inofst,24)
    +
    496 C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6)
    +
    497  inofst = inofst + 24
    +
    498  IF (iptr(6).GT.10000) THEN
    +
    499  iptr(1) = 24
    +
    500  RETURN
    +
    501  END IF
    +
    502  inofst = inofst + 8
    +
    503 C NUMBER OF DATA SUBSETS
    +
    504  CALL gbyte (msga,ident(14),inofst,16)
    +
    505  IF (ident(14).GT.500) THEN
    +
    506  print *,'THE NUMBER OF SUBSETS EXCEEDS THE CAPABILITY'
    +
    507  print *,'OF THIS VERSION OF THE BUFR DECODER. ANOTHER '
    +
    508  print *,'VERSION MUST BE CONSTRUCTED TO HANDLE AT LEAST'
    +
    509  print *,ident(14),'SUBSETS TO BE ABLE TO PROCESS THIS DATA'
    +
    510  iptr(1) = 400
    +
    511  RETURN
    +
    512  END IF
    +
    513  inofst = inofst + 16
    +
    514 C OBSERVED DATA FLAG
    +
    515  CALL gbyte (msga,ivals,inofst,1)
    +
    516  ident(15) = ivals(1)
    +
    517  inofst = inofst + 1
    +
    518 C COMPRESSED DATA FLAG
    +
    519  CALL gbyte (msga,ivals,inofst,1)
    +
    520  ident(16) = ivals(1)
    +
    521  inofst = inofst + 7
    +
    522 C CALCULATE NUMBER OF DESCRIPTORS
    +
    523  nrdesc = (iptr( 6) - 8) / 2
    +
    524  iptr(12) = nrdesc
    +
    525  iptr(13) = nrdesc
    +
    526 C EXTRACT DESCRIPTORS
    +
    527  CALL gbytes (msga,istack,inofst,16,0,nrdesc)
    +
    528 C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS'
    +
    529  DO 10 l = 1, nrdesc
    +
    530  iwork(l) = istack(l)
    +
    531 C PRINT *,L,ISTACK(L)
    +
    532  10 CONTINUE
    +
    533  iptr(13) = nrdesc
    +
    534 C RESET POINTER TO START OF SECTION 4
    +
    535  inofst = iptr(7) + iptr(6) * 8
    +
    536 C BIT OFFSET TO START OF SECTION 4
    +
    537  iptr( 9) = inofst
    +
    538 C SECTION 4 COUNT
    +
    539  CALL gbyte (msga,ivals,inofst,24)
    +
    540  IF (ivals(1).GT.10000) THEN
    +
    541  iptr(1) = 25
    +
    542  RETURN
    +
    543  END IF
    +
    544 C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1)
    +
    545  iptr( 8) = ivals(1)
    +
    546  inofst = inofst + 32
    +
    547 C SET FOR STARTING BIT OF DATA
    +
    548  iptr(25) = inofst
    +
    549 C FIND OUT IF '7777' TERMINATOR IS THERE
    +
    550  inofst = iptr(9) + iptr(8) * 8
    +
    551  CALL gbyte (msga,ivals,inofst,32)
    +
    552 C PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1)
    +
    553  IF (ivals(1).NE.926365495) THEN
    +
    554  print *,'BAD SECTION COUNT'
    +
    555  iptr(1) = 2
    +
    556  RETURN
    +
    557  ELSE
    +
    558  iptr(1) = 0
    +
    559  END IF
    +
    560  CALL fi6701(iptr,ident,msga,istack,iwork,aname,kdata,ivals,
    +
    561  * mstack,aunits,kdesc,mwidth,mref,mscale,knr,index)
    +
    562 C PRINT *,'HAVE RETURNED FROM FI6701'
    +
    563  IF (iptr(1).NE.0) THEN
    +
    564  RETURN
    +
    565  END IF
    +
    566 C FURTHER PROCESSING REQUIRED FOR PROFILER DATA
    +
    567  IF (ident(5).EQ.2) THEN
    +
    568  IF (ident(6).EQ.7) THEN
    +
    569 C DO 151 I = 1, 40
    +
    570 C IF (I.LE.20) THEN
    +
    571 C PRINT *,'IPTR(',I,')=',IPTR(I),
    +
    572 C * ' IDENT(',I,')= ',IDENT(I)
    +
    573 C ELSE
    +
    574 C PRINT *,'IPTR(',I,')=',IPTR(I)
    +
    575 C END IF
    +
    576 C 151 CONTINUE
    +
    577 C DO 153 I = 1, KNR(INDEX)
    +
    578 C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
    +
    579 C 153 CONTINUE
    +
    580  print *,'REFORMAT PROFILER DATA'
    +
    581  IF (ident(1).LT.2) THEN
    +
    582  CALL fi6709(ident,mstack,kdata,iptr)
    +
    583  ELSE
    +
    584  CALL fi6710(ident,mstack,kdata,iptr)
    +
    585  END IF
    +
    586  IF (iptr(1).NE.0) THEN
    +
    587  RETURN
    +
    588  END IF
    +
    589 C DO 154 I = 1, KNR(INDEX)
    +
    590 C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
    +
    591 C 154 CONTINUE
    +
    592  END IF
    +
    593  END IF
    +
    594  RETURN
    +
    595  END
    +
    596 
    +
    597 C> @brief Data extraction.
    +
    598 C> @author Bill Cavanaugh @date 1988-09-01
    +
    599 
    +
    600 C> Control the extraction of data from section 4 based on
    +
    601 C> data descriptors.
    +
    602 C>
    +
    603 C> Program history log:
    +
    604 C> - Bill Cavanaugh 1988-09-01
    +
    605 C> - Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed
    +
    606 C> data.
    +
    607 C> - Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with
    +
    608 C> delayed replication.
    +
    609 C> - Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
    +
    610 C>
    +
    611 C> @param[in] IPTR See w5fi67 routine docblock.
    +
    612 C> @param[in] IDENT See w3fi67 routine docblock.
    +
    613 C> @param[in] MSGA Array containing bufr message.
    +
    614 C> @param[inout] ISTACK [in] Original array of descriptors extracted from
    +
    615 C> source bufr message. [out] Arrays containing data from table b.
    +
    616 C> @param[in] MSTACK Working array of descriptors (expanded)and scaling
    +
    617 C> factor.
    +
    618 C> @param[inout] KDESC Image of current descriptor.
    +
    619 C> @param[in] INDEX
    +
    620 C> @param KNR
    +
    621 C> @param[out] IWORK Working descriptor list
    +
    622 C> @param IVALS
    +
    623 C> @param[out] KDATA Array containing decoded reports from bufr message
    +
    624 C> kdata(report number,parameter number).
    +
    625 C> @param[out] ANAME Descriptor name..
    +
    626 C> @param[out] AUNITS Units for descriptor.
    +
    627 C> @param[out] MSCALE Scale for value of descriptor.
    +
    628 C> @param[out] MREF Reference value for descriptor.
    +
    629 C> @param[out] MWIDTH Bit width for value of descriptor.
    +
    630 C>
    +
    631 C> @note Error return:
    +
    632 C> - IPTR(1)
    +
    633 C> - = 8 ERROR READING TABLE B
    +
    634 C> - = 9 ERROR READING TABLE D
    +
    635 C> - = 11 ERROR OPENING TABLE B
    +
    636 C>
    +
    637 C> @author Bill Cavanaugh @date 1988-09-01
    +
    638  SUBROUTINE fi6701(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,IVALS,
    +
    639  * MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX)
    +
    640 
    +
    641  SAVE
    +
    642 C
    +
    643  CHARACTER*40 ANAME(*)
    +
    644  CHARACTER*24 AUNITS(*)
    +
    645 C
    +
    646  INTEGER MSGA(*),KDATA(500,*),IVALS(*)
    +
    647  INTEGER MSCALE(*),KNR(*)
    +
    648  INTEGER LX,LY,LL,J
    +
    649  INTEGER MREF(700,3)
    +
    650  INTEGER MWIDTH(*)
    +
    651  INTEGER IHOLD(33)
    +
    652  INTEGER ITBLD(500,11)
    +
    653  INTEGER IPTR(*)
    +
    654  INTEGER IDENT(*)
    +
    655  INTEGER KDESC(*)
    +
    656  INTEGER ISTACK(*),IWORK(*)
    +
    657  INTEGER MSTACK(2,*),KK
    +
    658  INTEGER JDESC
    +
    659  INTEGER INDEX
    +
    660  INTEGER ITEST(30)
    +
    661 C
    +
    662  DATA itest /1,3,7,15,31,63,127,255,
    +
    663  * 511,1023,2047,4095,8191,16383,
    +
    664  * 32767, 65535,131071,262143,524287,
    +
    665  * 1048575,2097151,4194303,8388607,
    +
    666  * 16777215,33554431,67108863,134217727,
    +
    667  * 268435455,536870911,1073741823/
    +
    668 C
    +
    669 C PRINT *,' DECOLL FI6701'
    +
    670  IF (index.GT.1) THEN
    +
    671  GO TO 1000
    +
    672  END IF
    +
    673 C --------- DECOLL ---------------
    +
    674  iptr(23) = 0
    +
    675  iptr(26) = 0
    +
    676  iptr(27) = 0
    +
    677  iptr(28) = 0
    +
    678  iptr(29) = 0
    +
    679  iptr(30) = 0
    +
    680  iptr(36) = 0
    +
    681 C INITIALIZE OUTPUT AREA
    +
    682 C SET POINTER TO BEGINNING OF DATA
    +
    683 C SET BIT
    +
    684  iptr(17) = 1
    +
    685  1000 CONTINUE
    +
    686 C IPTR(12) = IPTR(13)
    +
    687  ll = 0
    +
    688  iptr(11) = 1
    +
    689  IF (iptr(10).EQ.0) THEN
    +
    690 C RE-ENTRY POINT FOR MULTIPLE
    +
    691 C NON-COMPRESSED REPORTS
    +
    692  ELSE
    +
    693  index = iptr(15)
    +
    694  iptr(17) = index
    +
    695  iptr(25) = iptr(10)
    +
    696  iptr(10) = 0
    +
    697  iptr(15) = 0
    +
    698  END IF
    +
    699 C PRINT *,'FI6701 - RPT',IPTR(17),' STARTS AT',IPTR(25)
    +
    700  iptr(24) = 0
    +
    701  iptr(31) = 0
    +
    702 C POINTING AT NEXT AVAILABLE DESCRIPTOR
    +
    703  mm = 0
    +
    704  IF (iptr(21).EQ.0) THEN
    +
    705 C PRINT *,' READING TABLE B'
    +
    706  DO 150 i = 1, 700
    +
    707  iptr(21) = i
    +
    708  READ(unit=20,fmt=20,err=9999,END=175)MF,
    +
    709  * mx,my,
    +
    710  * (aname(i)(k:k),k=1,40),
    +
    711  * (aunits(i)(k:k),k=1,24),
    +
    712  * mscale(i),mref(i,1),mwidth(i)
    +
    713  20 FORMAT(i1,i2,i3,40a1,24a1,i5,i15,1x,i4)
    +
    714  IF (mwidth(i).EQ.0) THEN
    +
    715  iptr(1) = 29
    +
    716  RETURN
    +
    717  END IF
    +
    718  mref(i,2) = 0
    +
    719  iptr(14) = i
    +
    720  kdesc(i) = mf*16384 + mx*256 + my
    +
    721 C PRINT *,I
    +
    722 C WRITE(6,21) MF,MX,MY,KDESC(I),
    +
    723 C * (ANAME(I)(K:K),K=1,40),
    +
    724 C * (AUNITS(I)(K:K),K=1,24),
    +
    725 C * MSCALE(I),MREF(I,1),MWIDTH(I)
    +
    726  21 FORMAT(1x,i1,i2,i3,1x,i6,1x,40a1,
    +
    727  * 2x,24a1,2x,i5,2x,i15,1x,i4)
    +
    728  150 CONTINUE
    +
    729  print *,'HAVE READ LIMIT OF 700 TABLE B DESCRIPTORS'
    +
    730  print *,'IF THERE ARE MORE THAT THAT, CORRECT READ LOOP'
    +
    731  175 CONTINUE
    +
    732 C CLOSE(UNIT=20,STATUS='KEEP')
    +
    733  iptr(21) = 1
    +
    734  END IF
    +
    735 C DO WHILE MM <= 500
    +
    736  10 CONTINUE
    +
    737 C PROCESS THRU THE FOLLOWING
    +
    738 C DEPENDING UPON THE VALUE OF 'F' (LF)
    +
    739  mm = mm + 1
    +
    740  12 CONTINUE
    +
    741  IF (mm.GT.2000) THEN
    +
    742  GO TO 200
    +
    743  END IF
    +
    744 C END OF CYCLE TEST (SERIAL/SEQUENTIAL)
    +
    745  IF (iptr(11).GT.iptr(12)) THEN
    +
    746 C PRINT *,' HAVE COMPLETED REPORT SEQUENCE'
    +
    747  IF (ident(16).NE.0) THEN
    +
    748 C PRINT *,' PROCESSING COMPRESSED REPORTS'
    +
    749 C REFORMAT DATA FROM DESCRIPTOR
    +
    750 C FORM TO USER FORM
    +
    751  RETURN
    +
    752  ELSE
    +
    753 C WRITE (6,1)
    +
    754 C 1 FORMAT (1H1)
    +
    755 C PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25)
    +
    756  iptr(17) = iptr(17) + 1
    +
    757  IF (iptr(17).GT.ident(14)) THEN
    +
    758  iptr(17) = iptr(17) - 1
    +
    759  GO TO 200
    +
    760  END IF
    +
    761  DO 300 i = 1, iptr(13)
    +
    762  iwork(i) = istack(i)
    +
    763  300 CONTINUE
    +
    764 C RESET POINTERS
    +
    765  ll = 0
    +
    766  iptr(1) = 0
    +
    767  iptr(11) = 1
    +
    768  iptr(12) = iptr(13)
    +
    769 C IS THIS LAST REPORT ?
    +
    770 C PRINT *,'READY',IPTR(39),INDEX
    +
    771  IF (iptr(39).GT.0) THEN
    +
    772  IF (index.GT.0) THEN
    +
    773 C PRINT *,'HERE IS SUBSET NR',INDEX
    +
    774  RETURN
    +
    775  END IF
    +
    776  END IF
    +
    777  GO TO 1000
    +
    778  END IF
    +
    779  END IF
    +
    780  14 CONTINUE
    +
    781 C GET NEXT DESCRIPTOR
    +
    782  CALL fi6708 (iptr,iwork,lf,lx,ly,jdesc)
    +
    783 C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ',
    +
    784 C * IPTR(11),IWORK(IPTR(11)),IPTR(31)
    +
    785 C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY,
    +
    786 C * ' FOR LOC',IPTR(17),IPTR(25)
    +
    787  IF (iptr(11).GT.1600) THEN
    +
    788  iptr(1) = 401
    +
    789  RETURN
    +
    790  END IF
    +
    791 C
    +
    792  kprm = iptr(31) + iptr(24)
    +
    793  IF (kprm.GT.1600) THEN
    +
    794  IF (kprm.GT.kold) THEN
    +
    795  print *,'EXCEEDED ARRAY SIZE',kprm,iptr(31),
    +
    796  * iptr(24)
    +
    797  kold = kprm
    +
    798  END IF
    +
    799  END IF
    +
    800 C REPLICATION PROCESSING
    +
    801  IF (lf.EQ.1) THEN
    +
    802 C ---------- F1 ---------
    +
    803  iptr(31) = iptr(31) + 1
    +
    804  kprm = iptr(31) + iptr(24)
    +
    805  mstack(1,kprm) = jdesc
    +
    806  mstack(2,kprm) = 0
    +
    807  kdata(iptr(17),kprm) = 0
    +
    808 C PRINT *,'FI6701-1',KPRM,MSTACK(1,KPRM),
    +
    809 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    810  CALL fi6705(iptr,ident,msga,iwork,lx,ly,
    +
    811  * kdata,ll,knr,mstack)
    +
    812  IF (iptr(1).NE.0) THEN
    +
    813  RETURN
    +
    814  ELSE
    +
    815  GO TO 12
    +
    816  END IF
    +
    817 C
    +
    818 C DATA DESCRIPTION OPERATORS
    +
    819  ELSE IF (lf.EQ.2)THEN
    +
    820  IF (lx.EQ.5) THEN
    +
    821  ELSE IF (lx.EQ.4) THEN
    +
    822  iptr(31) = iptr(31) + 1
    +
    823  kprm = iptr(31) + iptr(24)
    +
    824  mstack(1,kprm) = jdesc
    +
    825  mstack(2,kprm) = 0
    +
    826  kdata(iptr(17),kprm) = 0
    +
    827 C PRINT *,'FI6701-2',KPRM,MSTACK(1,KPRM),
    +
    828 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    829  END IF
    +
    830  CALL fi6706 (iptr,lx,ly,ident,msga,kdata,ivals,mstack,
    +
    831  * mwidth,mref,mscale,j,ll,kdesc,iwork,jdesc)
    +
    832  IF (iptr(1).NE.0) THEN
    +
    833  RETURN
    +
    834  END IF
    +
    835  GO TO 12
    +
    836 C DESCRIPTOR SEQUENCE STRINGS
    +
    837  ELSE IF (lf.EQ.3) THEN
    +
    838 C PRINT *,'F3 SEQUENCE DESCRIPTOR'
    +
    839  IF (iptr(22).EQ.0) THEN
    +
    840 C READ IN TABLE D, BUT JUST ONCE
    +
    841  ierr = 0
    +
    842 C PRINT *,' READING TABLE D'
    +
    843  DO 50 i = 1, 500
    +
    844  READ(21,15,err=9998,END=75 )
    +
    845  * (ihold(j),j=1,33)
    +
    846  15 FORMAT(11(i1,i2,i3,1x),3x)
    +
    847  iptr(20) = i
    +
    848  DO 25 jj = 1, 31, 3
    +
    849  kk = (jj/3) + 1
    +
    850  itbld(i,kk) = ihold(jj)*16384 +
    +
    851  * ihold(jj+1)*256 + ihold(jj+2)
    +
    852  IF (itbld(i,kk).EQ.0) THEN
    +
    853 C PRINT 16,(ITBLD(I,L),L=1,11)
    +
    854  GO TO 50
    +
    855  END IF
    +
    856  25 CONTINUE
    +
    857 C PRINT 16,(ITBLD(I,L),L=1,11)
    +
    858  50 CONTINUE
    +
    859  16 FORMAT(1x,11(i6,1x))
    +
    860  75 CONTINUE
    +
    861  CLOSE(unit=21,status='KEEP')
    +
    862  iptr(22) = 1
    +
    863  ENDIF
    +
    864  CALL fi6707(iptr,iwork,itbld,jdesc)
    +
    865  IF (iptr(1).GT.0) THEN
    +
    866  RETURN
    +
    867  END IF
    +
    868  GO TO 14
    +
    869 C
    +
    870 C STANDARD DESCRIPTOR PROCESSING
    +
    871  ELSE
    +
    872 C PRINT *,'ENTRY',IPTR(31),JDESC,' AT',IPTR(25)
    +
    873  kprm = iptr(31) + iptr(24)
    +
    874  CALL fi6702(iptr,ident,msga,kdata,kdesc,ll,mstack,
    +
    875  * aunits,mwidth,mref,mscale,jdesc,ivals,j)
    +
    876 C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR
    +
    877  iptr(36) = 0
    +
    878  IF (iptr(1).GT.0) THEN
    +
    879  RETURN
    +
    880  ELSE
    +
    881  IF (ident(16).EQ.0) THEN
    +
    882  knr(iptr(17)) = iptr(31)
    +
    883  ELSE
    +
    884  DO 310 kj = 1, 500
    +
    885  knr(kj) = iptr(31)
    +
    886  310 CONTINUE
    +
    887  END IF
    +
    888  GO TO 10
    +
    889  END IF
    +
    890  END IF
    +
    891 C END IF
    +
    892 C END DO WHILE
    +
    893  200 CONTINUE
    +
    894  IF (ident(16).NE.0) THEN
    +
    895 C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
    +
    896  ELSE
    +
    897 C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS'
    +
    898  END IF
    +
    899  RETURN
    +
    900  9998 CONTINUE
    +
    901  print *,' ERROR READING TABLE D'
    +
    902  iptr(1) = 8
    +
    903  RETURN
    +
    904  9999 CONTINUE
    +
    905  print *,' ERROR READING TABLE B'
    +
    906  iptr(1) = 9
    +
    907  RETURN
    +
    908  END
    +
    909 C> @brief Process standard descriptor.
    +
    910 C> @author Bill Cavanaugh @date 1988-09-01
    +
    911 
    +
    912 C> Process a standard descriptor (f = 0) and store data
    +
    913 C> in output array.
    +
    914 C>
    +
    915 C> Program history log:
    +
    916 C> - Bill Cavanaugh 1988-09-01
    +
    917 C> - Bill Cavanaugh 1991-04-04 Changed to pass width of text fields in bytes.
    +
    918 C>
    +
    919 C> @param[in] IPTR See w3fi67 routine docblock.
    +
    920 C> @param[in] IDENT See w3fi67 routine docblock.
    +
    921 C> @param[in] MSGA Array containing bufr message.
    +
    922 C> @param[inout] KDATA Array containing decoded reports from bufr message.
    +
    923 C> KDATA(Report number, parameter number)
    +
    924 C> @param[inout] KDESC Image of current descriptor.
    +
    925 C> @param[in] MSTACK
    +
    926 C> @param LL
    +
    927 C> @param[out] AUNITS Units for descriptor.
    +
    928 C> @param[out] MSCALE Scale for value of descriptor.
    +
    929 C> @param[out] MREF Reference value for descriptor.
    +
    930 C> @param[out] MWIDTH Bit width for value of descriptor.
    +
    931 C> @param JDESC
    +
    932 C> @param[in] IVALS Array of single parameter values.
    +
    933 C> @param J
    +
    934 C>
    +
    935 C> @note Error return:
    +
    936 C> IPTR(1) = 3 - Message contains a descriptor with f=0
    +
    937 C> that does not exist in table b.
    +
    938 C>
    +
    939 C> @author Bill Cavanaugh @date 1988-09-01
    +
    940  SUBROUTINE fi6702(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK,AUNITS,
    +
    941  * MWIDTH,MREF,MSCALE,JDESC,IVALS,J)
    +
    942 
    +
    943  SAVE
    +
    944 C TABLE B ENTRY
    +
    945  CHARACTER*24 ASKEY
    +
    946  CHARACTER*24 AUNITS(*)
    +
    947 C TABLE B ENTRY
    +
    948  INTEGER MSGA(*)
    +
    949  INTEGER IPTR(*)
    +
    950  INTEGER IDENT(*)
    +
    951  INTEGER J
    +
    952  INTEGER JDESC
    +
    953  INTEGER KDESC(*)
    +
    954  INTEGER MWIDTH(*),MSTACK(2,*),MSCALE(*)
    +
    955  INTEGER MREF(700,3),KDATA(500,*),IVALS(*)
    +
    956 C TABLE B ENTRY
    +
    957 C
    +
    958  DATA askey /'CCITT IA5 '/
    +
    959 C
    +
    960 C PRINT *,' FI6702 - STANDARD DESCRIPTOR PROCESSOR'
    +
    961 C GET A MATCH BETWEEN CURRENT
    +
    962 C DESCRIPTOR (JDESC) AND
    +
    963 C TABLE B ENTRY
    +
    964 C IF (KDESC(356).EQ.0) THEN
    +
    965 C PRINT *,'FI6702 - KDESC(356) WENT TO ZER0'
    +
    966 C IPTR(1) = 600
    +
    967 C RETURN
    +
    968 C END IF
    +
    969  k = 1
    +
    970  kk = iptr(14)
    +
    971  IF (jdesc.GT.kdesc(kk)) THEN
    +
    972  k = kk + 1
    +
    973  END IF
    +
    974  10 CONTINUE
    +
    975  IF (k.GT.kk) THEN
    +
    976  IF (iptr(36).NE.0) THEN
    +
    977 C HAVE SKIP FLAG
    +
    978  IF (ident(16).NE.0) THEN
    +
    979 C SKIP OVER COMPRESSED DATA
    +
    980 C LOWEST
    +
    981  iptr(25) = iptr(25) + iptr(36)
    +
    982 C NBINC
    +
    983  CALL gbyte (msga,ihold,iptr(25),6)
    +
    984  iptr(25) = iptr(25) + 6
    +
    985  iptr(31) = iptr(31) + 1
    +
    986  kprm = iptr(31) + iptr(24)
    +
    987  mstack(1,kprm) = jdesc
    +
    988  mstack(2,kprm) = 0
    +
    989  DO 50 i = 1, iptr(14)
    +
    990  kdata(i,kprm) = 99999
    +
    991  50 CONTINUE
    +
    992 C PROCESS DIFFERENCES
    +
    993  IF (ihold.NE.0) THEN
    +
    994  ibits = ihold * ident(14)
    +
    995  iptr(25) = iptr(25) + ibits
    +
    996  END IF
    +
    997  ELSE
    +
    998  iptr(31) = iptr(31) + 1
    +
    999  kprm = iptr(31) + iptr(24)
    +
    1000  mstack(1,kprm) = jdesc
    +
    1001  mstack(2,kprm) = 0
    +
    1002  kdata(iptr(17),kprm) = 99999
    +
    1003 C SKIP OVER NON-COMPRESSED DATA
    +
    1004 C PRINT *,'SKIP NON-COMPRESSED DATA'
    +
    1005  iptr(25) = iptr(25) + iptr(36)
    +
    1006  END IF
    +
    1007  RETURN
    +
    1008  ELSE
    +
    1009  print *,'FI6702 - ERROR = 3'
    +
    1010  print *,jdesc,k,kk,j,kdesc(j)
    +
    1011  print *,' '
    +
    1012  print *,'TABLE B'
    +
    1013  DO 20 ll = 1, iptr(14)
    +
    1014  print *,ll,kdesc(ll)
    +
    1015  20 CONTINUE
    +
    1016  iptr(1) = 3
    +
    1017  RETURN
    +
    1018  END IF
    +
    1019  ELSE
    +
    1020  j = ((kk - k) / 2) + k
    +
    1021  END IF
    +
    1022  IF (jdesc.EQ.kdesc(k)) THEN
    +
    1023  j = k
    +
    1024  GO TO 15
    +
    1025  ELSE IF (jdesc.EQ.kdesc(kk))THEN
    +
    1026  j = kk
    +
    1027  GO TO 15
    +
    1028  ELSE IF (jdesc.LT.kdesc(j)) THEN
    +
    1029  k = k + 1
    +
    1030  kk = j - 1
    +
    1031  GO TO 10
    +
    1032  ELSE IF (jdesc.GT.kdesc(j)) THEN
    +
    1033  k = j + 1
    +
    1034  kk = kk - 1
    +
    1035  GO TO 10
    +
    1036  END IF
    +
    1037  15 CONTINUE
    +
    1038 C HAVE A MATCH
    +
    1039 C SET FLAG IF TEXT EVENT
    +
    1040  IF (askey(1:9).EQ.aunits(j)(1:9)) THEN
    +
    1041  iptr(18) = 1
    +
    1042  iptr(40) = mwidth(j) / 8
    +
    1043  ELSE
    +
    1044  iptr(18) = 0
    +
    1045  END IF
    +
    1046  IF (ident(16).NE.0) THEN
    +
    1047 C COMPRESSED
    +
    1048  CALL fi6703(iptr,ident,msga,kdata,ivals,mstack,
    +
    1049  * mwidth,mref,mscale,j,jdesc)
    +
    1050  IF (iptr(1).NE.0) THEN
    +
    1051  RETURN
    +
    1052  END IF
    +
    1053  ELSE
    +
    1054 C NOT COMPRESSED
    +
    1055  CALL fi6704(iptr,msga,kdata,ivals,mstack,
    +
    1056  * mwidth,mref,mscale,j,ll,jdesc)
    +
    1057  END IF
    +
    1058  RETURN
    +
    1059  END
    +
    1060 C> @brief Process compressed data and place individual elements into output
    +
    1061 C> array
    +
    1062 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1063 
    +
    1064 C> Program history log:
    +
    1065 C> - Bill Cavanaugh 1988-09-01
    +
    1066 C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
    +
    1067 C> modified to hanle width of fields in bytes.
    +
    1068 C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
    +
    1069 C> and uncompressed form gave different results. This has been corrected.
    +
    1070 C> - Bill Cavanaugh 1991-06-21 Processing of text data has been changed to
    +
    1071 C> provide exact reproduction of all characters.
    +
    1072 C>
    +
    1073 C> @param[in] IPTR See w3fi67() routine docblock.
    +
    1074 C> @param[in] IDENT See w3fi67() routine docblock.
    +
    1075 C> @param[in] MSGA Array containing bufr message, mstack.
    +
    1076 C> @param[in] MSTACK
    +
    1077 C> @param[in] IVALS Array of single parameter values.
    +
    1078 C> @param[inout] J
    +
    1079 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1080 C> kdata(report number,parameter number).
    +
    1081 C> @param JDESC
    +
    1082 C> Arrays Containing data from table b.
    +
    1083 C> @param[out] MSCALE Scale for value of descriptor.
    +
    1084 C> @param[out] MREF Reference value for descriptor.
    +
    1085 C> @param[out] MWIDTH Bit width for value of descriptor.
    +
    1086 C>
    +
    1087 C> @note List caveats, other helpful hints or information.
    +
    1088 C>
    +
    1089 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1090  SUBROUTINE fi6703(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
    +
    1091  * MWIDTH,MREF,MSCALE,J,JDESC)
    +
    1092 
    +
    1093  SAVE
    +
    1094 C
    +
    1095  INTEGER MSGA(*),JDESC,MSTACK(2,*)
    +
    1096  INTEGER IPTR(*),IVALS(*),KDATA(500,*)
    +
    1097  INTEGER NRVALS,JWIDE,IDATA
    +
    1098  INTEGER IDENT(*)
    +
    1099  INTEGER MSCALE(*)
    +
    1100  INTEGER MREF(700,3)
    +
    1101  INTEGER J
    +
    1102  INTEGER MWIDTH(*)
    +
    1103  INTEGER KLOW(256)
    +
    1104 C
    +
    1105  LOGICAL TEXT
    +
    1106 C
    +
    1107  INTEGER MSK(28)
    +
    1108 C
    +
    1109 C
    +
    1110  DATA msk /1,3,7,15,31,63,127,
    +
    1111 C 1 2 3 4 5 6 7
    +
    1112  * 255,511,1023,2047,4095,
    +
    1113 C 8 9 10 11 12
    +
    1114  * 8191,16383,32767,65535,
    +
    1115 C 13 14 15 16
    +
    1116  * 131071,262143,524287,
    +
    1117 C 17 18 19
    +
    1118  * 1048575,2097151,4194303,
    +
    1119 C 20 21 22
    +
    1120  * 8388607,16777215,33554431,
    +
    1121 C 23 24 25
    +
    1122  * 67108863,134217727,268435455/
    +
    1123 C 26 27 28
    +
    1124 C
    +
    1125 C PRINT *,' FI6703 COMPR J=',J,' MWIDTH(J) =',MWIDTH(J),
    +
    1126 C * ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25)
    +
    1127  IF (iptr(18).EQ.0) THEN
    +
    1128  text = .false.
    +
    1129  ELSE
    +
    1130  text = .true.
    +
    1131  END IF
    +
    1132 C PRINT *,'DESCRIPTOR',KPRM
    +
    1133  IF (.NOT.text) THEN
    +
    1134  IF (iptr(29).GT.0) THEN
    +
    1135 C WORKING WITH ASSOCIATED FIELDS HERE
    +
    1136  iptr(31) = iptr(31) + 1
    +
    1137  kprm = iptr(31) + iptr(24)
    +
    1138 C GET LOWEST
    +
    1139  CALL gbyte (msga,lowest,iptr(25),iptr(29))
    +
    1140  iptr(25) = iptr(25) + iptr(29)
    +
    1141 C GET NBINC
    +
    1142  CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1143  iptr(25) = iptr(25) + 6
    +
    1144 C EXTRACT DATA FOR ASSOCIATED FIELD
    +
    1145  IF (nbinc.GT.0) THEN
    +
    1146  CALL gbytes (msga,ivals,iptr(25),nbinc,0,iptr(14))
    +
    1147  iptr(25) = iptr(25) + nbinc * iptr(14)
    +
    1148  DO 50 i = 1, iptr(14)
    +
    1149  kdata(i,kprm) = ivals(i) + lowest
    +
    1150  IF (kdata(i,kprm).GE.msk(nbinc)) THEN
    +
    1151  kdata(i,kprm) = 999999
    +
    1152  END IF
    +
    1153  50 CONTINUE
    +
    1154  ELSE
    +
    1155  DO 51 i = 1, iptr(14)
    +
    1156  IF (lowest.GE.msk(nbinc)) THEN
    +
    1157  kdata(i,kprm) = 999999
    +
    1158  ELSE
    +
    1159  kdata(i,kprm) = lowest
    +
    1160  END IF
    +
    1161  51 CONTINUE
    +
    1162  END IF
    +
    1163  END IF
    +
    1164 C SET PARAMETER
    +
    1165 C ISOLATE STANDARD BIT WIDTH
    +
    1166  jwide = mwidth(j) + iptr(26)
    +
    1167 C SINGLE VALUE FOR LOWEST
    +
    1168  nrvals = 1
    +
    1169 C LOWEST
    +
    1170 C PRINT *,'PARAM',KPRM
    +
    1171  CALL gbyte (msga,lowest,iptr(25),jwide)
    +
    1172 C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25)
    +
    1173  iptr(25) = iptr(25) + jwide
    +
    1174 C ISOLATE COMPRESSED BIT WIDTH
    +
    1175  CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1176 C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25)
    +
    1177  IF (iptr(32).EQ.2.AND.iptr(33).EQ.5) THEN
    +
    1178  ELSE
    +
    1179  IF (nbinc.GT.jwide) THEN
    +
    1180 C PRINT *,'FOR DESCRIPTOR',JDESC
    +
    1181 C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' MWIDTH(J)=',
    +
    1182 C * MWIDTH(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25)
    +
    1183 C DO 110 I = 1, KPRM
    +
    1184 C WRITE (6,111)I,(KDATA(J,I),J=1,6)
    +
    1185 C 110 CONTINUE
    +
    1186  111 FORMAT (1x,5hdata ,i3,6(2x,i10))
    +
    1187  iptr(1) = 500
    +
    1188 C RETURN
    +
    1189  print *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE',
    +
    1190  * ' B PLUS WIDTH CHANGES'
    +
    1191  END IF
    +
    1192  END IF
    +
    1193  iptr(25) = iptr(25) + 6
    +
    1194 C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC
    +
    1195 C IF TEXT EVENT, PROCESS TEXT
    +
    1196 C GET COMPRESSED VALUES
    +
    1197 C PRINT *,'COMPRESSED VALUES - NONTEXT'
    +
    1198  nrvals = ident(14)
    +
    1199  iptr(31) = iptr(31) + 1
    +
    1200  kprm = iptr(31) + iptr(24)
    +
    1201  IF (nbinc.NE.0) THEN
    +
    1202  CALL gbytes (msga,ivals,iptr(25),nbinc,0,nrvals)
    +
    1203  iptr(25) = iptr(25) + nbinc * nrvals
    +
    1204 C RECALCULATE TO ORIGINAL VALUES
    +
    1205  DO 100 i = 1, nrvals
    +
    1206 C PRINT *,IVALS(I),MSK(NBINC),NBINC
    +
    1207  IF (ivals(i).GE.msk(nbinc)) THEN
    +
    1208  kdata(i,kprm) = 999999
    +
    1209  ELSE
    +
    1210  IF (mref(j,2).EQ.0) THEN
    +
    1211  kdata(i,kprm) = ivals(i) + lowest + mref(j,1)
    +
    1212  ELSE
    +
    1213  kdata(i,kprm) = ivals(i) + lowest + mref(j,3)
    +
    1214  END IF
    +
    1215  END IF
    +
    1216  100 CONTINUE
    +
    1217 C PRINT *,I,JDESC,LOWEST,MREF(J,1),MREF(J,3)
    +
    1218 C PRINT *,I,JDESC,(IVALS(K),K=1,8)
    +
    1219  ELSE
    +
    1220  IF (lowest.EQ.msk(mwidth(j))) THEN
    +
    1221  DO 105 i = 1, nrvals
    +
    1222  kdata(i,kprm) = 999999
    +
    1223  105 CONTINUE
    +
    1224  ELSE
    +
    1225  IF (mref(j,2).EQ.0) THEN
    +
    1226  icomb = lowest + mref(j,1)
    +
    1227  ELSE
    +
    1228  icomb = lowest + mref(j,3)
    +
    1229  END IF
    +
    1230  DO 106 i = 1, nrvals
    +
    1231  kdata(i,kprm) = icomb
    +
    1232  106 CONTINUE
    +
    1233  END IF
    +
    1234  END IF
    +
    1235 C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25)
    +
    1236  mstack(1,kprm) = jdesc
    +
    1237  IF (iptr(27).NE.0) THEN
    +
    1238  mstack(2,kprm) = iptr(27)
    +
    1239  ELSE
    +
    1240  mstack(2,kprm) = mscale(j)
    +
    1241  END IF
    +
    1242 C WRITE (6,80) (DATA(I,KPRM),I=1,10)
    +
    1243 C 80 FORMAT(2X,10(F10.2,1X))
    +
    1244  ELSE IF (text) THEN
    +
    1245 C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40)
    +
    1246 C GET LOWEST
    +
    1247 C PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40))
    +
    1248  DO 1906 k = 1, iptr(40)
    +
    1249  CALL gbyte (msga,klow,iptr(25),8)
    +
    1250  iptr(25) = iptr(25) + 8
    +
    1251  IF (klow(k).NE.0) THEN
    +
    1252  iptr(1) = 27
    +
    1253  print *,'NON-ZERO LOWEST ON TEXT DATA'
    +
    1254  RETURN
    +
    1255  END IF
    +
    1256  1906 CONTINUE
    +
    1257 C GET NBINC
    +
    1258  CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1259 C PRINT *,'NBINC =',NBINC
    +
    1260  iptr(25) = iptr(25) + 6
    +
    1261  IF (nbinc.NE.iptr(40)) THEN
    +
    1262  iptr(1) = 28
    +
    1263  print *,'NBINC IS NOT THE NUMBER OF CHARACTERS',nbinc
    +
    1264  RETURN
    +
    1265  END IF
    +
    1266 C FOR NUMBER OF OBSERVATIONS
    +
    1267  iptr(31) = iptr(31) + 1
    +
    1268  kprm = iptr(31) + iptr(24)
    +
    1269  istart = kprm
    +
    1270  i24 = iptr(24)
    +
    1271  DO 1900 n = 1, ident(14)
    +
    1272  kprm = istart
    +
    1273  iptr(24) = i24
    +
    1274  nbits = iptr(40) * 8
    +
    1275  1700 CONTINUE
    +
    1276 C PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS
    +
    1277  IF (nbits.GT.32) THEN
    +
    1278  CALL gbyte (msga,idata,iptr(25),32)
    +
    1279  iptr(25) = iptr(25) + 32
    +
    1280  nbits = nbits - 32
    +
    1281 C CONVERTS ASCII TO EBCIDIC
    +
    1282 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1283 C PRINT *,IDATA
    +
    1284  CALL w3ai39 (idata,4)
    +
    1285  mstack(1,kprm) = jdesc
    +
    1286  mstack(2,kprm) = 0
    +
    1287  kdata(n,kprm) = idata
    +
    1288 C SET FOR NEXT PART
    +
    1289  kprm = kprm + 1
    +
    1290  iptr(24) = iptr(24) + 1
    +
    1291 C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
    +
    1292  1701 FORMAT (1x,i1,1x,6hkdata=,a4,2x,i5,2x,i5,2x,i5,2x,i12)
    +
    1293  GO TO 1700
    +
    1294  ELSE IF (nbits.GT.0) THEN
    +
    1295  CALL gbyte (msga,idata,iptr(25),nbits)
    +
    1296  iptr(25) = iptr(25) + nbits
    +
    1297  ibuf = (32 - nbits) / 8
    +
    1298  IF (ibuf.GT.0) THEN
    +
    1299  DO 1750 mp = 1, ibuf
    +
    1300  idata = idata * 256 + 32
    +
    1301  1750 CONTINUE
    +
    1302  END IF
    +
    1303 C CONVERTS ASCII TO EBCIDIC
    +
    1304 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1305  CALL w3ai39 (idata,4)
    +
    1306  mstack(1,kprm) = jdesc
    +
    1307  mstack(2,kprm) = 0
    +
    1308  kdata(n,kprm) = idata
    +
    1309 C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
    +
    1310  nbits = 0
    +
    1311  END IF
    +
    1312 C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
    +
    1313 C1800 FORMAT (2X,I4,2X,3A4)
    +
    1314  1900 CONTINUE
    +
    1315  END IF
    +
    1316  RETURN
    +
    1317  END
    +
    1318 C> @brief Process data that is not compressed.
    +
    1319 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1320 
    +
    1321 C> Program history log:
    +
    1322 C> - Bill Cavanaugh 1988-09-01
    +
    1323 C> - Bill Cavanaugh 1991-01-18 Modified to properly handle non-compressed
    +
    1324 C> data.
    +
    1325 C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
    +
    1326 C> modified to handle field width in bytes.
    +
    1327 C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
    +
    1328 C> and uncompressed form gave different results. This has been corrected.
    +
    1329 C>
    +
    1330 C> @param[in] IPTR See w3fi67 routine docblock
    +
    1331 C> @param[in] MSGA Array containing bufr message
    +
    1332 C> @param[inout] IVALS Array of single parameter values
    +
    1333 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1334 C> kdata(report number,parameter number)
    +
    1335 C> @param[inout] J [in] ? [out] arrays containing data from table b
    +
    1336 C> @param[out] MSCALE Scale for value of descriptor
    +
    1337 C> @param[in] MSTACK
    +
    1338 C> @param LL
    +
    1339 C> @param JDESC
    +
    1340 C> @param[out] MREF Reference value for descriptor
    +
    1341 C> @param[out] MWIDTH Bit width for value of descriptor
    +
    1342 C>
    +
    1343 C> @note Error return:
    +
    1344 C> - IPTR(1) = 13 - Bit width on ASCII chars not a multiple of 8.
    +
    1345 C>
    +
    1346 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1347  SUBROUTINE fi6704(IPTR,MSGA,KDATA,IVALS,MSTACK,
    +
    1348  * MWIDTH,MREF,MSCALE,J,LL,JDESC)
    +
    1349 
    +
    1350  SAVE
    +
    1351 C
    +
    1352  INTEGER MSGA(*)
    +
    1353  INTEGER IPTR(*),MREF(700,3),MSCALE(*)
    +
    1354  INTEGER MWIDTH(*),JDESC
    +
    1355  INTEGER IVALS(*)
    +
    1356  INTEGER LSTBLK(3)
    +
    1357  INTEGER KDATA(500,*),MSTACK(2,*)
    +
    1358  INTEGER J,LL
    +
    1359  LOGICAL LKEY
    +
    1360 C
    +
    1361 C
    +
    1362  INTEGER ITEST(30)
    +
    1363  DATA itest /1,3,7,15,31,63,127,255,
    +
    1364  * 511,1023,2047,4095,8191,16383,
    +
    1365  * 32767, 65535,131071,262143,524287,
    +
    1366  * 1048575,2097151,4194303,8388607,
    +
    1367  * 16777215,33554431,67108863,134217727,
    +
    1368  * 268435455,536870911,1073741823/
    +
    1369 C
    +
    1370 C PRINT *,' FI6704 NOCMP',J,JDESC,MWIDTH(J),IPTR(26),IPTR(25)
    +
    1371  IF ((iptr(26)+mwidth(j)).LT.1) THEN
    +
    1372  iptr(1) = 501
    +
    1373  RETURN
    +
    1374  END IF
    +
    1375 C -------- NOCMP --------
    +
    1376 C ISOLATE BIT WIDTH
    +
    1377  jwide = mwidth(j) + iptr(26)
    +
    1378 C IF NOT TEXT EVENT, PROCESS
    +
    1379  IF (iptr(18).NE.1) THEN
    +
    1380 C IF ASSOCIATED FIELD SW ON
    +
    1381  IF (iptr(29).GT.0) THEN
    +
    1382  IF (jdesc.NE.7957.AND.jdesc.NE.7937) THEN
    +
    1383  iptr(31) = iptr(31) + 1
    +
    1384  kprm = iptr(31) + iptr(24)
    +
    1385  mstack(1,kprm) = 33792 + iptr(29)
    +
    1386  mstack(2,kprm) = 0
    +
    1387  CALL gbyte (msga,ivals,iptr(25),iptr(29))
    +
    1388  iptr(25) = iptr(25) + iptr(29)
    +
    1389  kdata(iptr(17),kprm) = ivals(1)
    +
    1390 C PRINT *,'FI6704-A',KPRM,MSTACK(1,KPRM),
    +
    1391 C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
    +
    1392  END IF
    +
    1393  END IF
    +
    1394  iptr(31) = iptr(31) + 1
    +
    1395  kprm = iptr(31) + iptr(24)
    +
    1396  mstack(1,kprm) = jdesc
    +
    1397  IF (iptr(27).NE.0) THEN
    +
    1398  mstack(2,kprm) = iptr(27)
    +
    1399  ELSE
    +
    1400  mstack(2,kprm) = mscale(j)
    +
    1401  END IF
    +
    1402 C GET VALUES
    +
    1403 C CALL TO GET DATA OF GIVEN BIT WIDTH
    +
    1404  CALL gbyte (msga,ivals,iptr(25),jwide)
    +
    1405 C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25)
    +
    1406  iptr(25) = iptr(25) + jwide
    +
    1407 C RETURN WITH SINGLE VALUE
    +
    1408  IF (ivals(1).EQ.itest(jwide)) THEN
    +
    1409  kdata(iptr(17),kprm) = 999999
    +
    1410  ELSE
    +
    1411  IF (mref(j,2).EQ.0) THEN
    +
    1412  kdata(iptr(17),kprm) = ivals(1) + mref(j,1)
    +
    1413  ELSE
    +
    1414  kdata(iptr(17),kprm) = ivals(1) + mref(j,3)
    +
    1415  END IF
    +
    1416  END IF
    +
    1417 C PRINT *,'FI6704-B',KPRM,MSTACK(1,KPRM),
    +
    1418 C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
    +
    1419 C IF(JDESC.EQ.2049) THEN
    +
    1420 C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM)
    +
    1421 C END IF
    +
    1422 C PRINT *,'FI6704 ',KPRM,MSTACK(1,KPRM),
    +
    1423 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1424  ELSE
    +
    1425 C IF TEXT EVENT, PROCESS TEXT
    +
    1426 C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
    +
    1427  nrchrs = iptr(40)
    +
    1428  nrbits = nrchrs * 8
    +
    1429 C PRINT *,'CHARS =',NRCHRS,' BITS =',NRBITS
    +
    1430  iptr(31) = iptr(31) + 1
    +
    1431  kany = 0
    +
    1432  1800 CONTINUE
    +
    1433  kany = kany + 1
    +
    1434  IF (nrbits.GT.32) THEN
    +
    1435  CALL gbyte (msga,idata,iptr(25),32)
    +
    1436 C PRINT 1801,KANY,IDATA,IPTR(17),KPRM
    +
    1437 C1801 FORMAT (1X,I2,4X,Z8,2(4X,I4))
    +
    1438 C CONVERTS ASCII TO EBCIDIC
    +
    1439 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1440  CALL w3ai39 (idata,4)
    +
    1441  kprm = iptr(31) + iptr(24)
    +
    1442  kdata(iptr(17),kprm) = idata
    +
    1443  mstack(1,kprm) = jdesc
    +
    1444  mstack(2,kprm) = 0
    +
    1445 C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
    +
    1446 C * KDATA(IPTR(17),KPRM)
    +
    1447  iptr(25) = iptr(25) + 32
    +
    1448  nrbits = nrbits - 32
    +
    1449  iptr(24) = iptr(24) + 1
    +
    1450  GO TO 1800
    +
    1451  ELSE IF (nrbits.GT.0) THEN
    +
    1452 C PRINT *,'LAST TEXT WORD'
    +
    1453  CALL gbyte (msga,idata,iptr(25),nrbits)
    +
    1454  iptr(25) = iptr(25) + nrbits
    +
    1455 C CONVERTS ASCII TO EBCIDIC
    +
    1456 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1457  CALL w3ai39 (idata,4)
    +
    1458  kprm = iptr(31) + iptr(24)
    +
    1459  kshft = 32 - nrbits
    +
    1460  IF (kshft.GT.0) THEN
    +
    1461  ktry = kshft / 8
    +
    1462  DO 1722 lak = 1, ktry
    +
    1463  idata = idata * 256 + 64
    +
    1464 C PRINT 1723,IDATA
    +
    1465  1723 FORMAT (12x,z8)
    +
    1466  1722 CONTINUE
    +
    1467  END IF
    +
    1468  kdata(iptr(17),kprm) = idata
    +
    1469 C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM
    +
    1470  mstack(1,kprm) = jdesc
    +
    1471  mstack(2,kprm) = 0
    +
    1472 C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
    +
    1473 C * KDATA(IPTR(17),KPRM)
    +
    1474  END IF
    +
    1475 C TURN OFF TEXT
    +
    1476  iptr(18) = 0
    +
    1477  END IF
    +
    1478  RETURN
    +
    1479  END
    +
    1480 C> @brief Process a replication descriptor, must extract number
    +
    1481 C> of replications of n descriptors from the data stream.
    +
    1482 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1483 
    +
    1484 C> Process a replication descriptor, must extract number
    +
    1485 C> of replications of n descriptors from the data stream.
    +
    1486 C>
    +
    1487 C> Program history log:
    +
    1488 C> - Bill Cavanaugh 1988-09-01
    +
    1489 C>
    +
    1490 C> @param[in] IWORK Working descriptor list
    +
    1491 C> @param[in] IPTR See w3fi67 routine docblock
    +
    1492 C> @param[in] IDENT See w3fi67 routine docblock
    +
    1493 C> @param[inout] LX X portion of current descriptor
    +
    1494 C> @param[inout] LY Y portion of current descriptor
    +
    1495 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1496 C> kdata(report number,parameter number)
    +
    1497 C> @param LL
    +
    1498 C> @param KNR
    +
    1499 C> @param MSTACK
    +
    1500 C> @param MSGA
    +
    1501 C>
    +
    1502 C> @note Error return:
    +
    1503 C> - IPTR(1)
    +
    1504 C> - = 12 Data descriptor qualifier does not follow
    +
    1505 C> delayed replication descriptor.
    +
    1506 C> - = 20 Exceeded count for delayed replication pass.
    +
    1507 C>
    +
    1508 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1509  SUBROUTINE fi6705(IPTR,IDENT,MSGA,IWORK,LX,LY,
    +
    1510  * KDATA,LL,KNR,MSTACK)
    +
    1511 
    +
    1512  SAVE
    +
    1513 C
    +
    1514  INTEGER IPTR(*),KNR(*)
    +
    1515  INTEGER ITEMP(1600),LL
    +
    1516  INTEGER KTEMP(1600)
    +
    1517  INTEGER KDATA(500,*)
    +
    1518  INTEGER LX,MSTACK(2,*)
    +
    1519  INTEGER LY
    +
    1520  INTEGER MSGA(*),KVALS(500)
    +
    1521  INTEGER IWORK(*)
    +
    1522  INTEGER IDENT(*)
    +
    1523 C
    +
    1524 C PRINT *,' REPLICATION FI6705'
    +
    1525 C DO 100 I = 1, IPTR(13)
    +
    1526 C PRINT *,I,IWORK(I)
    +
    1527 C 100 CONTINUE
    +
    1528 C NUMBER OF DESCRIPTORS
    +
    1529  nrset = lx
    +
    1530 C NUMBER OF REPLICATIONS
    +
    1531  nrreps = ly
    +
    1532  icurr = iptr(11) - 1
    +
    1533  ipick = iptr(11) - 1
    +
    1534 C
    +
    1535  IF (nrreps.EQ.0) THEN
    +
    1536  iptr(39) = 1
    +
    1537 C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR
    +
    1538 C IPTR(31) = IPTR(31) + 1
    +
    1539 C KPRM = IPTR(31) + IPTR(24)
    +
    1540 C MSTACK(1,KPRM) = JDESC
    +
    1541 C MSTACK(2,KPRM) = 0
    +
    1542 C KDATA(IPTR(17),KPRM) = 0
    +
    1543 C PRINT *,'FI6705-1',KPRM,MSTACK(1,KPRM),
    +
    1544 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1545 C DELAYED REPLICATION - MUST GET NUMBER OF
    +
    1546 C REPLICATIONS FROM DATA.
    +
    1547 C GET NEXT DESCRIPTOR
    +
    1548  CALL fi6708(iptr,iwork,lf,lx,ly,jdesc)
    +
    1549 C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC
    +
    1550 C MUST BE DATA DESCRIPTION
    +
    1551 C OPERATION QUALIFIER
    +
    1552  IF (jdesc.EQ.7937.OR.jdesc.EQ.7947) THEN
    +
    1553  jwide = 8
    +
    1554  ELSE IF (jdesc.EQ.7938.OR.jdesc.EQ.7948) THEN
    +
    1555  jwide = 16
    +
    1556  ELSE
    +
    1557  iptr(1) = 12
    +
    1558  RETURN
    +
    1559  END IF
    +
    1560 
    +
    1561 C SET SINGLE VALUE FOR SEQUENTIAL,
    +
    1562 C MULTIPLE VALUES FOR COMPRESSED
    +
    1563  IF (ident(16).EQ.0) THEN
    +
    1564 C NON COMPRESSED
    +
    1565  CALL gbyte (msga,kvals,iptr(25),jwide)
    +
    1566 C PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1)
    +
    1567  iptr(25) = iptr(25) + jwide
    +
    1568  iptr(31) = iptr(31) + 1
    +
    1569  kprm = iptr(31) + iptr(24)
    +
    1570  mstack(1,kprm) = jdesc
    +
    1571  mstack(2,kprm) = 0
    +
    1572  kdata(iptr(17),kprm) = kvals(1)
    +
    1573  nrreps = kvals(1)
    +
    1574 C PRINT *,'FI6705-2',KPRM,MSTACK(1,KPRM),
    +
    1575 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1576  ELSE
    +
    1577  nrvals = ident(14)
    +
    1578  CALL gbytes (msga,kvals,iptr(25),jwide,0,nrvals)
    +
    1579  iptr(25) = iptr(25) + jwide * nrvals
    +
    1580  iptr(31) = iptr(31) + 1
    +
    1581  kprm = iptr(31) + iptr(24)
    +
    1582  mstack(1,kprm) = jdesc
    +
    1583  mstack(2,kprm) = 0
    +
    1584  kdata(iptr(17),kprm) = kvals(1)
    +
    1585  DO 100 i = 1, nrvals
    +
    1586  kdata(i,kprm) = kvals(i)
    +
    1587  100 CONTINUE
    +
    1588  nrreps = kvals(1)
    +
    1589  END IF
    +
    1590  ELSE
    +
    1591 C PRINT *,'NOT DELAYED REPLICATION'
    +
    1592  END IF
    +
    1593 C RESTRUCTURE WORKING STACK W/REPLICATIONS
    +
    1594 C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
    +
    1595 C PICK UP DESCRIPTORS TO BE REPLICATED
    +
    1596  DO 1000 i = 1, nrset
    +
    1597  CALL fi6708(iptr,iwork,lf,lx,ly,jdesc)
    +
    1598  itemp(i) = jdesc
    +
    1599 C PRINT *,'REPLICATION ',I,ITEMP(I)
    +
    1600  1000 CONTINUE
    +
    1601 C MOVE TRAILING DESCRIPTORS TO HOLD AREA
    +
    1602  lax = iptr(12) - iptr(11) + 1
    +
    1603 C PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12)
    +
    1604  DO 2000 i = 1, lax
    +
    1605  CALL fi6708(iptr,iwork,lf,lx,ly,jdesc)
    +
    1606  ktemp(i) = jdesc
    +
    1607 C PRINT *,' ',I,KTEMP(I)
    +
    1608  2000 CONTINUE
    +
    1609 C REPLICATIONS INTO ISTACK
    +
    1610 C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES'
    +
    1611 C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR
    +
    1612  DO 4000 i = 1, nrreps
    +
    1613  DO 3000 j = 1, nrset
    +
    1614  iwork(icurr) = itemp(j)
    +
    1615 C PRINT *,'FI6705 A',ICURR,IWORK(ICURR)
    +
    1616  icurr = icurr + 1
    +
    1617  3000 CONTINUE
    +
    1618  4000 CONTINUE
    +
    1619 C PRINT *,' TO LOC',ICURR-1
    +
    1620 C RESTORE TRAILING DESCRIPTORS
    +
    1621 C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR
    +
    1622  DO 5000 i = 1, lax
    +
    1623  iwork(icurr) = ktemp(i)
    +
    1624 C PRINT *,'FI6705 B',ICURR,IWORK(ICURR)
    +
    1625  icurr = icurr + 1
    +
    1626  5000 CONTINUE
    +
    1627  iptr(12) = icurr - 1
    +
    1628  iptr(11) = ipick
    +
    1629  RETURN
    +
    1630  END
    +
    1631 
    +
    1632 C> @brief Process operator descriptors.
    +
    1633 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1634 
    +
    1635 C> Extract and save indicated change values for use
    +
    1636 C> until changes are rescinded, or extract text strings indicated
    +
    1637 C> through 2 05 yyy.
    +
    1638 C>
    +
    1639 C> Program history log:
    +
    1640 C> - Bill Cavanaugh 1988-09-01
    +
    1641 C> - Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
    +
    1642 C> - Bill Cavanaugh 1991-05-10 Coding has been added to process proposed
    +
    1643 C> table c descriptor 2 06 yyy.
    +
    1644 C> - Bill Cavanaugh 1991-11-21 Coding has been added to properly process
    +
    1645 C> table c descriptor 2 03 yyy, the change
    +
    1646 C> to new reference value for selected
    +
    1647 C> descriptors.
    +
    1648 C>
    +
    1649 C> @param[in] IPTR See w3fi67 routine docblock.
    +
    1650 C> @param[in] LX X portion of current descriptor.
    +
    1651 C> @param[in] LY Y portion of current descriptor.
    +
    1652 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1653 C> kdata(report number,parameter number)
    +
    1654 C> arrays containing data from table b
    +
    1655 C> @param[out] MSCALE Scale for value of descriptor
    +
    1656 C> @param[out] MREF Reference value for descriptor
    +
    1657 C> @param[out] MWIDTH Bit width for value of descriptor
    +
    1658 C> @param IDENT
    +
    1659 C> @param MSGA
    +
    1660 C> @param IVALS
    +
    1661 C> @param MSTACK
    +
    1662 C> @param J
    +
    1663 C> @param LL
    +
    1664 C> @param KDESC
    +
    1665 C> @param IWORK
    +
    1666 C> @param JDESC
    +
    1667 C>
    +
    1668 C> @note Error return:
    +
    1669 C> - IPTR(1) = 5 - Erroneous x value in data descriptor operator
    +
    1670 C>
    +
    1671 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1672  SUBROUTINE fi6706 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
    +
    1673  * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC)
    +
    1674 
    +
    1675  SAVE
    +
    1676  INTEGER IPTR(*),KDATA(500,*),IVALS(*)
    +
    1677  INTEGER IDENT(*),IWORK(*)
    +
    1678  INTEGER MSGA(*),MSTACK(2,*)
    +
    1679  INTEGER MREF(700,3),KDESC(*)
    +
    1680  INTEGER MSCALE(*),MWIDTH(*)
    +
    1681  INTEGER J,JDESC
    +
    1682  INTEGER LL
    +
    1683  INTEGER LX
    +
    1684  INTEGER LY
    +
    1685 C
    +
    1686 C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR'
    +
    1687  IF (lx.EQ.1) THEN
    +
    1688 C CHANGE BIT WIDTH
    +
    1689  IF (ly.EQ.0) THEN
    +
    1690 C PRINT *,' RETURN TO NORMAL WIDTH'
    +
    1691  iptr(26) = 0
    +
    1692  ELSE
    +
    1693 C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS'
    +
    1694  iptr(26) = ly - 128
    +
    1695  END IF
    +
    1696  ELSE IF (lx.EQ.2) THEN
    +
    1697 C CHANGE SCALE
    +
    1698  IF (ly.EQ.0) THEN
    +
    1699 C RESET TO STANDARD SCALE
    +
    1700  iptr(27) = 0
    +
    1701  ELSE
    +
    1702 C SET NEW SCALE
    +
    1703  iptr(27) = ly - 128
    +
    1704  END IF
    +
    1705  ELSE IF (lx.EQ.3) THEN
    +
    1706 C CHANGE REFERENCE VALUE
    +
    1707 C FOR EACH OF THOSE DESCRIPTORS BETWEEN
    +
    1708 C 2 03 YYY WHERE Y LT 255 AND
    +
    1709 C 2 03 255, EXTRACT THE NEW REFERENCE
    +
    1710 C VALUE (BIT WIDTH YYY) AND PLACE
    +
    1711 C IN TERTIARY TABLE B REF VAL POSITION,
    +
    1712 C SET FLAG IN SECONDARY REFVAL POSITION
    +
    1713 C THOSE DESCRIPTORS DO NOT HAVE DATA
    +
    1714 C ASSOCIATED WITH THEM, BUT ONLY
    +
    1715 C IDENTIFY THE TABLE B ENTRIES THAT
    +
    1716 C ARE GETTING NEW REFERENCE VALUES.
    +
    1717  kyyy = ly
    +
    1718  IF (kyyy.GT.0.AND.kyyy.LT.255) THEN
    +
    1719 C START CYCLING THRU DESCRIPTORS UNTIL
    +
    1720 C TERMINATE NEW REF VALS IS FOUND
    +
    1721  300 CONTINUE
    +
    1722  CALL fi6708 (iptr,iwork,lf,lx,ly,jdesc)
    +
    1723  IF (jdesc.EQ.33791) THEN
    +
    1724 C IF 2 03 255 THEN RETURN
    +
    1725  RETURN
    +
    1726  ELSE
    +
    1727 C FIND MATCHING TABLE B ENTRY
    +
    1728  DO 500 lj = 1, iptr(14)
    +
    1729  IF (jdesc.EQ.kdesc(lj)) THEN
    +
    1730 C TURN ON NEW REF VAL FLAG
    +
    1731  mref(lj,2) = 1
    +
    1732 C INSERT NEW REF VAL
    +
    1733  CALL gbyte (msga,mref(lj,3),iptr(25),kyyy)
    +
    1734 C GO GET NEXT DESCRIPTOR
    +
    1735  GO TO 300
    +
    1736  END IF
    +
    1737  500 CONTINUE
    +
    1738 C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR
    +
    1739  print *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND'
    +
    1740  stop 203
    +
    1741  END IF
    +
    1742  ELSE IF (kyyy.EQ.0) THEN
    +
    1743 C MUST TURN OFF ALL NEW
    +
    1744 C REFERENCE VALUES
    +
    1745  DO 400 i = 1, iptr(14)
    +
    1746  mref(i,2) = 0
    +
    1747  400 CONTINUE
    +
    1748  END IF
    +
    1749 C LX = 3
    +
    1750 C MUST BE CONCLUDED WITH Y=255
    +
    1751  ELSE IF (lx.EQ.4) THEN
    +
    1752 C ASSOCIATED VALUES
    +
    1753  IF (ly.EQ.0) THEN
    +
    1754  iptr(29) = 0
    +
    1755 C PRINT *,'RESET ASSOCIATED VALUES',IPTR(29)
    +
    1756  ELSE
    +
    1757  iptr(29) = ly
    +
    1758  IF (iwork(iptr(11)).NE.7957) THEN
    +
    1759  print *,'2 04 YYY NOT FOLLOWED BY 0 31 021'
    +
    1760  iptr(1) = 11
    +
    1761  END IF
    +
    1762 C PRINT *,'SET ASSOCIATED VALUES',IPTR(29)
    +
    1763  END IF
    +
    1764  ELSE IF (lx.EQ.5) THEN
    +
    1765 C PROCESS TEXT DATA
    +
    1766  iptr(40) = ly
    +
    1767  iptr(18) = 1
    +
    1768  IF (ident(16).EQ.0) THEN
    +
    1769 C PRINT *,'2 05 YYY - TEXT - NONCOMPRESSED MODE'
    +
    1770  CALL fi6704(iptr,msga,kdata,ivals,mstack,
    +
    1771  * mwidth,mref,mscale,j,ll,jdesc)
    +
    1772  ELSE
    +
    1773 C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE'
    +
    1774  CALL fi6703(iptr,ident,msga,kdata,ivals,mstack,
    +
    1775  * mwidth,mref,mscale,j,jdesc)
    +
    1776  IF (iptr(1).NE.0) THEN
    +
    1777  RETURN
    +
    1778  END IF
    +
    1779  ENDIF
    +
    1780  iptr(18) = 0
    +
    1781  ELSE IF (lx.EQ.6) THEN
    +
    1782 C SKIP NEXT DESCRIPTOR
    +
    1783 C SET TO PASS OVER DESCRIPTOR AND DATA
    +
    1784 C IF DESCRIPTOR NOT IN TABLE B
    +
    1785  iptr(36) = ly
    +
    1786 C PRINT *,'SET TO SKIP',LY,' BIT FIELD'
    +
    1787  iptr(31) = iptr(31) + 1
    +
    1788  kprm = iptr(31) + iptr(24)
    +
    1789  mstack(1,kprm) = 34304 + ly
    +
    1790  mstack(2,kprm) = 0
    +
    1791  ELSE
    +
    1792  iptr(1) = 5
    +
    1793  ENDIF
    +
    1794  RETURN
    +
    1795  END
    +
    1796 
    +
    1797 C> @brief Substitute descriptor queue for queue descriptor
    +
    1798 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1799 
    +
    1800 C> Substitute descriptor queue for queue descriptor
    +
    1801 C>
    +
    1802 C> Program history log:
    +
    1803 C> - Bill Cavanaugh 1988-09-01
    +
    1804 C> - Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors.
    +
    1805 C> - Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors.
    +
    1806 C> based on tests with live data.
    +
    1807 C>
    +
    1808 C> @param[in] IWORK Working descriptor list.
    +
    1809 C> @param[in] IPTR See w3fi67 routine docblock.
    +
    1810 C> @param[in] ITBLD Array containing descriptor queues.
    +
    1811 C> @param[in] JDESC Queue descriptor to be expanded.
    +
    1812 C>
    +
    1813 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1814  SUBROUTINE fi6707(IPTR,IWORK,ITBLD,JDESC)
    +
    1815 
    +
    1816  SAVE
    +
    1817 C
    +
    1818  INTEGER IPTR(*),JDESC
    +
    1819  INTEGER IWORK(*),IHOLD(1600)
    +
    1820  INTEGER ITBLD(500,11)
    +
    1821 C
    +
    1822 C PRINT *,' FI6707 F3 ENTRY',IPTR(11),IPTR(12)
    +
    1823 C SET FOR BINARY SEARCH IN TABLE D
    +
    1824 C DO 2020 I = 1, IPTR(12)
    +
    1825 C PRINT *,'ENTRY IWORK',I,IWORK(I)
    +
    1826 C2020 CONTINUE
    +
    1827  jlo = 1
    +
    1828  jhi = iptr(20)
    +
    1829 C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC
    +
    1830  10 CONTINUE
    +
    1831  jmid = (jlo + jhi) / 2
    +
    1832 C PRINT *,JLO,ITBLD(JLO,1),JMID,ITBLD(JMID,1),JHI,ITBLD(JHI,1)
    +
    1833 C
    +
    1834  IF (jdesc.LT.itbld(jmid,1)) THEN
    +
    1835  IF (jdesc.EQ.itbld(jlo,1)) THEN
    +
    1836  jmid = jlo
    +
    1837  GO TO 100
    +
    1838  ELSE
    +
    1839  jlo = jlo + 1
    +
    1840  jhi = jmid - 1
    +
    1841  IF (jlo.GT.jmid) THEN
    +
    1842  iptr(1) = 4
    +
    1843  RETURN
    +
    1844  END IF
    +
    1845  GO TO 10
    +
    1846  END IF
    +
    1847  ELSE IF (jdesc.GT.itbld(jmid,1)) THEN
    +
    1848  IF (jdesc.EQ.itbld(jhi,1)) THEN
    +
    1849  jmid = jhi
    +
    1850  GO TO 100
    +
    1851  ELSE
    +
    1852  jlo = jmid + 1
    +
    1853  jhi = jhi - 1
    +
    1854  IF (jlo.GT.jhi) THEN
    +
    1855  iptr(1) = 4
    +
    1856  RETURN
    +
    1857  END IF
    +
    1858  GO TO 10
    +
    1859  END IF
    +
    1860  END IF
    +
    1861  100 CONTINUE
    +
    1862 C HAVE TABLE D MATCH
    +
    1863 C PRINT *,'D ',(ITBLD(JMID,LL),LL=1,11)
    +
    1864 C PRINT *,'TABLE D TO IHOLD'
    +
    1865  ik = 0
    +
    1866  jk = 0
    +
    1867  DO 200 ki = 2, 11
    +
    1868  IF (itbld(jmid,ki).NE.0) THEN
    +
    1869  ik = ik + 1
    +
    1870  ihold(ik) = itbld(jmid,ki)
    +
    1871 C PRINT *,IK,IHOLD(IK)
    +
    1872  ELSE
    +
    1873  GO TO 300
    +
    1874  END IF
    +
    1875  200 CONTINUE
    +
    1876  300 CONTINUE
    +
    1877  kk = iptr(11)
    +
    1878  IF (kk.GT.iptr(12)) THEN
    +
    1879 C NOTHING MORE TO APPEND
    +
    1880 C PRINT *,'NOTHING MORE TO APPEND'
    +
    1881  ELSE
    +
    1882 C APPEND TRAILING IWORK TO IHOLD
    +
    1883 C PRINT *,'APPEND FROM ',KK,' TO',IPTR(12)
    +
    1884  DO 500 i = kk, iptr(12)
    +
    1885  ik = ik + 1
    +
    1886  ihold(ik) = iwork(i)
    +
    1887  500 CONTINUE
    +
    1888  END IF
    +
    1889 C RESET IHOLD TO IWORK
    +
    1890 C PRINT *,' RESET IWORK STACK'
    +
    1891  kk = iptr(11) - 2
    +
    1892  DO 1000 i = 1, ik
    +
    1893  kk = kk + 1
    +
    1894  iwork(kk) = ihold(i)
    +
    1895  1000 CONTINUE
    +
    1896  iptr(12) = kk
    +
    1897 C PRINT *,' FI6707 F3 EXIT ',IPTR(11),IPTR(12)
    +
    1898 C DO 2000 I = 1, IPTR(12)
    +
    1899 C PRINT *,'EXIT IWORK',I,IWORK(I)
    +
    1900 C2000 CONTINUE
    +
    1901 C RESET POINTERS
    +
    1902  iptr(11) = iptr(11) - 1
    +
    1903  RETURN
    +
    1904  END
    +
    1905 C> @brief Subroutine FI6708
    +
    1906 C> @author Bill Cavanaugh @date 1989-01-17
    +
    1907 
    +
    1908 C> Program history log:
    +
    1909 C> - Bill Cavanaugh 1988-09-01
    +
    1910 C>
    +
    1911 C> @param[inout] IPTR See w3fi67() routine docblock.
    +
    1912 C> @param[in] IWORK Working descriptor list.
    +
    1913 C> @param LF
    +
    1914 C> @param LX
    +
    1915 C> @param LY
    +
    1916 C> @param[in] JDESC Queue descriptor to be expanded.
    +
    1917 C>
    +
    1918 C> @note List caveats, other helpful hints or information.
    +
    1919 C>
    +
    1920 C> @author Bill Cavanaugh @date 1989-01-17
    +
    1921  SUBROUTINE fi6708(IPTR,IWORK,LF,LX,LY,JDESC)
    +
    1922 
    +
    1923  SAVE
    +
    1924  INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC
    +
    1925 C
    +
    1926 C PRINT *,' FI6708 NEW DESCRIPTOR PICKUP'
    +
    1927  jdesc = iwork(iptr(11))
    +
    1928  ly = mod(jdesc,256)
    +
    1929  iptr(34) = ly
    +
    1930  lx = mod((jdesc/256),64)
    +
    1931  iptr(33) = lx
    +
    1932  lf = jdesc / 16384
    +
    1933  iptr(32) = lf
    +
    1934 C PRINT *,' CURRENT DESCRIPTOR BEING TESTED IS',LF,LX,LY
    +
    1935  iptr(11) = iptr(11) + 1
    +
    1936  RETURN
    +
    1937  END
    +
    1938 C> @brief Reformat decoded profiler data to show heights instead of
    +
    1939 C> height increments.
    +
    1940 C> @author Bill Cavanaugh @date 1990-02-14
    +
    1941 
    +
    1942 C> Reformat decoded profiler data to show heights instead of
    +
    1943 C> height increments.
    +
    1944 C>
    +
    1945 C> Program history log:
    +
    1946 C> - Bill Cavanaugh 1990-02-14
    +
    1947 C>
    +
    1948 C> @param[in] IDENT Array contains message information extracted from
    +
    1949 C> BUFR message:
    +
    1950 C> - IDENT( 1)-EDITION NUMBER (BYTE 4, SECTION 1)
    +
    1951 C> - IDENT( 2)-ORIGINATING CENTER (BYTES 5-6, SECTION 1)
    +
    1952 C> - IDENT( 3)-UPDATE SEQUENCE (BYTE 7, SECTION 1)
    +
    1953 C> - IDENT( 4)- (BYTE 8, SECTION 1)
    +
    1954 C> - IDENT( 5)-BUFR MESSAGE TYPE (BYTE 9, SECTION 1)
    +
    1955 C> - IDENT( 6)-BUFR MSG SUB-TYPE (BYTE 10, SECTION 1)
    +
    1956 C> - IDENT( 7)- (BYTES 11-12, SECTION 1)
    +
    1957 C> - IDENT( 8)-YEAR OF CENTURY (BYTE 13, SECTION 1)
    +
    1958 C> - IDENT( 9)-MONTH OF YEAR (BYTE 14, SECTION 1)
    +
    1959 C> - IDENT(10)-DAY OF MONTH (BYTE 15, SECTION 1)
    +
    1960 C> - IDENT(11)-HOUR OF DAY (BYTE 16, SECTION 1)
    +
    1961 C> - IDENT(12)-MINUTE OF HOUR (BYTE 17, SECTION 1)
    +
    1962 C> - IDENT(13)-RSVD BY ADP CENTERS(BYTE 18, SECTION 1)
    +
    1963 C> - IDENT(14)-NR OF DATA SUBSETS (BYTE 5-6, SECTION 3)
    +
    1964 C> - IDENT(15)-OBSERVED FLAG (BYTE 7, BIT 1, SECTION 3)
    +
    1965 C> - IDENT(16)-COMPRESSION FLAG (BYTE 7, BIT 2, SECTION 3)
    +
    1966 C> @param[in] MSTACK Working descriptor list and scaling factor
    +
    1967 C> @param[in] KDATA Array containing decoded reports
    +
    1968 C> @param[in] IPTR See w3fi67
    +
    1969 C>
    +
    1970 C> @note List caveats, other helpful hints or information.
    +
    1971 C>
    +
    1972 C> @author Bill Cavanaugh @date 1990-02-14
    +
    1973  SUBROUTINE fi6709(IDENT,MSTACK,KDATA,IPTR)
    +
    1974 
    +
    1975  SAVE
    +
    1976 C ----------------------------------------------------------------
    +
    1977 C
    +
    1978  INTEGER ISW
    +
    1979  INTEGER IDENT(*),KDATA(500,*)
    +
    1980  INTEGER MSTACK(2,*),IPTR(*)
    +
    1981  INTEGER KPROFL(500)
    +
    1982  INTEGER KPROF2(500)
    +
    1983  INTEGER KSET2(500)
    +
    1984 C
    +
    1985 C ----------------------------------------------------------
    +
    1986 C LOOP FOR NUMBER OF SUBSETS/REPORTS
    +
    1987  DO 3000 i = 1, ident(14)
    +
    1988 C INIT FOR DATA INPUT ARRAY
    +
    1989  mk = 1
    +
    1990 C INIT FOR DESC OUTPUT ARRAY
    +
    1991  jk = 0
    +
    1992 C LOCATION
    +
    1993  isw = 0
    +
    1994  DO 200 j = 1, 3
    +
    1995 C LATITUDE
    +
    1996  IF (mstack(1,mk).EQ.1282) THEN
    +
    1997  isw = isw + 1
    +
    1998  GO TO 100
    +
    1999 C LONGITUDE
    +
    2000  ELSE IF (mstack(1,mk).EQ.1538) THEN
    +
    2001  isw = isw + 2
    +
    2002  GO TO 100
    +
    2003 C HEIGHT ABOVE SEA LEVEL
    +
    2004  ELSE IF (mstack(1,mk).EQ.1793) THEN
    +
    2005  ihgt = kdata(i,mk)
    +
    2006  isw = isw + 4
    +
    2007  GO TO 100
    +
    2008  END IF
    +
    2009  GO TO 200
    +
    2010  100 CONTINUE
    +
    2011  jk = jk + 1
    +
    2012 C SAVE DESCRIPTOR
    +
    2013  kprofl(jk) = mstack(1,mk)
    +
    2014 C SAVE SCALE
    +
    2015  kprof2(jk) = mstack(2,mk)
    +
    2016 C SAVE DATA
    +
    2017  kset2(jk) = kdata(i,mk)
    +
    2018  mk = mk + 1
    +
    2019  200 CONTINUE
    +
    2020  IF (isw.NE.7) THEN
    +
    2021  print *,'LOCATION ERROR PROCESSING PROFILER'
    +
    2022  iptr(1) = 200
    +
    2023  RETURN
    +
    2024  END IF
    +
    2025 C TIME
    +
    2026  isw = 0
    +
    2027  DO 400 j = 1, 7
    +
    2028 C YEAR
    +
    2029  IF (mstack(1,mk).EQ.1025) THEN
    +
    2030  isw = isw + 1
    +
    2031  GO TO 300
    +
    2032 C MONTH
    +
    2033  ELSE IF (mstack(1,mk).EQ.1026) THEN
    +
    2034  isw = isw + 2
    +
    2035  GO TO 300
    +
    2036 C DAY
    +
    2037  ELSE IF (mstack(1,mk).EQ.1027) THEN
    +
    2038  isw = isw + 4
    +
    2039  GO TO 300
    +
    2040 C HOUR
    +
    2041  ELSE IF (mstack(1,mk).EQ.1028) THEN
    +
    2042  isw = isw + 8
    +
    2043  GO TO 300
    +
    2044 C MINUTE
    +
    2045  ELSE IF (mstack(1,mk).EQ.1029) THEN
    +
    2046  isw = isw + 16
    +
    2047  GO TO 300
    +
    2048 C TIME SIGNIFICANCE
    +
    2049  ELSE IF (mstack(1,mk).EQ.2069) THEN
    +
    2050  isw = isw + 32
    +
    2051  GO TO 300
    +
    2052  ELSE IF (mstack(1,mk).EQ.1049) THEN
    +
    2053  isw = isw + 64
    +
    2054  GO TO 300
    +
    2055  END IF
    +
    2056  GO TO 400
    +
    2057  300 CONTINUE
    +
    2058  jk = jk + 1
    +
    2059 C SAVE DESCRIPTOR
    +
    2060  kprofl(jk) = mstack(1,mk)
    +
    2061 C SAVE SCALE
    +
    2062  kprof2(jk) = mstack(2,mk)
    +
    2063 C SAVE DATA
    +
    2064  kset2(jk) = kdata(i,mk)
    +
    2065  mk = mk + 1
    +
    2066  400 CONTINUE
    +
    2067  IF (isw.NE.127) THEN
    +
    2068  print *,'TIME ERROR PROCESSING PROFILER',isw
    +
    2069  iptr(1) = 201
    +
    2070  RETURN
    +
    2071  END IF
    +
    2072 C SURFACE DATA
    +
    2073  krg = 0
    +
    2074  isw = 0
    +
    2075  DO 600 j = 1, 10
    +
    2076 C WIND SPEED
    +
    2077  IF (mstack(1,mk).EQ.2818) THEN
    +
    2078  isw = isw + 1
    +
    2079  GO TO 500
    +
    2080 C WIND DIRECTION
    +
    2081  ELSE IF (mstack(1,mk).EQ.2817) THEN
    +
    2082  isw = isw + 2
    +
    2083  GO TO 500
    +
    2084 C PRESS REDUCED TO MSL
    +
    2085  ELSE IF (mstack(1,mk).EQ.2611) THEN
    +
    2086  isw = isw + 4
    +
    2087  GO TO 500
    +
    2088 C TEMPERATURE
    +
    2089  ELSE IF (mstack(1,mk).EQ.3073) THEN
    +
    2090  isw = isw + 8
    +
    2091  GO TO 500
    +
    2092 C RAINFALL RATE
    +
    2093  ELSE IF (mstack(1,mk).EQ.3342) THEN
    +
    2094  isw = isw + 16
    +
    2095  GO TO 500
    +
    2096 C RELATIVE HUMIDITY
    +
    2097  ELSE IF (mstack(1,mk).EQ.3331) THEN
    +
    2098  isw = isw + 32
    +
    2099  GO TO 500
    +
    2100 C 1ST RANGE GATE OFFSET
    +
    2101  ELSE IF (mstack(1,mk).EQ.1982.OR.
    +
    2102  * mstack(1,mk).EQ.1983) THEN
    +
    2103 C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE
    +
    2104 C VALUE FOR LATER USE
    +
    2105  IF (mstack(1,mk).EQ.1983) THEN
    +
    2106  ihgt = kdata(i,mk)
    +
    2107  mk = mk + 1
    +
    2108  krg = 1
    +
    2109  ELSE
    +
    2110  IF (krg.EQ.0) THEN
    +
    2111  incrht = kdata(i,mk)
    +
    2112  mk = mk + 1
    +
    2113  krg = 1
    +
    2114 C PRINT *,'INITIAL INCR =',INCRHT
    +
    2115  ELSE
    +
    2116  lhgt = 500 + ihgt - kdata(i,mk)
    +
    2117  isw = isw + 64
    +
    2118 C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT
    +
    2119  END IF
    +
    2120  END IF
    +
    2121 C MODE #1
    +
    2122  ELSE IF (mstack(1,mk).EQ.8128) THEN
    +
    2123  isw = isw + 128
    +
    2124  GO TO 500
    +
    2125 C MODE #2
    +
    2126  ELSE IF (mstack(1,mk).EQ.8129) THEN
    +
    2127  isw = isw + 256
    +
    2128  GO TO 500
    +
    2129  END IF
    +
    2130  GO TO 600
    +
    2131  500 CONTINUE
    +
    2132 C SAVE DESCRIPTOR
    +
    2133  jk = jk + 1
    +
    2134  kprofl(jk) = mstack(1,mk)
    +
    2135 C SAVE SCALE
    +
    2136  kprof2(jk) = mstack(2,mk)
    +
    2137 C SAVE DATA
    +
    2138  kset2(jk) = kdata(i,mk)
    +
    2139 C IF (I.EQ.1) THEN
    +
    2140 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
    +
    2141 C END IF
    +
    2142  mk = mk + 1
    +
    2143  600 CONTINUE
    +
    2144  650 CONTINUE
    +
    2145  IF (isw.NE.511) THEN
    +
    2146  print *,'SURFACE ERROR PROCESSING PROFILER',isw
    +
    2147  iptr(1) = 202
    +
    2148  RETURN
    +
    2149  END IF
    +
    2150 C 43 LEVELS
    +
    2151  DO 2000 l = 1, 43
    +
    2152  2020 CONTINUE
    +
    2153  isw = 0
    +
    2154 C HEIGHT INCREMENT
    +
    2155  IF (mstack(1,mk).EQ.1982) THEN
    +
    2156 C PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK)
    +
    2157  incrht = kdata(i,mk)
    +
    2158  mk = mk + 1
    +
    2159  IF (lhgt.LT.(9250+ihgt)) THEN
    +
    2160  lhgt = ihgt + 500 - incrht
    +
    2161  ELSE
    +
    2162  lhgt = ihgt + 9250 - incrht
    +
    2163  END IF
    +
    2164  END IF
    +
    2165 C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA
    +
    2166 C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE
    +
    2167  lhgt = lhgt + incrht
    +
    2168 C PRINT *,'LEVEL ',L,LHGT
    +
    2169  IF (l.EQ.37) THEN
    +
    2170  lhgt = lhgt + incrht
    +
    2171  END IF
    +
    2172  jk = jk + 1
    +
    2173 C SAVE DESCRIPTOR
    +
    2174  kprofl(jk) = 1798
    +
    2175 C SAVE SCALE
    +
    2176  kprof2(jk) = 0
    +
    2177 C SAVE DATA
    +
    2178  kset2(jk) = lhgt
    +
    2179 C IF (I.EQ.10) THEN
    +
    2180 C PRINT *,' '
    +
    2181 C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK)
    +
    2182 C END IF
    +
    2183  isw = 0
    +
    2184  DO 800 j = 1, 9
    +
    2185  750 CONTINUE
    +
    2186  IF (mstack(1,mk).EQ.1982) THEN
    +
    2187  GO TO 2020
    +
    2188 C U VECTOR VALUE
    +
    2189  ELSE IF (mstack(1,mk).EQ.3008) THEN
    +
    2190  isw = isw + 1
    +
    2191  IF (kdata(i,mk).GE.2047) THEN
    +
    2192  vectu = 32767
    +
    2193  ELSE
    +
    2194  vectu = kdata(i,mk)
    +
    2195  END IF
    +
    2196  mk = mk + 1
    +
    2197  GO TO 800
    +
    2198 C V VECTOR VALUE
    +
    2199  ELSE IF (mstack(1,mk).EQ.3009) THEN
    +
    2200  isw = isw + 2
    +
    2201  IF (kdata(i,mk).GE.2047) THEN
    +
    2202  vectv = 32767
    +
    2203  ELSE
    +
    2204  vectv = kdata(i,mk)
    +
    2205  END IF
    +
    2206  mk = mk + 1
    +
    2207 C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF
    +
    2208 C DESCRIPTORS AND DATA
    +
    2209  IF (iand(isw,1).NE.0) THEN
    +
    2210  IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
    +
    2211 C SAVE DD DESCRIPTOR
    +
    2212  jk = jk + 1
    +
    2213  kprofl(jk) = 2817
    +
    2214 C SAVE SCALE
    +
    2215  kprof2(jk) = 0
    +
    2216 C SAVE DD DATA
    +
    2217  kset2(jk) = 32767
    +
    2218 C SAVE FFF DESCRIPTOR
    +
    2219  jk = jk + 1
    +
    2220  kprofl(jk) = 2818
    +
    2221 C SAVE SCALE
    +
    2222  kprof2(jk) = 1
    +
    2223 C SAVE FFF DATA
    +
    2224  kset2(jk) = 32767
    +
    2225  ELSE
    +
    2226 C GENERATE DDFFF
    +
    2227  CALL w3fc05 (vectu,vectv,dir,spd)
    +
    2228  ndir = dir
    +
    2229  spd = spd
    +
    2230  nspd = spd
    +
    2231 C PRINT *,' ',NDIR,NSPD
    +
    2232 C SAVE DD DESCRIPTOR
    +
    2233  jk = jk + 1
    +
    2234  kprofl(jk) = 2817
    +
    2235 C SAVE SCALE
    +
    2236  kprof2(jk) = 0
    +
    2237 C SAVE DD DATA
    +
    2238  kset2(jk) = dir
    +
    2239 C IF (I.EQ.1) THEN
    +
    2240 C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
    +
    2241 C END IF
    +
    2242 C SAVE FFF DESCRIPTOR
    +
    2243  jk = jk + 1
    +
    2244  kprofl(jk) = 2818
    +
    2245 C SAVE SCALE
    +
    2246  kprof2(jk) = 1
    +
    2247 C SAVE FFF DATA
    +
    2248  kset2(jk) = spd
    +
    2249 C IF (I.EQ.1) THEN
    +
    2250 C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
    +
    2251 C END IF
    +
    2252  END IF
    +
    2253  END IF
    +
    2254  GO TO 800
    +
    2255 C W VECTOR VALUE
    +
    2256  ELSE IF (mstack(1,mk).EQ.3010) THEN
    +
    2257  isw = isw + 4
    +
    2258  GO TO 700
    +
    2259 C Q/C TEST RESULTS
    +
    2260  ELSE IF (mstack(1,mk).EQ.8130) THEN
    +
    2261  isw = isw + 8
    +
    2262  GO TO 700
    +
    2263 C U,V QUALITY IND
    +
    2264  ELSE IF(iand(isw,16).EQ.0.AND.mstack(1,mk).EQ.2070) THEN
    +
    2265  isw = isw + 16
    +
    2266  GO TO 700
    +
    2267 C W QUALITY IND
    +
    2268  ELSE IF(iand(isw,32).EQ.0.AND.mstack(1,mk).EQ.2070) THEN
    +
    2269  isw = isw + 32
    +
    2270  GO TO 700
    +
    2271 C SPECTRAL PEAK POWER
    +
    2272  ELSE IF (mstack(1,mk).EQ.5568) THEN
    +
    2273  isw = isw + 64
    +
    2274  GO TO 700
    +
    2275 C U,V VARIABILITY
    +
    2276  ELSE IF (mstack(1,mk).EQ.3011) THEN
    +
    2277  isw = isw + 128
    +
    2278  GO TO 700
    +
    2279 C W VARIABILITY
    +
    2280  ELSE IF (mstack(1,mk).EQ.3013) THEN
    +
    2281  isw = isw + 256
    +
    2282  GO TO 700
    +
    2283  ELSE IF ((mstack(1,mk)/16384).NE.0) THEN
    +
    2284  mk = mk + 1
    +
    2285  GO TO 750
    +
    2286  END IF
    +
    2287  GO TO 800
    +
    2288  700 CONTINUE
    +
    2289  jk = jk + 1
    +
    2290 C SAVE DESCRIPTOR
    +
    2291  kprofl(jk) = mstack(1,mk)
    +
    2292 C SAVE SCALE
    +
    2293  kprof2(jk) = mstack(2,mk)
    +
    2294 C SAVE DATA
    +
    2295  kset2(jk) = kdata(i,mk)
    +
    2296  mk = mk + 1
    +
    2297 C IF (I.EQ.1) THEN
    +
    2298 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
    +
    2299 C END IF
    +
    2300  800 CONTINUE
    +
    2301  850 CONTINUE
    +
    2302  IF (isw.NE.511) THEN
    +
    2303  print *,'LEVEL ERROR PROCESSING PROFILER',isw
    +
    2304  iptr(1) = 203
    +
    2305  RETURN
    +
    2306  END IF
    +
    2307  2000 CONTINUE
    +
    2308 C MOVE DATA BACK INTO KDATA ARRAY
    +
    2309  DO 4000 ll = 1, jk
    +
    2310  kdata(i,ll) = kset2(ll)
    +
    2311  4000 CONTINUE
    +
    2312  3000 CONTINUE
    +
    2313 C PRINT *,'REBUILT ARRAY'
    +
    2314  DO 5000 ll = 1, jk
    +
    2315 C DESCRIPTOR
    +
    2316  mstack(1,ll) = kprofl(ll)
    +
    2317 C SCALE
    +
    2318  mstack(2,ll) = kprof2(ll)
    +
    2319 C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7)
    +
    2320  5000 CONTINUE
    +
    2321 C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY
    +
    2322  iptr(31) = jk
    +
    2323  RETURN
    +
    2324  END
    +
    2325 C> @brief Reformat profiler edition 2 data
    +
    2326 C> @author Bill Cavanaugh @date 1993-01-27
    +
    2327 
    +
    2328 C> Reformat profiler data in edition 2
    +
    2329 C>
    +
    2330 C> Program history log:
    +
    2331 C> - Bill Cavanaugh 1993-01-27
    +
    2332 C>
    +
    2333 C> @param[in] IDENT Array contains message information extracted from
    +
    2334 C> BUFR message:
    +
    2335 C> - IDENT( 1)-Edition number (byte 4, section 1)
    +
    2336 C> - IDENT( 2)-Originating center (bytes 5-6, section 1)
    +
    2337 C> - IDENT( 3)-Update sequence (byte 7, section 1)
    +
    2338 C> - IDENT( 4)- (byte 8, section 1)
    +
    2339 C> - IDENT( 5)-BUFR message type (byte 9, section 1)
    +
    2340 C> - IDENT( 6)-BUFR msg sub-type (byte 10, section 1)
    +
    2341 C> - IDENT( 7)- (bytes 11-12, section 1)
    +
    2342 C> - IDENT( 8)-Year of century (byte 13, section 1)
    +
    2343 C> - IDENT( 9)-Month of year (byte 14, section 1)
    +
    2344 C> - IDENT(10)-Day of month (byte 15, section 1)
    +
    2345 C> - IDENT(11)-Hour of day (byte 16, section 1)
    +
    2346 C> - IDENT(12)-Minute of hour (byte 17, section 1)
    +
    2347 C> - IDENT(13)-Rsvd by adp centers(byte 18, section 1)
    +
    2348 C> - IDENT(14)-Nr of data subsets (byte 5-6, section 3)
    +
    2349 C> - IDENT(15)-Observed flag (byte 7, bit 1, section 3)
    +
    2350 C> - IDENT(16)-Compression flag (byte 7, bit 2, section 3)
    +
    2351 C> @param[in] MSTACK Working descriptor list and scaling factor
    +
    2352 C> @param[in] KDATA Array containing decoded reports from bufr message.
    +
    2353 C> kdata(report number,parameter number)
    +
    2354 C> (report number limited to value of input argument
    +
    2355 C> maxr and parameter number limited to value of input
    +
    2356 C> argument maxd)
    +
    2357 C> @param[in] IPTR See w3fi67
    +
    2358 C>
    +
    2359 C> @author Bill Cavanaugh @date 1993-01-27
    +
    2360  SUBROUTINE fi6710(IDENT,MSTACK,KDATA,IPTR)
    +
    2361 
    +
    2362  INTEGER ISW
    +
    2363  INTEGER IDENT(*),KDATA(500,1600)
    +
    2364  INTEGER MSTACK(2,1600),IPTR(*)
    +
    2365  INTEGER KPROFL(1600)
    +
    2366  INTEGER KPROF2(1600)
    +
    2367  INTEGER KSET2(1600)
    +
    2368 C LOOP FOR NUMBER OF SUBSETS
    +
    2369  DO 3000 i = 1, ident(14)
    +
    2370  mk = 1
    +
    2371  jk = 0
    +
    2372  isw = 0
    +
    2373  DO 200 j = 1, 5
    +
    2374  IF (mstack(1,mk).EQ.257) THEN
    +
    2375 C BLOCK NUMBER
    +
    2376  isw = isw + 1
    +
    2377  ELSE IF (mstack(1,mk).EQ.258) THEN
    +
    2378 C STATION NUMBER
    +
    2379  isw = isw + 2
    +
    2380  ELSE IF (mstack(1,mk).EQ.1282) THEN
    +
    2381 C LATITUDE
    +
    2382  isw = isw + 4
    +
    2383  ELSE IF (mstack(1,mk).EQ.1538) THEN
    +
    2384 C LONGITUDE
    +
    2385  isw = isw + 8
    +
    2386  ELSE IF (mstack(1,mk).EQ.1793) THEN
    +
    2387 C HEIGHT OF STATION
    +
    2388  isw = isw + 16
    +
    2389  ihgt = kdata(i,mk)
    +
    2390  ELSE
    +
    2391  mk = mk + 1
    +
    2392  GO TO 200
    +
    2393  END IF
    +
    2394  jk = jk + 1
    +
    2395  kprofl(jk) = mstack(1,mk)
    +
    2396  kprof2(jk) = mstack(2,mk)
    +
    2397  kset2(jk) = kdata(i,mk)
    +
    2398 C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2399  mk = mk + 1
    +
    2400  200 CONTINUE
    +
    2401 C PRINT *,'LOCATION ',ISW
    +
    2402  IF (isw.NE.31) THEN
    +
    2403  print *,'LOCATION ERROR PROCESSING PROFILER'
    +
    2404  iptr(10) = 200
    +
    2405  RETURN
    +
    2406  END IF
    +
    2407 C PROCESS TIME ELEMENTS
    +
    2408  isw = 0
    +
    2409  DO 400 j = 1, 7
    +
    2410  IF (mstack(1,mk).EQ.1025) THEN
    +
    2411 C YEAR
    +
    2412  isw = isw + 1
    +
    2413  ELSE IF (mstack(1,mk).EQ.1026) THEN
    +
    2414 C MONTH
    +
    2415  isw = isw + 2
    +
    2416  ELSE IF (mstack(1,mk).EQ.1027) THEN
    +
    2417 C DAY
    +
    2418  isw = isw + 4
    +
    2419  ELSE IF (mstack(1,mk).EQ.1028) THEN
    +
    2420 C HOUR
    +
    2421  isw = isw + 8
    +
    2422  ELSE IF (mstack(1,mk).EQ.1029) THEN
    +
    2423 C MINUTE
    +
    2424  isw = isw + 16
    +
    2425  ELSE IF (mstack(1,mk).EQ.2069) THEN
    +
    2426 C TIME SIGNIFICANCE
    +
    2427  isw = isw + 32
    +
    2428  ELSE IF (mstack(1,mk).EQ.1049) THEN
    +
    2429 C TIME DISPLACEMENT
    +
    2430  isw = isw + 64
    +
    2431  ELSE
    +
    2432  mk = mk + 1
    +
    2433  GO TO 400
    +
    2434  END IF
    +
    2435  jk = jk + 1
    +
    2436  kprofl(jk) = mstack(1,mk)
    +
    2437  kprof2(jk) = mstack(2,mk)
    +
    2438  kset2(jk) = kdata(i,mk)
    +
    2439 C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2440  mk = mk + 1
    +
    2441  400 CONTINUE
    +
    2442 C PRINT *,'TIME ',ISW
    +
    2443  IF (isw.NE.127) THEN
    +
    2444  print *,'TIME ERROR PROCESSING PROFILER'
    +
    2445  iptr(1) = 201
    +
    2446  RETURN
    +
    2447  END IF
    +
    2448 C SURFACE DATA
    +
    2449  isw = 0
    +
    2450 C PRINT *,'SURFACE'
    +
    2451  DO 600 k = 1, 8
    +
    2452  IF (mstack(1,mk).EQ.2817) THEN
    +
    2453  isw = isw + 1
    +
    2454  ELSE IF (mstack(1,mk).EQ.2818) THEN
    +
    2455  isw = isw + 2
    +
    2456  ELSE IF (mstack(1,mk).EQ.2611) THEN
    +
    2457  isw = isw + 4
    +
    2458  ELSE IF (mstack(1,mk).EQ.3073) THEN
    +
    2459  isw = isw + 8
    +
    2460  ELSE IF (mstack(1,mk).EQ.3342) THEN
    +
    2461  isw = isw + 16
    +
    2462  ELSE IF (mstack(1,mk).EQ.3331) THEN
    +
    2463  isw = isw + 32
    +
    2464  ELSE IF (mstack(1,mk).EQ.1797) THEN
    +
    2465  incrht = kdata(i,mk)
    +
    2466  isw = isw + 64
    +
    2467 C PRINT *,'INITIAL INCREMENT = ',INCRHT
    +
    2468  mk = mk + 1
    +
    2469  GO TO 600
    +
    2470  ELSE IF (mstack(1,mk).EQ.6433) THEN
    +
    2471  isw = isw + 128
    +
    2472  ELSE
    +
    2473  mk = mk + 1
    +
    2474  GO TO 600
    +
    2475  END IF
    +
    2476  jk = jk + 1
    +
    2477  kprofl(jk) = mstack(1,mk)
    +
    2478  kprof2(jk) = mstack(2,mk)
    +
    2479  kset2(jk) = kdata(i,mk)
    +
    2480 C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2481  mk = mk + 1
    +
    2482  600 CONTINUE
    +
    2483  IF (isw.NE.255) THEN
    +
    2484  print *,'ERROR PROCESSING PROFILER'
    +
    2485  iptr(1) = 204
    +
    2486  RETURN
    +
    2487  END IF
    +
    2488  IF (mstack(1,mk).NE.1797) THEN
    +
    2489  print *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER'
    +
    2490  iptr(1) = 205
    +
    2491  RETURN
    +
    2492  END IF
    +
    2493 C MUST SAVE THIS HEIGHT VALUE
    +
    2494  lhgt = 500 + ihgt - kdata(i,mk)
    +
    2495 C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT
    +
    2496  mk = mk + 1
    +
    2497 C PROCESS LEVEL DATA
    +
    2498  DO 2000 l = 1, 43
    +
    2499  2020 CONTINUE
    +
    2500  isw = 0
    +
    2501 C HEIGHT INCREMENT
    +
    2502  IF (mstack(1,mk).EQ.1797) THEN
    +
    2503  incrht = kdata(i,mk)
    +
    2504 C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT
    +
    2505  mk = mk + 1
    +
    2506  IF (lhgt.LT.(9250+ihgt)) THEN
    +
    2507  lhgt = lhgt + 500 - incrht
    +
    2508  ELSE
    +
    2509  lhgt = lhgt + 9250 -incrht
    +
    2510  END IF
    +
    2511  END IF
    +
    2512 C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA
    +
    2513 C AT THIS POINT
    +
    2514  lhgt = lhgt + incrht
    +
    2515 C PRINT *,'LEVEL ',L,LHGT
    +
    2516  IF (l.EQ.37) THEN
    +
    2517  lhgt = lhgt + incrht
    +
    2518  END IF
    +
    2519  jk = jk + 1
    +
    2520 C SAVE DESCRIPTOR
    +
    2521  kprofl(jk) = 1798
    +
    2522 C SAVE SCALE
    +
    2523  kprof2(jk) = 0
    +
    2524 C SAVE DATA
    +
    2525  kset2(jk) = lhgt
    +
    2526 C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2527  isw = 0
    +
    2528  icon = 1
    +
    2529  DO 800 j = 1, 10
    +
    2530 750 CONTINUE
    +
    2531  IF (mstack(1,mk).EQ.1797) THEN
    +
    2532  GO TO 2020
    +
    2533  ELSE IF (mstack(1,mk).EQ.6432) THEN
    +
    2534 C HI/LO MODE
    +
    2535  isw = isw + 1
    +
    2536  ELSE IF (mstack(1,mk).EQ.6434) THEN
    +
    2537 C Q/C TEST
    +
    2538  isw = isw + 2
    +
    2539  ELSE IF (mstack(1,mk).EQ.2070) THEN
    +
    2540  IF (icon.EQ.1) THEN
    +
    2541 C FIRST PASS - U,V CONSENSUS
    +
    2542  isw = isw + 4
    +
    2543  icon = icon + 1
    +
    2544  ELSE
    +
    2545 C SECOND PASS - W CONSENSUS
    +
    2546  isw = isw + 64
    +
    2547  END IF
    +
    2548  ELSE IF (mstack(1,mk).EQ.2819) THEN
    +
    2549 C U VECTOR VALUE
    +
    2550  isw = isw + 8
    +
    2551  IF (kdata(i,mk).GE.2047) THEN
    +
    2552  vectu = 32767
    +
    2553  ELSE
    +
    2554  vectu = kdata(i,mk)
    +
    2555  END IF
    +
    2556  mk = mk + 1
    +
    2557  GO TO 800
    +
    2558  ELSE IF (mstack(1,mk).EQ.2820) THEN
    +
    2559 C V VECTOR VALUE
    +
    2560  isw = isw + 16
    +
    2561  IF (kdata(i,mk).GE.2047) THEN
    +
    2562  vectv = 32767
    +
    2563  ELSE
    +
    2564  vectv = kdata(i,mk)
    +
    2565  END IF
    +
    2566  IF (iand(isw,1).NE.0) THEN
    +
    2567  IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
    +
    2568 C SAVE DD DESCRIPTOR
    +
    2569  jk = jk + 1
    +
    2570  kprofl(jk) = 2817
    +
    2571  kprof2(jk) = 0
    +
    2572  kset2(jk) = 32767
    +
    2573 C SAVE FFF DESCRIPTOR
    +
    2574  jk = jk + 1
    +
    2575  kprofl(jk) = 2818
    +
    2576  kprof2(jk) = 1
    +
    2577  kset2(jk) = 32767
    +
    2578  ELSE
    +
    2579  CALL w3fc05 (vectu,vectv,dir,spd)
    +
    2580  ndir = dir
    +
    2581  spd = spd
    +
    2582  nspd = spd
    +
    2583 C PRINT *,' ',NDIR,NSPD
    +
    2584 C SAVE DD DESCRIPTOR
    +
    2585  jk = jk + 1
    +
    2586  kprofl(jk) = 2817
    +
    2587  kprof2(jk) = 0
    +
    2588  kset2(jk) = ndir
    +
    2589 C IF (I.EQ.1) THEN
    +
    2590 C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
    +
    2591 C ENDIF
    +
    2592 C SAVE FFF DESCRIPTOR
    +
    2593  jk = jk + 1
    +
    2594  kprofl(jk) = 2818
    +
    2595  kprof2(jk) = 1
    +
    2596  kset2(jk) = nspd
    +
    2597 C IF (I.EQ.1) THEN
    +
    2598 C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
    +
    2599 C ENDIF
    +
    2600  END IF
    +
    2601  mk = mk + 1
    +
    2602  GO TO 800
    +
    2603  END IF
    +
    2604  ELSE IF (mstack(1,mk).EQ.2866) THEN
    +
    2605 C SPEED STD DEVIATION
    +
    2606  isw = isw + 32
    +
    2607 C -- A CHANGE BY KEYSER : POWER DESC. BACK TO 5568
    +
    2608  ELSE IF (mstack(1,mk).EQ.5568) THEN
    +
    2609 C SIGNAL POWER
    +
    2610  isw = isw + 128
    +
    2611  ELSE IF (mstack(1,mk).EQ.2822) THEN
    +
    2612 C W COMPONENT
    +
    2613  isw = isw + 256
    +
    2614  ELSE IF (mstack(1,mk).EQ.2867) THEN
    +
    2615 C VERT STD DEVIATION
    +
    2616  isw = isw + 512
    +
    2617  ELSE
    +
    2618  mk = mk + 1
    +
    2619  GO TO 750
    +
    2620  END IF
    +
    2621  jk = jk + 1
    +
    2622 C SAVE DESCRIPTOR
    +
    2623  kprofl(jk) = mstack(1,mk)
    +
    2624 C SAVE SCALE
    +
    2625  kprof2(jk) = mstack(2,mk)
    +
    2626 C SAVE DATA
    +
    2627  kset2(jk) = kdata(i,mk)
    +
    2628  mk = mk + 1
    +
    2629 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
    +
    2630  800 CONTINUE
    +
    2631  850 CONTINUE
    +
    2632  IF (isw.NE.1023) THEN
    +
    2633  print *,'LEVEL ERROR PROCESSING PROFILER',isw
    +
    2634  iptr(1) = 202
    +
    2635  RETURN
    +
    2636  END IF
    +
    2637  2000 CONTINUE
    +
    2638  DO 4000 ll = 1,jk
    +
    2639  kdata(i,ll) = kset2(ll)
    +
    2640  4000 CONTINUE
    +
    2641  3000 CONTINUE
    +
    2642 C MOVE DATA BACK INTO KDATA ARRAY
    +
    2643  DO 5000 ll = 1, jk
    +
    2644 C DESCRIPTOR
    +
    2645  mstack(1,ll) = kprofl(ll)
    +
    2646 C SCALE
    +
    2647  mstack(2,ll) = kprof2(ll)
    +
    2648 C DATA
    +
    2649 C PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4)
    +
    2650  5000 CONTINUE
    +
    2651  iptr(31) = jk
    +
    2652  RETURN
    +
    2653  END
    +
    +
    +
    gbytes
    subroutine gbytes(IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
    Program history log:
    Definition: gbytes.f:26
    +
    fi6701
    subroutine fi6701(IPTR, IDENT, MSGA, ISTACK, IWORK, ANAME, KDATA, IVALS, MSTACK, AUNITS, KDESC, MWIDTH, MREF, MSCALE, KNR, INDEX)
    Data extraction.
    Definition: w3fi67.f:640
    +
    fi6708
    subroutine fi6708(IPTR, IWORK, LF, LX, LY, JDESC)
    Subroutine FI6708.
    Definition: w3fi67.f:1922
    +
    fi6704
    subroutine fi6704(IPTR, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, LL, JDESC)
    Process data that is not compressed.
    Definition: w3fi67.f:1349
    +
    w3ai39
    subroutine w3ai39(NFLD, N)
    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
    Definition: w3ai39.f:26
    +
    fi6707
    subroutine fi6707(IPTR, IWORK, ITBLD, JDESC)
    Substitute descriptor queue for queue descriptor.
    Definition: w3fi67.f:1815
    +
    w3fi67
    subroutine w3fi67(IPTR, IDENT, MSGA, ISTACK, MSTACK, KDATA, KNR, INDEX)
    This set of routines will decode a BUFR message and place information extracted from the BUFR message...
    Definition: w3fi67.f:285
    +
    fi6705
    subroutine fi6705(IPTR, IDENT, MSGA, IWORK, LX, LY, KDATA, LL, KNR, MSTACK)
    Process a replication descriptor, must extract number of replications of n descriptors from the data ...
    Definition: w3fi67.f:1511
    +
    w3fc05
    subroutine w3fc05(U, V, DIR, SPD)
    Given the true (Earth oriented) wind components compute the wind direction and speed.
    Definition: w3fc05.f:29
    +
    fi6710
    subroutine fi6710(IDENT, MSTACK, KDATA, IPTR)
    Reformat profiler edition 2 data.
    Definition: w3fi67.f:2361
    +
    fi6703
    subroutine fi6703(IPTR, IDENT, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, JDESC)
    Process compressed data and place individual elements into output array.
    Definition: w3fi67.f:1092
    +
    fi6706
    subroutine fi6706(IPTR, LX, LY, IDENT, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, LL, KDESC, IWORK, JDESC)
    Process operator descriptors.
    Definition: w3fi67.f:1674
    +
    gbyte
    subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
    This is the fortran version of gbyte.
    Definition: gbyte.f:27
    +
    fi6702
    subroutine fi6702(IPTR, IDENT, MSGA, KDATA, KDESC, LL, MSTACK, AUNITS, MWIDTH, MREF, MSCALE, JDESC, IVALS, J)
    Process standard descriptor.
    Definition: w3fi67.f:942
    +
    fi6709
    subroutine fi6709(IDENT, MSTACK, KDATA, IPTR)
    Reformat decoded profiler data to show heights instead of height increments.
    Definition: w3fi67.f:1974
    + + + + diff --git a/ver-2.10.0/w3fi68_8f.html b/ver-2.10.0/w3fi68_8f.html new file mode 100644 index 00000000..17b1da36 --- /dev/null +++ b/ver-2.10.0/w3fi68_8f.html @@ -0,0 +1,233 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi68.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi68.f File Reference
    +
    +
    + +

    Convert 25 word array to GRIB pds. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi68 (ID, PDS)
     Converts an array of 25, or 27 integer words into a grib product definition section (pds) of 28 bytes , or 30 bytes. More...
     
    +

    Detailed Description

    +

    Convert 25 word array to GRIB pds.

    +
    Author
    Ralph Jones
    +
    Date
    1991-05-08
    + +

    Definition in file w3fi68.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi68()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3fi68 (integer, dimension(*) ID,
    character * 1, dimension(*) PDS 
    )
    +
    + +

    Converts an array of 25, or 27 integer words into a grib product definition section (pds) of 28 bytes , or 30 bytes.

    +

    if pds bytes > 30, they are set to zero.

    +

    Program history log:

      +
    • Ralph Jones 1991-05-08
      • +
    • Ralph Jones 1992-09-25 Change to 25 words of input, level can be in two words. (10,11)
      • +
    • Ralph Jones 1993-01-08 Change for time range indicator if 10, store time p1 in pds bytes 19-20.
      • +
    • Ralph Jones 1993-01-26 Correction for fixed height above ground level
      • +
    • Ralph Jones 1993-03-29 Add save statement
      • +
    • Bill Cavanaugh 1993-06-24 Modified program to allow for generation of pds greater than 28 bytes (the desired pds size is in id(1).
      • +
    • Farley 1993-09-30 Change to allow for subcenter id; put id(24) into pds(26).
      • +
    • Ralph Jones 1993-10-12 Changes for on388 rev. oct 9,1993, new levels 125, 200, 201.
      • +
    • Ralph Jones 1994-02-23 Take out sbytes, replace with do loop
      • +
    • Ralph Jones 1994-04-14 Changes for on388 rev. mar 24,1994, new levels 115,116.
      • +
    • Ralph Jones 1994-12-04 Change to add id words 26, 27 for pds bytes 29 and 30.
      • +
    • Ralph Jones 1995-09-07 Change for new level 117, 119.
      • +
    • Mark Iredell 1995-10-31 REmoved saves and prints
      • +
    • Ebisuzaki 1998-06-30 Linux port
      • +
    • Stephen Gilbert 2001-06-05 Changed fortran intrinsic function OR() to f90 standard intrinsic IOR().
      • +
    • Mark Iredell 2003-02-25 Recognize level type 126
      • +
    • D. C. Stokes 2005-05-06 Recognize level types 235, 237, 238
      • +
    +
    Parameters
    + + + +
    [in]ID25,27 word integer array.
    [out]PDS28 30 or greater character pds for edition 1.
    +
    +
    +
    Note
    Layout of 'id' array:
      +
    • ID(1) = Number of bytes in product definition section (pds)
      • +
    • ID(2) = Parameter table version number
      • +
    • ID(3) = Identification of originating center
      • +
    • ID(4) = Model identification (allocated by originating center)
      • +
    • ID(5) = Grid identification
      • +
    • ID(6) = 0 if no gds section, 1 if gds section is included
      • +
    • ID(7) = 0 if no bms section, 1 if bms section is included
      • +
    • ID(8) = Indicator of parameter and units (table 2)
      • +
    • ID(9) = Indicator of type of level (table 3)
      • +
    • ID(10) = Value 1 of level (0 for 1-100,102,103,105,107 109,111,113,115,117,119,125,126,160,200,201,235,237,238 level is in id word 11)
      • +
    • ID(11) = Value 2 of level
      • +
    • ID(12) = Year of century
      • +
    • ID(13) = Month of year
      • +
    • ID(14) = Day of month
      • +
    • ID(15) = Hour of day
      • +
    • ID(16) = Minute of hour (in most cases set to 0)
      • +
    • ID(17) = Fcst time unit
      • +
    • ID(18) = P1 period of time
      • +
    • ID(19) = P2 period of time
      • +
    • ID(20) = Time range indicator
      • +
    • ID(21) = Number included in average
      • +
    • ID(22) = Number missing from averages
      • +
    • ID(23) = Century (20, change to 21 on jan. 1, 2001)
      • +
    • ID(24) = Subcenter identification
      • +
    • ID(25) = Scaling power of 10
      • +
    • ID(26) = Flag byte, 8 on/off flags + + + + + + + + + + + + + + +
      BIT NUMBER VALUE ID(26) DEFINITION
      1 0 0 FULL FCST FIELD
      1 128 FCST ERROR FIELD
      2 0 0 ORIGINAL FCST FIELD
      1 64 BIAS CORRECTED FCST FIELD
      3 0 0 ORIGINAL RESOLUTION RETAINED
      1 32 SMOOTHED FIELD
      +
      • +
    +
    +
    +ID(26) can be the sum of bits 1, 2, 3. bits 4-8 not used, set to zero if ID(1) is 28, you do not need ID(26) and ID(27).
      +
    • ID(27) = unused, set to 0 so pds byte 30 is set to zero.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1991-05-08
    + +

    Definition at line 85 of file w3fi68.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi68_8f.js b/ver-2.10.0/w3fi68_8f.js new file mode 100644 index 00000000..b7fd956a --- /dev/null +++ b/ver-2.10.0/w3fi68_8f.js @@ -0,0 +1,4 @@ +var w3fi68_8f = +[ + [ "w3fi68", "w3fi68_8f.html#a627b0d3ff494874dd3fb243e39cfa991", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi68_8f_source.html b/ver-2.10.0/w3fi68_8f_source.html new file mode 100644 index 00000000..da945ac8 --- /dev/null +++ b/ver-2.10.0/w3fi68_8f_source.html @@ -0,0 +1,274 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi68.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi68.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert 25 word array to GRIB pds.
    +
    3 C> @author Ralph Jones @date 1991-05-08
    +
    4 
    +
    5 C> Converts an array of 25, or 27 integer words into a
    +
    6 C> grib product definition section (pds) of 28 bytes , or 30 bytes.
    +
    7 C> if pds bytes > 30, they are set to zero.
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - Ralph Jones 1991-05-08
    +
    11 C> - Ralph Jones 1992-09-25 Change to 25 words of input, level
    +
    12 C> can be in two words. (10,11)
    +
    13 C> - Ralph Jones 1993-01-08 Change for time range indicator if 10,
    +
    14 C> store time p1 in pds bytes 19-20.
    +
    15 C> - Ralph Jones 1993-01-26 Correction for fixed height above
    +
    16 C> ground level
    +
    17 C> - Ralph Jones 1993-03-29 Add save statement
    +
    18 C> - Bill Cavanaugh 1993-06-24 Modified program to allow for generation
    +
    19 C> of pds greater than 28 bytes (the desired
    +
    20 C> pds size is in id(1).
    +
    21 C> - Farley 1993-09-30 Change to allow for subcenter id; put
    +
    22 C> id(24) into pds(26).
    +
    23 C> - Ralph Jones 1993-10-12 Changes for on388 rev. oct 9,1993, new
    +
    24 C> levels 125, 200, 201.
    +
    25 C> - Ralph Jones 1994-02-23 Take out sbytes, replace with do loop
    +
    26 C> - Ralph Jones 1994-04-14 Changes for on388 rev. mar 24,1994, new
    +
    27 C> levels 115,116.
    +
    28 C> - Ralph Jones 1994-12-04 Change to add id words 26, 27 for pds
    +
    29 C> bytes 29 and 30.
    +
    30 C> - Ralph Jones 1995-09-07 Change for new level 117, 119.
    +
    31 C> - Mark Iredell 1995-10-31 REmoved saves and prints
    +
    32 C> - Ebisuzaki 1998-06-30 Linux port
    +
    33 C> - Stephen Gilbert 2001-06-05 Changed fortran intrinsic function OR() to
    +
    34 C> f90 standard intrinsic IOR().
    +
    35 C> - Mark Iredell 2003-02-25 Recognize level type 126
    +
    36 C> - D. C. Stokes 2005-05-06 Recognize level types 235, 237, 238
    +
    37 C>
    +
    38 C> @param[in] ID 25,27 word integer array.
    +
    39 C> @param[out] PDS 28 30 or greater character pds for edition 1.
    +
    40 C>
    +
    41 C> @note Layout of 'id' array:
    +
    42 C> - ID(1) = Number of bytes in product definition section (pds)
    +
    43 C> - ID(2) = Parameter table version number
    +
    44 C> - ID(3) = Identification of originating center
    +
    45 C> - ID(4) = Model identification (allocated by originating center)
    +
    46 C> - ID(5) = Grid identification
    +
    47 C> - ID(6) = 0 if no gds section, 1 if gds section is included
    +
    48 C> - ID(7) = 0 if no bms section, 1 if bms section is included
    +
    49 C> - ID(8) = Indicator of parameter and units (table 2)
    +
    50 C> - ID(9) = Indicator of type of level (table 3)
    +
    51 C> - ID(10) = Value 1 of level (0 for 1-100,102,103,105,107
    +
    52 C> 109,111,113,115,117,119,125,126,160,200,201,235,237,238
    +
    53 C> level is in id word 11)
    +
    54 C> - ID(11) = Value 2 of level
    +
    55 C> - ID(12) = Year of century
    +
    56 C> - ID(13) = Month of year
    +
    57 C> - ID(14) = Day of month
    +
    58 C> - ID(15) = Hour of day
    +
    59 C> - ID(16) = Minute of hour (in most cases set to 0)
    +
    60 C> - ID(17) = Fcst time unit
    +
    61 C> - ID(18) = P1 period of time
    +
    62 C> - ID(19) = P2 period of time
    +
    63 C> - ID(20) = Time range indicator
    +
    64 C> - ID(21) = Number included in average
    +
    65 C> - ID(22) = Number missing from averages
    +
    66 C> - ID(23) = Century (20, change to 21 on jan. 1, 2001)
    +
    67 C> - ID(24) = Subcenter identification
    +
    68 C> - ID(25) = Scaling power of 10
    +
    69 C> - ID(26) = Flag byte, 8 on/off flags
    +
    70 C> |BIT NUMBER |VALUE |ID(26) | DEFINITION|
    +
    71 C> | :--------- | :--- | :--- | : ----------- |
    +
    72 C> |1 |0 |0 |FULL FCST FIELD|
    +
    73 C> | |1 |128 |FCST ERROR FIELD|
    +
    74 C> |2 |0 |0 |ORIGINAL FCST FIELD|
    +
    75 C> | |1 |64 |BIAS CORRECTED FCST FIELD|
    +
    76 C> |3 |0 |0 |ORIGINAL RESOLUTION RETAINED|
    +
    77 C> | |1 |32 |SMOOTHED FIELD|
    +
    78 C> @note ID(26) can be the sum of bits 1, 2, 3.
    +
    79 C> bits 4-8 not used, set to zero
    +
    80 C> if ID(1) is 28, you do not need ID(26) and ID(27).
    +
    81 C> - ID(27) = unused, set to 0 so pds byte 30 is set to zero.
    +
    82 C>
    +
    83 C> @author Ralph Jones @date 1991-05-08
    +
    84  SUBROUTINE w3fi68 (ID, PDS)
    +
    85 C
    +
    86  INTEGER ID(*)
    +
    87 C
    +
    88  CHARACTER * 1 PDS(*)
    +
    89 C
    +
    90  pds(1) = char(mod(id(1)/65536,256))
    +
    91  pds(2) = char(mod(id(1)/256,256))
    +
    92  pds(3) = char(mod(id(1),256))
    +
    93  pds(4) = char(id(2))
    +
    94  pds(5) = char(id(3))
    +
    95  pds(6) = char(id(4))
    +
    96  pds(7) = char(id(5))
    +
    97  i = 0
    +
    98  if (id(6).ne.0) i = i + 128
    +
    99  if (id(7).ne.0) i = i + 64
    +
    100  pds(8) = char(i)
    +
    101 
    +
    102  pds(9) = char(id(8))
    +
    103  pds(10) = char(id(9))
    +
    104  i9 = id(9)
    +
    105 C
    +
    106 C TEST TYPE OF LEVEL TO SEE IF LEVEL IS IN TWO
    +
    107 C WORDS OR ONE
    +
    108 C
    +
    109  IF ((i9.GE.1.AND.i9.LE.100).OR.i9.EQ.102.OR.
    +
    110  & i9.EQ.103.OR.i9.EQ.105.OR.i9.EQ.107.OR.
    +
    111  & i9.EQ.109.OR.i9.EQ.111.OR.i9.EQ.113.OR.
    +
    112  & i9.EQ.115.OR.i9.EQ.117.OR.i9.EQ.119.OR.
    +
    113  & i9.EQ.125.OR.i9.EQ.126.OR.i9.EQ.160.OR.
    +
    114  & i9.EQ.200.OR.i9.EQ.201.OR.i9.EQ.235.OR.
    +
    115  & i9.EQ.237.OR.i9.EQ.238) THEN
    +
    116  level = id(11)
    +
    117  IF (level.LT.0) THEN
    +
    118  level = - level
    +
    119  level = ior(level,32768)
    +
    120  END IF
    +
    121  pds(11) = char(mod(level/256,256))
    +
    122  pds(12) = char(mod(level,256))
    +
    123  ELSE
    +
    124  pds(11) = char(id(10))
    +
    125  pds(12) = char(id(11))
    +
    126  END IF
    +
    127  pds(13) = char(id(12))
    +
    128  pds(14) = char(id(13))
    +
    129  pds(15) = char(id(14))
    +
    130  pds(16) = char(id(15))
    +
    131  pds(17) = char(id(16))
    +
    132  pds(18) = char(id(17))
    +
    133 C
    +
    134 C TEST TIME RANGE INDICATOR (PDS BYTE 21) FOR 10
    +
    135 C IF SO PUT TIME P1 IN PDS BYTES 19-20.
    +
    136 C
    +
    137  IF (id(20).EQ.10) THEN
    +
    138  pds(19) = char(mod(id(18)/256,256))
    +
    139  pds(20) = char(mod(id(18),256))
    +
    140  ELSE
    +
    141  pds(19) = char(id(18))
    +
    142  pds(20) = char(id(19))
    +
    143  END IF
    +
    144  pds(21) = char(id(20))
    +
    145  pds(22) = char(mod(id(21)/256,256))
    +
    146  pds(23) = char(mod(id(21),256))
    +
    147  pds(24) = char(id(22))
    +
    148  pds(25) = char(id(23))
    +
    149  pds(26) = char(id(24))
    +
    150  iscale = id(25)
    +
    151  IF (iscale.LT.0) THEN
    +
    152  iscale = -iscale
    +
    153  iscale = ior(iscale,32768)
    +
    154  END IF
    +
    155  pds(27) = char(mod(iscale/256,256))
    +
    156  pds(28) = char(mod(iscale ,256))
    +
    157  IF (id(1).GT.28) THEN
    +
    158  pds(29) = char(id(26))
    +
    159  pds(30) = char(id(27))
    +
    160  END IF
    +
    161 C
    +
    162 C SET PDS 31-?? TO ZERO
    +
    163 C
    +
    164  IF (id(1).GT.30) THEN
    +
    165  k = id(1)
    +
    166  DO i = 31,k
    +
    167  pds(i) = char(0)
    +
    168  END DO
    +
    169  END IF
    +
    170 C
    +
    171  RETURN
    +
    172  END
    +
    +
    +
    w3fi68
    subroutine w3fi68(ID, PDS)
    Converts an array of 25, or 27 integer words into a grib product definition section (pds) of 28 bytes...
    Definition: w3fi68.f:85
    + + + + diff --git a/ver-2.10.0/w3fi69_8f.html b/ver-2.10.0/w3fi69_8f.html new file mode 100644 index 00000000..5563dc74 --- /dev/null +++ b/ver-2.10.0/w3fi69_8f.html @@ -0,0 +1,175 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi69.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi69.f File Reference
    +
    +
    + +

    Convert pds to 25, or 27 word array. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi69 (PDS, ID)
     Converts an edition 1 grib produce definition section (pds) to a 25, or 27 word integer array. More...
     
    +

    Detailed Description

    +

    Convert pds to 25, or 27 word array.

    +
    Author
    Ralph Jones
    +
    Date
    1991-05-14
    + +

    Definition in file w3fi69.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi69()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3fi69 (character * 1, dimension(*) PDS,
    integer, dimension(*) ID 
    )
    +
    + +

    Converts an edition 1 grib produce definition section (pds) to a 25, or 27 word integer array.

    +

    Program history log:

      +
    • Ralph Jones 1991-05-14
      • +
    • Ralph Jones 1992-09-25 Change level to use one or two words
      • +
    • Ralph Jones 1993-01-08 Change for time range indicator if 10
      • +
    • Ralph Jones 1993-03-29 Add save statement
      • +
    • Ralph Jones 1993-10-21 Changes for on388 rev. oct 9,1993, new levels 125, 200, 201.
      • +
    • Ralph Jones 1994-04-14 Changes for on388 rev. mar 24,1994, new levels 115, 116.
      • +
    • Ralph Jones 1994-12-04 Changes for 27 word integer array if pds is greater than 28 bytes.
      • +
    • Ralph Jones 1995-09-07 Changes for level 117, 119.
      • +
    • Stephen Gilbert 1998-12-21 Replaced Function ICHAR with mova2i.
      • +
    +
    Parameters
    + + + +
    [in]PDS28 to 100 character product definition section (pds) .
    [out]ID25, or 27 word integer array.
    +
    +
    +
    Note
    List caveats, other helpful hints or information.
    +
    Author
    Ralph Jones
    +
    Date
    1991-05-14
    + +

    Definition at line 29 of file w3fi69.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi69_8f.js b/ver-2.10.0/w3fi69_8f.js new file mode 100644 index 00000000..3f8f0cc2 --- /dev/null +++ b/ver-2.10.0/w3fi69_8f.js @@ -0,0 +1,4 @@ +var w3fi69_8f = +[ + [ "w3fi69", "w3fi69_8f.html#a725f7f35c86515ca113aa3a36ac133e0", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi69_8f_source.html b/ver-2.10.0/w3fi69_8f_source.html new file mode 100644 index 00000000..84afab38 --- /dev/null +++ b/ver-2.10.0/w3fi69_8f_source.html @@ -0,0 +1,241 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi69.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi69.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert pds to 25, or 27 word array.
    +
    3 C> @author Ralph Jones @date 1991-05-14
    +
    4 
    +
    5 C> Converts an edition 1 grib produce definition section (pds)
    +
    6 C> to a 25, or 27 word integer array.
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - Ralph Jones 1991-05-14
    +
    10 C> - Ralph Jones 1992-09-25 Change level to use one or two words
    +
    11 C> - Ralph Jones 1993-01-08 Change for time range indicator if 10
    +
    12 C> - Ralph Jones 1993-03-29 Add save statement
    +
    13 C> - Ralph Jones 1993-10-21 Changes for on388 rev. oct 9,1993, new
    +
    14 C> levels 125, 200, 201.
    +
    15 C> - Ralph Jones 1994-04-14 Changes for on388 rev. mar 24,1994, new
    +
    16 C> levels 115, 116.
    +
    17 C> - Ralph Jones 1994-12-04 Changes for 27 word integer array if
    +
    18 C> pds is greater than 28 bytes.
    +
    19 C> - Ralph Jones 1995-09-07 Changes for level 117, 119.
    +
    20 C> - Stephen Gilbert 1998-12-21 Replaced Function ICHAR with mova2i.
    +
    21 C>
    +
    22 C> @param[in] PDS 28 to 100 character product definition section (pds) .
    +
    23 C> @param[out] ID 25, or 27 word integer array.
    +
    24 C>
    +
    25 C> @note List caveats, other helpful hints or information.
    +
    26 C>
    +
    27 C> @author Ralph Jones @date 1991-05-14
    +
    28  SUBROUTINE w3fi69 (PDS, ID)
    +
    29 C
    +
    30  INTEGER ID(*)
    +
    31 C
    +
    32  CHARACTER * 1 PDS(*)
    +
    33 C
    +
    34  SAVE
    +
    35 C
    +
    36 C ID(1) = NUMBER OF BYTES IN PDS
    +
    37 C ID(2) = PARAMETER TABLE VERSION NUMBER
    +
    38 C ID(3) = IDENTIFICATION OF ORIGINATING CENTER
    +
    39 C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER)
    +
    40 C ID(5) = GRID IDENTIFICATION
    +
    41 C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED
    +
    42 C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED
    +
    43 C ID(8) = INDICATOR OF PARAMETER AND UNITS
    +
    44 C ID(9) = INDICATOR OF TYPE OF LEVEL OR LAYER
    +
    45 C ID(10) = LEVEL 1
    +
    46 C ID(11) = LEVEL 2
    +
    47 C ID(12) = YEAR OF CENTURY
    +
    48 C ID(13) = MONTH OF YEAR
    +
    49 C ID(14) = DAY OF MONTH
    +
    50 C ID(15) = HOUR OF DAY
    +
    51 C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0)
    +
    52 C ID(17) = FCST TIME UNIT
    +
    53 C ID(18) = P1 PERIOD OF TIME
    +
    54 C ID(19) = P2 PERIOD OF TIME
    +
    55 C ID(20) = TIME RANGE INDICATOR
    +
    56 C ID(21) = NUMBER INCLUDED IN AVERAGE
    +
    57 C ID(22) = NUMBER MISSING FROM AVERAGES OR ACCUMULATIONS
    +
    58 C ID(23) = CENTURY
    +
    59 C ID(24) = IDENTIFICATION OF SUB-CENTER (TABLE 0 - PART 2)
    +
    60 C ID(25) = SCALING POWER OF 10
    +
    61 C ID(26) = FLAG BYTE, 8 ON/OFF FLAGS
    +
    62 C BIT NUMBER VALUE ID(26) DEFINITION
    +
    63 C 1 0 0 FULL FCST FIELD
    +
    64 C 1 128 FCST ERROR FIELD
    +
    65 C 2 0 0 ORIGINAL FCST FIELD
    +
    66 C 1 64 BIAS CORRECTED FCST FIELD
    +
    67 C 3 0 0 ORIGINAL RESOLUTION RETAINED
    +
    68 C 1 32 SMOOTHED FIELD
    +
    69 C NOTE: ID(26) CAN BE THE SUM OF BITS 1, 2, 3.
    +
    70 C BITS 4-8 NOT USED, SET TO ZERO.
    +
    71 C IF ID(1) IS 28, YOU DO NOT NEED ID(26) AND ID(27).
    +
    72 C ID(27) = UNUSED, SET TO 0 SO PDS BYTE 30 IS SET TO ZERO.$
    +
    73 C
    +
    74  id(1) = mova2i(pds(1)) * 65536 + mova2i(pds(2)) * 256 +
    +
    75  & mova2i(pds(3))
    +
    76  id(2) = mova2i(pds(4))
    +
    77  id(3) = mova2i(pds(5))
    +
    78  id(4) = mova2i(pds(6))
    +
    79  id(5) = mova2i(pds(7))
    +
    80  id(6) = iand(ishft(mova2i(pds(8)),-7),1)
    +
    81  id(7) = iand(ishft(mova2i(pds(8)),-6),1)
    +
    82  id(8) = mova2i(pds(9))
    +
    83  id(9) = mova2i(pds(10))
    +
    84  i9 = mova2i(pds(10))
    +
    85 C
    +
    86 C TEST ID(9) FOR 1-100, 102,103, 105, 107, 109,
    +
    87 C 111,113,115,117,119,160,200,201, IF TRUE, SET ID(10) TO 0,
    +
    88 C AND STORE 16 BIT VALUE (BYTES 11 & 12) THE LEVEL IN ID(11).
    +
    89 C
    +
    90  IF ((i9.GE.1.AND.i9.LE.100).OR.i9.EQ.102.OR.
    +
    91  & i9.EQ.103.OR.i9.EQ.105.OR.i9.EQ.107.OR.
    +
    92  & i9.EQ.109.OR.i9.EQ.111.OR.i9.EQ.113.OR.
    +
    93  & i9.EQ.115.OR.i9.EQ.117.OR.i9.EQ.119.OR.
    +
    94  & i9.EQ.125.OR.i9.EQ.160.OR.i9.EQ.200.OR.
    +
    95  & i9.EQ.201) THEN
    +
    96  level = mova2i(pds(11)) * 256 + mova2i(pds(12))
    +
    97  IF (iand(level,32768).NE.0) THEN
    +
    98  level = -iand(level,32767)
    +
    99  END IF
    +
    100  id(10) = 0
    +
    101  id(11) = level
    +
    102  ELSE
    +
    103  id(10) = mova2i(pds(11))
    +
    104  id(11) = mova2i(pds(12))
    +
    105  END IF
    +
    106  id(12) = mova2i(pds(13))
    +
    107  id(13) = mova2i(pds(14))
    +
    108  id(14) = mova2i(pds(15))
    +
    109  id(15) = mova2i(pds(16))
    +
    110  id(16) = mova2i(pds(17))
    +
    111  id(17) = mova2i(pds(18))
    +
    112  id(18) = mova2i(pds(19))
    +
    113  id(19) = mova2i(pds(20))
    +
    114  id(20) = mova2i(pds(21))
    +
    115 C
    +
    116 C IF TIME RANGE IDICATOR IS 10, P1 IS PACKED INTO
    +
    117 C PDS BYTES 19-20. PUT THEM IN P1 AND SET P2 TO ZERO.
    +
    118 C
    +
    119  IF (id(20).EQ.10) THEN
    +
    120  id(18) = id(18) * 256 + id(19)
    +
    121  id(19) = 0
    +
    122  END IF
    +
    123  id(21) = mova2i(pds(22)) * 256 + mova2i(pds(23))
    +
    124  id(22) = mova2i(pds(24))
    +
    125  id(23) = mova2i(pds(25))
    +
    126  id(24) = mova2i(pds(26))
    +
    127  iscale = mova2i(pds(27)) * 256 + mova2i(pds(28))
    +
    128  IF (iand(iscale,32768).NE.0) THEN
    +
    129  iscale = -iand(iscale,32767)
    +
    130  END IF
    +
    131  id(25) = iscale
    +
    132  IF (id(1).GT.28) THEN
    +
    133  id(26) = mova2i(pds(29))
    +
    134  id(27) = mova2i(pds(30))
    +
    135  END IF
    +
    136 C
    +
    137  RETURN
    +
    138  END
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    w3fi69
    subroutine w3fi69(PDS, ID)
    Converts an edition 1 grib produce definition section (pds) to a 25, or 27 word integer array.
    Definition: w3fi69.f:29
    + + + + diff --git a/ver-2.10.0/w3fi70_8f.html b/ver-2.10.0/w3fi70_8f.html new file mode 100644 index 00000000..a2082100 --- /dev/null +++ b/ver-2.10.0/w3fi70_8f.html @@ -0,0 +1,176 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi70.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi70.f File Reference
    +
    +
    + +

    Computes scaling constants used by grdprt(). +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi70 (PDS, CNST, IER)
     Computes the four scaling constants used by grdprt, w3fp03, or w3fp05 from the 28 byte (pds) product definition section of grib edition one. More...
     
    +

    Detailed Description

    +

    Computes scaling constants used by grdprt().

    +
    Author
    Ralph Jones
    +
    Date
    1991-10-26
    + +

    Definition in file w3fi70.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi70()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi70 (character * 1, dimension(28) PDS,
    real, dimension(4) CNST,
     IER 
    )
    +
    + +

    Computes the four scaling constants used by grdprt, w3fp03, or w3fp05 from the 28 byte (pds) product definition section of grib edition one.

    +

    Program history log:

      +
    • Ralph Jones 1991-10-26
      • +
    • Ralph Jones 1993-03-29 Add save statement
      • +
    • Ralph Jones 1993-08-08 Add 156 (cin), 158 (tke) to tables
      • +
    • Ralph Jones 1993-10-16 Changes for o.n. 388 ver. oct. 8,1993
      • +
    +
    Parameters
    + + + + +
    [in]PDS28 byte (pds) grib product definition section.
    [out]CNST4 constant's used by grdprt(), w3fp05(), or w3fp03().
    [out]IER0 = normal return | 1 = .
    +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1991-10-26
    + +

    Definition at line 21 of file w3fi70.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi70_8f.js b/ver-2.10.0/w3fi70_8f.js new file mode 100644 index 00000000..3a46fd4d --- /dev/null +++ b/ver-2.10.0/w3fi70_8f.js @@ -0,0 +1,4 @@ +var w3fi70_8f = +[ + [ "w3fi70", "w3fi70_8f.html#a15c47f82fe6330c213820e90fbe63a92", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi70_8f_source.html b/ver-2.10.0/w3fi70_8f_source.html new file mode 100644 index 00000000..63890c8d --- /dev/null +++ b/ver-2.10.0/w3fi70_8f_source.html @@ -0,0 +1,937 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi70.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi70.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes scaling constants used by grdprt().
    +
    3 C> @author Ralph Jones @date 1991-10-26
    +
    4 C
    +
    5 C> Computes the four scaling constants used by grdprt, w3fp03,
    +
    6 C> or w3fp05 from the 28 byte (pds) product definition section of
    +
    7 C> grib edition one.
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - Ralph Jones 1991-10-26
    +
    11 C> - Ralph Jones 1993-03-29 Add save statement
    +
    12 C> - Ralph Jones 1993-08-08 Add 156 (cin), 158 (tke) to tables
    +
    13 C> - Ralph Jones 1993-10-16 Changes for o.n. 388 ver. oct. 8,1993
    +
    14 C>
    +
    15 C> @param[in] PDS 28 byte (pds) grib product definition section.
    +
    16 C> @param[out] CNST 4 constant's used by grdprt(), w3fp05(), or w3fp03().
    +
    17 C> @param[out] IER 0 = normal return | 1 = .
    +
    18 C>
    +
    19 C> @author Ralph Jones @date 1991-10-26
    +
    20  SUBROUTINE w3fi70(PDS,CNST,IER)
    +
    21 C
    +
    22 C SET DEFAULT VALUES FOR NMC FIELDS GRID PRINTING
    +
    23 C
    +
    24  REAL CNST(4)
    +
    25 C
    +
    26  INTEGER ID(25)
    +
    27  INTEGER Q
    +
    28 C
    +
    29  CHARACTER * 1 PDS(28)
    +
    30 C
    +
    31  SAVE
    +
    32 C
    +
    33 C UNPACK 28 BYTE (PDS) INTO 25 INTEGER WORDS
    +
    34 C
    +
    35  CALL w3fi69(pds,id)
    +
    36 C
    +
    37  ier = 0
    +
    38 C
    +
    39 C INDICATOR OF PARAMETER AND UNITS
    +
    40 C
    +
    41  q = id(8)
    +
    42 C
    +
    43 C INDICATOR OF LEVEL OR LAYERS
    +
    44 C
    +
    45  itypes = id(9)
    +
    46  i9 = id(9)
    +
    47 C
    +
    48 C HEIGHTS, PRESSURE, ETC. OF THE LEVEL OR LAYER
    +
    49 C
    +
    50  IF ((i9.GE.1.AND.i9.LE.100).OR.i9.EQ.102.OR.
    +
    51  & i9.EQ.103.OR.i9.EQ.105.OR.i9.EQ.107.OR.
    +
    52  & i9.EQ.109.OR.i9.EQ.111.OR.i9.EQ.113.OR.
    +
    53  & i9.EQ.125.OR.i9.EQ.160.OR.i9.EQ.200.OR.
    +
    54  & i9.EQ.201) THEN
    +
    55  ilvl = id(11)
    +
    56  ELSE
    +
    57  ilvl = id(10)
    +
    58  END IF
    +
    59 
    +
    60  IF (q.EQ.1.OR.q.EQ.2.OR.q.EQ.26) THEN
    +
    61 C
    +
    62 C*** PRESSURE, PRESSURE REDUCED TO MSL, PRESSURE ANOMALY (Pa)
    +
    63 C
    +
    64  cnst(1) = 0.0
    +
    65  cnst(2) = 0.01
    +
    66  cnst(3) = 4.0
    +
    67  cnst(4) = 0.0
    +
    68 C*** IF SFC, TROPOPAUSE PRESSURE, SIGMA ..
    +
    69  IF (itypes.EQ.1.OR.itypes.EQ.6.OR.itypes.EQ.7)cnst(3)=25.0
    +
    70  IF (itypes.EQ.107) cnst(3) = 25.0
    +
    71 C
    +
    72  ELSE IF (q.EQ.3) THEN
    +
    73 C
    +
    74 C*** PRESSURE TENDENCY (Pa/s)
    +
    75 C
    +
    76  cnst(1) = 0.0
    +
    77  cnst(2) = 1.0
    +
    78  cnst(3) = 4.0
    +
    79  cnst(4) = 0.0
    +
    80 C
    +
    81  ELSE IF (q.EQ.6) THEN
    +
    82 C
    +
    83 C*** GEOPOTENTIAL (m**2/s**2)
    +
    84 C
    +
    85  cnst(1) = 0.0
    +
    86  cnst(2) = 1.0
    +
    87  cnst(3) = 4.0
    +
    88  cnst(4) = 0.0
    +
    89 C
    +
    90  ELSE IF (q.EQ.7.OR.q.EQ.8.OR.q.EQ.27.OR.q.EQ.222) THEN
    +
    91 C
    +
    92 C*** GEOPOTENTIAL, GEOPOTENTIAL HEIGHT, ANOMALY
    +
    93 C*** 5-WAVE GEOPOTENTIAL HEIGHT ............
    +
    94 C
    +
    95  cnst(3) = 60.
    +
    96  IF (ilvl.LT.500) cnst(3) = 120.
    +
    97 C*** IF SFC OR TROPOPAUSE PRESSURE ..
    +
    98  IF ((itypes.EQ.1) .OR. (itypes.EQ.7)) cnst(3) = 500.0
    +
    99  IF (itypes.EQ.107) cnst(3) = 500.0
    +
    100 
    +
    101  cnst(1) = 0.0
    +
    102  cnst(2) = 1.0
    +
    103  cnst(4) = 0.0
    +
    104  IF (cnst(3) .EQ. 500.) cnst(4) = 2.0
    +
    105 C
    +
    106  ELSE IF (q.EQ.11.OR.q.EQ.12.OR.q.EQ.13.OR.q.EQ.14.OR.
    +
    107  & q.EQ.15.OR.q.EQ.16.OR.q.EQ.17.OR.q.EQ.18.OR.
    +
    108  & q.EQ.25.OR.q.EQ.85) THEN
    +
    109 C
    +
    110 
    +
    111 C*** TEMPERATURES (deg. K)
    +
    112 C*** VIRTUAL TEMPERATURE (deg. K)
    +
    113 C*** POTENTIAL TEMPERATURE (deg. K)
    +
    114 C*** PSEUDO-ADIABATIC POTENTIAL TEMPERATURE (deg. K)
    +
    115 C*** MAXIMUN TEMPERATURE (deg. K)
    +
    116 C*** MINUMUN TEMPERATURE (deg. K)
    +
    117 C*** DEW POINT TEMPERATURE (deg. K)
    +
    118 C*** DEW POINT DEPRESSION (OR DEFICIT) (deg. K)
    +
    119 C
    +
    120 C*** TEMP (DEG K) CONVERT TO DEG C, EXCEPT POTENTIAL TEMPERATURE
    +
    121 C
    +
    122 C CNST(1) = -273.15
    +
    123  cnst(1) = 0.0
    +
    124  cnst(2) = 1.0
    +
    125  cnst(3) = 5.0
    +
    126  cnst(4) = 0.0
    +
    127  IF (q.EQ.13) cnst(1) = 0.0
    +
    128 C
    +
    129  ELSE IF (q.EQ.19) THEN
    +
    130 C
    +
    131 C*** LAPSE RATE, deg. K/m ...............
    +
    132 C
    +
    133  cnst(1) = 0.0
    +
    134  cnst(2) = 1.0
    +
    135  cnst(3) = 4.0
    +
    136  cnst(4) = 0.0
    +
    137 C
    +
    138  ELSE IF (q.EQ.21.OR.q.EQ.22.OR.q.EQ.23) THEN
    +
    139 C
    +
    140 C*** RADAR SPECTRA (1), (2), (3) ...............
    +
    141 C
    +
    142  cnst(1) = 0.0
    +
    143  cnst(2) = 1.0
    +
    144  cnst(3) = 10.0
    +
    145  cnst(4) = 0.0
    +
    146 C
    +
    147  ELSE IF (q.EQ.28.OR.q.EQ.29.OR.q.EQ.30) THEN
    +
    148 C
    +
    149 C*** WAVE SPECTRA (1), (2), (3) ...............
    +
    150 C
    +
    151  cnst(1) = 0.0
    +
    152  cnst(2) = 1.0
    +
    153  cnst(3) = 10.0
    +
    154  cnst(4) = 0.0
    +
    155 C
    +
    156  ELSE IF (q.EQ.31) THEN
    +
    157 C
    +
    158 C*** WIND DIRECTION (deg. true)
    +
    159 C
    +
    160  cnst(1) = 0.0
    +
    161  cnst(2) = 1.0
    +
    162  cnst(3) = 10.0
    +
    163  cnst(4) = 0.0
    +
    164 C
    +
    165  ELSE IF (q.EQ.32.OR.q.EQ.33.OR.q.EQ.34) THEN
    +
    166 C
    +
    167 C*** WIND SPEED, U-COMPONENT OF WIND,
    +
    168 C*** V-COMPONENT OF WIND m/s -------------------
    +
    169 C
    +
    170  cnst(1) = 0.0
    +
    171  cnst(2) = 1.0
    +
    172  cnst(3) = 10.0
    +
    173  IF (itypes.EQ.1.AND.ilvl.EQ.0) cnst(3) = 3.0
    +
    174  IF (itypes.EQ.107) cnst(3) = 3.0
    +
    175  cnst(4) = 0.0
    +
    176 C
    +
    177  ELSE IF (q.EQ.35.OR.q.EQ.36) THEN
    +
    178 C
    +
    179 C*** STREAM FUNCTION, VELOCITY POTENTIAL (m**2/s)
    +
    180 C*** STREAM FUNCTION OR VELOCITY POTENTIAL (m**2/s) CONVERTED TO M.
    +
    181 C*** CONVERT TO METERS. (M*M/SEC * FOG)
    +
    182 C
    +
    183  cnst(1) = 0.
    +
    184  cnst(2) = 1.03125e-4 / 9.8
    +
    185  cnst(3) = 60.
    +
    186  cnst(4) = 0.
    +
    187 C
    +
    188  ELSE IF (q.EQ.37) THEN
    +
    189 C
    +
    190 C*** MONTGOMERY STREAM FUNCTION (m**2/s**2)
    +
    191 C
    +
    192  cnst(1) = 0.0
    +
    193  cnst(2) = 1.0
    +
    194  cnst(3) = 2.0
    +
    195  cnst(4) = 0.0
    +
    196 C
    +
    197  ELSE IF (q.EQ.38) THEN
    +
    198 C
    +
    199 C*** SIGMA COORD. VERTICAL VELOCITY (/s) TO MICROBARS/SEC
    +
    200 C
    +
    201  cnst(1) = 0.0
    +
    202  cnst(2) = 1.0
    +
    203  cnst(3) = 2.0
    +
    204  cnst(4) = 0.0
    +
    205 C
    +
    206  ELSE IF (q.EQ.39) THEN
    +
    207 C
    +
    208 C*** VERTICAL VELOCITY (Pa/s) TO MICROBARS/SEC
    +
    209 C*** SIGN CHANGED SUCH THAT POSITIVE VALUES INDICATE UPWARD MOTION.
    +
    210 C
    +
    211  cnst(1) = 0.0
    +
    212  cnst(2) = -1.e1
    +
    213  cnst(3) = 2.0
    +
    214  cnst(4) = 0.0
    +
    215 C
    +
    216  ELSE IF (q.EQ.40) THEN
    +
    217 C
    +
    218 C*** GEOMETRIC VERTICAL VELOCITY -DZDT- (m/s)
    +
    219 C
    +
    220  cnst(1) = 0.0
    +
    221  cnst(2) = 1.0
    +
    222  cnst(3) = 10.0
    +
    223  cnst(4) = 0.0
    +
    224 C
    +
    225  ELSE IF (q.EQ.41.OR.q.EQ.42.OR.q.EQ.43.OR.q.EQ.44.OR.
    +
    226  & q.EQ.45.OR.q.EQ.46) THEN
    +
    227 C
    +
    228 C*** ABSOLUTE VORTICITY -ABS-V (/s)
    +
    229 C*** ABSOLUTE DIVERGENCE -ABS-V (/s)
    +
    230 C*** RELATIVE VORTICITY -REL-V (/s)
    +
    231 C*** RELATIVE DIVERGENCE -REL-D (/s)
    +
    232 C*** VERTICAL U-COMPONENT SHEAR -VUCSH (/s)
    +
    233 C*** VERTICAL V-COMPONENT SHEAR -VVCSH (/s)
    +
    234 C
    +
    235  cnst(1) = 0.0
    +
    236  cnst(2) = 1.0e+6
    +
    237  cnst(3) = 40.0
    +
    238  cnst(4) = 0.0
    +
    239 C
    +
    240  ELSE IF (q.EQ.47) THEN
    +
    241 C
    +
    242 C*** DIRECTION OF CURRENT -DIR-C (deg. true)
    +
    243 C
    +
    244  cnst(1) = 0.0
    +
    245  cnst(2) = 1.0
    +
    246  cnst(3) = 10.0
    +
    247  cnst(4) = 0.0
    +
    248 C
    +
    249  ELSE IF (q.EQ.48.OR.q.EQ.49.OR.q.EQ.50) THEN
    +
    250 C
    +
    251 C*** SPEED OF CURRENT (m/s)
    +
    252 C*** U AND V COMPONENTS OF CURRENT (m/s)
    +
    253 C
    +
    254  cnst(1) = 0.
    +
    255  cnst(2) = 1.
    +
    256  cnst(3) = 2.
    +
    257  cnst(4) = 0.
    +
    258 C
    +
    259  ELSE IF (q.EQ.51.OR.q.EQ.53) THEN
    +
    260 C
    +
    261 C*** SPECIFIC HUMIDITY SPF H (kg/kg)
    +
    262 C*** HUMIDITY MIXING RATIO MIXR (kg/kg)
    +
    263 C
    +
    264  cnst(1) = 0.0
    +
    265  cnst(2) = 1.e+3
    +
    266  cnst(3) = 2.0
    +
    267  cnst(4) = 0.0
    +
    268 C
    +
    269  ELSE IF (q.EQ.52) THEN
    +
    270 C
    +
    271 C*** RELATIVE HUMIDITY R H (%)
    +
    272 C
    +
    273  cnst(1) = 0.0
    +
    274  cnst(2) = 1.0
    +
    275  cnst(3) = 20.0
    +
    276  cnst(4) = 0.0
    +
    277 C
    +
    278  ELSE IF (q.EQ.54.OR.q.EQ.57.OR.q.EQ.58) THEN
    +
    279 C
    +
    280 C*** PRECIPITABLE WATER (kg/m**2) OR .1 GRAM/CM*CM OR MILLIMETERS/CM*CM
    +
    281 C*** CHANGE TO CENTI-INCHES/CM*CM
    +
    282 C*** EVAPERATION
    +
    283 C*** CLOUD ICE (kg/m**2)
    +
    284 C
    +
    285  cnst(1) = 0.0
    +
    286  cnst(2) = 3.937
    +
    287  cnst(3) = 10.0
    +
    288  cnst(4) = 0.0
    +
    289 C
    +
    290  ELSE IF (q.EQ.55.OR.q.EQ.56) THEN
    +
    291 C
    +
    292 C*** VAPOR PRESSURE VAPP, SATURATION DEFICIT SAT D (Pa)
    +
    293 C
    +
    294  cnst(1) = 0.0
    +
    295  cnst(2) = 1.0
    +
    296  cnst(3) = 10.0
    +
    297  cnst(4) = 0.0
    +
    298 C
    +
    299  ELSE IF (q.EQ.59) THEN
    +
    300 C
    +
    301 C*** PRECIPITATION RATE (kg/m**2/s)
    +
    302 C
    +
    303  cnst(1) = 0.0
    +
    304  cnst(2) = 1.0
    +
    305  cnst(3) = 20.0
    +
    306  cnst(4) = 0.0
    +
    307 C
    +
    308  ELSE IF (q.EQ.60) THEN
    +
    309 C
    +
    310 C*** THUNDERSTORM PROBABILITY (%)
    +
    311 C
    +
    312  cnst(1) = 0.0
    +
    313  cnst(2) = 1.0
    +
    314  cnst(3) = 20.0
    +
    315  cnst(4) = 0.0
    +
    316 C
    +
    317  ELSE IF (q.EQ.61.OR.q.EQ.62.OR.q.EQ.63.OR.q.EQ.64.OR.
    +
    318  & q.EQ.65) THEN
    +
    319 C
    +
    320 C*** TOTAL PRECIPITATION A PCP (kg/m**2)
    +
    321 C*** LARGE SCALE PRECIPITATION NCPCP (kg/m**2)
    +
    322 C*** CONVECTIVE PRECIPITATION ACPCP (kg/m**2)
    +
    323 C*** SNOWFALL RATE WATER EQUIVALENT SRWEQ (kg/m**2/s)
    +
    324 C*** WATER EQUIV. OF ACCUM. SNOW DEPTH WEASD (kg/m**2)
    +
    325 C
    +
    326  cnst(1) = 0.0
    +
    327  cnst(2) = 1.0
    +
    328  cnst(3) = 2.0
    +
    329  cnst(4) = 0.0
    +
    330 
    +
    331  ELSE IF (q.EQ.66) THEN
    +
    332 C
    +
    333 C*** SNOW DEPTH (METERS) (1 or 0) for snow or no snow
    +
    334 C
    +
    335  cnst(1) = 0.0
    +
    336  cnst(2) = 1.0
    +
    337  cnst(3) = 1.0
    +
    338  cnst(4) = 0.0
    +
    339 C
    +
    340  ELSE IF (q.EQ.67.OR.q.EQ.68.OR.q.EQ.69.OR.q.EQ.70) THEN
    +
    341 C
    +
    342 C*** MIXING LAYER DEPTH MIXHT (m)
    +
    343 C*** TRANSIENT THEMOCLINE DEPTH TTHDP (m)
    +
    344 C*** MAIN THERMOCLINE DEPTH MTHCD (m)
    +
    345 C*** MAIN THERMOCLINE ANOMALY MTHCA (m)
    +
    346 C
    +
    347  cnst(1) = 0.0
    +
    348  cnst(2) = 39.37
    +
    349  cnst(3) = 06.0
    +
    350  cnst(4) = 0.0
    +
    351 C
    +
    352  ELSE IF (q.EQ.120.OR.q.EQ.121) THEN
    +
    353 C
    +
    354 C*** WAVE COMPONENT OF GEOPOTENTIAL (GEOP M)
    +
    355 C
    +
    356  cnst(1) = 0.0
    +
    357  cnst(2) = 1.0
    +
    358  cnst(3) = 10.0
    +
    359  cnst(4) = 0.0
    +
    360 C
    +
    361  ELSE IF (q.EQ.71.OR.q.EQ.72.OR.q.EQ.73.OR.q.EQ.74.OR.
    +
    362  & q.EQ.75) THEN
    +
    363 C
    +
    364 C*** TOTAL CLOUD COVER T CDC (%)
    +
    365 C*** CONVECTIVE CLOUD COVER CDCON (%)
    +
    366 C*** LOW CLOUD COVER L CDC (%)
    +
    367 C*** MEDIUM CLOUD COVER M CDC (%)
    +
    368 C*** HIGH CLOUD COVER H CDC (%)
    +
    369 C
    +
    370  cnst(1) = 0.0
    +
    371  cnst(2) = 1.0
    +
    372  cnst(3) = 10.0
    +
    373  cnst(4) = 0.0
    +
    374 C
    +
    375  ELSE IF (q.EQ.76) THEN
    +
    376 C
    +
    377 C*** CLOUD WATER -C-WAT (kg/m**2)
    +
    378 C
    +
    379  cnst(1) = 0.0
    +
    380  cnst(2) = 1.0
    +
    381  cnst(3) = 10.0
    +
    382  cnst(4) = 0.0
    +
    383 C
    +
    384  ELSE IF (q.EQ.78) THEN
    +
    385 C
    +
    386 C*** CONVECTIVE SNOW -C-SNO (kg/m**2)
    +
    387 C
    +
    388  cnst(1) = 0.0
    +
    389  cnst(2) = 1.0
    +
    390  cnst(3) = 10.0
    +
    391  cnst(4) = 0.0
    +
    392 C
    +
    393  ELSE IF (q.EQ.79) THEN
    +
    394 C
    +
    395 C*** LARGE SCALE SNOW -LSSNO (kg/m**2)
    +
    396 C
    +
    397  cnst(1) = 0.0
    +
    398  cnst(2) = 0.1
    +
    399  cnst(3) = 500.0
    +
    400  cnst(4) = 0.0
    +
    401 C
    +
    402  ELSE IF (q.EQ.80) THEN
    +
    403 C
    +
    404 C*** WATER TEMPERAUTER -WTMP- (deg. K)
    +
    405 C
    +
    406  cnst(1) = 0.0
    +
    407  cnst(2) = 1.0
    +
    408  cnst(3) = 2.0
    +
    409  cnst(4) = 0.0
    +
    410 C
    +
    411  ELSE IF (q.EQ.81) THEN
    +
    412 C
    +
    413 C*** LAND/SEA (1=LAND; 0=SEA)
    +
    414 C*** ICE CONCENTRATION (ICE=1; NO ICE=0)
    +
    415 C
    +
    416  cnst(1) = 0.0
    +
    417  cnst(2) = 1.0
    +
    418  cnst(3) = 1.0
    +
    419  cnst(4) = 0.5
    +
    420 C
    +
    421  ELSE IF (q.EQ.82.OR.q.EQ.83.OR.q.EQ.92.OR.q.EQ.97) THEN
    +
    422 C
    +
    423 C*** DEVIATION OF SEA LEVEL FROM MEAN (m)
    +
    424 C*** SUFACE ROUGHNESS (m)
    +
    425 C*** ICE THICKNESS (m)
    +
    426 C*** ICE GROWTH (m)
    +
    427 C
    +
    428  cnst(1) = 0.0
    +
    429  cnst(2) = 1.0
    +
    430  cnst(3) = 2.0
    +
    431  cnst(4) = 0.0
    +
    432 C
    +
    433  ELSE IF (q.EQ.84) THEN
    +
    434 C
    +
    435 C*** ALBEDO (%)
    +
    436 C
    +
    437  cnst(1) = 0.0
    +
    438  cnst(2) = 1.0
    +
    439  cnst(3) = 10.0
    +
    440  cnst(4) = 0.0
    +
    441 C
    +
    442  ELSE IF (q.EQ.86) THEN
    +
    443 C
    +
    444 C*** SOIL MOISTURE CONTENT (kg/m**2) -SOILM
    +
    445 C
    +
    446  cnst(1) = 0.0
    +
    447  cnst(2) = 1.0
    +
    448  cnst(3) = 10.0
    +
    449  cnst(4) = 0.0
    +
    450 C
    +
    451  ELSE IF (q.EQ.87) THEN
    +
    452 C
    +
    453 C*** VEGETATION -VEG- (%)
    +
    454 C
    +
    455  cnst(1) = 0.0
    +
    456  cnst(2) = 1.0
    +
    457  cnst(3) = 10.0
    +
    458  cnst(4) = 0.0
    +
    459 C
    +
    460  ELSE IF (q.EQ.88) THEN
    +
    461 C
    +
    462 C*** SALINITY -SALTY- (kg/kg)
    +
    463 C
    +
    464  cnst(1) = 0.0
    +
    465  cnst(2) = 1.0
    +
    466  cnst(3) = 10.0
    +
    467  cnst(4) = 0.0
    +
    468 C
    +
    469  ELSE IF (q.EQ.89) THEN
    +
    470 C
    +
    471 C*** DENSITY -DEN-- (kg/m**3)
    +
    472 C
    +
    473  cnst(1) = 0.0
    +
    474  cnst(2) = 1.0
    +
    475  cnst(3) = 10.0
    +
    476  cnst(4) = 0.0
    +
    477 C
    +
    478  ELSE IF (q.EQ.90) THEN
    +
    479 C
    +
    480 C*** WATER RUNOFF -WAT-R (kg/m**2)
    +
    481 C
    +
    482  cnst(1) = 0.0
    +
    483  cnst(2) = 1.0
    +
    484  cnst(3) = 10.0
    +
    485  cnst(4) = 0.0
    +
    486 C
    +
    487  ELSE IF (q.EQ.93) THEN
    +
    488 C
    +
    489 C*** DIRECTION OF ICE DRIFT -DICED (deg. true)
    +
    490 C
    +
    491  cnst(1) = 0.0
    +
    492  cnst(2) = 1.0
    +
    493  cnst(3) = 10.0
    +
    494  cnst(4) = 0.0
    +
    495 C
    +
    496  ELSE IF (q.EQ.94.OR.q.EQ.95.OR.q.EQ.96) THEN
    +
    497 C
    +
    498 C*** SPEED OF ICE DRIFT -SICED (m/s)
    +
    499 C*** U-COMPONENT OF ICE DRIFT -U-ICE (m/s)
    +
    500 C*** V-COMPONENT OF ICE DRIFT -V-ICE (m/s)
    +
    501 C
    +
    502  cnst(1) = 0.0
    +
    503  cnst(2) = 1.0
    +
    504  cnst(3) = 2.0
    +
    505  cnst(4) = 0.0
    +
    506 C
    +
    507  ELSE IF (q.EQ.98) THEN
    +
    508 C
    +
    509 C*** ICE DIVERGENCE -ICE D (/s)
    +
    510 C
    +
    511  cnst(1) = 0.0
    +
    512  cnst(2) = 1.0
    +
    513  cnst(3) = 10.0
    +
    514  cnst(4) = 0.0
    +
    515 C
    +
    516  ELSE IF (q.EQ.99) THEN
    +
    517 C
    +
    518 C*** SNO MELT -SNO- M (kg/m**2)
    +
    519 C
    +
    520  cnst(1) = 0.0
    +
    521  cnst(2) = 1.0
    +
    522  cnst(3) = 10.0
    +
    523  cnst(4) = 0.0
    +
    524 C
    +
    525  ELSE IF (q.EQ.100.OR.q.EQ.102.OR.q.EQ.105) THEN
    +
    526 C
    +
    527 C*** HEIGHT OF WIND DRIVEN OCEAN WAVES, SEA SWELLS, OR COMBINATION
    +
    528 C*** (m)
    +
    529 C
    +
    530  cnst(1) = 0.0
    +
    531  cnst(2) = 1.0
    +
    532  cnst(3) = 1.0
    +
    533  cnst(4) = 0.0
    +
    534 C
    +
    535  ELSE IF (q.EQ.101.OR.q.EQ.104.OR.q.EQ.107.OR.q.EQ.109) THEN
    +
    536 C
    +
    537 C*** DIRECTION OF WIND WAVES, SWELLS WAVES, PRIMARY WAVE, SECONDARY
    +
    538 C*** WAVE (deg. true) --------------------
    +
    539 C
    +
    540  cnst(1) = 0.0
    +
    541  cnst(2) = 1.0
    +
    542  cnst(3) = 20.0
    +
    543  cnst(4) = 0.0
    +
    544 C
    +
    545  ELSE IF (q.EQ.103.OR.q.EQ.106.OR.q.EQ.108.OR.q.EQ.110) THEN
    +
    546 C
    +
    547 C*** MEAN PERIOD OF WIND WAVES, SWELLS WAVES, PRIMARY WAVE, SECONDARY
    +
    548 C*** WAVE (s) --------------------
    +
    549 C
    +
    550  cnst(1) = 0.0
    +
    551  cnst(2) = 1.0
    +
    552  cnst(3) = 2.0
    +
    553  cnst(4) = 0.0
    +
    554 C
    +
    555  ELSE IF (q.EQ.111.OR.q.EQ.112.OR.q.EQ.113.OR.q.EQ.114.OR.
    +
    556  & q.EQ.115.OR.q.EQ.116.OR.q.EQ.117.OR.q.EQ.121.OR.
    +
    557  & q.EQ.122.OR.q.EQ.123) THEN
    +
    558 C
    +
    559 C*** NET SHORTWAVE RADITION (SURFACE) -NSWRS w/m **2
    +
    560 C*** NET LONGWAVE RADITION (SURFACE) -SHTFL w/m**2
    +
    561 C*** NET SHORTWAVE RADITION (TOP OF ATOMS.) -NSWRT w/m**2
    +
    562 C*** NET LONGWAVE RADITION (TOP OF ATOMS.) -NLWRT w/m**2
    +
    563 C*** LONG WAVE RADITION -LWAVR w/m**2
    +
    564 C*** SHORT WAVE RADITION -SWAVE w/m**2
    +
    565 C*** GLOBAL RADITION -G-RAD w/m**2
    +
    566 C*** LATENT HEAT FLUX -LHTFL w/m**2
    +
    567 C*** SENSIBLE HEAT FLUX -SHTFL w/m**2
    +
    568 C*** BOUNDARY LAYER DISSIPATION -BLYDP w/m**2
    +
    569 C
    +
    570  cnst(1) = 0.0
    +
    571  cnst(2) = 1.0
    +
    572  cnst(3) = 5.0
    +
    573  IF (q.EQ.114) cnst(3) = 20.0
    +
    574  cnst(4) = 0.0
    +
    575 C
    +
    576  ELSE IF (q.EQ.127) THEN
    +
    577 C
    +
    578 C IMAGE DATA -IMG-D
    +
    579 C
    +
    580  cnst(1) = 0.0
    +
    581  cnst(2) = 1.0
    +
    582  cnst(3) = 10.0
    +
    583  cnst(4) = 0.0
    +
    584 C
    +
    585  ELSE IF (q.EQ.128) THEN
    +
    586 C
    +
    587 C Mean Sea Level Pressure -MSLSA (Pa)
    +
    588 C (Standard Atmosphere Reduction)
    +
    589 C
    +
    590  cnst(1) = 0.0
    +
    591  cnst(2) = 0.01
    +
    592  cnst(3) = 4.0
    +
    593  cnst(4) = 0.0
    +
    594 C
    +
    595  ELSE IF (q.EQ.129) THEN
    +
    596 C
    +
    597 C Mean Sea Level Pressure -MSLMA (Pa)
    +
    598 C (Maps System Reduction)
    +
    599 C
    +
    600  cnst(1) = 0.0
    +
    601  cnst(2) = 0.01
    +
    602  cnst(3) = 4.0
    +
    603  cnst(4) = 0.0
    +
    604 C
    +
    605  ELSE IF (q.EQ.130) THEN
    +
    606 C
    +
    607 C Mean Sea Level Pressure -MSLET (Pa)
    +
    608 C (ETA Model Reduction)
    +
    609 C
    +
    610  cnst(1) = 0.0
    +
    611  cnst(2) = 0.01
    +
    612  cnst(3) = 4.0
    +
    613  cnst(4) = 0.0
    +
    614 C
    +
    615  ELSE IF (q.EQ.131.OR.q.EQ.132.OR.q.EQ.133.OR.q.EQ.134) THEN
    +
    616 C
    +
    617 C*** SURFACE LIFTED INDEX ..(DEG K)
    +
    618 C*** BEST (4 LAYER) LIFTED INDEX ..(DEG K)
    +
    619 C*** K INDEX ..(DEG K) TO DEG C.
    +
    620 C*** SWEAT INDEX ..(DEG K) TO DEG C.
    +
    621 C
    +
    622  IF (q.EQ.131.OR.q.EQ.132) THEN
    +
    623  cnst(1) = 0.0
    +
    624  ELSE
    +
    625  cnst(1) = -273.15
    +
    626  END IF
    +
    627  cnst(2) = 1.0
    +
    628  cnst(3) = 4.0
    +
    629  cnst(4) = 0.0
    +
    630 C
    +
    631  ELSE IF (q.EQ.135) THEN
    +
    632 C
    +
    633 C*** HORIZONTIAL MOISTURE DIVERGENCE (KG/KG/S) -MCONV
    +
    634 C
    +
    635  cnst(1) = 0.0
    +
    636  cnst(2) = 1.e+8
    +
    637  cnst(3) = 10.0
    +
    638  cnst(4) = 0.0
    +
    639 C
    +
    640  ELSE IF (q.EQ.136) THEN
    +
    641 C
    +
    642 C*** VERTICAL SPEED SHEAR (1/SEC)... TO BE CONVERTED TO KNOTS/1000 FT
    +
    643 C
    +
    644  cnst(1) = 0.0
    +
    645  cnst(2) = 592.086
    +
    646  cnst(3) = 2.0
    +
    647  cnst(4) = 0.0
    +
    648 C
    +
    649  ELSE IF (q.EQ.137) THEN
    +
    650 C
    +
    651 C*** 3-hr pressure tendency (TSLSA) (Pa/s)
    +
    652 C
    +
    653  cnst(1) = 0.0
    +
    654  cnst(2) = 1000.0
    +
    655  cnst(3) = 10.0
    +
    656  cnst(4) = 0.0
    +
    657 C
    +
    658  ELSE IF (q.EQ.156) THEN
    +
    659 C
    +
    660 C*** CONVECTIVE INHIBITION -CIN-- (J/kg)
    +
    661 C
    +
    662  cnst(1) = 0.0
    +
    663  cnst(2) = 1.0
    +
    664  cnst(3) = 10.0
    +
    665  cnst(4) = 0.0
    +
    666 C
    +
    667  ELSE IF (q.EQ.157) THEN
    +
    668 C
    +
    669 C*** CONVECTIVE AVAILABLE POTENTIAL ENERGY -CAPE- (J/kg)
    +
    670 C
    +
    671  cnst(1) = 0.0
    +
    672  cnst(2) = 1.0
    +
    673  cnst(3) = 500.0
    +
    674  cnst(4) = 0.0
    +
    675 C
    +
    676  ELSE IF (q.EQ.158) THEN
    +
    677 C
    +
    678 C*** TURBULENT KINETIC ENERGY -TKE-- (J/kg)
    +
    679 C
    +
    680  cnst(1) = 0.0
    +
    681  cnst(2) = 1.0
    +
    682  cnst(3) = 100.0
    +
    683  cnst(4) = 0.0
    +
    684 C
    +
    685  ELSE IF (q.EQ.175) THEN
    +
    686 C
    +
    687 C*** MODEL LAYER NUMBER (FROM BOTTOM UP) -SGLYR (non-dim)
    +
    688 C
    +
    689  cnst(1) = 0.0
    +
    690  cnst(2) = 1.0
    +
    691  cnst(3) = 1.0
    +
    692  cnst(4) = 0.0
    +
    693 C
    +
    694  ELSE IF (q.EQ.176) THEN
    +
    695 C
    +
    696 C*** LATITUDE (-90 TO +90) -NLAT- (deg)
    +
    697 C
    +
    698  cnst(1) = 0.0
    +
    699  cnst(2) = 1.0
    +
    700  cnst(3) = 10.0
    +
    701  cnst(4) = 0.0
    +
    702 C
    +
    703  ELSE IF (q.EQ.177) THEN
    +
    704 C
    +
    705 C*** EAST LATITUDE (0-360) -ELON- (deg)
    +
    706 C
    +
    707  cnst(1) = 0.0
    +
    708  cnst(2) = 1.0
    +
    709  cnst(3) = 10.0
    +
    710  cnst(4) = 0.0
    +
    711 C
    +
    712  ELSE IF (q.EQ.201) THEN
    +
    713 C
    +
    714 C*** ICE-FREE WATER SURFACE -ICWAT (%)
    +
    715 C
    +
    716  cnst(1) = 0.0
    +
    717  cnst(2) = 1.0
    +
    718  cnst(3) = 10.0
    +
    719  cnst(4) = 0.0
    +
    720 C
    +
    721  ELSE IF (q.EQ.204) THEN
    +
    722 C
    +
    723 C*** DOWNWARD SHORT WAVE RAD. FLUX -DSWRF (W/m**2)
    +
    724 C
    +
    725  cnst(1) = 0.0
    +
    726  cnst(2) = 1.0
    +
    727  cnst(3) = 10.0
    +
    728  cnst(4) = 0.0
    +
    729 C
    +
    730  ELSE IF (q.EQ.205) THEN
    +
    731 C
    +
    732 C*** DOWNWARD LONG WAVE RAD. FLUX -DLWRF (W/m**2)
    +
    733 C
    +
    734  cnst(1) = 0.0
    +
    735  cnst(2) = 1.0
    +
    736  cnst(3) = 10.0
    +
    737  cnst(4) = 0.0
    +
    738 C
    +
    739  ELSE IF (q.EQ.207) THEN
    +
    740 C
    +
    741 C*** MOISTURE AVAILABILITY -MSTAV (%)
    +
    742 C
    +
    743  cnst(1) = 0.0
    +
    744  cnst(2) = 1.0
    +
    745  cnst(3) = 10.0
    +
    746  cnst(4) = 0.0
    +
    747 C
    +
    748  ELSE IF (q.EQ.208) THEN
    +
    749 C
    +
    750 C*** EXCHANGE COEFFICIENT -SFEXC (kg/m**3)(m/s)
    +
    751 C
    +
    752  cnst(1) = 0.0
    +
    753  cnst(2) = 1.0
    +
    754  cnst(3) = 10.0
    +
    755  cnst(4) = 0.0
    +
    756 CC
    +
    757  ELSE IF (q.EQ.209) THEN
    +
    758 C
    +
    759 C*** NO. OF MIXED LAYERS NEXT TO SURFACE -MIXLY (integer)
    +
    760 C
    +
    761  cnst(1) = 0.0
    +
    762  cnst(2) = 1.0
    +
    763  cnst(3) = 10.0
    +
    764  cnst(4) = 0.0
    +
    765 C
    +
    766  ELSE IF (q.EQ.211) THEN
    +
    767 C
    +
    768 C*** UPWARD SHORT WAVE RAD. FLUX -USWRF (W/m**2)
    +
    769 C
    +
    770  cnst(1) = 0.0
    +
    771  cnst(2) = 1.0
    +
    772  cnst(3) = 10.0
    +
    773  cnst(4) = 0.0
    +
    774 C
    +
    775  ELSE IF (q.EQ.212) THEN
    +
    776 C
    +
    777 C*** UPWARD LONG WAVE RAD. FLUX -ULWRF (W/m**2)
    +
    778 C
    +
    779  cnst(1) = 0.0
    +
    780  cnst(2) = 1.0
    +
    781  cnst(3) = 10.0
    +
    782  cnst(4) = 0.0
    +
    783 C
    +
    784  ELSE IF (q.EQ.213) THEN
    +
    785 C
    +
    786 C*** AMOUNT OF NON-CONVECTIVE CLOUD -CDLYR (%)
    +
    787 C
    +
    788  cnst(1) = 0.0
    +
    789  cnst(2) = 1.0
    +
    790  cnst(3) = 10.0
    +
    791  cnst(4) = 0.0
    +
    792 C
    +
    793  ELSE IF (q.EQ.216) THEN
    +
    794 C
    +
    795 C*** TEMPERATURE TENDENCY BY ALL RADIATION -TTRAD (Deg. K/s)
    +
    796 C
    +
    797  cnst(1) = 0.0
    +
    798  cnst(2) = 1.0
    +
    799  cnst(3) = 10.0
    +
    800  cnst(4) = 0.0
    +
    801 C
    +
    802  ELSE IF (q.EQ.218) THEN
    +
    803 C
    +
    804 C*** PRECIP. INDEX (0.0-1.00) -PREIX (note will look like %)
    +
    805 C
    +
    806  cnst(1) = 0.0
    +
    807  cnst(2) = 100.0
    +
    808  cnst(3) = 10.0
    +
    809  cnst(4) = 0.0
    +
    810 C
    +
    811  ELSE IF (q.EQ.220) THEN
    +
    812 C
    +
    813 C*** NATURAL LOG OF SURFACE PRESSURE -NLGSP ln(kPa)
    +
    814 C
    +
    815  cnst(1) = 0.0
    +
    816  cnst(2) = 1.0
    +
    817  cnst(3) = 10.0
    +
    818  cnst(4) = 0.0
    +
    819 C
    +
    820 C*** NONE OF THE ABOVE ....
    +
    821 C
    +
    822  ELSE
    +
    823 C
    +
    824 C SET DEFAULT VALUES
    +
    825 C
    +
    826  cnst(1) = 0.0
    +
    827  cnst(2) = 1.0
    +
    828  cnst(3) = 5.0
    +
    829  cnst(4) = 0.0
    +
    830  ier = 1
    +
    831  END IF
    +
    832 C
    +
    833  RETURN
    +
    834  END
    +
    +
    +
    w3fi70
    subroutine w3fi70(PDS, CNST, IER)
    Computes the four scaling constants used by grdprt, w3fp03, or w3fp05 from the 28 byte (pds) product ...
    Definition: w3fi70.f:21
    +
    w3fi69
    subroutine w3fi69(PDS, ID)
    Converts an edition 1 grib produce definition section (pds) to a 25, or 27 word integer array.
    Definition: w3fi69.f:29
    + + + + diff --git a/ver-2.10.0/w3fi71_8f.html b/ver-2.10.0/w3fi71_8f.html new file mode 100644 index 00000000..4f9ab768 --- /dev/null +++ b/ver-2.10.0/w3fi71_8f.html @@ -0,0 +1,351 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi71.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi71.f File Reference
    +
    +
    + +

    Make array used by GRIB packer for GDS. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi71 (IGRID, IGDS, IERR)
     Makes a 18, 37, 55, 64, or 91 word integer array used by w3fi72() GRIB packer to make the grid description section (GDS) - section 2. More...
     
    +

    Detailed Description

    +

    Make array used by GRIB packer for GDS.

    +
    Author
    Ralph Jones
    +
    Date
    1992-02-21
    + +

    Definition in file w3fi71.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi71()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi71 (integer IGRID,
    integer, dimension (*) IGDS,
     IERR 
    )
    +
    + +

    Makes a 18, 37, 55, 64, or 91 word integer array used by w3fi72() GRIB packer to make the grid description section (GDS) - section 2.

    +
    Note
      +
    • 1) Office note grid type 26 is 6 in grib, 26 is an international exchange grid.
      • +
    • 2) Values returned in 18, 37, 55, 64, or 91 word integer array igds vary depending on grid representation type.
      • +
    • LAT/LON GRID:
        +
      • IGDS( 1) = number of vertical coordinates
        • +
      • IGDS( 2) = pv, pl or 255
        • +
      • IGDS( 3) = data representation type (code table 6)
        • +
      • IGDS( 4) = no. of points along a latitude
        • +
      • IGDS( 5) = no. of points along a longitude meridian
        • +
      • IGDS( 6) = latitude of origin (south - ive)
        • +
      • IGDS( 7) = longitude of origin (west -ive)
        • +
      • IGDS( 8) = resolution flag (code table 7)
        • +
      • IGDS( 9) = latitude of extreme point (south - ive)
        • +
      • IGDS(10) = longitude of extreme point (west - ive)
        • +
      • IGDS(11) = latitude increment
        • +
      • IGDS(12) = longitude increment
        • +
      • IGDS(13) = scanning mode flags (code table 8)
        • +
      • IGDS(14) = ... through ...
        • +
      • IGDS(18) = ... not used for this grid
        • +
      • IGDS(19) - igds(91) for grids 37-44, number of points
        • +
      • in each of 73 rows.
        • +
      +
      • +
    • GAUSSIAN GRID:
        +
      • IGDS( 1) = ... through ...
        • +
      • IGDS(10) = ... same as lat/lon grid
        • +
      • IGDS(11) = number of latitude lines between a pole
        • +
      • and the equator
        • +
      • IGDS(12) = longitude increment
        • +
      • IGDS(13) = scanning mode flags (code table 8)
        • +
      • IGDS(14) = ... through ...
        • +
      • IGDS(18) = ... not used for this grid
        • +
      +
      • +
    • SPHERICAL HARMONICS:
        +
      • IGDS( 1) = number of vertical coordinates
        • +
      • IGDS( 2) = pv, pl or 255
        • +
      • IGDS( 3) = data representation type (code table 6)
        • +
      • IGDS( 4) = j - pentagonal resolution parameter
        • +
      • IGDS( 5) = k - pentagonal resolution parameter
        • +
      • IGDS( 6) = m - pentagonal resolution parameter
        • +
      • IGDS( 7) = representation type (code table 9)
        • +
      • IGDS( 8) = representation mode (code table 10)
        • +
      • IGDS( 9) = ... through ...
        • +
      • IGDS(18) = ... not used for this grid
        • +
      +
      • +
    • POLAR STEREOGRAPHIC:
        +
      • IGDS( 1) = number of vertical coordinates
        • +
      • IGDS( 2) = pv, pl or 255
        • +
      • IGDS( 3) = data representation type (code table 6)
        • +
      • IGDS( 4) = no. of points along x-axis
        • +
      • IGDS( 5) = no. of points along y-axis
        • +
      • IGDS( 6) = latitude of origin (south -ive)
        • +
      • IGDS( 7) = longitute of origin (west -ive)
        • +
      • IGDS( 8) = resolution flag (code table 7)
        • +
      • IGDS( 9) = longitude of meridian parallel to y-axis
        • +
      • IGDS(10) = x-direction grid length (increment)
        • +
      • IGDS(11) = y-direction grid length (increment)
        • +
      • IGDS(12) = projection center flag (0=north pole on plane,
        • +
      • 1=south pole on plane,
        • +
      • IGDS(13) = scanning mode flags (code table 8)
        • +
      • IGDS(14) = ... through ...
        • +
      • IGDS(18) = .. not used for this grid
        • +
      +
      • +
    • MERCATOR:
        +
      • IGDS( 1) = ... through ...
        • +
      • IGDS(12) = ... same as lat/lon grid
        • +
      • IGDS(13) = latitude at which projection cylinder
        • +
      • intersects earth
        • +
      • IGDS(14) = scanning mode flags
        • +
      • IGDS(15) = ... through ...
        • +
      • IGDS(18) = .. not used for this grid
        • +
      +
      • +
    • LAMBERT CONFORMAL:
        +
      • IGDS( 1) = number of vertical coordinates
        • +
      • IGDS( 2) = pv, pl or 255
        • +
      • IGDS( 3) = data representation type (code table 6)
        • +
      • IGDS( 4) = no. of points along x-axis
        • +
      • IGDS( 5) = no. of points along y-axis
        • +
      • IGDS( 6) = latitude of origin (south -ive)
        • +
      • IGDS( 7) = longitute of origin (west -ive)
        • +
      • IGDS( 8) = resolution flag (code table 7)
        • +
      • IGDS( 9) = longitude of meridian parallel to y-axis
        • +
      • IGDS(10) = x-direction grid length (increment)
        • +
      • IGDS(11) = y-direction grid length (increment)
        • +
      • IGDS(12) = projection center flag (0=north pole on plane,
        • +
      • 1=south pole on plane,
        • +
      • IGDS(13) = scanning mode flags (code table 8)
        • +
      • IGDS(14) = not used
        • +
      • IGDS(15) = first latitude from the pole at which the
        • +
      • secant cone cuts the sperical earth
        • +
      • IGDS(16) = second latitude ...
        • +
      • IGDS(17) = latitude of south pole (millidegrees)
        • +
      • IGDS(18) = longitude of south pole (millidegrees)
        • +
      +
      • +
    • ARAKAWA SEMI-STAGGERED E-GRID ON ROTATED LAT/LON GRID
        +
      • IGDS( 1) = number of vertical coordinates
        • +
      • IGDS( 2) = pv, pl or 255
        • +
      • IGDS( 3) = data representation type (code table 6) [201]
        • +
      • IGDS( 4) = ni - total number of actual data points
        • +
      • included on grid
        • +
      • IGDS( 5) = nj - dummy second dimension; set=1
        • +
      • IGDS( 6) = la1 - latitude of first grid point
        • +
      • IGDS( 7) = lo1 - longitude of first grid point
        • +
      • IGDS( 8) = resolution and component flag (code table 7)
        • +
      • IGDS( 9) = la2 - number of mass points along
        • +
      • southernmost row of grid
        • +
      • IGDS(10) = lo2 - number of rows in each column
        • +
      • IGDS(11) = di - longitudinal direction increment
        • +
      • IGDS(12) = dj - latitudinal direction increment
        • +
      • IGDS(13) = scanning mode flags (code table 8)
        • +
      • IGDS(14) = ... through ...
        • +
      • IGDS(18) = ... not used for this grid (set to zero)
        • +
      +
      • +
    • ARAKAWA FILLED E-GRID ON ROTATED LAT/LON GRID
        +
      • IGDS( 1) = number of vertical coordinates
        • +
      • IGDS( 2) = pv, pl or 255
        • +
      • IGDS( 3) = data representation type (code table 6) [202]
        • +
      • IGDS( 4) = ni - total number of actual data points
        • +
      • included on grid
        • +
      • IGDS( 5) = nj - dummy second dimention; set=1
        • +
      • IGDS( 6) = la1 - latitude latitude of first grid point
        • +
      • IGDS( 7) = lo1 - longitude of first grid point
        • +
      • IGDS( 8) = resolution and component flag (code table 7)
        • +
      • IGDS( 9) = la2 - number of (zonal) points in each row
        • +
      • IGDS(10) = lo2 - number of (meridional) points in each
        • +
      • column
        • +
      • IGDS(11) = di - longitudinal direction increment
        • +
      • IGDS(12) = dj - latitudinal direction increment
        • +
      • IGDS(13) = scanning mode flags (code table 8)
        • +
      • IGDS(14) = ... through ...
        • +
      • IGDS(18) = ... not used for this grid
        • +
      +
      • +
    • ARAKAWA STAGGERED E-GRID ON ROTATED LAT/LON GRID
        +
      • IGDS( 1) = number of vertical coordinates
        • +
      • IGDS( 2) = pv, pl or 255
        • +
      • IGDS( 3) = data representation type (code table 6) [203]
        • +
      • IGDS( 4) = ni - number of data points in each row
        • +
      • IGDS( 5) = nj - number of rows
        • +
      • IGDS( 6) = la1 - latitude of first grid point
        • +
      • IGDS( 7) = lo1 - longitude of first grid point
        • +
      • IGDS( 8) = resolution and component flag (code table 7)
        • +
      • IGDS( 9) = la2 - central latitude
        • +
      • IGDS(10) = lo2 - central longtitude
        • +
      • IGDS(11) = di - longitudinal direction increment
        • +
      • IGDS(12) = dj - latitudinal direction increment
        • +
      • IGDS(13) = scanning mode flags (code table 8)
        • +
      • IGDS(14) = ... through ...
        • +
      • IGDS(18) = ... not used for this grid
        • +
      +
      • +
    • CURVILINEAR ORTHOGONAL GRID
        +
      • IGDS( 1) = number of vertical coordinates
        • +
      • IGDS( 2) = pv, pl or 255
        • +
      • IGDS( 3) = data representation type (code table 6) [204]
        • +
      • IGDS( 4) = ni - number of data points in each row
        • +
      • IGDS( 5) = nj - number of rows
        • +
      • IGDS( 6) = reserved (set to 0)
        • +
      • IGDS( 7) = reserved (set to 0)
        • +
      • IGDS( 8) = resolution and component flag (code table 7)
        • +
      • IGDS( 9) = reserved (set to 0)
        • +
      • IGDS(10) = reserved (set to 0)
        • +
      • IGDS(11) = reserved (set to 0)
        • +
      • IGDS(12) = reserved (set to 0)
        • +
      • IGDS(13) = scanning mode flags (code table 8)
        • +
      • IGDS(14) = ... through ...
        • +
      • IGDS(18) = ... not used for this grid
        • +
      +
      • +
    +
    +
    Parameters
    + + + + +
    [in]IGRIDGRIB grid number, or office note 84 grid number
    [out]IGDS18, 37, 55, 64, or 91 word integer array with information to make a grib grid description section.
    [out]IERR
      +
    • 0 Correct exit
      • +
    • 1 Grid type in igrid is not in table
      • +
    +
    +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1992-02-21
    + +

    Definition at line 187 of file w3fi71.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi71_8f.js b/ver-2.10.0/w3fi71_8f.js new file mode 100644 index 00000000..cc74ec30 --- /dev/null +++ b/ver-2.10.0/w3fi71_8f.js @@ -0,0 +1,4 @@ +var w3fi71_8f = +[ + [ "w3fi71", "w3fi71_8f.html#add1b6b2b2c9fda60094914f5e676ec42", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi71_8f_source.html b/ver-2.10.0/w3fi71_8f_source.html new file mode 100644 index 00000000..d62f9521 --- /dev/null +++ b/ver-2.10.0/w3fi71_8f_source.html @@ -0,0 +1,1758 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi71.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi71.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Make array used by GRIB packer for GDS.
    +
    3 C> @author Ralph Jones @date 1992-02-21
    +
    4 
    +
    5 C> Makes a 18, 37, 55, 64, or 91 word integer array
    +
    6 C> used by w3fi72() GRIB packer to make the grid description section
    +
    7 C> (GDS) - section 2.
    +
    8 C>
    +
    9 C> @note
    +
    10 C> - 1) Office note grid type 26 is 6 in grib, 26 is an
    +
    11 C> international exchange grid.
    +
    12 C>
    +
    13 C> - 2) Values returned in 18, 37, 55, 64, or 91 word integer array
    +
    14 C> igds vary depending on grid representation type.
    +
    15 C>
    +
    16 C> - LAT/LON GRID:
    +
    17 C> - IGDS( 1) = number of vertical coordinates
    +
    18 C> - IGDS( 2) = pv, pl or 255
    +
    19 C> - IGDS( 3) = data representation type (code table 6)
    +
    20 C> - IGDS( 4) = no. of points along a latitude
    +
    21 C> - IGDS( 5) = no. of points along a longitude meridian
    +
    22 C> - IGDS( 6) = latitude of origin (south - ive)
    +
    23 C> - IGDS( 7) = longitude of origin (west -ive)
    +
    24 C> - IGDS( 8) = resolution flag (code table 7)
    +
    25 C> - IGDS( 9) = latitude of extreme point (south - ive)
    +
    26 C> - IGDS(10) = longitude of extreme point (west - ive)
    +
    27 C> - IGDS(11) = latitude increment
    +
    28 C> - IGDS(12) = longitude increment
    +
    29 C> - IGDS(13) = scanning mode flags (code table 8)
    +
    30 C> - IGDS(14) = ... through ...
    +
    31 C> - IGDS(18) = ... not used for this grid
    +
    32 C> - IGDS(19) - igds(91) for grids 37-44, number of points
    +
    33 C> - in each of 73 rows.
    +
    34 C>
    +
    35 C> - GAUSSIAN GRID:
    +
    36 C> - IGDS( 1) = ... through ...
    +
    37 C> - IGDS(10) = ... same as lat/lon grid
    +
    38 C> - IGDS(11) = number of latitude lines between a pole
    +
    39 C> - and the equator
    +
    40 C> - IGDS(12) = longitude increment
    +
    41 C> - IGDS(13) = scanning mode flags (code table 8)
    +
    42 C> - IGDS(14) = ... through ...
    +
    43 C> - IGDS(18) = ... not used for this grid
    +
    44 C>
    +
    45 C> - SPHERICAL HARMONICS:
    +
    46 C> - IGDS( 1) = number of vertical coordinates
    +
    47 C> - IGDS( 2) = pv, pl or 255
    +
    48 C> - IGDS( 3) = data representation type (code table 6)
    +
    49 C> - IGDS( 4) = j - pentagonal resolution parameter
    +
    50 C> - IGDS( 5) = k - pentagonal resolution parameter
    +
    51 C> - IGDS( 6) = m - pentagonal resolution parameter
    +
    52 C> - IGDS( 7) = representation type (code table 9)
    +
    53 C> - IGDS( 8) = representation mode (code table 10)
    +
    54 C> - IGDS( 9) = ... through ...
    +
    55 C> - IGDS(18) = ... not used for this grid
    +
    56 C>
    +
    57 C> - POLAR STEREOGRAPHIC:
    +
    58 C> - IGDS( 1) = number of vertical coordinates
    +
    59 C> - IGDS( 2) = pv, pl or 255
    +
    60 C> - IGDS( 3) = data representation type (code table 6)
    +
    61 C> - IGDS( 4) = no. of points along x-axis
    +
    62 C> - IGDS( 5) = no. of points along y-axis
    +
    63 C> - IGDS( 6) = latitude of origin (south -ive)
    +
    64 C> - IGDS( 7) = longitute of origin (west -ive)
    +
    65 C> - IGDS( 8) = resolution flag (code table 7)
    +
    66 C> - IGDS( 9) = longitude of meridian parallel to y-axis
    +
    67 C> - IGDS(10) = x-direction grid length (increment)
    +
    68 C> - IGDS(11) = y-direction grid length (increment)
    +
    69 C> - IGDS(12) = projection center flag (0=north pole on plane,
    +
    70 C> - 1=south pole on plane,
    +
    71 C> - IGDS(13) = scanning mode flags (code table 8)
    +
    72 C> - IGDS(14) = ... through ...
    +
    73 C> - IGDS(18) = .. not used for this grid
    +
    74 C>
    +
    75 C> - MERCATOR:
    +
    76 C> - IGDS( 1) = ... through ...
    +
    77 C> - IGDS(12) = ... same as lat/lon grid
    +
    78 C> - IGDS(13) = latitude at which projection cylinder
    +
    79 C> - intersects earth
    +
    80 C> - IGDS(14) = scanning mode flags
    +
    81 C> - IGDS(15) = ... through ...
    +
    82 C> - IGDS(18) = .. not used for this grid
    +
    83 C>
    +
    84 C> - LAMBERT CONFORMAL:
    +
    85 C> - IGDS( 1) = number of vertical coordinates
    +
    86 C> - IGDS( 2) = pv, pl or 255
    +
    87 C> - IGDS( 3) = data representation type (code table 6)
    +
    88 C> - IGDS( 4) = no. of points along x-axis
    +
    89 C> - IGDS( 5) = no. of points along y-axis
    +
    90 C> - IGDS( 6) = latitude of origin (south -ive)
    +
    91 C> - IGDS( 7) = longitute of origin (west -ive)
    +
    92 C> - IGDS( 8) = resolution flag (code table 7)
    +
    93 C> - IGDS( 9) = longitude of meridian parallel to y-axis
    +
    94 C> - IGDS(10) = x-direction grid length (increment)
    +
    95 C> - IGDS(11) = y-direction grid length (increment)
    +
    96 C> - IGDS(12) = projection center flag (0=north pole on plane,
    +
    97 C> - 1=south pole on plane,
    +
    98 C> - IGDS(13) = scanning mode flags (code table 8)
    +
    99 C> - IGDS(14) = not used
    +
    100 C> - IGDS(15) = first latitude from the pole at which the
    +
    101 C> - secant cone cuts the sperical earth
    +
    102 C> - IGDS(16) = second latitude ...
    +
    103 C> - IGDS(17) = latitude of south pole (millidegrees)
    +
    104 C> - IGDS(18) = longitude of south pole (millidegrees)
    +
    105 C>
    +
    106 C> - ARAKAWA SEMI-STAGGERED E-GRID ON ROTATED LAT/LON GRID
    +
    107 C> - IGDS( 1) = number of vertical coordinates
    +
    108 C> - IGDS( 2) = pv, pl or 255
    +
    109 C> - IGDS( 3) = data representation type (code table 6) [201]
    +
    110 C> - IGDS( 4) = ni - total number of actual data points
    +
    111 C> - included on grid
    +
    112 C> - IGDS( 5) = nj - dummy second dimension; set=1
    +
    113 C> - IGDS( 6) = la1 - latitude of first grid point
    +
    114 C> - IGDS( 7) = lo1 - longitude of first grid point
    +
    115 C> - IGDS( 8) = resolution and component flag (code table 7)
    +
    116 C> - IGDS( 9) = la2 - number of mass points along
    +
    117 C> - southernmost row of grid
    +
    118 C> - IGDS(10) = lo2 - number of rows in each column
    +
    119 C> - IGDS(11) = di - longitudinal direction increment
    +
    120 C> - IGDS(12) = dj - latitudinal direction increment
    +
    121 C> - IGDS(13) = scanning mode flags (code table 8)
    +
    122 C> - IGDS(14) = ... through ...
    +
    123 C> - IGDS(18) = ... not used for this grid (set to zero)
    +
    124 C>
    +
    125 C> - ARAKAWA FILLED E-GRID ON ROTATED LAT/LON GRID
    +
    126 C> - IGDS( 1) = number of vertical coordinates
    +
    127 C> - IGDS( 2) = pv, pl or 255
    +
    128 C> - IGDS( 3) = data representation type (code table 6) [202]
    +
    129 C> - IGDS( 4) = ni - total number of actual data points
    +
    130 C> - included on grid
    +
    131 C> - IGDS( 5) = nj - dummy second dimention; set=1
    +
    132 C> - IGDS( 6) = la1 - latitude latitude of first grid point
    +
    133 C> - IGDS( 7) = lo1 - longitude of first grid point
    +
    134 C> - IGDS( 8) = resolution and component flag (code table 7)
    +
    135 C> - IGDS( 9) = la2 - number of (zonal) points in each row
    +
    136 C> - IGDS(10) = lo2 - number of (meridional) points in each
    +
    137 C> - column
    +
    138 C> - IGDS(11) = di - longitudinal direction increment
    +
    139 C> - IGDS(12) = dj - latitudinal direction increment
    +
    140 C> - IGDS(13) = scanning mode flags (code table 8)
    +
    141 C> - IGDS(14) = ... through ...
    +
    142 C> - IGDS(18) = ... not used for this grid
    +
    143 C>
    +
    144 C> - ARAKAWA STAGGERED E-GRID ON ROTATED LAT/LON GRID
    +
    145 C> - IGDS( 1) = number of vertical coordinates
    +
    146 C> - IGDS( 2) = pv, pl or 255
    +
    147 C> - IGDS( 3) = data representation type (code table 6) [203]
    +
    148 C> - IGDS( 4) = ni - number of data points in each row
    +
    149 C> - IGDS( 5) = nj - number of rows
    +
    150 C> - IGDS( 6) = la1 - latitude of first grid point
    +
    151 C> - IGDS( 7) = lo1 - longitude of first grid point
    +
    152 C> - IGDS( 8) = resolution and component flag (code table 7)
    +
    153 C> - IGDS( 9) = la2 - central latitude
    +
    154 C> - IGDS(10) = lo2 - central longtitude
    +
    155 C> - IGDS(11) = di - longitudinal direction increment
    +
    156 C> - IGDS(12) = dj - latitudinal direction increment
    +
    157 C> - IGDS(13) = scanning mode flags (code table 8)
    +
    158 C> - IGDS(14) = ... through ...
    +
    159 C> - IGDS(18) = ... not used for this grid
    +
    160 C>
    +
    161 C> - CURVILINEAR ORTHOGONAL GRID
    +
    162 C> - IGDS( 1) = number of vertical coordinates
    +
    163 C> - IGDS( 2) = pv, pl or 255
    +
    164 C> - IGDS( 3) = data representation type (code table 6) [204]
    +
    165 C> - IGDS( 4) = ni - number of data points in each row
    +
    166 C> - IGDS( 5) = nj - number of rows
    +
    167 C> - IGDS( 6) = reserved (set to 0)
    +
    168 C> - IGDS( 7) = reserved (set to 0)
    +
    169 C> - IGDS( 8) = resolution and component flag (code table 7)
    +
    170 C> - IGDS( 9) = reserved (set to 0)
    +
    171 C> - IGDS(10) = reserved (set to 0)
    +
    172 C> - IGDS(11) = reserved (set to 0)
    +
    173 C> - IGDS(12) = reserved (set to 0)
    +
    174 C> - IGDS(13) = scanning mode flags (code table 8)
    +
    175 C> - IGDS(14) = ... through ...
    +
    176 C> - IGDS(18) = ... not used for this grid
    +
    177 C>
    +
    178 C> @param[in] IGRID GRIB grid number, or office note 84 grid number
    +
    179 C> @param[out] IGDS 18, 37, 55, 64, or 91 word integer array with
    +
    180 C> information to make a grib grid description section.
    +
    181 C> @param[out] IERR:
    +
    182 C> - 0 Correct exit
    +
    183 C> - 1 Grid type in igrid is not in table
    +
    184 C>
    +
    185 C> @author Ralph Jones @date 1992-02-21
    +
    186  SUBROUTINE w3fi71 (IGRID, IGDS, IERR)
    +
    187 C
    +
    188  INTEGER IGRID
    +
    189  INTEGER IGDS (*)
    +
    190  INTEGER GRD1 (18)
    +
    191  INTEGER GRD2 (18)
    +
    192  INTEGER GRD3 (18)
    +
    193  INTEGER GRD4 (18)
    +
    194  INTEGER GRD5 (18)
    +
    195  INTEGER GRD6 (18)
    +
    196  INTEGER GRD8 (18)
    +
    197  INTEGER GRD10 (18)
    +
    198  INTEGER GRD11 (18)
    +
    199  INTEGER GRD12 (18)
    +
    200  INTEGER GRD13 (18)
    +
    201  INTEGER GRD14 (18)
    +
    202  INTEGER GRD15 (18)
    +
    203  INTEGER GRD16 (18)
    +
    204  INTEGER GRD17 (18)
    +
    205  INTEGER GRD18 (18)
    +
    206  INTEGER GRD21 (55)
    +
    207  INTEGER GRD22 (55)
    +
    208  INTEGER GRD23 (55)
    +
    209  INTEGER GRD24 (55)
    +
    210  INTEGER GRD25 (37)
    +
    211  INTEGER GRD26 (37)
    +
    212  INTEGER GRD27 (18)
    +
    213  INTEGER GRD28 (18)
    +
    214  INTEGER GRD29 (18)
    +
    215  INTEGER GRD30 (18)
    +
    216  INTEGER GRD33 (18)
    +
    217  INTEGER GRD34 (18)
    +
    218  INTEGER GRD37 (91)
    +
    219  INTEGER GRD38 (91)
    +
    220  INTEGER GRD39 (91)
    +
    221  INTEGER GRD40 (91)
    +
    222  INTEGER GRD41 (91)
    +
    223  INTEGER GRD42 (91)
    +
    224  INTEGER GRD43 (91)
    +
    225  INTEGER GRD44 (91)
    +
    226  INTEGER GRD45 (18)
    +
    227  INTEGER GRD53 (18)
    +
    228  INTEGER GRD55 (18)
    +
    229  INTEGER GRD56 (18)
    +
    230  INTEGER GRD61 (64)
    +
    231  INTEGER GRD62 (64)
    +
    232  INTEGER GRD63 (64)
    +
    233  INTEGER GRD64 (64)
    +
    234  INTEGER GRD83 (18)
    +
    235  INTEGER GRD85 (18)
    +
    236  INTEGER GRD86 (18)
    +
    237  INTEGER GRD87 (18)
    +
    238  INTEGER GRD88 (18)
    +
    239  INTEGER GRD90 (18)
    +
    240  INTEGER GRD91 (18)
    +
    241  INTEGER GRD92 (18)
    +
    242  INTEGER GRD93 (18)
    +
    243  INTEGER GRD94 (18)
    +
    244  INTEGER GRD95 (18)
    +
    245  INTEGER GRD96 (18)
    +
    246  INTEGER GRD97 (18)
    +
    247  INTEGER GRD98 (18)
    +
    248  INTEGER GRD99 (18)
    +
    249  INTEGER GRD100(18)
    +
    250  INTEGER GRD101(18)
    +
    251  INTEGER GRD103(18)
    +
    252  INTEGER GRD104(18)
    +
    253  INTEGER GRD105(18)
    +
    254  INTEGER GRD106(18)
    +
    255  INTEGER GRD107(18)
    +
    256  INTEGER GRD110(18)
    +
    257  INTEGER GRD120(18)
    +
    258  INTEGER GRD122(18)
    +
    259  INTEGER GRD123(18)
    +
    260  INTEGER GRD124(18)
    +
    261  INTEGER GRD125(18)
    +
    262  INTEGER GRD126(18)
    +
    263  INTEGER GRD127(18)
    +
    264  INTEGER GRD128(18)
    +
    265  INTEGER GRD129(18)
    +
    266  INTEGER GRD130(18)
    +
    267  INTEGER GRD132(18)
    +
    268  INTEGER GRD138(18)
    +
    269  INTEGER GRD139(18)
    +
    270  INTEGER GRD140(18)
    +
    271  INTEGER GRD145(18)
    +
    272  INTEGER GRD146(18)
    +
    273  INTEGER GRD147(18)
    +
    274  INTEGER GRD148(18)
    +
    275  INTEGER GRD150(18)
    +
    276  INTEGER GRD151(18)
    +
    277  INTEGER GRD160(18)
    +
    278  INTEGER GRD161(18)
    +
    279  INTEGER GRD163(18)
    +
    280  INTEGER GRD170(18)
    +
    281  INTEGER GRD171(18)
    +
    282  INTEGER GRD172(18)
    +
    283  INTEGER GRD173(18)
    +
    284  INTEGER GRD174(18)
    +
    285  INTEGER GRD175(18)
    +
    286  INTEGER GRD176(18)
    +
    287  INTEGER GRD179(18)
    +
    288  INTEGER GRD180(18)
    +
    289  INTEGER GRD181(18)
    +
    290  INTEGER GRD182(18)
    +
    291  INTEGER GRD183(18)
    +
    292  INTEGER GRD184(18)
    +
    293  INTEGER GRD187(18)
    +
    294  INTEGER GRD188(18)
    +
    295  INTEGER GRD189(18)
    +
    296  INTEGER GRD190(18)
    +
    297  INTEGER GRD192(18)
    +
    298  INTEGER GRD193(18)
    +
    299  INTEGER GRD194(18)
    +
    300  INTEGER GRD195(18)
    +
    301  INTEGER GRD196(18)
    +
    302  INTEGER GRD197(18)
    +
    303  INTEGER GRD198(18)
    +
    304  INTEGER GRD199(18)
    +
    305  INTEGER GRD200(18)
    +
    306  INTEGER GRD201(18)
    +
    307  INTEGER GRD202(18)
    +
    308  INTEGER GRD203(18)
    +
    309  INTEGER GRD204(18)
    +
    310  INTEGER GRD205(18)
    +
    311  INTEGER GRD206(18)
    +
    312  INTEGER GRD207(18)
    +
    313  INTEGER GRD208(18)
    +
    314  INTEGER GRD209(18)
    +
    315  INTEGER GRD210(18)
    +
    316  INTEGER GRD211(18)
    +
    317  INTEGER GRD212(18)
    +
    318  INTEGER GRD213(18)
    +
    319  INTEGER GRD214(18)
    +
    320  INTEGER GRD215(18)
    +
    321  INTEGER GRD216(18)
    +
    322  INTEGER GRD217(18)
    +
    323  INTEGER GRD218(18)
    +
    324  INTEGER GRD219(18)
    +
    325  INTEGER GRD220(18)
    +
    326  INTEGER GRD221(18)
    +
    327  INTEGER GRD222(18)
    +
    328  INTEGER GRD223(18)
    +
    329  INTEGER GRD224(18)
    +
    330  INTEGER GRD225(18)
    +
    331  INTEGER GRD226(18)
    +
    332  INTEGER GRD227(18)
    +
    333  INTEGER GRD228(18)
    +
    334  INTEGER GRD229(18)
    +
    335  INTEGER GRD230(18)
    +
    336  INTEGER GRD231(18)
    +
    337  INTEGER GRD232(18)
    +
    338  INTEGER GRD233(18)
    +
    339  INTEGER GRD234(18)
    +
    340  INTEGER GRD235(18)
    +
    341  INTEGER GRD236(18)
    +
    342  INTEGER GRD237(18)
    +
    343  INTEGER GRD238(18)
    +
    344  INTEGER GRD239(18)
    +
    345  INTEGER GRD240(18)
    +
    346  INTEGER GRD241(18)
    +
    347  INTEGER GRD242(18)
    +
    348  INTEGER GRD243(18)
    +
    349  INTEGER GRD244(18)
    +
    350  INTEGER GRD245(18)
    +
    351  INTEGER GRD246(18)
    +
    352  INTEGER GRD247(18)
    +
    353  INTEGER GRD248(18)
    +
    354  INTEGER GRD249(18)
    +
    355  INTEGER GRD250(18)
    +
    356  INTEGER GRD251(18)
    +
    357  INTEGER GRD252(18)
    +
    358  INTEGER GRD253(18)
    +
    359  INTEGER GRD254(18)
    +
    360 C
    +
    361  DATA grd1 / 0, 255, 1, 73, 23, -48090, 0, 128, 48090,
    +
    362  & 0, 513669,513669, 22500, 64, 0, 0, 0, 0/
    +
    363  DATA grd2 / 0, 255, 0, 144, 73, 90000, 0, 128, -90000,
    +
    364  & -2500, 2500, 2500, 0, 0, 0, 0, 0, 0/
    +
    365  DATA grd3 / 0, 255, 0, 360,181, 90000, 0, 128, -90000,
    +
    366  & -1000, 1000, 1000, 0, 0, 0, 0, 0, 0/
    +
    367  DATA grd4 / 0, 255, 0, 720,361, 90000, 0, 128, -90000,
    +
    368  & -500, 500, 500, 0, 0, 0, 0, 0, 0/
    +
    369  DATA grd5 / 0, 255, 5, 53, 57, 7647, -133443, 8, -105000,
    +
    370  & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/
    +
    371  DATA grd6 / 0, 255, 5, 53, 45, 7647, -133443, 8, -105000,
    +
    372  & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/
    +
    373  DATA grd8 / 0, 255, 1, 116, 44, -48670, 3104, 128, 61050,
    +
    374  & 0, 318830, 318830, 22500, 64, 0, 0, 0, 0/
    +
    375  DATA grd10 / 0, 255, 0, 180, 139, 64000, 1000, 128, -74000,
    +
    376  & 359000, 1000, 2000, 0, 0, 0, 0, 0, 0/
    +
    377  DATA grd11 / 0, 255, 0, 720, 311, 77500, 0, 128, -77500,
    +
    378  & 359500, 500, 500, 0, 0, 0, 0, 0, 0/
    +
    379  DATA grd12 / 0, 255, 0, 301, 331, 55000, 260000, 128, 0,
    +
    380  & 310000, 166, 166, 0, 0, 0, 0, 0, 0/
    +
    381  DATA grd13 / 0, 255, 0, 241, 151, 50000, 210000, 128, 25000,
    +
    382  & 250000, 166, 166, 0, 0, 0, 0, 0, 0/
    +
    383  DATA grd14 / 0, 255, 0, 511, 301, 30000, 130000, 128, -20000,
    +
    384  & 215000, 166, 166, 0, 0, 0, 0, 0, 0/
    +
    385  DATA grd15 / 0, 255, 0, 401, 187, 75000, 140000, 128, 44000,
    +
    386  & 240000, 166, 250, 0, 0, 0, 0, 0, 0/
    +
    387  DATA grd16 / 0, 255, 0, 548, 391, 74000, 165000, 128, 48000,
    +
    388  & 237933, 66, 133, 0, 0, 0, 0, 0, 0/
    +
    389  DATA grd17 / 0, 255, 0, 736, 526, 50000, 195000, 128, 15000,
    +
    390  & 244000, 66, 66, 0, 0, 0, 0, 0, 0/
    +
    391  DATA grd18 / 0, 255, 0, 586, 481, 47000, 261000, 128, 15000,
    +
    392  & 300000, 66, 66, 0, 0, 0, 0, 0, 0/
    +
    393  DATA grd21 / 0, 33, 0,65535,37, 0, 0, 128, 90000,
    +
    394  & 180000, 2500, 5000, 64, 0, 0, 0, 0, 0,
    +
    395  & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37,
    +
    396  & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37,
    +
    397  & 37, 37, 37, 37, 37, 37, 1/
    +
    398  DATA grd22 / 0, 33, 0,65535,37, 0, -180000, 128, 90000,
    +
    399  & 0, 2500, 5000, 64, 0, 0, 0, 0, 0,
    +
    400  & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37,
    +
    401  & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37,
    +
    402  & 37, 37, 37, 37, 37, 37, 1/
    +
    403  DATA grd23 / 0, 33, 0,65535, 37, -90000, 0, 128, 0,
    +
    404  & 180000, 2500, 5000, 64, 0, 0, 0, 0, 0,
    +
    405  & 1, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37,
    +
    406  & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37,
    +
    407  & 37, 37, 37, 37, 37, 37, 37/
    +
    408  DATA grd24 / 0, 33, 0,65535, 37, -90000, -180000, 128, 0,
    +
    409  & 0, 2500, 5000, 64, 0, 0, 0, 0, 0,
    +
    410  & 1, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37,
    +
    411  & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37,
    +
    412  & 37, 37, 37, 37, 37, 37, 37/
    +
    413  DATA grd25 / 0, 33, 0,65535, 19, 0, 0, 128, 90000,
    +
    414  & 355000, 5000, 5000, 64, 0, 0, 0, 0, 0,
    +
    415  & 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72,
    +
    416  & 72, 72, 72, 1/
    +
    417  DATA grd26 / 0, 33, 0,65535, 19, -90000, 0, 128, 0,
    +
    418  & 355000, 5000, 5000, 64, 0, 0, 0, 0, 0,
    +
    419  & 1, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72,
    +
    420  & 72, 72, 72, 72/
    +
    421  DATA grd27 / 0, 255, 5, 65, 65, -20826, -125000, 8, -80000,
    +
    422  & 381000, 381000, 0, 64, 0, 0, 0, 0, 0/
    +
    423  DATA grd28 / 0, 255, 5, 65, 65, 20826, 145000, 8, -80000,
    +
    424  & 381000, 381000,128, 64, 0, 0, 0, 0, 0/
    +
    425  DATA grd29 / 0, 255, 0, 145, 37, 0, 0, 128, 90000,
    +
    426  & 360000, 2500, 2500, 64, 0, 0, 0, 0, 0/
    +
    427  DATA grd30 / 0, 255, 0, 145, 37, -90000, 0, 128, 0,
    +
    428  & 360000, 2500, 2500, 64, 0, 0, 0, 0, 0/
    +
    429  DATA grd33 / 0, 255, 0, 181, 46, 0, 0, 128, 90000,
    +
    430  & 360000, 2000, 2000, 64, 0, 0, 0, 0, 0/
    +
    431  DATA grd34 / 0, 255, 0, 181, 46, -90000, 0, 128, 0,
    +
    432  & 360000, 2000, 2000, 64, 0, 0, 0, 0, 0/
    +
    433  DATA grd37 / 0, 33, 0,65535,73, 0, -30000, 128, 90000,
    +
    434  & 60000, 1250,65535, 64, 0, 0, 0, 0, 0,
    +
    435  & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70,
    +
    436  & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60,
    +
    437  & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43,
    +
    438  & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22,
    +
    439  & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/
    +
    440  DATA grd38 / 0, 33, 0,65535,73, 0, 60000, 128, 90000,
    +
    441  & 150000, 1250,65535, 64, 0, 0, 0, 0, 0,
    +
    442  & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70,
    +
    443  & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60,
    +
    444  & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43,
    +
    445  & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22,
    +
    446  & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/
    +
    447  DATA grd39 / 0, 33, 0,65535,73, 0, 150000, 128, 90000,
    +
    448  & -120000, 1250,65535, 64, 0, 0, 0, 0, 0,
    +
    449  & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70,
    +
    450  & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60,
    +
    451  & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43,
    +
    452  & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22,
    +
    453  & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/
    +
    454  DATA grd40 / 0, 33, 0,65535,73, 0, -120000, 128, 90000,
    +
    455  & -30000, 1250,65535, 64, 0, 0, 0, 0, 0,
    +
    456  & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70,
    +
    457  & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60,
    +
    458  & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43,
    +
    459  & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22,
    +
    460  & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/
    +
    461  DATA grd41 / 0, 33, 0,65535,73, -90000, -30000, 128, 0,
    +
    462  & 60000, 1250,65535, 64, 0, 0, 0, 0, 0,
    +
    463  & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23,
    +
    464  & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44,
    +
    465  & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60,
    +
    466  & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71,
    +
    467  & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/
    +
    468  DATA grd42 / 0, 33, 0,65535,73, -90000, 60000, 128, 0,
    +
    469  & 150000, 1250,65535, 64, 0, 0, 0, 0, 0,
    +
    470  & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23,
    +
    471  & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44,
    +
    472  & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60,
    +
    473  & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71,
    +
    474  & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/
    +
    475  DATA grd43 / 0, 33, 0,65535,73, -90000, 150000, 128, 0,
    +
    476  & -120000, 1250,65535, 64, 0, 0, 0, 0, 0,
    +
    477  & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23,
    +
    478  & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44,
    +
    479  & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60,
    +
    480  & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71,
    +
    481  & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/
    +
    482  DATA grd44 / 0, 33, 0,65535,73, -90000, -120000, 128, 0,
    +
    483  & -30000, 1250,65535, 64, 0, 0, 0, 0, 0,
    +
    484  & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23,
    +
    485  & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44,
    +
    486  & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60,
    +
    487  & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71,
    +
    488  & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/
    +
    489  DATA grd45 / 0, 255, 0, 288,145, 90000, 0, 128, -90000,
    +
    490  & -1250, 1250, 1250, 0, 0, 0, 0, 0, 0/
    +
    491  DATA grd53 / 0, 255, 1, 117, 51, -61050, 0, 128, 61050,
    +
    492  & 0, 318830, 318830, 22500, 64, 0, 0, 0, 0/
    +
    493  DATA grd55 / 0, 255, 5, 87, 71, -10947, -154289, 8, -105000,
    +
    494  & 254000, 254000, 0, 64, 0, 0, 0, 0, 0/
    +
    495  DATA grd56 / 0, 255, 5, 87, 71, 7647, -133443, 8, -105000,
    +
    496  & 127000, 127000, 0, 64, 0, 0, 0, 0, 0/
    +
    497  DATA grd61 / 0, 33, 0,65535, 46, 0, 0, 128, 90000,
    +
    498  & 180000, 2000, 2000, 64, 0, 0, 0, 0, 0,
    +
    499  & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
    +
    500  & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
    +
    501  & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
    +
    502  & 1/
    +
    503  DATA grd62 / 0, 33, 0,65535, 46, 0, -180000, 128, 90000,
    +
    504  & 0, 2000, 2000, 64, 0, 0, 0, 0, 0,
    +
    505  & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
    +
    506  & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
    +
    507  & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
    +
    508  & 1/
    +
    509  DATA grd63 / 0, 33, 0,65535, 46, 0, -90000, 128, 0,
    +
    510  & 180000, 2000, 2000, 64, 0, 0, 0, 0, 0,
    +
    511  & 1, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
    +
    512  & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
    +
    513  & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
    +
    514  & 91/
    +
    515  DATA grd64 / 0, 33, 0,65535, 46, -90000, -180000, 128, 0,
    +
    516  & 0, 2000, 2000, 64, 0, 0, 0, 0, 0,
    +
    517  & 1, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
    +
    518  & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
    +
    519  & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91,
    +
    520  & 91/
    +
    521  DATA grd83 / 0, 255,205,758,567, 2228, -140481, 136, 47500,
    +
    522  & -104000, 121,121,64, 53492, -10984, 0, 0, 0/
    +
    523  DATA grd85 / 0, 255, 0, 360, 90, 500, 500, 128, 89500,
    +
    524  & 359500, 1000, 1000, 64, 0, 0, 0, 0, 0/
    +
    525  DATA grd86 / 0, 255, 0, 360, 90, -89500, 500, 128, -500,
    +
    526  & 359500, 1000, 1000, 64, 0, 0, 0, 0, 0/
    +
    527  DATA grd87 / 0, 255, 5, 81, 62, 22876, -120491, 8, -105000,
    +
    528  & 68153, 68153, 0, 64, 0, 0, 0, 0, 0/
    +
    529  DATA grd88 / 0, 255, 5, 580,548, 10000, -128000, 8, -105000,
    +
    530  & 15000, 15000, 0, 64, 0, 0, 0, 0, 0/
    +
    531  DATA grd90 / 0, 255, 3,4289,2753, 20192, -121554, 8, -95000,
    +
    532  & 1270, 1270, 0, 64, 0, 25000, 25000, 0, 0/
    +
    533  DATA grd91 / 0, 255, 5,1649,1105, 40530, -178571, 8, -150000,
    +
    534  & 2976, 2976, 0, 64, 0, 0, 0, 0, 0/
    +
    535  DATA grd92 / 0, 255, 5,3297,2209, 40530, -178571, 8, -150000,
    +
    536  & 1488, 1488, 0, 64, 0, 0, 0, 0, 0/
    +
    537  DATA grd93 / 0, 255,203,223,501, 44232, -169996, 136, 63000,
    +
    538  & -150000, 67,66,64, 0, 0, 0, 0, 0/
    +
    539  DATA grd94 / 0, 255,205,595,625, 34921, -161663, 136, 54000,
    +
    540  & -106000, 63, 54,64, 83771, -151721, 0, 0, 0/
    +
    541  DATA grd95 / 0, 255,205,401,325, 17609, -76327, 136, 54000,
    +
    542  & -106000, 31, 27,64, 18840, -61261, 0, 0, 0/
    +
    543  DATA grd96 / 0, 255,205,373,561, 11625, -156339, 136, 54000,
    +
    544  & -106000, 31, 27,64, 30429, -157827, 0, 0, 0/
    +
    545  DATA grd97 / 0, 255,205,1371,1100, 15947,-125468, 136, 54000,
    +
    546  & -106000, 42, 36,64,45407,-52390, 0, 0, 0/
    +
    547  DATA grd98 / 0, 255, 4, 192, 94, 88542, 0, 128, -88542,
    +
    548  & -1875, 47,1875, 0, 0, 0, 0, 0, 0/
    +
    549  DATA grd99 / 0, 255,203,669,1165, -7450, -144140, 136, 54000,
    +
    550  & -106000, 90, 77, 64, 0, 0, 0, 0, 0/
    +
    551  DATA grd100/ 0, 255, 5, 83, 83, 17108, -129296, 8, -105000,
    +
    552  & 91452, 91452, 0, 64, 0, 0, 0, 0, 0/
    +
    553  DATA grd101/ 0, 255, 5, 113, 91, 10528, -137146, 8, -105000,
    +
    554  & 91452, 91452, 0, 64, 0, 0, 0, 0, 0/
    +
    555  DATA grd103/ 0, 255, 5, 65, 56, 22405, -121352, 8, -105000,
    +
    556  & 91452, 91452, 0, 64, 0, 0, 0, 0, 0/
    +
    557  DATA grd104/ 0, 255, 5, 147,110, -268, -139475, 8, -105000,
    +
    558  & 90755, 90755, 0, 64, 0, 0, 0, 0, 0/
    +
    559  DATA grd105/ 0, 255, 5, 83, 83, 17529, -129296, 8, -105000,
    +
    560  & 90755, 90755, 0, 64, 0, 0, 0, 0, 0/
    +
    561  DATA grd106/ 0, 255, 5, 165,117, 17533, -129296, 8, -105000,
    +
    562  & 45373, 45373, 0, 64, 0, 0, 0, 0, 0/
    +
    563  DATA grd107/ 0, 255, 5, 120, 92, 23438, -120168, 8, -105000,
    +
    564  & 45373, 45373, 0, 64, 0, 0, 0, 0, 0/
    +
    565  DATA grd110/ 0, 255, 0, 464,224, 25063, -124938, 128, 52938,
    +
    566  & -67063, 125, 125, 64, 0, 0, 0, 0, 0/
    +
    567  DATA grd120/ 0, 255,204,1200,1684, 0, 0, 8, 0,
    +
    568  & 0, 0, 0, 64, 0, 0, 0, 0, 0/
    +
    569  DATA grd122/ 0, 255,204, 350, 465, 0, 0, 8, 0,
    +
    570  & 0, 0, 0, 64, 0, 0, 0, 0, 0/
    +
    571  DATA grd123/ 0, 255,204, 280, 360, 0, 0, 8, 0,
    +
    572  & 0, 0, 0, 64, 0, 0, 0, 0, 0/
    +
    573  DATA grd124/ 0, 255,204, 240, 314, 0, 0, 8, 0,
    +
    574  & 0, 0, 0, 64, 0, 0, 0, 0, 0/
    +
    575  DATA grd125/ 0, 255,204, 300, 340, 0, 0, 8, 0,
    +
    576  & 0, 0, 0, 64, 0, 0, 0, 0, 0/
    +
    577  DATA grd126/ 0, 255, 4, 384,190, 89277, 0, 128, -89277,
    +
    578  & -938, 95, 938, 0, 0, 0, 0, 0, 0/
    +
    579  DATA grd127/ 0, 255, 4, 768,384, 89642, 0, 128, -89642,
    +
    580  & -469, 192, 469, 0, 0, 0, 0, 0, 0/
    +
    581  DATA grd128/ 0, 255, 4,1152,576, 89761, 0, 128, -89761,
    +
    582  & -313, 288, 313, 0, 0, 0, 0, 0, 0/
    +
    583  DATA grd129/ 0, 255, 4,1760,880, 89844, 0, 128, -89844,
    +
    584  & -205, 440, 205, 0, 0, 0, 0, 0, 0/
    +
    585  DATA grd130/ 0, 255, 3, 451,337, 16281, -126138, 8, -95000,
    +
    586  & 13545, 13545, 0, 64, 0, 25000, 25000, 0, 0/
    +
    587  DATA grd132/ 0, 255, 3, 697,553, 1000, -145500, 8, -107000,
    +
    588  & 16232, 16232, 0, 64, 0, 50000, 50000, 0, 0/
    +
    589  DATA grd138/ 0, 255, 3, 468,288, 21017, -123282, 8, -97000,
    +
    590  & 12000, 12000, 0, 64, 0, 33000, 45000, 0, 0/
    +
    591  DATA grd139/ 0, 255, 3, 80,52, 17721, -161973, 8, -157500,
    +
    592  & 12000, 12000, 0, 64, 0, 19000, 21000, 0, 0/
    +
    593  DATA grd140/ 0, 255, 3, 199,163, 53020, -166477, 8, -148600,
    +
    594  & 12000, 12000, 0, 64, 0, 57000, 63000, 0, 0/
    +
    595  DATA grd145/ 0, 255, 3, 169,145, 32174, -90159, 8, -79500,
    +
    596  & 12000, 12000, 0, 64, 0, 36000, 46000, 0, 0/
    +
    597  DATA grd146/ 0, 255, 3, 166,142, 32353, -89994, 8, -79500,
    +
    598  & 12000, 12000, 0, 64, 0, 36000, 46000, 0, 0/
    +
    599  DATA grd147/ 0, 255, 3, 268,259, 24595, -100998, 8, -97000,
    +
    600  & 12000, 12000, 0, 64, 0, 33000, 45000, 0, 0/
    +
    601  DATA grd148/ 0, 255, 3, 442,265, 21821, -120628, 8, -97000,
    +
    602  & 12000, 12000, 0, 64, 0, 33000, 45000, 0, 0/
    +
    603  DATA grd150/ 0, 255, 0, 401,201, 5000, -100000, 128, 25000,
    +
    604  & -60000, 100, 100, 64, 0, 0, 0, 0, 0/
    +
    605  DATA grd151/ 0, 255, 5, 478, 429, -7450, 215860, 8, -110000,
    +
    606  & 33812, 33812, 0, 64, 0, 0, 0, 0, 0/
    +
    607  DATA grd160/ 0, 255, 5, 180,156, 19132, -185837, 8, -150000,
    +
    608  & 47625, 47625, 0, 64, 0, 0, 0, 0, 0/
    +
    609  DATA grd161/ 0, 255, 0, 137,103, 50750, 271750, 72, -250,
    +
    610  & -19750, 500,500, 0, 0, 0, 0, 0, 0/
    +
    611  DATA grd163/ 0, 255, 3,1008,722, 20600, -118300, 8, -95000,
    +
    612  & 5000, 5000, 0, 64, 0, 38000, 38000, 0, 0/
    +
    613  DATA grd170/ 0, 255, 4, 512, 256, 89463, 0, 128, -89463,
    +
    614  & -703, 128, 703, 0, 0, 0, 0, 0, 0/
    +
    615  DATA grd171/ 0, 255, 5, 770,930, 25032, -119560, 0, -80000,
    +
    616  & 12700, 12700, 0, 64, 0, 0, 0, 0, 0/
    +
    617  DATA grd172/ 0, 255, 5, 690,710, -36899, -220194, 0, -80000,
    +
    618  & 12700, 12700, 128, 64, 0, 0, 0, 0, 0/
    +
    619  DATA grd173/ 0, 255, 0,4320,2160, 89958, 42, 128, -89958,
    +
    620  & 359958, 83, 83, 0, 0, 0, 0, 0, 0/
    +
    621  DATA grd174/ 0, 255, 0,2880,1440, 89938, 62, 128, -89938,
    +
    622  & -62, 125, 125,64, 0, 0, 0, 0, 0/
    +
    623  DATA grd175/ 0, 255, 0, 556,334, 0, 130000, 128, 30060,
    +
    624  & 180040, 90, 90, 64, 0, 0, 0, 0, 0/
    +
    625  DATA grd176/ 0, 255, 0, 327,235, 49100, -92200, 128, 40910,
    +
    626  & -75900, 35, 50, 0, 0, 0, 0, 0, 0/
    +
    627  DATA grd179/ 0, 255, 5,1196,817, -2500, -142500, 8, -100000,
    +
    628  & 12679, 12679, 0, 64, 0, 0, 0, 0, 0/
    +
    629  DATA grd180/ 0, 255, 0, 759,352, 55054, -127000, 128, 17146,
    +
    630  & -45136, 108, 108, 0, 0, 0, 0, 0, 0/
    +
    631  DATA grd181/ 0, 255, 0, 370,278, 30054, -100000, 128, 138,
    +
    632  & -60148, 108, 108, 0, 0, 0, 0, 0, 0/
    +
    633  DATA grd182/ 0, 255, 0, 278,231, 32973, -170000, 128, 8133,
    +
    634  & -140084, 108, 108, 0, 0, 0, 0, 0, 0/
    +
    635  DATA grd183/ 0, 255, 0, 648,278, 75054, -200000, 128, 45138,
    +
    636  & -130124, 108, 108, 0, 0, 0, 0, 0, 0/
    +
    637  DATA grd184/ 0, 255, 3,2145,1377, 20192, -121554, 8, -95000,
    +
    638  & 2540, 2540, 0, 64, 0, 25000, 25000, 0, 0/
    +
    639  DATA grd187/ 0, 255, 3,2145,1597, 20192, -121554, 8, -95000,
    +
    640  & 2540, 2540, 0, 64, 0, 25000, 25000, 0, 0/
    +
    641  DATA grd188/ 0, 255, 3, 709, 795, 37979, -125958, 8, -95000,
    +
    642  & 2540, 2540, 0, 64, 0, 25000, 25000, 0, 0/
    +
    643  DATA grd189/ 0, 255, 5, 655, 855, 51500, -142500, 8, -135000,
    +
    644  & 1448, 1448, 0, 64, 0, 0, 0, 0, 0/
    +
    645  DATA grd190/ 0, 255,205,954,835, -7491, -144134, 136, 54000,
    +
    646  & -106000, 126, 108, 64, 44540, 14802, 0, 0, 0/
    +
    647  DATA grd192/ 0, 255,203,237,387, -3441, -148799, 136, 50000,
    +
    648  & -111000, 225,207,64, 0, 0, 0, 0, 0/
    +
    649  DATA grd193 / 0, 255, 0, 1440, 721, 90000, 0, 128, -90000,
    +
    650  & -250, 250, 250, 0, 0, 0, 0, 0, 0/
    +
    651  DATA grd194/ 0, 255, 1, 544,310, 15000, -75500, 128, 22005,
    +
    652  & -62509, 2500, 2500, 20000, 64, 0, 0, 0, 0/
    +
    653  DATA grd195/ 0, 255, 1, 177,129, 16829, -68196, 128, 19747,
    +
    654  & -63972, 2500, 2500, 20000, 64, 0, 0, 0, 0/
    +
    655  DATA grd196/ 0, 255, 1, 321,225, 18073, -161525, 136, 23088,
    +
    656  & -153869, 2500, 2500, 20000, 64, 0, 0, 0, 0/
    +
    657  DATA grd197/ 0, 255, 3,1073,689, 20192, -121550, 8, -95000,
    +
    658  & 5079, 5079, 0, 64, 0, 25000, 25000, 0, 0/
    +
    659  DATA grd198/ 0, 255, 5, 825, 553, 40530, -178571, 8, -150000,
    +
    660  & 5953, 5953, 0, 64, 0, 0, 0, 0, 0/
    +
    661  DATA grd199/ 0, 255, 1, 193,193, 12350, -216313, 128, 16794,
    +
    662  & -211720, 2500, 2500, 20000, 64, 0, 0, 0, 0/
    +
    663  DATA grd200/ 0, 255, 3, 108, 94, 16201, 285720, 136, -107000,
    +
    664  & 16232, 16232, 0, 64, 0, 50000, 50000, -90000, 0/
    +
    665  DATA grd201/ 0, 255, 5, 65, 65, -20826, -150000, 8, -105000,
    +
    666  & 381000, 381000, 0, 64, 0, 0, 0, 0, 0/
    +
    667  DATA grd202/ 0, 255, 5, 65, 43, 7838, -141028, 8, -105000,
    +
    668  & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/
    +
    669  DATA grd203/ 0, 255, 5, 45, 39, 19132, -185837, 8, -150000,
    +
    670  & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/
    +
    671  DATA grd204/ 0, 255, 1, 93, 68, -25000, 110000, 128, 60644,
    +
    672  & -109129, 160000, 160000, 20000, 64, 0, 0, 0, 0/
    +
    673  DATA grd205/ 0, 255, 5, 45, 39, 616, -84904, 8, -60000,
    +
    674  & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/
    +
    675  DATA grd206/ 0, 255, 3, 51, 41, 22289, -117991, 8, - 95000,
    +
    676  & 81271, 81271, 0, 64, 0, 25000, 25000, 0, 0/
    +
    677  DATA grd207/ 0, 255, 5, 49, 35, 42085, -175641, 8, -150000,
    +
    678  & 95250, 95250, 0, 64, 0, 0, 0, 0, 0/
    +
    679  DATA grd208/ 0, 255, 1, 29, 27, 9343, -167315, 128, 28092,
    +
    680  & -145878, 80000, 80000, 20000, 64, 0, 0, 0, 0/
    +
    681  DATA grd209/ 0, 255, 3, 275,223, -4850, -151100, 8, -111000,
    +
    682  & 44000, 44000, 0, 64, 0, 45000, 45000, 0, 0/
    +
    683  DATA grd210/ 0, 255, 1, 25, 25, 9000, -77000, 128, 26422,
    +
    684  & -58625, 80000, 80000, 20000, 64, 0, 0, 0, 0/
    +
    685  DATA grd211/ 0, 255, 3, 93, 65, 12190, -133459, 8, -95000,
    +
    686  & 81271, 81271, 0, 64, 0, 25000, 25000, 0, 0/
    +
    687  DATA grd212/ 0, 255, 3, 185,129, 12190, -133459, 136, -95000,
    +
    688  & 40635, 40635, 0, 64, 0, 25000, 25000, -90000, 0/
    +
    689  DATA grd213/ 0, 255, 5, 129, 85, 7838, -141028, 8, -105000,
    +
    690  & 95250, 95250, 0, 64, 0, 0, 0, 0, 0/
    +
    691  DATA grd214/ 0, 255, 5, 97, 69, 42085, -175641, 8, -150000,
    +
    692  & 47625, 47625, 0, 64, 0, 0, 0, 0, 0/
    +
    693  DATA grd215/ 0, 255, 3, 369,257, 12190, -133459, 8, -95000,
    +
    694  & 20318, 20318, 0, 64, 0, 25000, 25000, 0, 0/
    +
    695  DATA grd216/ 0, 255, 5, 139,107, 30000, -173000, 136, -135000,
    +
    696  & 45000, 45000, 0, 64, 0, 0, 0, 0, 0/
    +
    697  DATA grd217/ 0, 255, 5, 277,213, 30000, -173000, 8, -135000,
    +
    698  & 22500, 22500, 0, 64, 0, 0, 0, 0, 0/
    +
    699  DATA grd218/ 0, 255, 3, 614,428, 12190, -133459, 8, -95000,
    +
    700  & 12191, 12191, 0, 64, 0, 25000, 25000, 0, 0/
    +
    701  DATA grd219/ 0, 255, 5, 385,465, 25032, -119560, 0, -80000,
    +
    702  & 25400, 25400, 0, 64, 0, 0, 0, 0, 0/
    +
    703  DATA grd220/ 0, 255, 5, 345,355, -36899, -220194, 0, -80000,
    +
    704  & 25400, 25400, 128, 64, 0, 0, 0, 0, 0/
    +
    705  DATA grd221/ 0, 255, 3, 349,277, 1000, -145500, 8, -107000,
    +
    706  & 32463, 32463, 0, 64, 0, 50000, 50000, 0, 0/
    +
    707  DATA grd222/ 0, 255, 3, 138,112, -4850, -151100, 8, -111000,
    +
    708  & 88000, 88000, 0, 64, 0, 45000, 45000, 0, 0/
    +
    709  DATA grd223/ 0, 255, 5, 129,129, -20826, -150000, 8, -105000,
    +
    710  & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/
    +
    711  DATA grd224/ 0, 255, 5, 65, 65, 20826, 120000, 8, -105000,
    +
    712  & 381000, 381000, 128, 64, 0, 0, 0, 0, 0/
    +
    713  DATA grd225/ 0, 255, 1, 185,135, -25000, -250000, 128, 60640,
    +
    714  & -109129, 80000, 80000, 20000, 64, 0, 0, 0, 0/
    +
    715  DATA grd226/ 0, 255, 3, 737,513, 12190, -133459, 8, -95000,
    +
    716  & 10159, 10159, 0, 64, 0, 25000, 25000, 0, 0/
    +
    717  DATA grd227/ 0, 255, 3,1473,1025, 12190, -133459, 8, -95000,
    +
    718  & 5079, 5079, 0, 64, 0, 25000, 25000, 0, 0/
    +
    719  DATA grd228/ 0, 255, 0, 144, 73, 90000, 0, 128, -90000,
    +
    720  & -2500, 2500, 2500, 64, 0, 0, 0, 0, 0/
    +
    721  DATA grd229/ 0, 255, 0, 360,181, 90000, 0, 128, -90000,
    +
    722  & -1000, 1000, 1000, 64, 0, 0, 0, 0, 0/
    +
    723  DATA grd230/ 0, 255, 0, 720,361, 90000, 0, 128, -90000,
    +
    724  & -500, 500, 500, 64, 0, 0, 0, 0, 0/
    +
    725  DATA grd231/ 0, 255, 0, 720,181, 0, 0, 128, 90000,
    +
    726  & -500, 500, 500, 64, 0, 0, 0, 0, 0/
    +
    727  DATA grd232/ 0, 255, 0, 360, 91, 0, 0, 128, 90000,
    +
    728  & -1000, 1000, 1000, 64, 0, 0, 0, 0, 0/
    +
    729  DATA grd233/ 0, 255, 0, 288,157, 78000, 0, 128, -78000,
    +
    730  & -1250, 1000, 1250, 0, 0, 0, 0, 0, 0/
    +
    731  DATA grd234/ 0, 255, 0, 133,121, 15000, -98000, 128, -45000,
    +
    732  & -65000, 250, 250, 64, 0, 0, 0, 0, 0/
    +
    733  DATA grd235/ 0, 255, 0, 720,360, 89750, 250, 128, -89750,
    +
    734  & -250, 500, 500, 0, 0, 0, 0, 0, 0/
    +
    735  DATA grd236/ 0, 255, 3, 151,113, 16281, 233862, 136, -95000,
    +
    736  & 40635, 40635, 0, 64, 0, 25000, 25000, -90000, 0/
    +
    737  DATA grd237/ 0, 255, 3, 54, 47, 16201, 285720, 8, -107000,
    +
    738  & 32463, 32463, 0, 64, 0, 50000, 50000, 0, 0/
    +
    739  DATA grd238/ 0, 255, 0, 275, 203, 50250, 261750, 128, -250,
    +
    740  & -29750, 250, 250, 0, 0, 0, 0, 0, 0/
    +
    741  DATA grd239/ 0, 255, 0, 155, 123, 75250, 159500, 128, 44750,
    +
    742  & -123500, 250, 500, 0, 0, 0, 0, 0, 0/
    +
    743  DATA grd240/ 0, 255, 5, 1121, 881, 23098, -119036, 8, -105000,
    +
    744  & 4763, 4763, 0, 64, 0, 0, 0, 0, 0/
    +
    745  DATA grd241/ 0, 255, 3, 549,445, -4850, -151100, 8, -111000,
    +
    746  & 22000, 22000, 0, 64, 0, 45000, 45000, 0, 0/
    +
    747  DATA grd242/ 0, 255, 5, 553,425, 30000, -173000, 8, -135000,
    +
    748  & 11250, 11250, 0, 64, 0, 0, 0, 0, 0/
    +
    749  DATA grd243/ 0, 255, 0, 126,101, 10000, -170000, 128, 50000,
    +
    750  & -120000, 400, 400, 64, 0, 0, 0, 0, 0/
    +
    751  DATA grd244/ 0, 255, 0, 275, 203, 50250, 261750, 128, -250,
    +
    752  & -29750, 250, 250, 0, 0, 0, 0, 0, 0/
    +
    753  DATA grd245/ 0, 255, 3, 336,372, 22980, -92840, 8, -80000,
    +
    754  & 8000, 8000, 0, 64, 0, 35000, 35000, 0, 0/
    +
    755  DATA grd246/ 0, 255, 3, 332,371, 25970, -127973, 8, -115000,
    +
    756  & 8000, 8000, 0, 64, 0, 40000, 40000, 0, 0/
    +
    757  DATA grd247/ 0, 255, 3, 336,372, 22980, -110840, 8, -98000,
    +
    758  & 8000, 8000, 0, 64, 0, 35000, 35000, 0, 0/
    +
    759  DATA grd248/ 0, 255, 0, 135,101, 14500, -71500, 128, 22000,
    +
    760  & -61450, 75, 75, 64, 0, 0, 0, 0, 0/
    +
    761  DATA grd249/ 0, 255, 5, 367,343, 45400, -171600, 8, -150000,
    +
    762  & 9868, 9868, 0, 64, 0, 0, 0, 0, 0/
    +
    763  DATA grd250/ 0, 255, 0, 135,101, 16500, -162000, 128, 24000,
    +
    764  & -151950, 75, 75, 64, 0, 0, 0, 0, 0/
    +
    765  DATA grd251/ 0, 255, 0, 332,210, 26350, -83050, 128, 47250,
    +
    766  & -49950, 100, 100, 64, 0, 0, 0, 0, 0/
    +
    767  DATA grd252/ 0, 255, 3, 301,225, 16281, 233862, 8, 265000,
    +
    768  & 20318, 20318, 0, 64, 0, 25000, 25000, 0, 0/
    +
    769  DATA grd253/ 0, 255, 0, 373,224, 60500, 189750, 128, 4750,
    +
    770  & -77250, 250, 250, 0, 0, 0, 0, 0, 0/
    +
    771  DATA grd254/ 0, 255, 1, 369,300, -35000, -250000, 128, 60789,
    +
    772  & -109129, 40000,40000, 20000, 64, 0, 0, 0, 0/
    +
    773 C
    +
    774  ierr = 0
    +
    775 C
    +
    776  DO 1 i = 1,18
    +
    777  igds(i) = 0
    +
    778  1 CONTINUE
    +
    779 C
    +
    780  IF (igrid.GE.37.AND.igrid.LE.44) THEN
    +
    781  DO 2 i = 19,91
    +
    782  igds(i) = 0
    +
    783  2 CONTINUE
    +
    784  END IF
    +
    785 C
    +
    786  IF (igrid.GE.21.AND.igrid.LE.24) THEN
    +
    787  DO i = 19,55
    +
    788  igds(i) = 0
    +
    789  END DO
    +
    790  END IF
    +
    791 C
    +
    792  IF (igrid.GE.25.AND.igrid.LE.26) THEN
    +
    793  DO i = 19,37
    +
    794  igds(i) = 0
    +
    795  END DO
    +
    796  END IF
    +
    797 C
    +
    798  IF (igrid.GE.61.AND.igrid.LE.64) THEN
    +
    799  DO i = 19,64
    +
    800  igds(i) = 0
    +
    801  END DO
    +
    802  END IF
    +
    803 C
    +
    804  IF (igrid.EQ.1) THEN
    +
    805  DO 3 i = 1,18
    +
    806  igds(i) = grd1(i)
    +
    807  3 CONTINUE
    +
    808 C
    +
    809  ELSE IF (igrid.EQ.2) THEN
    +
    810  DO 4 i = 1,18
    +
    811  igds(i) = grd2(i)
    +
    812  4 CONTINUE
    +
    813 C
    +
    814  ELSE IF (igrid.EQ.3) THEN
    +
    815  DO 5 i = 1,18
    +
    816  igds(i) = grd3(i)
    +
    817  5 CONTINUE
    +
    818 C
    +
    819  ELSE IF (igrid.EQ.4) THEN
    +
    820  DO 6 i = 1,18
    +
    821  igds(i) = grd4(i)
    +
    822  6 CONTINUE
    +
    823 C
    +
    824  ELSE IF (igrid.EQ.5) THEN
    +
    825  DO 10 i = 1,18
    +
    826  igds(i) = grd5(i)
    +
    827  10 CONTINUE
    +
    828 C
    +
    829  ELSE IF (igrid.EQ.6) THEN
    +
    830  DO 20 i = 1,18
    +
    831  igds(i) = grd6(i)
    +
    832  20 CONTINUE
    +
    833 C
    +
    834  ELSE IF (igrid.EQ.8) THEN
    +
    835  DO i = 1,18
    +
    836  igds(i) = grd8(i)
    +
    837  END DO
    +
    838 C
    +
    839  ELSE IF (igrid.EQ.10) THEN
    +
    840  DO i = 1,18
    +
    841  igds(i) = grd10(i)
    +
    842  END DO
    +
    843 C
    +
    844  ELSE IF (igrid.EQ.11) THEN
    +
    845  DO i = 1,18
    +
    846  igds(i) = grd11(i)
    +
    847  END DO
    +
    848 C
    +
    849  ELSE IF (igrid.EQ.12) THEN
    +
    850  DO i = 1,18
    +
    851  igds(i) = grd12(i)
    +
    852  END DO
    +
    853 C
    +
    854  ELSE IF (igrid.EQ.13) THEN
    +
    855  DO i = 1,18
    +
    856  igds(i) = grd13(i)
    +
    857  END DO
    +
    858 C
    +
    859  ELSE IF (igrid.EQ.14) THEN
    +
    860  DO i = 1,18
    +
    861  igds(i) = grd14(i)
    +
    862  END DO
    +
    863 C
    +
    864  ELSE IF (igrid.EQ.15) THEN
    +
    865  DO i = 1,18
    +
    866  igds(i) = grd15(i)
    +
    867  END DO
    +
    868 C
    +
    869  ELSE IF (igrid.EQ.16) THEN
    +
    870  DO i = 1,18
    +
    871  igds(i) = grd16(i)
    +
    872  END DO
    +
    873 C
    +
    874  ELSE IF (igrid.EQ.17) THEN
    +
    875  DO i = 1,18
    +
    876  igds(i) = grd17(i)
    +
    877  END DO
    +
    878 C
    +
    879  ELSE IF (igrid.EQ.18) THEN
    +
    880  DO i = 1,18
    +
    881  igds(i) = grd18(i)
    +
    882  END DO
    +
    883 C
    +
    884  ELSE IF (igrid.EQ.21) THEN
    +
    885  DO 30 i = 1,55
    +
    886  igds(i) = grd21(i)
    +
    887  30 CONTINUE
    +
    888 C
    +
    889  ELSE IF (igrid.EQ.22) THEN
    +
    890  DO 40 i = 1,55
    +
    891  igds(i) = grd22(i)
    +
    892  40 CONTINUE
    +
    893 C
    +
    894  ELSE IF (igrid.EQ.23) THEN
    +
    895  DO 50 i = 1,55
    +
    896  igds(i) = grd23(i)
    +
    897  50 CONTINUE
    +
    898 C
    +
    899  ELSE IF (igrid.EQ.24) THEN
    +
    900  DO 60 i = 1,55
    +
    901  igds(i) = grd24(i)
    +
    902  60 CONTINUE
    +
    903 C
    +
    904  ELSE IF (igrid.EQ.25) THEN
    +
    905  DO 70 i = 1,37
    +
    906  igds(i) = grd25(i)
    +
    907  70 CONTINUE
    +
    908 C
    +
    909  ELSE IF (igrid.EQ.26) THEN
    +
    910  DO 80 i = 1,37
    +
    911  igds(i) = grd26(i)
    +
    912  80 CONTINUE
    +
    913 C
    +
    914  ELSE IF (igrid.EQ.27) THEN
    +
    915  DO 90 i = 1,18
    +
    916  igds(i) = grd27(i)
    +
    917  90 CONTINUE
    +
    918 C
    +
    919  ELSE IF (igrid.EQ.28) THEN
    +
    920  DO 100 i = 1,18
    +
    921  igds(i) = grd28(i)
    +
    922  100 CONTINUE
    +
    923 C
    +
    924  ELSE IF (igrid.EQ.29) THEN
    +
    925  DO 110 i = 1,18
    +
    926  igds(i) = grd29(i)
    +
    927  110 CONTINUE
    +
    928 C
    +
    929  ELSE IF (igrid.EQ.30) THEN
    +
    930  DO 120 i = 1,18
    +
    931  igds(i) = grd30(i)
    +
    932  120 CONTINUE
    +
    933 C
    +
    934  ELSE IF (igrid.EQ.33) THEN
    +
    935  DO 130 i = 1,18
    +
    936  igds(i) = grd33(i)
    +
    937  130 CONTINUE
    +
    938 C
    +
    939  ELSE IF (igrid.EQ.34) THEN
    +
    940  DO 140 i = 1,18
    +
    941  igds(i) = grd34(i)
    +
    942  140 CONTINUE
    +
    943 C
    +
    944  ELSE IF (igrid.EQ.37) THEN
    +
    945  DO 141 i = 1,91
    +
    946  igds(i) = grd37(i)
    +
    947  141 CONTINUE
    +
    948 C
    +
    949  ELSE IF (igrid.EQ.38) THEN
    +
    950  DO 142 i = 1,91
    +
    951  igds(i) = grd38(i)
    +
    952  142 CONTINUE
    +
    953 C
    +
    954  ELSE IF (igrid.EQ.39) THEN
    +
    955  DO 143 i = 1,91
    +
    956  igds(i) = grd39(i)
    +
    957  143 CONTINUE
    +
    958 C
    +
    959  ELSE IF (igrid.EQ.40) THEN
    +
    960  DO 144 i = 1,91
    +
    961  igds(i) = grd40(i)
    +
    962  144 CONTINUE
    +
    963 C
    +
    964  ELSE IF (igrid.EQ.41) THEN
    +
    965  DO 145 i = 1,91
    +
    966  igds(i) = grd41(i)
    +
    967  145 CONTINUE
    +
    968 C
    +
    969  ELSE IF (igrid.EQ.42) THEN
    +
    970  DO 146 i = 1,91
    +
    971  igds(i) = grd42(i)
    +
    972  146 CONTINUE
    +
    973 C
    +
    974  ELSE IF (igrid.EQ.43) THEN
    +
    975  DO 147 i = 1,91
    +
    976  igds(i) = grd43(i)
    +
    977  147 CONTINUE
    +
    978 C
    +
    979  ELSE IF (igrid.EQ.44) THEN
    +
    980  DO 148 i = 1,91
    +
    981  igds(i) = grd44(i)
    +
    982  148 CONTINUE
    +
    983 C
    +
    984  ELSE IF (igrid.EQ.45) THEN
    +
    985  DO 149 i = 1,18
    +
    986  igds(i) = grd45(i)
    +
    987  149 CONTINUE
    +
    988 C
    +
    989  ELSE IF (igrid.EQ.53) THEN
    +
    990  DO i = 1,18
    +
    991  igds(i) = grd53(i)
    +
    992  END DO
    +
    993 C
    +
    994  ELSE IF (igrid.EQ.55) THEN
    +
    995  DO 152 i = 1,18
    +
    996  igds(i) = grd55(i)
    +
    997  152 CONTINUE
    +
    998 C
    +
    999  ELSE IF (igrid.EQ.56) THEN
    +
    1000  DO 154 i = 1,18
    +
    1001  igds(i) = grd56(i)
    +
    1002  154 CONTINUE
    +
    1003 C
    +
    1004  ELSE IF (igrid.EQ.61) THEN
    +
    1005  DO 160 i = 1,64
    +
    1006  igds(i) = grd61(i)
    +
    1007  160 CONTINUE
    +
    1008 C
    +
    1009  ELSE IF (igrid.EQ.62) THEN
    +
    1010  DO 170 i = 1,64
    +
    1011  igds(i) = grd62(i)
    +
    1012  170 CONTINUE
    +
    1013 C
    +
    1014  ELSE IF (igrid.EQ.63) THEN
    +
    1015  DO 180 i = 1,64
    +
    1016  igds(i) = grd63(i)
    +
    1017  180 CONTINUE
    +
    1018 C
    +
    1019  ELSE IF (igrid.EQ.64) THEN
    +
    1020  DO 190 i = 1,64
    +
    1021  igds(i) = grd64(i)
    +
    1022  190 CONTINUE
    +
    1023 C
    +
    1024  ELSE IF (igrid.EQ.83) THEN
    +
    1025  DO i = 1,18
    +
    1026  igds(i) = grd83(i)
    +
    1027  ENDDO
    +
    1028 C
    +
    1029  ELSE IF (igrid.EQ.85) THEN
    +
    1030  DO 192 i = 1,18
    +
    1031  igds(i) = grd85(i)
    +
    1032  192 CONTINUE
    +
    1033 C
    +
    1034  ELSE IF (igrid.EQ.86) THEN
    +
    1035  DO 194 i = 1,18
    +
    1036  igds(i) = grd86(i)
    +
    1037  194 CONTINUE
    +
    1038 C
    +
    1039  ELSE IF (igrid.EQ.87) THEN
    +
    1040  DO 195 i = 1,18
    +
    1041  igds(i) = grd87(i)
    +
    1042  195 CONTINUE
    +
    1043 C
    +
    1044  ELSE IF (igrid.EQ.88) THEN
    +
    1045  DO 2195 i = 1,18
    +
    1046  igds(i) = grd88(i)
    +
    1047 2195 CONTINUE
    +
    1048 C
    +
    1049  ELSE IF (igrid.EQ.90) THEN
    +
    1050  DO 196 i = 1,18
    +
    1051  igds(i) = grd90(i)
    +
    1052  196 CONTINUE
    +
    1053 C
    +
    1054  ELSE IF (igrid.EQ.91) THEN
    +
    1055  DO 197 i = 1,18
    +
    1056  igds(i) = grd91(i)
    +
    1057  197 CONTINUE
    +
    1058 C
    +
    1059  ELSE IF (igrid.EQ.92) THEN
    +
    1060  DO 198 i = 1,18
    +
    1061  igds(i) = grd92(i)
    +
    1062  198 CONTINUE
    +
    1063 C
    +
    1064  ELSE IF (igrid.EQ.93) THEN
    +
    1065  DO 199 i = 1,18
    +
    1066  igds(i) = grd93(i)
    +
    1067  199 CONTINUE
    +
    1068 C
    +
    1069  ELSE IF (igrid.EQ.94) THEN
    +
    1070  DO 200 i = 1,18
    +
    1071  igds(i) = grd94(i)
    +
    1072  200 CONTINUE
    +
    1073 C
    +
    1074  ELSE IF (igrid.EQ.95) THEN
    +
    1075  DO 201 i = 1,18
    +
    1076  igds(i) = grd95(i)
    +
    1077  201 CONTINUE
    +
    1078 C
    +
    1079  ELSE IF (igrid.EQ.96) THEN
    +
    1080  DO 202 i = 1,18
    +
    1081  igds(i) = grd96(i)
    +
    1082  202 CONTINUE
    +
    1083 C
    +
    1084  ELSE IF (igrid.EQ.97) THEN
    +
    1085  DO 203 i = 1,18
    +
    1086  igds(i) = grd97(i)
    +
    1087  203 CONTINUE
    +
    1088 C
    +
    1089  ELSE IF (igrid.EQ.98) THEN
    +
    1090  DO 204 i = 1,18
    +
    1091  igds(i) = grd98(i)
    +
    1092  204 CONTINUE
    +
    1093 C
    +
    1094  ELSE IF (igrid.EQ.99) THEN
    +
    1095  DO i = 1,18
    +
    1096  igds(i) = grd99(i)
    +
    1097  ENDDO
    +
    1098 C
    +
    1099  ELSE IF (igrid.EQ.100) THEN
    +
    1100  DO 205 i = 1,18
    +
    1101  igds(i) = grd100(i)
    +
    1102  205 CONTINUE
    +
    1103 C
    +
    1104  ELSE IF (igrid.EQ.101) THEN
    +
    1105  DO 210 i = 1,18
    +
    1106  igds(i) = grd101(i)
    +
    1107  210 CONTINUE
    +
    1108 C
    +
    1109  ELSE IF (igrid.EQ.103) THEN
    +
    1110  DO 220 i = 1,18
    +
    1111  igds(i) = grd103(i)
    +
    1112  220 CONTINUE
    +
    1113 C
    +
    1114  ELSE IF (igrid.EQ.104) THEN
    +
    1115  DO 230 i = 1,18
    +
    1116  igds(i) = grd104(i)
    +
    1117  230 CONTINUE
    +
    1118 C
    +
    1119  ELSE IF (igrid.EQ.105) THEN
    +
    1120  DO 240 i = 1,18
    +
    1121  igds(i) = grd105(i)
    +
    1122  240 CONTINUE
    +
    1123 C
    +
    1124  ELSE IF (igrid.EQ.106) THEN
    +
    1125  DO 242 i = 1,18
    +
    1126  igds(i) = grd106(i)
    +
    1127  242 CONTINUE
    +
    1128 C
    +
    1129  ELSE IF (igrid.EQ.107) THEN
    +
    1130  DO 244 i = 1,18
    +
    1131  igds(i) = grd107(i)
    +
    1132  244 CONTINUE
    +
    1133 C
    +
    1134  ELSE IF (igrid.EQ.110) THEN
    +
    1135  DO i = 1,18
    +
    1136  igds(i) = grd110(i)
    +
    1137  ENDDO
    +
    1138 C
    +
    1139  ELSE IF (igrid.EQ.120) THEN
    +
    1140  DO i = 1,18
    +
    1141  igds(i) = grd120(i)
    +
    1142  ENDDO
    +
    1143 C
    +
    1144  ELSE IF (igrid.EQ.122) THEN
    +
    1145  DO i = 1,18
    +
    1146  igds(i) = grd122(i)
    +
    1147  ENDDO
    +
    1148 C
    +
    1149  ELSE IF (igrid.EQ.123) THEN
    +
    1150  DO i = 1,18
    +
    1151  igds(i) = grd123(i)
    +
    1152  ENDDO
    +
    1153 C
    +
    1154  ELSE IF (igrid.EQ.124) THEN
    +
    1155  DO i = 1,18
    +
    1156  igds(i) = grd124(i)
    +
    1157  ENDDO
    +
    1158 C
    +
    1159  ELSE IF (igrid.EQ.125) THEN
    +
    1160  DO i = 1,18
    +
    1161  igds(i) = grd125(i)
    +
    1162  ENDDO
    +
    1163 C
    +
    1164  ELSE IF (igrid.EQ.126) THEN
    +
    1165  DO 245 i = 1,18
    +
    1166  igds(i) = grd126(i)
    +
    1167  245 CONTINUE
    +
    1168 C
    +
    1169  ELSE IF (igrid.EQ.127) THEN
    +
    1170  DO i = 1,18
    +
    1171  igds(i) = grd127(i)
    +
    1172  ENDDO
    +
    1173 C
    +
    1174  ELSE IF (igrid.EQ.128) THEN
    +
    1175  DO i = 1,18
    +
    1176  igds(i) = grd128(i)
    +
    1177  ENDDO
    +
    1178 C
    +
    1179  ELSE IF (igrid.EQ.129) THEN
    +
    1180  DO i = 1,18
    +
    1181  igds(i) = grd129(i)
    +
    1182  ENDDO
    +
    1183 C
    +
    1184  ELSE IF (igrid.EQ.130) THEN
    +
    1185  DO i = 1,18
    +
    1186  igds(i) = grd130(i)
    +
    1187  ENDDO
    +
    1188 C
    +
    1189  ELSE IF (igrid.EQ.132) THEN
    +
    1190  DO i = 1,18
    +
    1191  igds(i) = grd132(i)
    +
    1192  ENDDO
    +
    1193 C
    +
    1194  ELSE IF (igrid.EQ.138) THEN
    +
    1195  DO i = 1,18
    +
    1196  igds(i) = grd138(i)
    +
    1197  ENDDO
    +
    1198 C
    +
    1199  ELSE IF (igrid.EQ.139) THEN
    +
    1200  DO i = 1,18
    +
    1201  igds(i) = grd139(i)
    +
    1202  ENDDO
    +
    1203 C
    +
    1204  ELSE IF (igrid.EQ.140) THEN
    +
    1205  DO i = 1,18
    +
    1206  igds(i) = grd140(i)
    +
    1207  ENDDO
    +
    1208 C
    +
    1209  ELSE IF (igrid.EQ.145) THEN
    +
    1210  DO i = 1,18
    +
    1211  igds(i) = grd145(i)
    +
    1212  ENDDO
    +
    1213 C
    +
    1214  ELSE IF (igrid.EQ.146) THEN
    +
    1215  DO i = 1,18
    +
    1216  igds(i) = grd146(i)
    +
    1217  ENDDO
    +
    1218 C
    +
    1219  ELSE IF (igrid.EQ.147) THEN
    +
    1220  DO i = 1,18
    +
    1221  igds(i) = grd147(i)
    +
    1222  ENDDO
    +
    1223 C
    +
    1224  ELSE IF (igrid.EQ.148) THEN
    +
    1225  DO i = 1,18
    +
    1226  igds(i) = grd148(i)
    +
    1227  ENDDO
    +
    1228 C
    +
    1229  ELSE IF (igrid.EQ.150) THEN
    +
    1230  DO i = 1,18
    +
    1231  igds(i) = grd150(i)
    +
    1232  ENDDO
    +
    1233 C
    +
    1234  ELSE IF (igrid.EQ.151) THEN
    +
    1235  DO i = 1,18
    +
    1236  igds(i) = grd151(i)
    +
    1237  ENDDO
    +
    1238 C
    +
    1239  ELSE IF (igrid.EQ.160) THEN
    +
    1240  DO i = 1,18
    +
    1241  igds(i) = grd160(i)
    +
    1242  ENDDO
    +
    1243 C
    +
    1244  ELSE IF (igrid.EQ.161) THEN
    +
    1245  DO i = 1,18
    +
    1246  igds(i) = grd161(i)
    +
    1247  ENDDO
    +
    1248  ELSE IF (igrid.EQ.163) THEN
    +
    1249  DO i = 1,18
    +
    1250  igds(i) = grd163(i)
    +
    1251  ENDDO
    +
    1252 C
    +
    1253  ELSE IF (igrid.EQ.170) THEN
    +
    1254  DO i = 1,18
    +
    1255  igds(i) = grd170(i)
    +
    1256  ENDDO
    +
    1257 C
    +
    1258  ELSE IF (igrid.EQ.171) THEN
    +
    1259  DO i = 1,18
    +
    1260  igds(i) = grd171(i)
    +
    1261  ENDDO
    +
    1262 C
    +
    1263  ELSE IF (igrid.EQ.172) THEN
    +
    1264  DO i = 1,18
    +
    1265  igds(i) = grd172(i)
    +
    1266  ENDDO
    +
    1267 C
    +
    1268  ELSE IF (igrid.EQ.173) THEN
    +
    1269  DO i = 1,18
    +
    1270  igds(i) = grd173(i)
    +
    1271  ENDDO
    +
    1272 C
    +
    1273  ELSE IF (igrid.EQ.174) THEN
    +
    1274  DO i = 1,18
    +
    1275  igds(i) = grd174(i)
    +
    1276  ENDDO
    +
    1277 C
    +
    1278  ELSE IF (igrid.EQ.175) THEN
    +
    1279  DO i = 1,18
    +
    1280  igds(i) = grd175(i)
    +
    1281  ENDDO
    +
    1282 C
    +
    1283  ELSE IF (igrid.EQ.176) THEN
    +
    1284  DO i = 1,18
    +
    1285  igds(i) = grd176(i)
    +
    1286  ENDDO
    +
    1287 C
    +
    1288  ELSE IF (igrid.EQ.179) THEN
    +
    1289  DO i = 1,18
    +
    1290  igds(i) = grd179(i)
    +
    1291  ENDDO
    +
    1292 C
    +
    1293  ELSE IF (igrid.EQ.180) THEN
    +
    1294  DO i = 1,18
    +
    1295  igds(i) = grd180(i)
    +
    1296  ENDDO
    +
    1297 C
    +
    1298  ELSE IF (igrid.EQ.181) THEN
    +
    1299  DO i = 1,18
    +
    1300  igds(i) = grd181(i)
    +
    1301  ENDDO
    +
    1302 C
    +
    1303  ELSE IF (igrid.EQ.182) THEN
    +
    1304  DO i = 1,18
    +
    1305  igds(i) = grd182(i)
    +
    1306  ENDDO
    +
    1307 C
    +
    1308  ELSE IF (igrid.EQ.183) THEN
    +
    1309  DO i = 1,18
    +
    1310  igds(i) = grd183(i)
    +
    1311  ENDDO
    +
    1312 C
    +
    1313  ELSE IF (igrid.EQ.184) THEN
    +
    1314  DO i = 1,18
    +
    1315  igds(i) = grd184(i)
    +
    1316  ENDDO
    +
    1317 C
    +
    1318  ELSE IF (igrid.EQ.187) THEN
    +
    1319  DO i = 1,18
    +
    1320  igds(i) = grd187(i)
    +
    1321  ENDDO
    +
    1322 C
    +
    1323  ELSE IF (igrid.EQ.188) THEN
    +
    1324  DO i = 1,18
    +
    1325  igds(i) = grd188(i)
    +
    1326  ENDDO
    +
    1327 C
    +
    1328  ELSE IF (igrid.EQ.189) THEN
    +
    1329  DO i = 1,18
    +
    1330  igds(i) = grd189(i)
    +
    1331  ENDDO
    +
    1332 C
    +
    1333  ELSE IF (igrid.EQ.190) THEN
    +
    1334  DO 2190 i = 1,18
    +
    1335  igds(i) = grd190(i)
    +
    1336  2190 CONTINUE
    +
    1337 C
    +
    1338  ELSE IF (igrid.EQ.192) THEN
    +
    1339  DO 2191 i = 1,18
    +
    1340  igds(i) = grd192(i)
    +
    1341  2191 CONTINUE
    +
    1342 C
    +
    1343  ELSE IF (igrid.EQ.193) THEN
    +
    1344  DO i = 1,18
    +
    1345  igds(i) = grd193(i)
    +
    1346  END DO
    +
    1347 C
    +
    1348  ELSE IF (igrid.EQ.194) THEN
    +
    1349  DO 2192 i = 1,18
    +
    1350  igds(i) = grd194(i)
    +
    1351  2192 CONTINUE
    +
    1352 C
    +
    1353  ELSE IF (igrid.EQ.195) THEN
    +
    1354  DO i = 1,18
    +
    1355  igds(i) = grd195(i)
    +
    1356  END DO
    +
    1357 C
    +
    1358  ELSE IF (igrid.EQ.196) THEN
    +
    1359  DO 249 i = 1,18
    +
    1360  igds(i) = grd196(i)
    +
    1361  249 CONTINUE
    +
    1362 C
    +
    1363  ELSE IF (igrid.EQ.197) THEN
    +
    1364  DO i = 1,18
    +
    1365  igds(i) = grd197(i)
    +
    1366  END DO
    +
    1367 C
    +
    1368  ELSE IF (igrid.EQ.198) THEN
    +
    1369  DO 2490 i = 1,18
    +
    1370  igds(i) = grd198(i)
    +
    1371  2490 CONTINUE
    +
    1372 C
    +
    1373  ELSE IF (igrid.EQ.199) THEN
    +
    1374  DO i = 1,18
    +
    1375  igds(i) = grd199(i)
    +
    1376  END DO
    +
    1377 C
    +
    1378  ELSE IF (igrid.EQ.200) THEN
    +
    1379  DO i = 1,18
    +
    1380  igds(i) = grd200(i)
    +
    1381  END DO
    +
    1382 C
    +
    1383  ELSE IF (igrid.EQ.201) THEN
    +
    1384  DO 250 i = 1,18
    +
    1385  igds(i) = grd201(i)
    +
    1386  250 CONTINUE
    +
    1387 C
    +
    1388  ELSE IF (igrid.EQ.202) THEN
    +
    1389  DO 260 i = 1,18
    +
    1390  igds(i) = grd202(i)
    +
    1391  260 CONTINUE
    +
    1392 C
    +
    1393  ELSE IF (igrid.EQ.203) THEN
    +
    1394  DO 270 i = 1,18
    +
    1395  igds(i) = grd203(i)
    +
    1396  270 CONTINUE
    +
    1397 C
    +
    1398  ELSE IF (igrid.EQ.204) THEN
    +
    1399  DO 280 i = 1,18
    +
    1400  igds(i) = grd204(i)
    +
    1401  280 CONTINUE
    +
    1402 C
    +
    1403  ELSE IF (igrid.EQ.205) THEN
    +
    1404  DO 290 i = 1,18
    +
    1405  igds(i) = grd205(i)
    +
    1406  290 CONTINUE
    +
    1407 C
    +
    1408  ELSE IF (igrid.EQ.206) THEN
    +
    1409  DO 300 i = 1,18
    +
    1410  igds(i) = grd206(i)
    +
    1411  300 CONTINUE
    +
    1412 C
    +
    1413  ELSE IF (igrid.EQ.207) THEN
    +
    1414  DO 310 i = 1,18
    +
    1415  igds(i) = grd207(i)
    +
    1416  310 CONTINUE
    +
    1417 C
    +
    1418  ELSE IF (igrid.EQ.208) THEN
    +
    1419  DO 320 i = 1,18
    +
    1420  igds(i) = grd208(i)
    +
    1421  320 CONTINUE
    +
    1422 C
    +
    1423  ELSE IF (igrid.EQ.209) THEN
    +
    1424  DO 330 i = 1,18
    +
    1425  igds(i) = grd209(i)
    +
    1426  330 CONTINUE
    +
    1427 C
    +
    1428  ELSE IF (igrid.EQ.210) THEN
    +
    1429  DO 340 i = 1,18
    +
    1430  igds(i) = grd210(i)
    +
    1431  340 CONTINUE
    +
    1432 C
    +
    1433  ELSE IF (igrid.EQ.211) THEN
    +
    1434  DO 350 i = 1,18
    +
    1435  igds(i) = grd211(i)
    +
    1436  350 CONTINUE
    +
    1437 C
    +
    1438  ELSE IF (igrid.EQ.212) THEN
    +
    1439  DO 360 i = 1,18
    +
    1440  igds(i) = grd212(i)
    +
    1441  360 CONTINUE
    +
    1442 C
    +
    1443  ELSE IF (igrid.EQ.213) THEN
    +
    1444  DO 370 i = 1,18
    +
    1445  igds(i) = grd213(i)
    +
    1446  370 CONTINUE
    +
    1447 C
    +
    1448  ELSE IF (igrid.EQ.214) THEN
    +
    1449  DO 380 i = 1,18
    +
    1450  igds(i) = grd214(i)
    +
    1451  380 CONTINUE
    +
    1452 C
    +
    1453  ELSE IF (igrid.EQ.215) THEN
    +
    1454  DO 390 i = 1,18
    +
    1455  igds(i) = grd215(i)
    +
    1456  390 CONTINUE
    +
    1457 C
    +
    1458  ELSE IF (igrid.EQ.216) THEN
    +
    1459  DO 400 i = 1,18
    +
    1460  igds(i) = grd216(i)
    +
    1461  400 CONTINUE
    +
    1462 C
    +
    1463  ELSE IF (igrid.EQ.217) THEN
    +
    1464  DO 401 i = 1,18
    +
    1465  igds(i) = grd217(i)
    +
    1466  401 CONTINUE
    +
    1467 C
    +
    1468  ELSE IF (igrid.EQ.218) THEN
    +
    1469  DO 410 i = 1,18
    +
    1470  igds(i) = grd218(i)
    +
    1471  410 CONTINUE
    +
    1472 C
    +
    1473  ELSE IF (igrid.EQ.219) THEN
    +
    1474  DO 411 i = 1,18
    +
    1475  igds(i) = grd219(i)
    +
    1476  411 CONTINUE
    +
    1477 C
    +
    1478  ELSE IF (igrid.EQ.220) THEN
    +
    1479  DO 412 i = 1,18
    +
    1480  igds(i) = grd220(i)
    +
    1481  412 CONTINUE
    +
    1482 C
    +
    1483  ELSE IF (igrid.EQ.221) THEN
    +
    1484  DO 413 i = 1,18
    +
    1485  igds(i) = grd221(i)
    +
    1486  413 CONTINUE
    +
    1487 C
    +
    1488  ELSE IF (igrid.EQ.222) THEN
    +
    1489  DO 414 i = 1,18
    +
    1490  igds(i) = grd222(i)
    +
    1491  414 CONTINUE
    +
    1492 C
    +
    1493  ELSE IF (igrid.EQ.223) THEN
    +
    1494  DO 415 i = 1,18
    +
    1495  igds(i) = grd223(i)
    +
    1496  415 CONTINUE
    +
    1497 C
    +
    1498  ELSE IF (igrid.EQ.224) THEN
    +
    1499  DO 416 i = 1,18
    +
    1500  igds(i) = grd224(i)
    +
    1501  416 CONTINUE
    +
    1502 C
    +
    1503  ELSE IF (igrid.EQ.225) THEN
    +
    1504  DO 417 i = 1,18
    +
    1505  igds(i) = grd225(i)
    +
    1506  417 CONTINUE
    +
    1507 C
    +
    1508  ELSE IF (igrid.EQ.226) THEN
    +
    1509  DO 418 i = 1,18
    +
    1510  igds(i) = grd226(i)
    +
    1511  418 CONTINUE
    +
    1512 C
    +
    1513  ELSE IF (igrid.EQ.227) THEN
    +
    1514  DO 419 i = 1,18
    +
    1515  igds(i) = grd227(i)
    +
    1516  419 CONTINUE
    +
    1517 C
    +
    1518  ELSE IF (igrid.EQ.228) THEN
    +
    1519  DO 420 i = 1,18
    +
    1520  igds(i) = grd228(i)
    +
    1521  420 CONTINUE
    +
    1522 C
    +
    1523  ELSE IF (igrid.EQ.229) THEN
    +
    1524  DO 421 i = 1,18
    +
    1525  igds(i) = grd229(i)
    +
    1526  421 CONTINUE
    +
    1527 C
    +
    1528  ELSE IF (igrid.EQ.230) THEN
    +
    1529  DO 422 i = 1,18
    +
    1530  igds(i) = grd230(i)
    +
    1531  422 CONTINUE
    +
    1532 C
    +
    1533  ELSE IF (igrid.EQ.231) THEN
    +
    1534  DO 423 i = 1,18
    +
    1535  igds(i) = grd231(i)
    +
    1536  423 CONTINUE
    +
    1537 C
    +
    1538  ELSE IF (igrid.EQ.232) THEN
    +
    1539  DO 424 i = 1,18
    +
    1540  igds(i) = grd232(i)
    +
    1541  424 CONTINUE
    +
    1542 C
    +
    1543  ELSE IF (igrid.EQ.233) THEN
    +
    1544  DO 425 i = 1,18
    +
    1545  igds(i) = grd233(i)
    +
    1546  425 CONTINUE
    +
    1547 C
    +
    1548  ELSE IF (igrid.EQ.234) THEN
    +
    1549  DO 426 i = 1,18
    +
    1550  igds(i) = grd234(i)
    +
    1551  426 CONTINUE
    +
    1552 C
    +
    1553  ELSE IF (igrid.EQ.235) THEN
    +
    1554  DO 427 i = 1,18
    +
    1555  igds(i) = grd235(i)
    +
    1556  427 CONTINUE
    +
    1557 C
    +
    1558  ELSE IF (igrid.EQ.236) THEN
    +
    1559  DO 428 i = 1,18
    +
    1560  igds(i) = grd236(i)
    +
    1561  428 CONTINUE
    +
    1562 C
    +
    1563  ELSE IF (igrid.EQ.237) THEN
    +
    1564  DO 429 i = 1,18
    +
    1565  igds(i) = grd237(i)
    +
    1566  429 CONTINUE
    +
    1567 C
    +
    1568  ELSE IF (igrid.EQ.238) THEN
    +
    1569  DO i = 1,18
    +
    1570  igds(i) = grd238(i)
    +
    1571  END DO
    +
    1572 C
    +
    1573  ELSE IF (igrid.EQ.239) THEN
    +
    1574  DO i = 1,18
    +
    1575  igds(i) = grd239(i)
    +
    1576  END DO
    +
    1577 C
    +
    1578  ELSE IF (igrid.EQ.240) THEN
    +
    1579  DO i = 1,18
    +
    1580  igds(i) = grd240(i)
    +
    1581  END DO
    +
    1582 C
    +
    1583  ELSE IF (igrid.EQ.241) THEN
    +
    1584  DO 430 i = 1,18
    +
    1585  igds(i) = grd241(i)
    +
    1586  430 CONTINUE
    +
    1587 C
    +
    1588  ELSE IF (igrid.EQ.242) THEN
    +
    1589  DO 431 i = 1,18
    +
    1590  igds(i) = grd242(i)
    +
    1591  431 CONTINUE
    +
    1592 C
    +
    1593  ELSE IF (igrid.EQ.243) THEN
    +
    1594  DO 432 i = 1,18
    +
    1595  igds(i) = grd243(i)
    +
    1596  432 CONTINUE
    +
    1597 C
    +
    1598  ELSE IF (igrid.EQ.244) THEN
    +
    1599  DO i = 1,18
    +
    1600  igds(i) = grd244(i)
    +
    1601  END DO
    +
    1602 C
    +
    1603  ELSE IF (igrid.EQ.245) THEN
    +
    1604  DO 433 i = 1,18
    +
    1605  igds(i) = grd245(i)
    +
    1606  433 CONTINUE
    +
    1607 C
    +
    1608  ELSE IF (igrid.EQ.246) THEN
    +
    1609  DO 434 i = 1,18
    +
    1610  igds(i) = grd246(i)
    +
    1611  434 CONTINUE
    +
    1612 C
    +
    1613  ELSE IF (igrid.EQ.247) THEN
    +
    1614  DO 435 i = 1,18
    +
    1615  igds(i) = grd247(i)
    +
    1616  435 CONTINUE
    +
    1617 C
    +
    1618  ELSE IF (igrid.EQ.248) THEN
    +
    1619  DO 436 i = 1,18
    +
    1620  igds(i) = grd248(i)
    +
    1621  436 CONTINUE
    +
    1622 C
    +
    1623  ELSE IF (igrid.EQ.249) THEN
    +
    1624  DO 437 i = 1,18
    +
    1625  igds(i) = grd249(i)
    +
    1626  437 CONTINUE
    +
    1627 C
    +
    1628  ELSE IF (igrid.EQ.250) THEN
    +
    1629  DO 438 i = 1,18
    +
    1630  igds(i) = grd250(i)
    +
    1631  438 CONTINUE
    +
    1632 C
    +
    1633  ELSE IF (igrid.EQ.251) THEN
    +
    1634  DO 439 i = 1,18
    +
    1635  igds(i) = grd251(i)
    +
    1636  439 CONTINUE
    +
    1637 C
    +
    1638  ELSE IF (igrid.EQ.252) THEN
    +
    1639  DO 440 i = 1,18
    +
    1640  igds(i) = grd252(i)
    +
    1641  440 CONTINUE
    +
    1642  ELSE IF (igrid.EQ.253) THEN
    +
    1643  DO 441 i = 1,18
    +
    1644  igds(i) = grd253(i)
    +
    1645  441 CONTINUE
    +
    1646  ELSE IF (igrid.EQ.254) THEN
    +
    1647  DO 442 i = 1,18
    +
    1648  igds(i) = grd254(i)
    +
    1649  442 CONTINUE
    +
    1650 C
    +
    1651  ELSE
    +
    1652  ierr = 1
    +
    1653  ENDIF
    +
    1654 C
    +
    1655  RETURN
    +
    1656  END
    +
    +
    +
    w3fi71
    subroutine w3fi71(IGRID, IGDS, IERR)
    Makes a 18, 37, 55, 64, or 91 word integer array used by w3fi72() GRIB packer to make the grid descri...
    Definition: w3fi71.f:187
    + + + + diff --git a/ver-2.10.0/w3fi72_8f.html b/ver-2.10.0/w3fi72_8f.html new file mode 100644 index 00000000..70cf6c1f --- /dev/null +++ b/ver-2.10.0/w3fi72_8f.html @@ -0,0 +1,376 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi72.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi72.f File Reference
    +
    +
    + +

    Make a complete GRIB message. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi72 (ITYPE, FLD, IFLD, IBITL, IPFLAG, ID, PDS, IGFLAG, IGRID, IGDS, ICOMP, IBFLAG, IBMAP, IBLEN, IBDSFL, NPTS, KBUF, ITOT, JERR)
     Makes a complete GRIB message from a user supplied array of floating point or integer data. More...
     
    +

    Detailed Description

    +

    Make a complete GRIB message.

    +
    Author
    Ralph Jones
    +
    Date
    1991-05-08
    + +

    Definition in file w3fi72.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi72()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi72 ( ITYPE,
    real, dimension(*) FLD,
    integer, dimension(*) IFLD,
     IBITL,
     IPFLAG,
    integer, dimension(*) ID,
    character * 1, dimension(*) PDS,
     IGFLAG,
     IGRID,
    integer, dimension(*) IGDS,
     ICOMP,
     IBFLAG,
    integer, dimension(*) IBMAP,
     IBLEN,
    integer, dimension(*) IBDSFL,
     NPTS,
    character * 1, dimension(*) KBUF,
     ITOT,
     JERR 
    )
    +
    + +

    Makes a complete GRIB message from a user supplied array of floating point or integer data.

    +

    The user has the option of supplying the PDS or an integer array that will be used to create a PDS (with w3fi68()). The user must also supply other necessary information.

    +
    Parameters
    + + + + + + +
    [in]ITYPE
      +
    • 0 = Floating point data supplied in array 'fld'
      • +
    • 1 = Integer data supplied in array 'ifld'
      • +
    +
    [in]FLDReal array of data (at proper gridpoints) to be converted to grib format if itype=0. see remarks #1 & 2.
    [in]IFLDInteger array of data (at proper gridpoints) to be converted to grib format if itype=1. See remarks #1 & 2.
    [in]IBITL
      +
    • 0 = Computer computes length for packing data from power of 2 (number of bits) best fit of data using 'variable' bit packer w3fi58().
      • +
    • 8, 12, Etc. computer rescales data to fit into that 'fixed' number of bits using w3fi59(). See remarks #3.
      • +
    +
    [in]IPFLAG
      +
    • 0 = Make pds from user supplied array (id)
      • +
    • 1 = User supplying pds
      • +
    +
    +
    +
    +
    Note
    If pds is greater than 30, use iplfag=1. The user could call w3fi68() before he calls w3fi72(). This would make the first 30 bytes of the pds, user then would make bytes after 30.
    +
    Parameters
    + + + + + + + + + + + + + + + +
    [in]IDInteger array of values that w3fi68() will use to make an edition 1 pds if ipflag=0. (see the docblock for w3fi68() for layout of array)
    [in]PDSCharacter array of values (valid pds supplied by user) if ipflag=1. length may exceed 28 bytes (contents of bytes beyond 28 are passed through unchanged).
    [in]IGFLAG
      +
    • 0 = Make gds based on 'igrid' value.
      • +
    • 1 = Make gds from user supplied info in 'igds' and 'igrid' value. See remarks #4.
      • +
    +
    [in]IGRID
      +
    • # = Grid identification (table b)
      • +
    • 255 = If user defined grid; igds must be supplied and igflag must =1.
      • +
    +
    [in]IGDSInteger array containing user gds info (same format as supplied by w3fi71() - see dockblock for layout) if igflag=1.
    [in]ICOMPResolution and component flag for bit 5 of gds(17)
      +
    • 0 = Earth oriented winds
      • +
    • 1 = Grid oriented winds
      • +
    +
    [in]IBFLAG
      +
    • 0 = Make bit map from user supplied data
      • +
    • # = Bit map predefined by center. See remarks #5.
      • +
    +
    [in]IBMAPInteger array containing bit map
    [in]IBLENLength of bit map will be used to verify length of field (error if it doesn't match).
    [in]IBDSFLInteger array containing table 11 flag info
      +
    • BDS octet 4:
      • +
    • (1)
        +
      • 0 = Grid point data
        • +
      • 1 = Spherical harmonic coefficients
        • +
      +
      • +
    • (2) 0 = Simple packing
        +
      • 1 = Second order packing
        • +
      +
      • +
    • (3) ... Same value as 'itype'
        +
      • 0 = Original data were floating point values
        • +
      • 1 = Original data were integer values
        • +
      +
      • +
    • (4) 0 = No additional flags at octet 14
        +
      • 1 = Octet 14 contains flag bits 5-12
        • +
      +
      • +
    • (5) 0 = Reserved - always set to 0 Byte 6 option 1 not available (as of 5-16-93)
      • +
    • (6) 0 = Single datum at each grid point
        +
      • 1 = Matrix of values at each grid point Byte 7 option 0 with second order packing n/a (as of 5-16-93)
        • +
      +
      • +
    • (7) 0 = No secondary bit maps
        +
      • 1 = Secondary bit maps present
        • +
      +
      • +
    • (8) 0 = Second order values have constant width
        +
      • 1 = Second order values have different widths
        • +
      +
      • +
    +
    [out]NPTSNumber of gridpoints in array fld or ifld
    [out]KBUFEntire grib message ('grib' to '7777') equivalence to integer array to make sure it is on word boundary.
    [out]ITOTTotal length of grib message in bytes
    [out]JERR
      +
    • = 0, Completed making grib field without error
      • +
    • = 1, Ipflag not 0 or 1
      • +
    • = 2, Igflag not 0 or 1
      • +
    • = 3, Error converting ieee f.p. number to ibm370 f.p.
      • +
    • = 4, W3fi71() error/igrid not defined
      • +
    • = 5, W3fk74() error/grid representation type not valid
      • +
    • = 6, Grid too large for packer dimension arrays
      • +
    • = See automation division for revision!
      • +
    • = 7, Length of bit map not equal to size of fld/ifld
      • +
    • = 8, W3fi73() error, all values in ibmap are zero
      • +
    +
    +
    +
    +
    Note
      +
    • 1: If bit map to be included in message, null data should be included in fld or ifld. this routine will take care of 'discarding' any null data based on the bit map.
      • +
    • 2: Units must be those in grib documentation: nmc o.n. 388 or wmo publication 306.
      • +
    • 3: In either case, input numbers will be multiplied by '10 to the nth' power found in id(25) or pds(27-28), the d-scaling factor, prior to binary packing.
      • +
    • 4: All nmc produced grib fields will have a grid definition section included in the grib message. id(6) will be set to '1'.
        +
      • GDS will be built based on grid number (igrid), unless igflag=1 (user supplying igds). user must still supply igrid even if igds provided.
        • +
      +
      • +
    • 5: if bit map used then id(7) or pds(8) must indicate the presence of a bit map.
      • +
    • 6: Array kbuf should be equivalenced to an integer value or array to make sure it is on a word boundary.
      • +
    • 7: Subprogram can be called from a multiprocessing environment.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1991-05-08
    + +

    Definition at line 121 of file w3fi72.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi72_8f.js b/ver-2.10.0/w3fi72_8f.js new file mode 100644 index 00000000..324a160a --- /dev/null +++ b/ver-2.10.0/w3fi72_8f.js @@ -0,0 +1,4 @@ +var w3fi72_8f = +[ + [ "w3fi72", "w3fi72_8f.html#aaac6e022f341c919316466672ef3e70c", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi72_8f_source.html b/ver-2.10.0/w3fi72_8f_source.html new file mode 100644 index 00000000..f8a009a9 --- /dev/null +++ b/ver-2.10.0/w3fi72_8f_source.html @@ -0,0 +1,508 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi72.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi72.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Make a complete GRIB message.
    +
    3 C> @author Ralph Jones @date 1991-05-08
    +
    4 
    +
    5 C> Makes a complete GRIB message from a user supplied
    +
    6 C> array of floating point or integer data. The user has the
    +
    7 C> option of supplying the PDS or an integer array that will be
    +
    8 C> used to create a PDS (with w3fi68()). The user must also
    +
    9 C> supply other necessary information.
    +
    10 C>
    +
    11 C> @param[in] ITYPE
    +
    12 C> - 0 = Floating point data supplied in array 'fld'
    +
    13 C> - 1 = Integer data supplied in array 'ifld'
    +
    14 C> @param[in] FLD Real array of data (at proper gridpoints) to be
    +
    15 C> converted to grib format if itype=0.
    +
    16 C> see remarks #1 & 2.
    +
    17 C> @param[in] IFLD Integer array of data (at proper gridpoints) to be
    +
    18 C> converted to grib format if itype=1. See remarks #1 & 2.
    +
    19 C> @param[in] IBITL
    +
    20 C> - 0 = Computer computes length for packing data from
    +
    21 C> power of 2 (number of bits) best fit of data
    +
    22 C> using 'variable' bit packer w3fi58().
    +
    23 C> - 8, 12, Etc. computer rescales data to fit into that
    +
    24 C> 'fixed' number of bits using w3fi59(). See remarks #3.
    +
    25 C> @param[in] IPFLAG
    +
    26 C> - 0 = Make pds from user supplied array (id)
    +
    27 C> - 1 = User supplying pds
    +
    28 C> @note If pds is greater than 30, use iplfag=1. The user could call w3fi68()
    +
    29 C> before he calls w3fi72(). This would make the first 30 bytes of the pds,
    +
    30 C> user then would make bytes after 30.
    +
    31 C> @param[in] ID Integer array of values that w3fi68() will use
    +
    32 C> to make an edition 1 pds if ipflag=0. (see the
    +
    33 C> docblock for w3fi68() for layout of array)
    +
    34 C> @param[in] PDS Character array of values (valid pds supplied
    +
    35 C> by user) if ipflag=1. length may exceed 28 bytes
    +
    36 C> (contents of bytes beyond 28 are passed
    +
    37 C> through unchanged).
    +
    38 C> @param[in] IGFLAG
    +
    39 C> - 0 = Make gds based on 'igrid' value.
    +
    40 C> - 1 = Make gds from user supplied info in 'igds' and 'igrid' value.
    +
    41 C> See remarks #4.
    +
    42 C> @param[in] IGRID
    +
    43 C> - # = Grid identification (table b)
    +
    44 C> - 255 = If user defined grid; igds must be supplied and igflag must =1.
    +
    45 C> @param[in] IGDS Integer array containing user gds info (same
    +
    46 C> format as supplied by w3fi71() - see dockblock for
    +
    47 C> layout) if igflag=1.
    +
    48 C> @param[in] ICOMP Resolution and component flag for bit 5 of gds(17)
    +
    49 C> - 0 = Earth oriented winds
    +
    50 C> - 1 = Grid oriented winds
    +
    51 C> @param[in] IBFLAG
    +
    52 C> - 0 = Make bit map from user supplied data
    +
    53 C> - # = Bit map predefined by center. See remarks #5.
    +
    54 C> @param[in] IBMAP Integer array containing bit map
    +
    55 C> @param[in] IBLEN Length of bit map will be used to verify length
    +
    56 C> of field (error if it doesn't match).
    +
    57 C> @param[in] IBDSFL Integer array containing table 11 flag info
    +
    58 C> - BDS octet 4:
    +
    59 C> - (1)
    +
    60 C> - 0 = Grid point data
    +
    61 C> - 1 = Spherical harmonic coefficients
    +
    62 C> - (2) 0 = Simple packing
    +
    63 C> - 1 = Second order packing
    +
    64 C> - (3) ... Same value as 'itype'
    +
    65 C> - 0 = Original data were floating point values
    +
    66 C> - 1 = Original data were integer values
    +
    67 C> - (4) 0 = No additional flags at octet 14
    +
    68 C> - 1 = Octet 14 contains flag bits 5-12
    +
    69 C> - (5) 0 = Reserved - always set to 0
    +
    70 C> Byte 6 option 1 not available (as of 5-16-93)
    +
    71 C> - (6) 0 = Single datum at each grid point
    +
    72 C> - 1 = Matrix of values at each grid point
    +
    73 C> Byte 7 option 0 with second order packing n/a (as of 5-16-93)
    +
    74 C> - (7) 0 = No secondary bit maps
    +
    75 C> - 1 = Secondary bit maps present
    +
    76 C> - (8) 0 = Second order values have constant width
    +
    77 C> - 1 = Second order values have different widths
    +
    78 C> @param[out] NPTS Number of gridpoints in array fld or ifld
    +
    79 C> @param[out] KBUF Entire grib message ('grib' to '7777')
    +
    80 C> equivalence to integer array to make sure it is on word boundary.
    +
    81 C> @param[out] ITOT Total length of grib message in bytes
    +
    82 C> @param[out] JERR
    +
    83 C> - = 0, Completed making grib field without error
    +
    84 C> - = 1, Ipflag not 0 or 1
    +
    85 C> - = 2, Igflag not 0 or 1
    +
    86 C> - = 3, Error converting ieee f.p. number to ibm370 f.p.
    +
    87 C> - = 4, W3fi71() error/igrid not defined
    +
    88 C> - = 5, W3fk74() error/grid representation type not valid
    +
    89 C> - = 6, Grid too large for packer dimension arrays
    +
    90 C> - = See automation division for revision!
    +
    91 C> - = 7, Length of bit map not equal to size of fld/ifld
    +
    92 C> - = 8, W3fi73() error, all values in ibmap are zero
    +
    93 C>
    +
    94 C> @note
    +
    95 C> - 1: If bit map to be included in message, null data should
    +
    96 C> be included in fld or ifld. this routine will take care
    +
    97 C> of 'discarding' any null data based on the bit map.
    +
    98 C> - 2: Units must be those in grib documentation: nmc o.n. 388
    +
    99 C> or wmo publication 306.
    +
    100 C> - 3: In either case, input numbers will be multiplied by
    +
    101 C> '10 to the nth' power found in id(25) or pds(27-28),
    +
    102 C> the d-scaling factor, prior to binary packing.
    +
    103 C> - 4: All nmc produced grib fields will have a grid definition
    +
    104 C> section included in the grib message. id(6) will be
    +
    105 C> set to '1'.
    +
    106 C> - GDS will be built based on grid number (igrid), unless
    +
    107 C> igflag=1 (user supplying igds). user must still supply
    +
    108 C> igrid even if igds provided.
    +
    109 C> - 5: if bit map used then id(7) or pds(8) must indicate the
    +
    110 C> presence of a bit map.
    +
    111 C> - 6: Array kbuf should be equivalenced to an integer value or
    +
    112 C> array to make sure it is on a word boundary.
    +
    113 C> - 7: Subprogram can be called from a multiprocessing environment.
    +
    114 C>
    +
    115 C> @author Ralph Jones @date 1991-05-08
    +
    116  SUBROUTINE w3fi72(ITYPE,FLD,IFLD,IBITL,
    +
    117  & IPFLAG,ID,PDS,
    +
    118  & IGFLAG,IGRID,IGDS,ICOMP,
    +
    119  & IBFLAG,IBMAP,IBLEN,IBDSFL,
    +
    120  & NPTS,KBUF,ITOT,JERR)
    +
    121 C
    +
    122  REAL FLD(*)
    +
    123 C
    +
    124  INTEGER IBDSFL(*)
    +
    125  INTEGER IBMAP(*)
    +
    126  INTEGER ID(*)
    +
    127  INTEGER IFLD(*)
    +
    128  INTEGER IGDS(*)
    +
    129  INTEGER IB(4)
    +
    130  INTEGER NLEFT, NUMBMS
    +
    131 C
    +
    132  CHARACTER * 1 BDS11(11)
    +
    133  CHARACTER * 1 KBUF(*)
    +
    134  CHARACTER * 1 PDS(*)
    +
    135  CHARACTER * 1 GDS(200)
    +
    136  CHARACTER(1),ALLOCATABLE:: BMS(:)
    +
    137  CHARACTER(1),ALLOCATABLE:: PFLD(:)
    +
    138  CHARACTER(1),ALLOCATABLE:: IPFLD(:)
    +
    139  CHARACTER * 1 SEVEN
    +
    140  CHARACTER * 1 ZERO
    +
    141 C
    +
    142 C
    +
    143 C ASCII REP OF /'G', 'R', 'I', 'B'/
    +
    144 C
    +
    145  DATA ib / 71, 82, 73, 66/
    +
    146 C
    +
    147  ier = 0
    +
    148  iberr = 0
    +
    149  jerr = 0
    +
    150  igribl = 8
    +
    151  ipdsl = 0
    +
    152  lengds = 0
    +
    153  lenbms = 0
    +
    154  lenbds = 0
    +
    155  itoss = 0
    +
    156 C
    +
    157 C$ 1.0 PRODUCT DEFINITION SECTION(PDS).
    +
    158 C
    +
    159 C SET ID(6) TO 1 ...OR... MODIFY PDS(8) ...
    +
    160 C REGARDLESS OF USER SPECIFICATION...
    +
    161 C NMC GRIB FIELDS WILL ALWAYS HAVE A GDS
    +
    162 C
    +
    163  IF (ipflag .EQ.0) THEN
    +
    164  id(6) = 1
    +
    165  CALL w3fi68(id,pds)
    +
    166  ELSE IF (ipflag .EQ. 1) THEN
    +
    167  IF (iand(mova2i(pds(8)),64) .EQ. 64) THEN
    +
    168 C BOTH GDS AND BMS
    +
    169  pds(8) = char(192)
    +
    170  ELSE IF (mova2i(pds(8)) .EQ. 0) THEN
    +
    171 C GDS ONLY
    +
    172  pds(8) = char(128)
    +
    173  END IF
    +
    174  CONTINUE
    +
    175  ELSE
    +
    176 C PRINT *,' W3FI72 ERROR, IPFLAG IS NOT 0 OR 1 IPFLAG = ',IPFLAG
    +
    177  jerr = 1
    +
    178  GO TO 900
    +
    179  END IF
    +
    180 C
    +
    181 C GET LENGTH OF PDS
    +
    182 C
    +
    183  ipdsl = mova2i(pds(1)) * 65536 + mova2i(pds(2)) * 256 +
    +
    184  & mova2i(pds(3))
    +
    185 C
    +
    186 C$ 2.0 GRID DEFINITION SECTION (GDS).
    +
    187 C
    +
    188 C IF IGFLAG=1 THEN USER IS SUPPLYING THE IGDS INFORMATION
    +
    189 C
    +
    190  IF (igflag .EQ. 0) THEN
    +
    191  CALL w3fi71(igrid,igds,igerr)
    +
    192  IF (igerr .EQ. 1) THEN
    +
    193 C PRINT *,' W3FI71 ERROR, GRID TYPE NOT DEFINED...',IGRID
    +
    194  jerr = 4
    +
    195  GO TO 900
    +
    196  END IF
    +
    197  END IF
    +
    198  IF (igflag .EQ. 0 .OR. igflag .EQ.1) THEN
    +
    199  CALL w3fi74(igds,icomp,gds,lengds,npts,igerr)
    +
    200  IF (igerr .EQ. 1) THEN
    +
    201 C PRINT *,' W3FI74 ERROR, GRID REP TYPE NOT VALID...',IGDS(3)
    +
    202  jerr = 5
    +
    203  GO TO 900
    +
    204  ELSE
    +
    205  END IF
    +
    206  ELSE
    +
    207 C PRINT *,' W3FI72 ERROR, IGFLAG IS NOT 0 OR 1 IGFLAG = ',IGFLAG
    +
    208  jerr = 2
    +
    209  GO TO 900
    +
    210  END IF
    +
    211 C
    +
    212 C$ 3.0 BIT MAP SECTION (BMS).
    +
    213 C
    +
    214 C SET ITOSS=1 IF BITMAP BEING USED. W3FI75 WILL TOSS DATA
    +
    215 C PRIOR TO PACKING. LATER CODING WILL BE NEEDED WHEN THE
    +
    216 C 'PREDEFINED' GRIDS ARE FINALLY 'DEFINED'.
    +
    217 C
    +
    218  IF (mova2i(pds(8)) .EQ. 64 .OR.
    +
    219  & mova2i(pds(8)) .EQ. 192) THEN
    +
    220  itoss = 1
    +
    221  IF (ibflag .EQ. 0) THEN
    +
    222  IF (iblen .NE. npts) THEN
    +
    223 C PRINT *,' W3FI72 ERROR, IBLEN .NE. NPTS = ',IBLEN,NPTS
    +
    224  jerr = 7
    +
    225  GO TO 900
    +
    226  END IF
    +
    227  IF (mod(iblen,16).NE.0) THEN
    +
    228  nleft = 16 - mod(iblen,16)
    +
    229  ELSE
    +
    230  nleft = 0
    +
    231  END IF
    +
    232  numbms = 6 + (iblen+nleft) / 8
    +
    233  ALLOCATE(bms(numbms))
    +
    234  zero = char(00)
    +
    235  bms = zero
    +
    236  CALL w3fi73(ibflag,ibmap,iblen,bms,lenbms,ier)
    +
    237  IF (ier .NE. 0) THEN
    +
    238 C PRINT *,' W3FI73 ERROR, IBMAP VALUES ARE ALL ZERO'
    +
    239  jerr = 8
    +
    240  GO TO 900
    +
    241  END IF
    +
    242  ELSE
    +
    243 C PRINT *,' BIT MAP PREDEFINED BY CENTER, IBFLAG = ',IBFLAG
    +
    244  END IF
    +
    245  END IF
    +
    246 C
    +
    247 C$ 4.0 BINARY DATA SECTION (BDS).
    +
    248 C
    +
    249 C$ 4.1 SCALE THE DATA WITH D-SCALE FROM PDS(27-28)
    +
    250 C
    +
    251  jscale = mova2i(pds(27)) * 256 + mova2i(pds(28))
    +
    252  IF (iand(jscale,32768).NE.0) THEN
    +
    253  jscale = - iand(jscale,32767)
    +
    254  END IF
    +
    255  scale = 10.0 ** jscale
    +
    256  IF (itype .EQ. 0) THEN
    +
    257  DO 410 i = 1,npts
    +
    258  fld(i) = fld(i) * scale
    +
    259  410 CONTINUE
    +
    260  ELSE
    +
    261  DO 411 i = 1,npts
    +
    262  ifld(i) = nint(float(ifld(i)) * scale)
    +
    263  411 CONTINUE
    +
    264  END IF
    +
    265 C
    +
    266 C$ 4.2 CALL W3FI75 TO PACK DATA AND MAKE BDS.
    +
    267 C
    +
    268  ALLOCATE(pfld(npts*4))
    +
    269 C
    +
    270  IF(ibdsfl(2).NE.0) THEN
    +
    271  ALLOCATE(ipfld(npts*4))
    +
    272  ipfld=char(0)
    +
    273  ELSE
    +
    274  ALLOCATE(ipfld(1))
    +
    275  ENDIF
    +
    276 C
    +
    277  CALL w3fi75(ibitl,itype,itoss,fld,ifld,ibmap,ibdsfl,
    +
    278  & npts,bds11,ipfld,pfld,len,lenbds,iberr,pds,igds)
    +
    279 C
    +
    280  IF(ibdsfl(2).NE.0) THEN
    +
    281 C CALL XMOVEX(PFLD,IPFLD,NPTS*4)
    +
    282  do ii = 1, npts*4
    +
    283  pfld(ii) = ipfld(ii)
    +
    284  enddo
    +
    285  ENDIF
    +
    286  DEALLOCATE(ipfld)
    +
    287 C
    +
    288  IF (iberr .EQ. 1) THEN
    +
    289  jerr = 3
    +
    290  GO TO 900
    +
    291  END IF
    +
    292 C 4.3 IF D-SCALE NOT 0, RESCALE INPUT FIELD TO
    +
    293 C ORIGINAL VALUE
    +
    294 C
    +
    295  IF (jscale.NE.0) THEN
    +
    296  dscale = 1.0 / scale
    +
    297  IF (itype.EQ.0) THEN
    +
    298  DO 412 i = 1, npts
    +
    299  fld(i) = fld(i) * dscale
    +
    300  412 CONTINUE
    +
    301  ELSE
    +
    302  DO 413 i = 1, npts
    +
    303  fld(i) = nint(float(ifld(i)) * dscale)
    +
    304  413 CONTINUE
    +
    305  END IF
    +
    306  END IF
    +
    307 C
    +
    308 C$ 5.0 OUTPUT SECTION.
    +
    309 C
    +
    310 C$ 5.1 ZERO OUT THE OUTPUT ARRAY KBUF.
    +
    311 C
    +
    312  zero = char(00)
    +
    313  itot = igribl + ipdsl + lengds + lenbms + lenbds + 4
    +
    314 C PRINT *,'IGRIBL =',IGRIBL
    +
    315 C PRINT *,'IPDSL =',IPDSL
    +
    316 C PRINT *,'LENGDS =',LENGDS
    +
    317 C PRINT *,'LENBMS =',LENBMS
    +
    318 C PRINT *,'LENBDS =',LENBDS
    +
    319 C PRINT *,'ITOT =',ITOT
    +
    320  kbuf(1:itot)=zero
    +
    321 C
    +
    322 C$ 5.2 MOVE SECTION 0 - 'IS' INTO KBUF (8 BYTES).
    +
    323 C
    +
    324  istart = 0
    +
    325  DO 520 i = 1,4
    +
    326  kbuf(i) = char(ib(i))
    +
    327  520 CONTINUE
    +
    328 C
    +
    329  kbuf(5) = char(mod(itot / 65536,256))
    +
    330  kbuf(6) = char(mod(itot / 256,256))
    +
    331  kbuf(7) = char(mod(itot ,256))
    +
    332  kbuf(8) = char(1)
    +
    333 C
    +
    334 C$ 5.3 MOVE SECTION 1 - 'PDS' INTO KBUF (28 BYTES).
    +
    335 C
    +
    336  istart = istart + igribl
    +
    337  IF (ipdsl.GT.0) THEN
    +
    338 C CALL XMOVEX(KBUF(ISTART+1),PDS,IPDSL)
    +
    339  do ii = 1, ipdsl
    +
    340  kbuf(istart+ii) = pds(ii)
    +
    341  enddo
    +
    342  ELSE
    +
    343 C PRINT *,'LENGTH OF PDS LESS OR EQUAL 0, IPDSL = ',IPDSL
    +
    344  END IF
    +
    345 C
    +
    346 C$ 5.4 MOVE SECTION 2 - 'GDS' INTO KBUF.
    +
    347 C
    +
    348  istart = istart + ipdsl
    +
    349  IF (lengds .GT. 0) THEN
    +
    350 C CALL XMOVEX(KBUF(ISTART+1),GDS,LENGDS)
    +
    351  do ii = 1, lengds
    +
    352  kbuf(istart+ii) = gds(ii)
    +
    353  enddo
    +
    354  END IF
    +
    355 C
    +
    356 C$ 5.5 MOVE SECTION 3 - 'BMS' INTO KBUF.
    +
    357 C
    +
    358  istart = istart + lengds
    +
    359  IF (lenbms .GT. 0) THEN
    +
    360 C CALL XMOVEX(KBUF(ISTART+1),BMS,LENBMS)
    +
    361  do ii = 1, lenbms
    +
    362  kbuf(istart+ii) = bms(ii)
    +
    363  enddo
    +
    364  END IF
    +
    365 C
    +
    366 C$ 5.6 MOVE SECTION 4 - 'BDS' INTO KBUF.
    +
    367 C
    +
    368 C$ MOVE THE FIRST 11 OCTETS OF THE BDS INTO KBUF.
    +
    369 C
    +
    370  istart = istart + lenbms
    +
    371 C CALL XMOVEX(KBUF(ISTART+1),BDS11,11)
    +
    372  do ii = 1, 11
    +
    373  kbuf(istart+ii) = bds11(ii)
    +
    374  enddo
    +
    375 C
    +
    376 C$ MOVE THE PACKED DATA INTO THE KBUF
    +
    377 C
    +
    378  istart = istart + 11
    +
    379  IF (len.GT.0) THEN
    +
    380 C CALL XMOVEX(KBUF(ISTART+1),PFLD,LEN)
    +
    381  do ii = 1, len
    +
    382  kbuf(istart+ii) = pfld(ii)
    +
    383  enddo
    +
    384  END IF
    +
    385 C
    +
    386 C$ ADD '7777' TO END OFF KBUF
    +
    387 C NOTE THAT THESE 4 OCTETS NOT INCLUDED IN ACTUAL SIZE OF BDS.
    +
    388 C
    +
    389  seven = char(55)
    +
    390  istart = itot - 4
    +
    391  DO 562 i = 1,4
    +
    392  kbuf(istart+i) = seven
    +
    393  562 CONTINUE
    +
    394 C
    +
    395  900 CONTINUE
    +
    396  IF(ALLOCATED(bms)) DEALLOCATE(bms)
    +
    397  IF(ALLOCATED(pfld)) DEALLOCATE(pfld)
    +
    398  RETURN
    +
    399  END
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    lengds
    function lengds(KGDS)
    Program history log:
    Definition: lengds.f:15
    +
    w3fi73
    subroutine w3fi73(IBFLAG, IBMAP, IBLEN, BMS, LENBMS, IER)
    This subroutine constructs a grib bit map section.
    Definition: w3fi73.f:23
    +
    w3fi75
    subroutine w3fi75(IBITL, ITYPE, ITOSS, FLD, IFLD, IBMAP, IBDSFL, NPTS, BDS11, IPFLD, PFLD, LEN, LENBDS, IBERR, PDS, IGDS)
    This routine packs a grib field and forms octets(1-11) of the binary data section (bds).
    Definition: w3fi75.f:90
    +
    w3fi74
    subroutine w3fi74(IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR)
    This subroutine constructs a GRIB grid definition section.
    Definition: w3fi74.f:19
    +
    w3fi72
    subroutine w3fi72(ITYPE, FLD, IFLD, IBITL, IPFLAG, ID, PDS, IGFLAG, IGRID, IGDS, ICOMP, IBFLAG, IBMAP, IBLEN, IBDSFL, NPTS, KBUF, ITOT, JERR)
    Makes a complete GRIB message from a user supplied array of floating point or integer data.
    Definition: w3fi72.f:121
    +
    w3fi68
    subroutine w3fi68(ID, PDS)
    Converts an array of 25, or 27 integer words into a grib product definition section (pds) of 28 bytes...
    Definition: w3fi68.f:85
    +
    w3fi71
    subroutine w3fi71(IGRID, IGDS, IERR)
    Makes a 18, 37, 55, 64, or 91 word integer array used by w3fi72() GRIB packer to make the grid descri...
    Definition: w3fi71.f:187
    + + + + diff --git a/ver-2.10.0/w3fi73_8f.html b/ver-2.10.0/w3fi73_8f.html new file mode 100644 index 00000000..f3900b43 --- /dev/null +++ b/ver-2.10.0/w3fi73_8f.html @@ -0,0 +1,200 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi73.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi73.f File Reference
    +
    +
    + +

    Construct grib bit map section (BMS). +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi73 (IBFLAG, IBMAP, IBLEN, BMS, LENBMS, IER)
     This subroutine constructs a grib bit map section. More...
     
    +

    Detailed Description

    +

    Construct grib bit map section (BMS).

    +
    Author
    M. Farley
    +
    Date
    1992-07-01
    + +

    Definition in file w3fi73.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi73()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi73 (integer IBFLAG,
    integer, dimension(*) IBMAP,
    integer IBLEN,
    character*1, dimension(*) BMS,
    integer LENBMS,
     IER 
    )
    +
    + +

    This subroutine constructs a grib bit map section.

    +

    Program history log:

      +
    • M. Farley 1992-07-01
      • +
    • Bill Cavanaugh 1994-02-14 Recoded
      • +
    • Ebisuzaki 1998-06-30 Linux port
      • +
    +
    Parameters
    + + + + + + + +
    [in]IBFLAG
      +
    • 0, if bit map supplied by user
      • +
    • #, Number of predefined center bit map
      • +
    +
    [in]IBMAPInteger array containing user bit map
    [in]IBLENLength of bit map
    [out]BMSCompleted grib bit map section
    [out]LENBMSLength of bit map section
    [out]IER0 normal exit, 8 = ibmap values are all zero
    +
    +
    +
    Author
    M. Farley
    +
    Date
    1992-07-01
    + +

    Definition at line 23 of file w3fi73.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi73_8f.js b/ver-2.10.0/w3fi73_8f.js new file mode 100644 index 00000000..c4d107f6 --- /dev/null +++ b/ver-2.10.0/w3fi73_8f.js @@ -0,0 +1,4 @@ +var w3fi73_8f = +[ + [ "w3fi73", "w3fi73_8f.html#a89eedc9b7ba4fd46b1f6ac9eba1f773e", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi73_8f_source.html b/ver-2.10.0/w3fi73_8f_source.html new file mode 100644 index 00000000..9e2d1b8d --- /dev/null +++ b/ver-2.10.0/w3fi73_8f_source.html @@ -0,0 +1,192 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi73.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi73.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Construct grib bit map section (BMS).
    +
    3 C> @author M. Farley @date 1992-07-01
    +
    4 
    +
    5 C> This subroutine constructs a grib bit map section.
    +
    6 C>
    +
    7 C> Program history log:
    +
    8 C> - M. Farley 1992-07-01
    +
    9 C> - Bill Cavanaugh 1994-02-14 Recoded
    +
    10 C> - Ebisuzaki 1998-06-30 Linux port
    +
    11 C>
    +
    12 C> @param[in] IBFLAG
    +
    13 C> - 0, if bit map supplied by user
    +
    14 C> - #, Number of predefined center bit map
    +
    15 C> @param[in] IBMAP Integer array containing user bit map
    +
    16 C> @param[in] IBLEN Length of bit map
    +
    17 C> @param[out] BMS Completed grib bit map section
    +
    18 C> @param[out] LENBMS Length of bit map section
    +
    19 C> @param[out] IER 0 normal exit, 8 = ibmap values are all zero
    +
    20 C>
    +
    21 C> @author M. Farley @date 1992-07-01
    +
    22  SUBROUTINE w3fi73 (IBFLAG,IBMAP,IBLEN,BMS,LENBMS,IER)
    +
    23 C
    +
    24  INTEGER IBMAP(*)
    +
    25  INTEGER LENBMS
    +
    26  INTEGER IBLEN
    +
    27  INTEGER IBFLAG
    +
    28 C
    +
    29  CHARACTER*1 BMS(*)
    +
    30 C
    +
    31  ier = 0
    +
    32 C
    +
    33  iz = 0
    +
    34  DO 20 i = 1, iblen
    +
    35  IF (ibmap(i).EQ.0) iz = iz + 1
    +
    36  20 CONTINUE
    +
    37  IF (iz.EQ.iblen) THEN
    +
    38 C
    +
    39 C AT THIS POINT ALL BIT MAP POSITIONS ARE ZERO
    +
    40 C
    +
    41  ier = 8
    +
    42  RETURN
    +
    43  END IF
    +
    44 C
    +
    45 C BIT MAP IS A COMBINATION OF ONES AND ZEROS
    +
    46 C OR BIT MAP ALL ONES
    +
    47 C
    +
    48 C CONSTRUCT BIT MAP FIELD OF BIT MAP SECTION
    +
    49 C
    +
    50  CALL sbytesc(bms,ibmap,48,1,0,iblen)
    +
    51 C
    +
    52  IF (mod(iblen,16).NE.0) THEN
    +
    53  nleft = 16 - mod(iblen,16)
    +
    54  ELSE
    +
    55  nleft = 0
    +
    56  END IF
    +
    57 C
    +
    58  num = 6 + (iblen+nleft) / 8
    +
    59 C
    +
    60 C CONSTRUCT BMS FROM COLLECTED DATA
    +
    61 C
    +
    62 C SIZE INTO FIRST THREE BYTES
    +
    63 C
    +
    64  CALL sbytec(bms,num,0,24)
    +
    65 C NUMBER OF FILL BITS INTO BYTE 4
    +
    66  CALL sbytec(bms,nleft,24,8)
    +
    67 C OCTET 5-6 TO CONTAIN INFO FROM IBFLAG
    +
    68  CALL sbytec(bms,ibflag,32,16)
    +
    69 C
    +
    70 C BIT MAP MAY BE ALL ONES OR A COMBINATION
    +
    71 C OF ONES AND ZEROS
    +
    72 C
    +
    73 C ACTUAL BITS OF BIT MAP PLACED ALL READY
    +
    74 C
    +
    75 C INSTALL FILL POSITIONS IF NEEDED
    +
    76  IF (nleft.NE.0) THEN
    +
    77  nleft = 16 - nleft
    +
    78 C ZERO FILL POSITIONS
    +
    79  CALL sbytec(bms,0,iblen+48,nleft)
    +
    80  END IF
    +
    81 C
    +
    82 C STORE NUM IN LENBMS (LENGTH OF BMS SECTION)
    +
    83 C
    +
    84  lenbms = num
    +
    85 C PRINT *,'W3FI73 - BMS LEN =',NUM,LENBMS
    +
    86 C
    +
    87  RETURN
    +
    88  END
    +
    +
    +
    w3fi73
    subroutine w3fi73(IBFLAG, IBMAP, IBLEN, BMS, LENBMS, IER)
    This subroutine constructs a grib bit map section.
    Definition: w3fi73.f:23
    +
    sbytesc
    subroutine sbytesc(OUT, IN, ISKIP, NBYTE, NSKIP, N)
    Store bytes - pack bits: Put arbitrary size values into a packed bit string, taking the low order bit...
    Definition: sbytesc.f:17
    +
    sbytec
    subroutine sbytec(OUT, IN, ISKIP, NBYTE)
    This is a wrapper for sbytesc()
    Definition: sbytec.f:14
    + + + + diff --git a/ver-2.10.0/w3fi74_8f.html b/ver-2.10.0/w3fi74_8f.html new file mode 100644 index 00000000..874916f4 --- /dev/null +++ b/ver-2.10.0/w3fi74_8f.html @@ -0,0 +1,192 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi74.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi74.f File Reference
    +
    +
    + +

    Construct Grid Definition Section (GDS). +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi74 (IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR)
     This subroutine constructs a GRIB grid definition section. More...
     
    +

    Detailed Description

    +

    Construct Grid Definition Section (GDS).

    +
    Author
    M. Farley
    +
    Date
    1992-07-07
    + +

    Definition in file w3fi74.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi74()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi74 (integer, dimension (*) IGDS,
     ICOMP,
    character*1, dimension (*) GDS,
     LENGDS,
     NPTS,
     IGERR 
    )
    +
    + +

    This subroutine constructs a GRIB grid definition section.

    +
    Note
    Subprogram can be called from a multiprocessing environment.
    +
    Parameters
    + + + + + + + +
    [in]IGDSInteger array supplied by w3fi71().
    [in]ICOMPTable 7- resolution & component flag (bit 5) for gds(17) wind components.
    [out]GDSCompleted grib grid definition section.
    [out]LENGDSLength of gds.
    [out]NPTSNumber of points in grid.
    [out]IGERR1, grid representation type not valid.
    +
    +
    +
    Author
    M. Farley
    +
    Date
    1992-07-07
    + +

    Definition at line 19 of file w3fi74.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi74_8f.js b/ver-2.10.0/w3fi74_8f.js new file mode 100644 index 00000000..32c1c1a7 --- /dev/null +++ b/ver-2.10.0/w3fi74_8f.js @@ -0,0 +1,4 @@ +var w3fi74_8f = +[ + [ "w3fi74", "w3fi74_8f.html#ab921a7e370356989116ba2ac3e429d61", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi74_8f_source.html b/ver-2.10.0/w3fi74_8f_source.html new file mode 100644 index 00000000..bdbccbe1 --- /dev/null +++ b/ver-2.10.0/w3fi74_8f_source.html @@ -0,0 +1,503 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi74.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi74.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Construct Grid Definition Section (GDS).
    +
    3 C> @author M. Farley @date 1992-07-07
    +
    4 
    +
    5 C> This subroutine constructs a GRIB grid definition section.
    +
    6 C>
    +
    7 C> @note Subprogram can be called from a multiprocessing environment.
    +
    8 C>
    +
    9 C> @param[in] IGDS Integer array supplied by w3fi71().
    +
    10 C> @param[in] ICOMP Table 7- resolution & component flag (bit 5)
    +
    11 C> for gds(17) wind components.
    +
    12 C> @param[out] GDS Completed grib grid definition section.
    +
    13 C> @param[out] LENGDS Length of gds.
    +
    14 C> @param[out] NPTS Number of points in grid.
    +
    15 C> @param[out] IGERR 1, grid representation type not valid.
    +
    16 C>
    +
    17 C> @author M. Farley @date 1992-07-07
    +
    18  SUBROUTINE w3fi74 (IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR)
    +
    19 C
    +
    20  INTEGER IGDS (*)
    +
    21 C
    +
    22  CHARACTER*1 GDS (*)
    +
    23 C
    +
    24  isum = 0
    +
    25  igerr = 0
    +
    26 C
    +
    27 C PRINT *,' '
    +
    28 C PRINT *,'(W3FI74-IGDS = )'
    +
    29 C PRINT *,(IGDS(I),I=1,18)
    +
    30 C PRINT *,' '
    +
    31 C
    +
    32 C COMPUTE LENGTH OF GDS IN OCTETS (OCTETS 1-3)
    +
    33 C LENGDS = 32 FOR LAT/LON, GNOMIC, GAUSIAN LAT/LON,
    +
    34 C POLAR STEREOGRAPHIC, SPHERICAL HARMONICS,
    +
    35 C ROTATED LAT/LON E-STAGGER
    +
    36 C LENGDS = 34 ROTATED LAT/LON A,B,C,D STAGGERS
    +
    37 C LENGDS = 42 FOR MERCATOR, LAMBERT, TANGENT CONE
    +
    38 C LENGDS = 178 FOR MERCATOR, LAMBERT, TANGENT CONE
    +
    39 C
    +
    40  IF (igds(3) .EQ. 0 .OR. igds(3) .EQ. 2 .OR.
    +
    41  & igds(3) .EQ. 4 .OR. igds(3) .EQ. 5 .OR.
    +
    42  & igds(3) .EQ. 50 .OR. igds(3) .EQ. 201.OR.
    +
    43  & igds(3) .EQ. 202.OR. igds(3) .EQ. 203.OR.
    +
    44  & igds(3) .EQ. 204 ) THEN
    +
    45  lengds = 32
    +
    46 C
    +
    47 C CORRECTION FOR GRIDS 37-44
    +
    48 C
    +
    49  IF (igds(3).EQ.0.AND.igds(1).EQ.0.AND.igds(2).NE.
    +
    50  & 255) THEN
    +
    51  lengds = igds(5) * 2 + 32
    +
    52  ENDIF
    +
    53  ELSE IF (igds(3) .EQ. 1 .OR. igds(3) .EQ. 3 .OR.
    +
    54  & igds(3) .EQ. 13) THEN
    +
    55  lengds = 42
    +
    56  ELSE IF (igds(3) .EQ. 205) THEN
    +
    57  lengds = 34
    +
    58  ELSE
    +
    59 C PRINT *,' W3FI74 ERROR, GRID REPRESENTATION TYPE NOT VALID'
    +
    60  igerr = 1
    +
    61  RETURN
    +
    62  ENDIF
    +
    63 C
    +
    64 C PUT LENGTH OF GDS SECTION IN BYTES 1,2,3
    +
    65 C
    +
    66  gds(1) = char(mod(lengds/65536,256))
    +
    67  gds(2) = char(mod(lengds/ 256,256))
    +
    68  gds(3) = char(mod(lengds ,256))
    +
    69 C
    +
    70 C OCTET 4 = NV, NUMBER OF VERTICAL COORDINATE PARAMETERS
    +
    71 C OCTET 5 = PV, PL OR 255
    +
    72 C OCTET 6 = DATA REPRESENTATION TYPE (TABLE 6)
    +
    73 C
    +
    74  gds(4) = char(igds(1))
    +
    75  gds(5) = char(igds(2))
    +
    76  gds(6) = char(igds(3))
    +
    77 C
    +
    78 C FILL OCTET THE REST OF THE GDS BASED ON DATA REPRESENTATION
    +
    79 C TYPE (TABLE 6)
    +
    80 C
    +
    81 C$$
    +
    82 C PROCESS ROTATED LAT/LON A,B,C,D STAGGERS
    +
    83 C
    +
    84  IF (igds(3).EQ.205) THEN
    +
    85  gds( 7) = char(mod(igds(4)/256,256))
    +
    86  gds( 8) = char(mod(igds(4) ,256))
    +
    87  gds( 9) = char(mod(igds(5)/256,256))
    +
    88  gds(10) = char(mod(igds(5) ,256))
    +
    89  lato = igds(6) ! LAT OF FIRST POINT
    +
    90  IF (lato .LT. 0) THEN
    +
    91  lato = -lato
    +
    92  lato = ior(lato,8388608)
    +
    93  ENDIF
    +
    94  gds(11) = char(mod(lato/65536,256))
    +
    95  gds(12) = char(mod(lato/ 256,256))
    +
    96  gds(13) = char(mod(lato ,256))
    +
    97  lono = igds(7) ! LON OF FIRST POINT
    +
    98  IF (lono .LT. 0) THEN
    +
    99  lono = -lono
    +
    100  lono = ior(lono,8388608)
    +
    101  ENDIF
    +
    102  gds(14) = char(mod(lono/65536,256))
    +
    103  gds(15) = char(mod(lono/ 256,256))
    +
    104  gds(16) = char(mod(lono ,256))
    +
    105  latext = igds(9) ! CENTER LAT
    +
    106  IF (latext .LT. 0) THEN
    +
    107  latext = -latext
    +
    108  latext = ior(latext,8388608)
    +
    109  ENDIF
    +
    110  gds(18) = char(mod(latext/65536,256))
    +
    111  gds(19) = char(mod(latext/ 256,256))
    +
    112  gds(20) = char(mod(latext ,256))
    +
    113  lonext = igds(10) ! CENTER LON
    +
    114  IF (lonext .LT. 0) THEN
    +
    115  lonext = -lonext
    +
    116  lonext = ior(lonext,8388608)
    +
    117  ENDIF
    +
    118  gds(21) = char(mod(lonext/65536,256))
    +
    119  gds(22) = char(mod(lonext/ 256,256))
    +
    120  gds(23) = char(mod(lonext ,256))
    +
    121  gds(24) = char(mod(igds(11)/256,256))
    +
    122  gds(25) = char(mod(igds(11) ,256))
    +
    123  gds(26) = char(mod(igds(12)/256,256))
    +
    124  gds(27) = char(mod(igds(12) ,256))
    +
    125  gds(28) = char(igds(13))
    +
    126  lato = igds(14) ! LAT OF LAST POINT
    +
    127  IF (lato .LT. 0) THEN
    +
    128  lato = -lato
    +
    129  lato = ior(lato,8388608)
    +
    130  ENDIF
    +
    131  gds(29) = char(mod(lato/65536,256))
    +
    132  gds(30) = char(mod(lato/ 256,256))
    +
    133  gds(31) = char(mod(lato ,256))
    +
    134  lono = igds(15) ! LON OF LAST POINT
    +
    135  IF (lono .LT. 0) THEN
    +
    136  lono = -lono
    +
    137  lono = ior(lono,8388608)
    +
    138  ENDIF
    +
    139  gds(32) = char(mod(lono/65536,256))
    +
    140  gds(33) = char(mod(lono/ 256,256))
    +
    141  gds(34) = char(mod(lono ,256))
    +
    142 C
    +
    143 C PROCESS LAT/LON GRID TYPES OR GAUSSIAN GRID OR ARAKAWA
    +
    144 C STAGGERED, SEMI-STAGGERED, OR FILLED E-GRIDS
    +
    145 C
    +
    146  ELSEIF (igds(3).EQ.0.OR.igds(3).EQ.4.OR.
    +
    147  & igds(3).EQ.201.OR.igds(3).EQ.202.OR.
    +
    148  & igds(3).EQ.203.OR.igds(3).EQ.204) THEN
    +
    149  gds( 7) = char(mod(igds(4)/256,256))
    +
    150  gds( 8) = char(mod(igds(4) ,256))
    +
    151  gds( 9) = char(mod(igds(5)/256,256))
    +
    152  gds(10) = char(mod(igds(5) ,256))
    +
    153  lato = igds(6)
    +
    154  IF (lato .LT. 0) THEN
    +
    155  lato = -lato
    +
    156  lato = ior(lato,8388608)
    +
    157  ENDIF
    +
    158  gds(11) = char(mod(lato/65536,256))
    +
    159  gds(12) = char(mod(lato/ 256,256))
    +
    160  gds(13) = char(mod(lato ,256))
    +
    161  lono = igds(7)
    +
    162  IF (lono .LT. 0) THEN
    +
    163  lono = -lono
    +
    164  lono = ior(lono,8388608)
    +
    165  ENDIF
    +
    166  gds(14) = char(mod(lono/65536,256))
    +
    167  gds(15) = char(mod(lono/ 256,256))
    +
    168  gds(16) = char(mod(lono ,256))
    +
    169  latext = igds(9)
    +
    170  IF (latext .LT. 0) THEN
    +
    171  latext = -latext
    +
    172  latext = ior(latext,8388608)
    +
    173  ENDIF
    +
    174  gds(18) = char(mod(latext/65536,256))
    +
    175  gds(19) = char(mod(latext/ 256,256))
    +
    176  gds(20) = char(mod(latext ,256))
    +
    177  lonext = igds(10)
    +
    178  IF (lonext .LT. 0) THEN
    +
    179  lonext = -lonext
    +
    180  lonext = ior(lonext,8388608)
    +
    181  ENDIF
    +
    182  gds(21) = char(mod(lonext/65536,256))
    +
    183  gds(22) = char(mod(lonext/ 256,256))
    +
    184  gds(23) = char(mod(lonext ,256))
    +
    185  ires = iand(igds(8),128)
    +
    186  IF (igds(3).EQ.201.OR.igds(3).EQ.202.OR.
    +
    187  & igds(3).EQ.203.OR.igds(3).EQ.204) THEN
    +
    188  gds(24) = char(mod(igds(11)/256,256))
    +
    189  gds(25) = char(mod(igds(11) ,256))
    +
    190  ELSE IF (ires.EQ.0) THEN
    +
    191  gds(24) = char(255)
    +
    192  gds(25) = char(255)
    +
    193  ELSE
    +
    194  gds(24) = char(mod(igds(12)/256,256))
    +
    195  gds(25) = char(mod(igds(12) ,256))
    +
    196  END IF
    +
    197  IF (igds(3).EQ.4) THEN
    +
    198  gds(26) = char(mod(igds(11)/256,256))
    +
    199  gds(27) = char(mod(igds(11) ,256))
    +
    200  ELSE IF (igds(3).EQ.201.OR.igds(3).EQ.202.OR.
    +
    201  & igds(3).EQ.203.OR.igds(3).EQ.204)THEN
    +
    202  gds(26) = char(mod(igds(12)/256,256))
    +
    203  gds(27) = char(mod(igds(12) ,256))
    +
    204  ELSE IF (ires.EQ.0) THEN
    +
    205  gds(26) = char(255)
    +
    206  gds(27) = char(255)
    +
    207  ELSE
    +
    208  gds(26) = char(mod(igds(11)/256,256))
    +
    209  gds(27) = char(mod(igds(11) ,256))
    +
    210  END IF
    +
    211  gds(28) = char(igds(13))
    +
    212  gds(29) = char(0)
    +
    213  gds(30) = char(0)
    +
    214  gds(31) = char(0)
    +
    215  gds(32) = char(0)
    +
    216  IF (lengds.GT.32) THEN
    +
    217  isum = 0
    +
    218  i = 19
    +
    219  DO 10 j = 33,lengds,2
    +
    220  isum = isum + igds(i)
    +
    221  gds(j) = char(mod(igds(i)/256,256))
    +
    222  gds(j+1) = char(mod(igds(i) ,256))
    +
    223  i = i + 1
    +
    224  10 CONTINUE
    +
    225  END IF
    +
    226 C
    +
    227 C$$ PROCESS MERCATOR GRID TYPES
    +
    228 C
    +
    229  ELSE IF (igds(3) .EQ. 1) THEN
    +
    230  gds( 7) = char(mod(igds(4)/256,256))
    +
    231  gds( 8) = char(mod(igds(4) ,256))
    +
    232  gds( 9) = char(mod(igds(5)/256,256))
    +
    233  gds(10) = char(mod(igds(5) ,256))
    +
    234  lato = igds(6)
    +
    235  IF (lato .LT. 0) THEN
    +
    236  lato = -lato
    +
    237  lato = ior(lato,8388608)
    +
    238  ENDIF
    +
    239  gds(11) = char(mod(lato/65536,256))
    +
    240  gds(12) = char(mod(lato/ 256,256))
    +
    241  gds(13) = char(mod(lato ,256))
    +
    242  lono = igds(7)
    +
    243  IF (lono .LT. 0) THEN
    +
    244  lono = -lono
    +
    245  lono = ior(lono,8388608)
    +
    246  ENDIF
    +
    247  gds(14) = char(mod(lono/65536,256))
    +
    248  gds(15) = char(mod(lono/ 256,256))
    +
    249  gds(16) = char(mod(lono ,256))
    +
    250  latext = igds(9)
    +
    251  IF (latext .LT. 0) THEN
    +
    252  latext = -latext
    +
    253  latext = ior(latext,8388608)
    +
    254  ENDIF
    +
    255  gds(18) = char(mod(latext/65536,256))
    +
    256  gds(19) = char(mod(latext/ 256,256))
    +
    257  gds(20) = char(mod(latext ,256))
    +
    258  lonext = igds(10)
    +
    259  IF (lonext .LT. 0) THEN
    +
    260  lonext = -lonext
    +
    261  lonext = ior(lonext,8388608)
    +
    262  ENDIF
    +
    263  gds(21) = char(mod(lonext/65536,256))
    +
    264  gds(22) = char(mod(lonext/ 256,256))
    +
    265  gds(23) = char(mod(lonext ,256))
    +
    266  gds(24) = char(mod(igds(13)/65536,256))
    +
    267  gds(25) = char(mod(igds(13)/ 256,256))
    +
    268  gds(26) = char(mod(igds(13) ,256))
    +
    269  gds(27) = char(0)
    +
    270  gds(28) = char(igds(14))
    +
    271  gds(29) = char(mod(igds(12)/65536,256))
    +
    272  gds(30) = char(mod(igds(12)/ 256,256))
    +
    273  gds(31) = char(mod(igds(12) ,256))
    +
    274  gds(32) = char(mod(igds(11)/65536,256))
    +
    275  gds(33) = char(mod(igds(11)/ 256,256))
    +
    276  gds(34) = char(mod(igds(11) ,256))
    +
    277  gds(35) = char(0)
    +
    278  gds(36) = char(0)
    +
    279  gds(37) = char(0)
    +
    280  gds(38) = char(0)
    +
    281  gds(39) = char(0)
    +
    282  gds(40) = char(0)
    +
    283  gds(41) = char(0)
    +
    284  gds(42) = char(0)
    +
    285 C$$ PROCESS LAMBERT CONFORMAL GRID TYPES
    +
    286  ELSE IF (igds(3) .EQ. 3) THEN
    +
    287  gds( 7) = char(mod(igds(4)/256,256))
    +
    288  gds( 8) = char(mod(igds(4) ,256))
    +
    289  gds( 9) = char(mod(igds(5)/256,256))
    +
    290  gds(10) = char(mod(igds(5) ,256))
    +
    291  lato = igds(6)
    +
    292  IF (lato .LT. 0) THEN
    +
    293  lato = -lato
    +
    294  lato = ior(lato,8388608)
    +
    295  ENDIF
    +
    296  gds(11) = char(mod(lato/65536,256))
    +
    297  gds(12) = char(mod(lato/ 256,256))
    +
    298  gds(13) = char(mod(lato ,256))
    +
    299  lono = igds(7)
    +
    300  IF (lono .LT. 0) THEN
    +
    301  lono = -lono
    +
    302  lono = ior(lono,8388608)
    +
    303  ENDIF
    +
    304  gds(14) = char(mod(lono/65536,256))
    +
    305  gds(15) = char(mod(lono/ 256,256))
    +
    306  gds(16) = char(mod(lono ,256))
    +
    307  lonm = igds(9)
    +
    308  IF (lonm .LT. 0) THEN
    +
    309  lonm = -lonm
    +
    310  lonm = ior(lonm,8388608)
    +
    311  ENDIF
    +
    312  gds(18) = char(mod(lonm/65536,256))
    +
    313  gds(19) = char(mod(lonm/ 256,256))
    +
    314  gds(20) = char(mod(lonm ,256))
    +
    315  gds(21) = char(mod(igds(10)/65536,256))
    +
    316  gds(22) = char(mod(igds(10)/ 256,256))
    +
    317  gds(23) = char(mod(igds(10) ,256))
    +
    318  gds(24) = char(mod(igds(11)/65536,256))
    +
    319  gds(25) = char(mod(igds(11)/ 256,256))
    +
    320  gds(26) = char(mod(igds(11) ,256))
    +
    321  gds(27) = char(igds(12))
    +
    322  gds(28) = char(igds(13))
    +
    323  gds(29) = char(mod(igds(15)/65536,256))
    +
    324  gds(30) = char(mod(igds(15)/ 256,256))
    +
    325  gds(31) = char(mod(igds(15) ,256))
    +
    326  gds(32) = char(mod(igds(16)/65536,256))
    +
    327  gds(33) = char(mod(igds(16)/ 256,256))
    +
    328  gds(34) = char(mod(igds(16) ,256))
    +
    329  gds(35) = char(mod(igds(17)/65536,256))
    +
    330  gds(36) = char(mod(igds(17)/ 256,256))
    +
    331  gds(37) = char(mod(igds(17) ,256))
    +
    332  gds(38) = char(mod(igds(18)/65536,256))
    +
    333  gds(39) = char(mod(igds(18)/ 256,256))
    +
    334  gds(40) = char(mod(igds(18) ,256))
    +
    335  gds(41) = char(0)
    +
    336  gds(42) = char(0)
    +
    337 C$$ PROCESS POLAR STEREOGRAPHIC GRID TYPES
    +
    338  ELSE IF (igds(3) .EQ. 5) THEN
    +
    339  gds( 7) = char(mod(igds(4)/256,256))
    +
    340  gds( 8) = char(mod(igds(4) ,256))
    +
    341  gds( 9) = char(mod(igds(5)/256,256))
    +
    342  gds(10) = char(mod(igds(5) ,256))
    +
    343  lato = igds(6)
    +
    344  IF (lato .LT. 0) THEN
    +
    345  lato = -lato
    +
    346  lato = ior(lato,8388608)
    +
    347  ENDIF
    +
    348  gds(11) = char(mod(lato/65536,256))
    +
    349  gds(12) = char(mod(lato/ 256,256))
    +
    350  gds(13) = char(mod(lato ,256))
    +
    351  lono = igds(7)
    +
    352  IF (lono .LT. 0) THEN
    +
    353  lono = -lono
    +
    354  lono = ior(lono,8388608)
    +
    355  ENDIF
    +
    356  gds(14) = char(mod(lono/65536,256))
    +
    357  gds(15) = char(mod(lono/ 256,256))
    +
    358  gds(16) = char(mod(lono ,256))
    +
    359  lonm = igds(9)
    +
    360  IF (lonm .LT. 0) THEN
    +
    361  lonm = -lonm
    +
    362  lonm = ior(lonm,8388608)
    +
    363  ENDIF
    +
    364  gds(18) = char(mod(lonm/65536,256))
    +
    365  gds(19) = char(mod(lonm/ 256,256))
    +
    366  gds(20) = char(mod(lonm ,256))
    +
    367  gds(21) = char(mod(igds(10)/65536,256))
    +
    368  gds(22) = char(mod(igds(10)/ 256,256))
    +
    369  gds(23) = char(mod(igds(10) ,256))
    +
    370  gds(24) = char(mod(igds(11)/65536,256))
    +
    371  gds(25) = char(mod(igds(11)/ 256,256))
    +
    372  gds(26) = char(mod(igds(11) ,256))
    +
    373  gds(27) = char(igds(12))
    +
    374  gds(28) = char(igds(13))
    +
    375  gds(29) = char(0)
    +
    376  gds(30) = char(0)
    +
    377  gds(31) = char(0)
    +
    378  gds(32) = char(0)
    +
    379  ENDIF
    +
    380 C PRINT 10,(GDS(IG),IG=1,32)
    +
    381 C10 FORMAT (' GDS= ',32(1X,Z2.2))
    +
    382 C
    +
    383 C COMPUTE NUMBER OF POINTS IN GRID BY MULTIPLYING
    +
    384 C IGDS(4) AND IGDS(5) ... NEEDED FOR PACKER
    +
    385 C
    +
    386  IF (igds(3).EQ.0.AND.igds(1).EQ.0.AND.igds(2).NE.
    +
    387  & 255) THEN
    +
    388  npts = isum
    +
    389  ELSE
    +
    390  npts = igds(4) * igds(5)
    +
    391  ENDIF
    +
    392 C
    +
    393 C 'IOR' ICOMP-BIT 5 RESOLUTION & COMPONENT FLAG FOR WINDS
    +
    394 C WITH IGDS(8) INFO (REST OF RESOLUTION & COMPONENT FLAG DATA)
    +
    395 C
    +
    396  itemp = ishft(icomp,3)
    +
    397  gds(17) = char(ior(igds(8),itemp))
    +
    398 C
    +
    399  RETURN
    +
    400  END
    +
    +
    +
    lengds
    function lengds(KGDS)
    Program history log:
    Definition: lengds.f:15
    +
    w3fi74
    subroutine w3fi74(IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR)
    This subroutine constructs a GRIB grid definition section.
    Definition: w3fi74.f:19
    + + + + diff --git a/ver-2.10.0/w3fi75_8f.html b/ver-2.10.0/w3fi75_8f.html new file mode 100644 index 00000000..961cef2f --- /dev/null +++ b/ver-2.10.0/w3fi75_8f.html @@ -0,0 +1,1061 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi75.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi75.f File Reference
    +
    +
    + +

    GRIB pack data and form bds octets(1-11) +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

    +Functions/Subroutines

    subroutine fi7501 (IWORK, IPFLD, NPTS, IBDSFL, BDS11, LEN, LENBDS, PDS, REFNCE, ISCAL2, KWIDE)
     BDS second order packing. More...
     
    subroutine fi7502 (IWORK, ISTART, NPTS, ISAME)
     Second order same value collection. More...
     
    subroutine fi7503 (IWORK, IPFLD, NPTS, IBDSFL, BDS11, LEN, LENBDS, PDS, REFNCE, ISCAL2, KWIDE, IGDS)
     Row by row, col by col packing. More...
     
    subroutine fi7505 (N, NBITS)
     Determine number of bits to contain value. More...
     
    subroutine fi7513 (IWORK, ISTART, NPTS, MAX, MIN, INRNGE)
     Select block of data for packing. More...
     
    subroutine fi7516 (IWORK, NPTS, INRNG, ISTART, MAX, MIN, MXVAL, LWIDTH)
     Scan number of points. More...
     
    subroutine fi7517 (IRET, IWORK, NPTS, ISTRTB, INRNGA, MAXB, MINB, MXVALB, LWIDEB)
     Scan backward. More...
     
    subroutine fi7518 (IRET, IWORK, NPTS, ISTRTA, INRNGA, INRNGB, MAXA, MINA, LWIDEA, MXVALA)
     Scan forward. More...
     
    subroutine w3fi75 (IBITL, ITYPE, ITOSS, FLD, IFLD, IBMAP, IBDSFL, NPTS, BDS11, IPFLD, PFLD, LEN, LENBDS, IBERR, PDS, IGDS)
     This routine packs a grib field and forms octets(1-11) of the binary data section (bds). More...
     
    +

    Detailed Description

    +

    GRIB pack data and form bds octets(1-11)

    +
    Author
    M. Farley
    +
    Date
    1992-07-10
    + +

    Definition in file w3fi75.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ fi7501()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7501 (integer, dimension(*) IWORK,
    character(len=1), dimension(*) IPFLD,
     NPTS,
    integer, dimension(*) IBDSFL,
    character*1, dimension(*) BDS11,
    integer LEN,
    integer LENBDS,
    character*1, dimension(*) PDS,
    real REFNCE,
    integer ISCAL2,
    integer KWIDE 
    )
    +
    + +

    BDS second order packing.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-08-06 Perform secondary packing on grid point data, generating all BDS information.
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-08-06
      • +
    • Bill Cavanaugh 1993-12-15 Corrected location of start of first order values and start of second order values to reflect a byte location in the BDS instead of an offset.
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    +
    Parameters
    + + + + + + + + + + + + +
    [in]IWORKInteger source array
    [in]NPTSNumber of points in iwork
    [in]IBDSFLFlags
    [out]IPFLDContains bds from byte 12 on
    [out]BDS11Contains first 11 bytes for bds
    [out]LENNumber of bytes from 12 on
    [out]LENBDSTotal length of bds
    PDS
    REFNCE
    ISCAL2
    KWIDE
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment.
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-08-06
    + +

    Definition at line 537 of file w3fi75.f.

    + +
    +
    + +

    ◆ fi7502()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7502 (integer, dimension(*) IWORK,
    integer ISTART,
    integer NPTS,
    integer ISAME 
    )
    +
    + +

    Second order same value collection.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-06-23 Collect sequential same values for processing as second order value for grib messages.
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-06-23
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    +
    Parameters
    + + + + + +
    [in]IWORKArray containing source data
    [in]ISTARTStarting location for this test
    [in]NPTSNumber of points in iwork
    [out]ISAMENumber of sequential points having the same value
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment.
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-06-23
    + +

    Definition at line 857 of file w3fi75.f.

    + +
    +
    + +

    ◆ fi7503()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7503 (integer, dimension(*) IWORK,
    character*1, dimension(*) IPFLD,
     NPTS,
    integer, dimension(*) IBDSFL,
    character*1, dimension(*) BDS11,
    integer LEN,
    integer LENBDS,
    character*1, dimension(*) PDS,
    real REFNCE,
    integer ISCAL2,
    integer KWIDE,
    integer, dimension(*) IGDS 
    )
    +
    + +

    Row by row, col by col packing.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-08-06 Perform row by row or column by column packing generating all bds information.
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-08-06
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    +
    Parameters
    + + + + + + + + + + + + + +
    [in]IWORKInteger source array
    [in]NPTSNumber of points in iwork
    [in]IBDSFLFlags
    [out]IPFLDContains bds from byte 12 on
    [out]BDS11Contains first 11 bytes for bds
    [out]LENNumber of bytes from 12 on
    [out]LENBDSTotal length of bds
    PDS
    REFNCE
    ISCAL2
    KWIDE
    IGDS
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment.
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-08-06
    + +

    Definition at line 902 of file w3fi75.f.

    + +
    +
    + +

    ◆ fi7505()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine fi7505 (integer N,
    integer NBITS 
    )
    +
    + +

    Determine number of bits to contain value.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-06-23 Calculate number of bits to contain value n, with a maximum of 32 bits.
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-06-23
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    +
    Parameters
    + + + +
    [in]NInteger value
    [out]NBITSNumber of bits to contain n
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment.
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-06-23
    + +

    Definition at line 1208 of file w3fi75.f.

    + +
    +
    + +

    ◆ fi7513()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7513 (integer, dimension(*) IWORK,
    integer ISTART,
    integer NPTS,
    integer MAX,
    integer MIN,
    integer INRNGE 
    )
    +
    + +

    Select block of data for packing.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1994-01-21 Select a block of data for packing
    +

    Program history log:

      +
    • Bill Cavanaugh 1994-01-21
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    • Return address if encounter set of same values
      Parameters
      + + + + + + + +
      [in]IWORK
      [in]ISTART
      [in]NPTS
      [out]MAX
      [out]MIN
      [out]INRNGE
      +
      +
      +
      Note
      Subprogram can be called from a multiprocessing environment.
      +
      Author
      Bill Cavanaugh
      +
      Date
      1994-01-21
      +
      • +
    + +

    Definition at line 1248 of file w3fi75.f.

    + +
    +
    + +

    ◆ fi7516()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7516 (integer, dimension(*) IWORK,
    integer NPTS,
    integer INRNG,
    integer ISTART,
    integer MAX,
    integer MIN,
    integer MXVAL,
    integer LWIDTH 
    )
    +
    + +

    Scan number of points.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1994-01-21 Scan forward from current position. collect points and determine maximum and minimum values and the number of points that are included. Forward search is terminated by encountering a set of identical values, by reaching the number of points selected or by reaching the end of data.
    +

    Program history log:

      +
    • Bill Cavavnaugh 1994-01-21
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    • Return address if encounter set of same values
      Parameters
      + + + + + + + + + +
      [in]IWORKData array
      [in]NPTSNumber of points in data array
      [in]ISTARTStarting location in data
      [out]INRNGNumber of points selected
      [out]MAXMaximum value of points
      [out]MINMinimum value of points
      [out]MXVALMaximum value that can be contained in lwidth bits
      [out]LWIDTHNumber of bits to contain max diff
      +
      +
      +
      Note
      Subprogram can be called from a multiprocessing environment.
      +
      Author
      Bill Cavanaugh
      +
      Date
      1994-01-21
      +
      • +
    + +

    Definition at line 1371 of file w3fi75.f.

    + +
    +
    + +

    ◆ fi7517()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7517 ( IRET,
    integer, dimension(*) IWORK,
    integer NPTS,
    integer ISTRTB,
    integer INRNGA,
    integer MAXB,
    integer MINB,
    integer MXVALB,
    integer LWIDEB 
    )
    +
    + +

    Scan backward.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1994-01-21 Scan backwards until a value exceeds range of group b this may shorten group a
    +

    Program history log:

      +
    • Bill Cavanaugh 1994-01-21
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    • Mark Iredell 1998-06-17 Removed alternate return
      • +
    +
    Parameters
    + + + + + + + + + + +
    [in]IWORK
    [in]ISTRTB
    [in]NPTS
    [in]INRNGA
    [out]IRET
    [out]MAXB
    [out]MINB
    MXVALB
    LWIDEB
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment.
    +
    Author
    Bill Cavanaugh
    +
    Date
    1994-01-21
    + +

    Definition at line 1435 of file w3fi75.f.

    + +
    +
    + +

    ◆ fi7518()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7518 ( IRET,
    integer, dimension(*) IWORK,
    integer NPTS,
    integer ISTRTA,
    integer INRNGA,
     INRNGB,
    integer MAXA,
    integer MINA,
    integer LWIDEA,
    integer MXVALA 
    )
    +
    + +

    Scan forward.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1994-01-21 Scan forward from start of block b towards end of block b if next point under test forces a larger maxvala then terminate indicating last point tested for inclusion into block a.
    +

    Program history log:

      +
    • Bill Cavanaugh 1994-01-21
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    • Mark Iredell 1998-06-17 Removed alternate return
      • +
    +
    Parameters
    + + + + + + + + + + + +
    IWORK
    ISTRTA
    INRNGA
    INRNGB
    MAXA
    MINA
    LWIDEA
    MXVALA
    [in]NPTS
    [out]IRET
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment.
    +
    Author
    Bill Cavanaugh
    +
    Date
    1994-01-21
    + +

    Definition at line 1512 of file w3fi75.f.

    + +
    +
    + +

    ◆ w3fi75()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi75 ( IBITL,
     ITYPE,
     ITOSS,
    real, dimension(*) FLD,
    integer, dimension(*) IFLD,
    integer, dimension(*) IBMAP,
    integer, dimension(*) IBDSFL,
     NPTS,
    character * 1, dimension(11) BDS11,
    character(len=1), dimension(*) IPFLD,
    character * 1, dimension(*) PFLD,
     LEN,
     LENBDS,
     IBERR,
    character * 1, dimension(*) PDS,
    integer, dimension(*) IGDS 
    )
    +
    + +

    This routine packs a grib field and forms octets(1-11) of the binary data section (bds).

    +

    Program history log:

      +
    • M. Farley 1992-07-10 Original author
      • +
    • Ralph Jones 1992-10-01 Correction for field of constant data
      • +
    • Ralph Jones 1992-10-16 Get rid of arrays fp and int
      • +
    • Bill Cavanaugh 1993-08-06 Added routines fi7501, fi7502, fi7503 To allow second order packing in pds.
      • +
    • John Stackpole 1993-07-21 Assorted repairs to get 2nd diff pack in
      • +
    • Bill Cavanaugh 1993-10-28 Commented out nonoperational prints and Write statements
      • +
    • Bill Cavanaugh 1993-12-15 Corrected location of start of first order Values and start of second order values to Reflect a byte location in the bds instead Of an offset in subroutine fi7501().
      • +
    • Bill Cavanaugh 1994-01-27 Added igds as input argument to this routine And added pds and igds arrays to the call to W3fi82 to provide information needed for Boustrophedonic processing.
      • +
    • Bill Cavanaugh 1994-05-25 Subroutine fi7503 has been added to provide For row by row or column by column second Order packing. this feature can be activated By setting ibdsfl(7) to zero.
      • +
    • Bill Cavanaugh 1994-07-08 Commented out print statements used for debug
      • +
    • M. Farley 1994-11-22 Enlarged work arrays to handle .5degree grids
      • +
    • Ralph Jones 1995-06-01 Correction for number of unused bits at end Of section 4, in bds byte 4, bits 5-8.
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    • Stephen Gilbert 2001-06-06 Changed gbyte/sbyte calls to refer to Wesley ebisuzaki's endian independent versions gbytec/sbytec. Use f90 standard routine bit_size to get number of bits in an integer instead of w3fi01.
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + + + +
    [in]IBITL
      +
    • 0, computer computes packing length from power of 2 that best fits the data.
      • +
    • 8, 12, etc. computer rescales data to fit into set number of bits.
      • +
    +
    [in]ITYPE
      +
    • 0 = if input data is floating point (fld)
      • +
    • 1 = If input data is integer (ifld)
      • +
    +
    [in]ITOSS
      +
    • 0 = no bit map is included (don't toss data)
      • +
    • 1 = Toss null data according to ibmap
      • +
    +
    [in]FLDReal array of data to be packed if itype=0
    [in]IFLDInteger array to be packed if itype=1
    [in]IBMAPBit map supplied from user
    [in]IBDSFLInteger array containing table 11 flag info BDS octet 4:
      +
    • (1)
        +
      • 0 = grid point data
        • +
      • 1 = spherical harmonic coefficients
        • +
      +
      • +
    • (2)
        +
      • 0 = simple packing
        • +
      • 1 = second order packing
        • +
      +
      • +
    • (3)
        +
      • 0 = original data were floating point values
        • +
      • 1 = original data were integer values
        • +
      +
      • +
    • (4)
        +
      • 0 = no additional flags at octet 14
        • +
      • 1 = octet 14 contains flag bits 5-12
        • +
      +
      • +
    • (5) 0 = reserved - always set to 0
      • +
    • (6)
        +
      • 0 = single datum at each grid point
        • +
      • 1 = matrix of values at each grid point
        • +
      +
      • +
    • (7)
        +
      • 0 = no secondary bit maps
        • +
      • 1 = secondary bit maps present
        • +
      +
      • +
    • (8)
        +
      • 0 = second order values have constant width
        • +
      • 1 = second order values have different widths
        • +
      +
      • +
    +
    [in]NPTSNumber of gridpoints in array to be packed
    [in]IGDSArray of gds information
    [out]BDS11First 11 octets of bds
    [out]PFLDPacked grib field
    [out]LENLength of pfld
    [out]LENBDSLength of bds
    [out]IBERR1, error converting ieee f.p. number to ibm370 f.p.
    IPFLD
    PDS
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment.
    + +

    Definition at line 90 of file w3fi75.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi75_8f.js b/ver-2.10.0/w3fi75_8f.js new file mode 100644 index 00000000..8e104cf6 --- /dev/null +++ b/ver-2.10.0/w3fi75_8f.js @@ -0,0 +1,12 @@ +var w3fi75_8f = +[ + [ "fi7501", "w3fi75_8f.html#a76d712772f7a7b26ca1bba569d377e14", null ], + [ "fi7502", "w3fi75_8f.html#acafb610fbee0d6e272301e3277cf4d32", null ], + [ "fi7503", "w3fi75_8f.html#a96ec02cf0c85d44fc9f0fffff0ef038c", null ], + [ "fi7505", "w3fi75_8f.html#ad8add9d378e5f476eb9a03253aac0673", null ], + [ "fi7513", "w3fi75_8f.html#a36ae6b4d235133cbe224771791cc78a1", null ], + [ "fi7516", "w3fi75_8f.html#a2594a5111d3b15a124e611eee1152fb7", null ], + [ "fi7517", "w3fi75_8f.html#ae605cd757c3b135016711cb96e8ddb12", null ], + [ "fi7518", "w3fi75_8f.html#abdf0aa822fec98a9c20620ea1e170b7a", null ], + [ "w3fi75", "w3fi75_8f.html#aa4b8fc64e075cd7c24ab51663d4d6912", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi75_8f_source.html b/ver-2.10.0/w3fi75_8f_source.html new file mode 100644 index 00000000..482859ee --- /dev/null +++ b/ver-2.10.0/w3fi75_8f_source.html @@ -0,0 +1,1674 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi75.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi75.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief GRIB pack data and form bds octets(1-11)
    +
    3 C> @author M. Farley @date 1992-07-10
    +
    4 
    +
    5 C> This routine packs a grib field and forms octets(1-11)
    +
    6 C> of the binary data section (bds).
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - M. Farley 1992-07-10 Original author
    +
    10 C> - Ralph Jones 1992-10-01 Correction for field of constant data
    +
    11 C> - Ralph Jones 1992-10-16 Get rid of arrays fp and int
    +
    12 C> - Bill Cavanaugh 1993-08-06 Added routines fi7501, fi7502, fi7503
    +
    13 C> To allow second order packing in pds.
    +
    14 C> - John Stackpole 1993-07-21 Assorted repairs to get 2nd diff pack in
    +
    15 C> - Bill Cavanaugh 1993-10-28 Commented out nonoperational prints and
    +
    16 C> Write statements
    +
    17 C> - Bill Cavanaugh 1993-12-15 Corrected location of start of first order
    +
    18 C> Values and start of second order values to
    +
    19 C> Reflect a byte location in the bds instead
    +
    20 C> Of an offset in subroutine fi7501().
    +
    21 C> - Bill Cavanaugh 1994-01-27 Added igds as input argument to this routine
    +
    22 C> And added pds and igds arrays to the call to
    +
    23 C> W3fi82 to provide information needed for
    +
    24 C> Boustrophedonic processing.
    +
    25 C> - Bill Cavanaugh 1994-05-25 Subroutine fi7503 has been added to provide
    +
    26 C> For row by row or column by column second
    +
    27 C> Order packing. this feature can be activated
    +
    28 C> By setting ibdsfl(7) to zero.
    +
    29 C> - Bill Cavanaugh 1994-07-08 Commented out print statements used for debug
    +
    30 C> - M. Farley 1994-11-22 Enlarged work arrays to handle .5degree grids
    +
    31 C> - Ralph Jones 1995-06-01 Correction for number of unused bits at end
    +
    32 C> Of section 4, in bds byte 4, bits 5-8.
    +
    33 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    34 C> - Stephen Gilbert 2001-06-06 Changed gbyte/sbyte calls to refer to
    +
    35 C> Wesley ebisuzaki's endian independent
    +
    36 C> versions gbytec/sbytec.
    +
    37 C> Use f90 standard routine bit_size to get
    +
    38 C> number of bits in an integer instead of w3fi01.
    +
    39 C>
    +
    40 C> @param[in] IBITL
    +
    41 C> - 0, computer computes packing length from power of 2 that best fits the data.
    +
    42 C> - 8, 12, etc. computer rescales data to fit into set number of bits.
    +
    43 C> @param[in] ITYPE
    +
    44 C> - 0 = if input data is floating point (fld)
    +
    45 C> - 1 = If input data is integer (ifld)
    +
    46 C> @param[in] ITOSS
    +
    47 C> - 0 = no bit map is included (don't toss data)
    +
    48 C> - 1 = Toss null data according to ibmap
    +
    49 C> @param[in] FLD Real array of data to be packed if itype=0
    +
    50 C> @param[in] IFLD Integer array to be packed if itype=1
    +
    51 C> @param[in] IBMAP Bit map supplied from user
    +
    52 C> @param[in] IBDSFL Integer array containing table 11 flag info
    +
    53 C> BDS octet 4:
    +
    54 C> - (1)
    +
    55 C> - 0 = grid point data
    +
    56 C> - 1 = spherical harmonic coefficients
    +
    57 C> - (2)
    +
    58 C> - 0 = simple packing
    +
    59 C> - 1 = second order packing
    +
    60 C> - (3)
    +
    61 C> - 0 = original data were floating point values
    +
    62 C> - 1 = original data were integer values
    +
    63 C> - (4)
    +
    64 C> - 0 = no additional flags at octet 14
    +
    65 C> - 1 = octet 14 contains flag bits 5-12
    +
    66 C> - (5) 0 = reserved - always set to 0
    +
    67 C> - (6)
    +
    68 C> - 0 = single datum at each grid point
    +
    69 C> - 1 = matrix of values at each grid point
    +
    70 C> - (7)
    +
    71 C> - 0 = no secondary bit maps
    +
    72 C> - 1 = secondary bit maps present
    +
    73 C> - (8)
    +
    74 C> - 0 = second order values have constant width
    +
    75 C> - 1 = second order values have different widths
    +
    76 C> @param[in] NPTS Number of gridpoints in array to be packed
    +
    77 C> @param[in] IGDS Array of gds information
    +
    78 C> @param[out] BDS11 First 11 octets of bds
    +
    79 C> @param[out] PFLD Packed grib field
    +
    80 C> @param[out] LEN Length of pfld
    +
    81 C> @param[out] LENBDS Length of bds
    +
    82 C> @param[out] IBERR 1, error converting ieee f.p. number to ibm370 f.p.
    +
    83 C> @param IPFLD
    +
    84 C> @param PDS
    +
    85 C>
    +
    86 C> @note Subprogram can be called from a multiprocessing environment.
    +
    87 C>
    +
    88  SUBROUTINE w3fi75 (IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL,
    +
    89  & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS)
    +
    90 C
    +
    91  REAL FLD(*)
    +
    92 C REAL FWORK(260000)
    +
    93 C
    +
    94 C FWORK CAN USE DYNAMIC ALLOCATION OF MEMORY ON CRAY
    +
    95 C
    +
    96  REAL FWORK(NPTS)
    +
    97  REAL RMIN,REFNCE
    +
    98 C
    +
    99  character(len=1) IPFLD(*)
    +
    100  INTEGER IBDSFL(*)
    +
    101  INTEGER IBMAP(*)
    +
    102  INTEGER IFLD(*),IGDS(*)
    +
    103 C INTEGER IWORK(260000)
    +
    104 C
    +
    105 C IWORK CAN USE DYNAMIC ALLOCATION OF MEMORY ON CRAY
    +
    106 C
    +
    107  INTEGER IWORK(NPTS)
    +
    108 C
    +
    109  LOGICAL CONST
    +
    110 C
    +
    111  CHARACTER * 1 BDS11(11),PDS(*)
    +
    112  CHARACTER * 1 PFLD(*)
    +
    113 C
    +
    114 C 1.0 PACK THE FIELD.
    +
    115 C
    +
    116 C 1.1 TOSS DATA IF BITMAP BEING USED,
    +
    117 C MOVING 'DATA' TO WORK AREA...
    +
    118 C
    +
    119  const = .false.
    +
    120  iberr = 0
    +
    121  iw = 0
    +
    122 C
    +
    123  IF (itoss .EQ. 1) THEN
    +
    124  IF (itype .EQ. 0) THEN
    +
    125  DO 110 it=1,npts
    +
    126  IF (ibmap(it) .EQ. 1) THEN
    +
    127  iw = iw + 1
    +
    128  fwork(iw) = fld(it)
    +
    129  ENDIF
    +
    130  110 CONTINUE
    +
    131  npts = iw
    +
    132  ELSE IF (itype .EQ. 1) THEN
    +
    133  DO 111 it=1,npts
    +
    134  IF (ibmap(it) .EQ. 1) THEN
    +
    135  iw = iw + 1
    +
    136  iwork(iw) = ifld(it)
    +
    137  ENDIF
    +
    138  111 CONTINUE
    +
    139  npts = iw
    +
    140  ENDIF
    +
    141 C
    +
    142 C ELSE, JUST MOVE DATA TO WORK ARRAY
    +
    143 C
    +
    144  ELSE IF (itoss .EQ. 0) THEN
    +
    145  IF (itype .EQ. 0) THEN
    +
    146  DO 112 it=1,npts
    +
    147  fwork(it) = fld(it)
    +
    148  112 CONTINUE
    +
    149  ELSE IF (itype .EQ. 1) THEN
    +
    150  DO 113 it=1,npts
    +
    151  iwork(it) = ifld(it)
    +
    152  113 CONTINUE
    +
    153  ENDIF
    +
    154  ENDIF
    +
    155 C
    +
    156 C 1.2 CONVERT DATA IF NEEDED PRIOR TO PACKING.
    +
    157 C (INTEGER TO F.P. OR F.P. TO INTEGER)
    +
    158 C ITYPE = 0...FLOATING POINT DATA
    +
    159 C IBITL = 0...PACK IN LEAST # BITS...CONVERT TO INTEGER
    +
    160 C ITYPE = 1...INTEGER DATA
    +
    161 C IBITL > 0...PACK IN FIXED # BITS...CONVERT TO FLOATING POINT
    +
    162 C
    +
    163  IF (itype .EQ. 0 .AND. ibitl .EQ. 0) THEN
    +
    164  DO 120 if=1,npts
    +
    165  iwork(if) = nint(fwork(if))
    +
    166  120 CONTINUE
    +
    167  ELSE IF (itype .EQ. 1 .AND. ibitl .NE. 0) THEN
    +
    168  DO 123 if=1,npts
    +
    169  fwork(if) = float(iwork(if))
    +
    170  123 CONTINUE
    +
    171  ENDIF
    +
    172 C
    +
    173 C 1.3 PACK THE DATA.
    +
    174 C
    +
    175  IF (ibdsfl(2).NE.0) THEN
    +
    176 C SECOND ORDER PACKING
    +
    177 C
    +
    178 C PRINT*,' DOING SECOND ORDER PACKING...'
    +
    179  IF (ibitl.EQ.0) THEN
    +
    180 C
    +
    181 C PRINT*,' AND VARIABLE BIT PACKING'
    +
    182 C
    +
    183 C WORKING WITH INTEGER VALUES
    +
    184 C SINCE DOING VARIABLE BIT PACKING
    +
    185 C
    +
    186  max = iwork(1)
    +
    187  min = iwork(1)
    +
    188  DO 300 i = 2, npts
    +
    189  IF (iwork(i).LT.min) THEN
    +
    190  min = iwork(i)
    +
    191  ELSE IF (iwork(i).GT.max) THEN
    +
    192  max = iwork(i)
    +
    193  END IF
    +
    194  300 CONTINUE
    +
    195 C EXTRACT MINIMA
    +
    196  DO 400 i = 1, npts
    +
    197 C IF (IWORK(I).LT.0) THEN
    +
    198 C PRINT *,'MINIMA 400',I,IWORK(I),NPTS
    +
    199 C END IF
    +
    200  iwork(i) = iwork(i) - min
    +
    201  400 CONTINUE
    +
    202  refnce = min
    +
    203  idiff = max - min
    +
    204 C PRINT *,'REFERENCE VALUE',REFNCE
    +
    205 C
    +
    206 C WRITE (6,FMT='('' MINIMA REMOVED = '',/,
    +
    207 C & 10(3X,10I10,/))') (IWORK(I),I=1,6)
    +
    208 C WRITE (6,FMT='('' END OF ARRAY = '',/,
    +
    209 C & 10(3X,10I10,/))') (IWORK(I),I=NPTS-5,NPTS)
    +
    210 C
    +
    211 C FIND BIT WIDTH OF IDIFF
    +
    212 C
    +
    213  CALL fi7505 (idiff,kwide)
    +
    214 C PRINT*,' BIT WIDTH FOR ORIGINAL DATA', KWIDE
    +
    215  iscal2 = 0
    +
    216 C
    +
    217 C MULTIPLICATIVE SCALE FACTOR SET TO 1
    +
    218 C IN ANTICIPATION OF POSSIBLE USE IN GLAHN 2DN DIFF
    +
    219 C
    +
    220  scal2 = 1.
    +
    221 C
    +
    222  ELSE
    +
    223 C
    +
    224 C PRINT*,' AND FIXED BIT PACKING, IBITL = ', IBITL
    +
    225 C FIXED BIT PACKING
    +
    226 C - LENGTH OF FIELD IN IBITL
    +
    227 C - MUST BE REAL DATA
    +
    228 C FLOATING POINT INPUT
    +
    229 C
    +
    230  rmax = fwork(1)
    +
    231  rmin = fwork(1)
    +
    232  DO 100 i = 2, npts
    +
    233  IF (fwork(i).LT.rmin) THEN
    +
    234  rmin = fwork(i)
    +
    235  ELSE IF (fwork(i).GT.rmax) THEN
    +
    236  rmax = fwork(i)
    +
    237  END IF
    +
    238  100 CONTINUE
    +
    239  refnce = rmin
    +
    240 C PRINT *,'100 REFERENCE',REFNCE
    +
    241 C EXTRACT MINIMA
    +
    242  DO 200 i = 1, npts
    +
    243  fwork(i) = fwork(i) - rmin
    +
    244  200 CONTINUE
    +
    245 C PRINT *,'REFERENCE VALUE',REFNCE
    +
    246 C WRITE (6,FMT='('' MINIMA REMOVED = '',/,
    +
    247 C & 10(3X,10F8.2,/))') (FWORK(I),I=1,6)
    +
    248 C WRITE (6,FMT='('' END OF ARRAY = '',/,
    +
    249 C & 10(3X,10F8.2,/))') (FWORK(I),I=NPTS-5,NPTS)
    +
    250 C FIND LARGEST DELTA
    +
    251  idelt = nint(rmax - rmin)
    +
    252 C DO BINARY SCALING
    +
    253 C FIND OUT WHAT BINARY SCALE FACTOR
    +
    254 C PERMITS CONTAINMENT OF
    +
    255 C LARGEST DELTA
    +
    256  CALL fi7505 (idelt,iwide)
    +
    257 C
    +
    258 C BINARY SCALING
    +
    259 C
    +
    260  iscal2 = iwide - ibitl
    +
    261 C PRINT *,'SCALING NEEDED TO FIT =',ISCAL2
    +
    262 C PRINT*,' RANGE OF = ',IDELT
    +
    263 C
    +
    264 C EXPAND DATA WITH BINARY SCALING
    +
    265 C CONVERT TO INTEGER
    +
    266  scal2 = 2.0**iscal2
    +
    267  scal2 = 1./ scal2
    +
    268  DO 600 i = 1, npts
    +
    269  iwork(i) = nint(fwork(i) * scal2)
    +
    270  600 CONTINUE
    +
    271  kwide = ibitl
    +
    272  END IF
    +
    273 C
    +
    274 C *****************************************************************
    +
    275 C
    +
    276 C FOLLOWING IS FOR GLAHN SECOND DIFFERENCING
    +
    277 C NOT STANDARD GRIB
    +
    278 C
    +
    279 C TEST FOR SECOND DIFFERENCE PACKING
    +
    280 C BASED OF SIZE OF PDS - SIZE IN FIRST 3 BYTES
    +
    281 C
    +
    282  CALL gbytec(pds,ipdsiz,0,24)
    +
    283  IF (ipdsiz.EQ.50) THEN
    +
    284 C PRINT*,' DO SECOND DIFFERENCE PACKING '
    +
    285 C
    +
    286 C GLAHN PACKING TO 2ND DIFFS
    +
    287 C
    +
    288 C WRITE (6,FMT='('' CALL TO W3FI82 WITH = '',/,
    +
    289 C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS)
    +
    290 C
    +
    291  CALL w3fi82 (iwork,fval1,fdiff1,npts,pds,igds)
    +
    292 C
    +
    293 C PRINT *,'GLAHN',FVAL1,FDIFF1
    +
    294 C WRITE (6,FMT='('' OUT FROM W3FI82 WITH = '',/,
    +
    295 C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS)
    +
    296 C
    +
    297 C MUST NOW RE-REMOVE THE MINIMUM VALUE
    +
    298 C OF THE SECOND DIFFERENCES TO ASSURE
    +
    299 C ALL POSITIVE NUMBERS FOR SECOND ORDER GRIB PACKING
    +
    300 C
    +
    301 C ORIGINAL REFERENCE VALUE ADDED TO FIRST POINT
    +
    302 C VALUE FROM THE 2ND DIFF PACKER TO BE ADDED
    +
    303 C BACK IN WHEN THE 2ND DIFF VALUES ARE
    +
    304 C RECONSTRUCTED BACK TO THE BASIC VALUES
    +
    305 C
    +
    306 C ALSO, THE REFERENCE VALUE IS
    +
    307 C POWER-OF-TWO SCALED TO MATCH
    +
    308 C FVAL1. ALL OF THIS SCALING
    +
    309 C WILL BE REMOVED AFTER THE
    +
    310 C GLAHN SECOND DIFFERENCING IS UNDONE.
    +
    311 C THE SCALING FACTOR NEEDED TO DO THAT
    +
    312 C IS SAVED IN THE PDS AS A SIGNED POSITIVE
    +
    313 C TWO BYTE INTEGER
    +
    314 C
    +
    315 C THE SCALING FOR THE 2ND DIF PACKED
    +
    316 C VALUES IS PROPERLY SET TO ZERO
    +
    317 C
    +
    318  fval1 = fval1 + refnce*scal2
    +
    319 C FIRST TEST TO SEE IF
    +
    320 C ON 32 OR 64 BIT COMPUTER
    +
    321 C CALL W3FI01(LW)
    +
    322  IF (bit_size(lw).EQ.32) THEN
    +
    323  CALL w3fi76 (fval1,iexp,imant,32)
    +
    324  ELSE
    +
    325  CALL w3fi76 (fval1,iexp,imant,64)
    +
    326  END IF
    +
    327  CALL sbytec(pds,iexp,320,8)
    +
    328  CALL sbytec(pds,imant,328,24)
    +
    329 C
    +
    330  IF (bit_size(lw).EQ.32) THEN
    +
    331  CALL w3fi76 (fdiff1,iexp,imant,32)
    +
    332  ELSE
    +
    333  CALL w3fi76 (fdiff1,iexp,imant,64)
    +
    334  END IF
    +
    335  CALL sbytec(pds,iexp,352,8)
    +
    336  CALL sbytec(pds,imant,360,24)
    +
    337 C
    +
    338 C TURN ISCAL2 INTO SIGNED POSITIVE INTEGER
    +
    339 C AND STORE IN TWO BYTES
    +
    340 C
    +
    341  IF(iscal2.GE.0) THEN
    +
    342  CALL sbytec(pds,iscal2,384,16)
    +
    343  ELSE
    +
    344  CALL sbytec(pds,1,384,1)
    +
    345  iscal2 = - iscal2
    +
    346  CALL sbytec( pds,iscal2,385,15)
    +
    347  ENDIF
    +
    348 C
    +
    349  max = iwork(1)
    +
    350  min = iwork(1)
    +
    351  DO 700 i = 2, npts
    +
    352  IF (iwork(i).LT.min) THEN
    +
    353  min = iwork(i)
    +
    354  ELSE IF (iwork(i).GT.max) THEN
    +
    355  max = iwork(i)
    +
    356  END IF
    +
    357  700 CONTINUE
    +
    358 C EXTRACT MINIMA
    +
    359  DO 710 i = 1, npts
    +
    360  iwork(i) = iwork(i) - min
    +
    361  710 CONTINUE
    +
    362  refnce = min
    +
    363 C PRINT *,'710 REFERENCE',REFNCE
    +
    364  iscal2 = 0
    +
    365 C
    +
    366 C AND RESET VALUE OF KWIDE - THE BIT WIDTH
    +
    367 C FOR THE RANGE OF THE VALUES
    +
    368 C
    +
    369  idiff = max - min
    +
    370  CALL fi7505 (idiff,kwide)
    +
    371 C
    +
    372 C PRINT*,'BIT WIDTH (KWIDE) OF 2ND DIFFS', KWIDE
    +
    373 C
    +
    374 C **************************** END OF GLAHN PACKING ************
    +
    375  ELSE IF (ibdsfl(2).EQ.1.AND.ibdsfl(7).EQ.0) THEN
    +
    376 C HAVE SECOND ORDER PACKING WITH NO SECOND ORDER
    +
    377 C BIT MAP. ERGO ROW BY ROW - COL BY COL
    +
    378  CALL fi7503 (iwork,ipfld,npts,ibdsfl,bds11,
    +
    379  * len,lenbds,pds,refnce,iscal2,kwide,igds)
    +
    380  RETURN
    +
    381  END IF
    +
    382 C WRITE (6,FMT='('' CALL TO FI7501 WITH = '',/,
    +
    383 C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS)
    +
    384 C WRITE (6,FMT='('' END OF ARRAY = '',/,
    +
    385 C & 10(3X,10I6,/))') (IWORK(I),I=NPTS-5,NPTS)
    +
    386 C PRINT*,' REFNCE,ISCAL2, KWIDE AT CALL TO FI7501',
    +
    387 C & REFNCE, ISCAL2,KWIDE
    +
    388 C
    +
    389 C SECOND ORDER PACKING
    +
    390 C
    +
    391  CALL fi7501 (iwork,ipfld,npts,ibdsfl,bds11,
    +
    392  * len,lenbds,pds,refnce,iscal2,kwide)
    +
    393 C
    +
    394 C BDS COMPLETELY ASSEMBLED IN FI7501 FOR SECOND ORDER
    +
    395 C PACKING.
    +
    396 C
    +
    397  ELSE
    +
    398 C SIMPLE PACKING
    +
    399 C
    +
    400 C PRINT*,' SIMPLE FIRST ORDER PACKING...'
    +
    401  IF (ibitl.EQ.0) THEN
    +
    402 C PRINT*,' WITH VARIABLE BIT LENGTH'
    +
    403 C
    +
    404 C WITH VARIABLE BIT LENGTH, ADJUSTED
    +
    405 C TO ACCOMMODATE LARGEST VALUE
    +
    406 C BINARY SCALING ALWAYS = 0
    +
    407 C
    +
    408  CALL w3fi58(iwork,npts,iwork,pfld,nbits,len,kmin)
    +
    409  rmin = kmin
    +
    410  refnce = rmin
    +
    411  iscale = 0
    +
    412 C PRINT*,' BIT LENGTH CAME OUT AT ...',NBITS
    +
    413 C
    +
    414 C SET CONST .TRUE. IF ALL VALUES ARE THE SAME
    +
    415 C
    +
    416  IF (len.EQ.0.AND.nbits.EQ.0) const = .true.
    +
    417 C
    +
    418  ELSE
    +
    419 C PRINT*,' FIXED BIT LENGTH, IBITL = ', IBITL
    +
    420 C
    +
    421 C FIXED BIT LENGTH PACKING (VARIABLE PRECISION)
    +
    422 C VALUES SCALED BY POWER OF 2 (ISCALE) TO
    +
    423 C FIT LARGEST VALUE INTO GIVEN BIT LENGTH (IBITL)
    +
    424 C
    +
    425  CALL w3fi59(fwork,npts,ibitl,iwork,pfld,iscale,len,rmin)
    +
    426  refnce = rmin
    +
    427 C PRINT *,' SCALING NEEDED TO FIT IS ...', ISCALE
    +
    428  nbits = ibitl
    +
    429 C
    +
    430 C SET CONST .TRUE. IF ALL VALUES ARE THE SAME
    +
    431 C
    +
    432  IF (len.EQ.0) THEN
    +
    433  const = .true.
    +
    434  nbits = 0
    +
    435  END IF
    +
    436  END IF
    +
    437 C
    +
    438 C$ COMPUTE LENGTH OF BDS IN OCTETS
    +
    439 C
    +
    440  inum = npts * nbits + 88
    +
    441 C PRINT *,'NUMBER OF BITS BEFORE FILL ADDED',INUM
    +
    442 C
    +
    443 C NUMBER OF FILL BITS
    +
    444  nfill = 0
    +
    445  nleft = mod(inum,16)
    +
    446  IF (nleft.NE.0) THEN
    +
    447  inum = inum + 16 - nleft
    +
    448  nfill = 16 - nleft
    +
    449  END IF
    +
    450 C PRINT *,'NUMBER OF BITS AFTER FILL ADDED',INUM
    +
    451 C LENGTH OF BDS IN BYTES
    +
    452  lenbds = inum / 8
    +
    453 C
    +
    454 C 2.0 FORM THE BINARY DATA SECTION (BDS).
    +
    455 C
    +
    456 C CONCANTENATE ALL FIELDS FOR BDS
    +
    457 C
    +
    458 C BYTES 1-3
    +
    459  CALL sbytec (bds11,lenbds,0,24)
    +
    460 C
    +
    461 C BYTE 4
    +
    462 C FLAGS
    +
    463  CALL sbytec (bds11,ibdsfl(1),24,1)
    +
    464  CALL sbytec (bds11,ibdsfl(2),25,1)
    +
    465  CALL sbytec (bds11,ibdsfl(3),26,1)
    +
    466  CALL sbytec (bds11,ibdsfl(4),27,1)
    +
    467 C NR OF FILL BITS
    +
    468  CALL sbytec (bds11,nfill,28,4)
    +
    469 C
    +
    470 C$ FILL OCTETS 5-6 WITH THE SCALE FACTOR.
    +
    471 C
    +
    472 C BYTE 5-6
    +
    473  IF (iscale.LT.0) THEN
    +
    474  CALL sbytec (bds11,1,32,1)
    +
    475  iscale = - iscale
    +
    476  CALL sbytec (bds11,iscale,33,15)
    +
    477  ELSE
    +
    478  CALL sbytec (bds11,iscale,32,16)
    +
    479  END IF
    +
    480 C
    +
    481 C$ FILL OCTET 7-10 WITH THE REFERENCE VALUE
    +
    482 C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT
    +
    483 C FLOATING POINT NUMBER
    +
    484 C
    +
    485 C BYTE 7-10
    +
    486 C REFERENCE VALUE
    +
    487 C FIRST TEST TO SEE IF
    +
    488 C ON 32 OR 64 BIT COMPUTER
    +
    489 C CALL W3FI01(LW)
    +
    490  IF (bit_size(lw).EQ.32) THEN
    +
    491  CALL w3fi76 (refnce,iexp,imant,32)
    +
    492  ELSE
    +
    493  CALL w3fi76 (refnce,iexp,imant,64)
    +
    494  END IF
    +
    495  CALL sbytec (bds11,iexp,48,8)
    +
    496  CALL sbytec (bds11,imant,56,24)
    +
    497 C
    +
    498 C
    +
    499 C$ FILL OCTET 11 WITH THE NUMBER OF BITS.
    +
    500 C
    +
    501 C BYTE 11
    +
    502  CALL sbytec (bds11,nbits,80,8)
    +
    503  END IF
    +
    504 C
    +
    505  RETURN
    +
    506  END
    +
    507 C
    +
    508 C> @brief BDS second order packing.
    +
    509 C> @author Bill Cavanaugh @date 1993-08-06
    +
    510 
    +
    511 C> Perform secondary packing on grid point data, generating all BDS information.
    +
    512 C>
    +
    513 C> Program history log:
    +
    514 C> - Bill Cavanaugh 1993-08-06
    +
    515 C> - Bill Cavanaugh 1993-12-15 Corrected location of start of first order
    +
    516 C> values and start of second order values to reflect a byte location in the
    +
    517 C> BDS instead of an offset.
    +
    518 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    519 C>
    +
    520 C> @param[in] IWORK Integer source array
    +
    521 C> @param[in] NPTS Number of points in iwork
    +
    522 C> @param[in] IBDSFL Flags
    +
    523 C> @param[out] IPFLD Contains bds from byte 12 on
    +
    524 C> @param[out] BDS11 Contains first 11 bytes for bds
    +
    525 C> @param[out] LEN Number of bytes from 12 on
    +
    526 C> @param[out] LENBDS Total length of bds
    +
    527 C> @param PDS
    +
    528 C> @param REFNCE
    +
    529 C> @param ISCAL2
    +
    530 C> @param KWIDE
    +
    531 C>
    +
    532 C> @note Subprogram can be called from a multiprocessing environment.
    +
    533 C>
    +
    534 C> @author Bill Cavanaugh @date 1993-08-06
    +
    535  SUBROUTINE fi7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11,
    +
    536  * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE)
    +
    537 
    +
    538  CHARACTER*1 BDS11(*),PDS(*)
    +
    539 C
    +
    540  REAL REFNCE
    +
    541 C
    +
    542  INTEGER ISCAL2,KWIDE
    +
    543  INTEGER LENBDS
    +
    544  CHARACTER(len=1) IPFLD(*)
    +
    545  INTEGER LEN,KBDS(22)
    +
    546  INTEGER IWORK(*)
    +
    547 C OCTET NUMBER IN SECTION, FIRST ORDER PACKING
    +
    548 C INTEGER KBDS(12)
    +
    549 C FLAGS
    +
    550  INTEGER IBDSFL(*)
    +
    551 C EXTENDED FLAGS
    +
    552 C INTEGER KBDS(14)
    +
    553 C OCTET NUMBER FOR SECOND ORDER PACKING
    +
    554 C INTEGER KBDS(15)
    +
    555 C NUMBER OF FIRST ORDER VALUES
    +
    556 C INTEGER KBDS(17)
    +
    557 C NUMBER OF SECOND ORDER PACKED VALUES
    +
    558 C INTEGER KBDS(19)
    +
    559 C WIDTH OF SECOND ORDER PACKING
    +
    560  character(len=1) ISOWID(400000)
    +
    561 C SECONDARY BIT MAP
    +
    562  character(len=1) ISOBMP(65600)
    +
    563 C FIRST ORDER PACKED VALUES
    +
    564  character(len=1) IFOVAL(400000)
    +
    565 C SECOND ORDER PACKED VALUES
    +
    566  character(len=1) ISOVAL(800000)
    +
    567 C
    +
    568 C INTEGER KBDS(11)
    +
    569 C BIT WIDTH TABLE
    +
    570  INTEGER IBITS(31)
    +
    571 C
    +
    572  DATA ibits/1,3,7,15,31,63,127,255,511,1023,
    +
    573  * 2047,4095,8191,16383,32767,65535,131072,
    +
    574  * 262143,524287,1048575,2097151,4194303,
    +
    575  * 8388607,16777215,33554431,67108863,
    +
    576  * 134217727,268435455,536870911,
    +
    577  * 1073741823,2147483647/
    +
    578 C ----------------------------------
    +
    579 C INITIALIZE ARRAYS
    +
    580 
    +
    581  DO i = 1, 400000
    +
    582  ifoval(i) = char(0)
    +
    583  isowid(i) = char(0)
    +
    584  ENDDO
    +
    585 C
    +
    586  DO 101 i = 1, 65600
    +
    587  isobmp(i) = char(0)
    +
    588  101 CONTINUE
    +
    589  DO 102 i = 1, 800000
    +
    590  isoval(i) = char(0)
    +
    591  102 CONTINUE
    +
    592 C INITIALIZE POINTERS
    +
    593 C SECONDARY BIT WIDTH POINTER
    +
    594  iwdptr = 0
    +
    595 C SECONDARY BIT MAP POINTER
    +
    596  ibmp2p = 0
    +
    597 C FIRST ORDER VALUE POINTER
    +
    598  ifoptr = 0
    +
    599 C BYTE POINTER TO START OF 1ST ORDER VALUES
    +
    600  kbds(12) = 0
    +
    601 C BYTE POINTER TO START OF 2ND ORDER VALUES
    +
    602  kbds(15) = 0
    +
    603 C TO CONTAIN NUMBER OF FIRST ORDER VALUES
    +
    604  kbds(17) = 0
    +
    605 C TO CONTAIN NUMBER OF SECOND ORDER VALUES
    +
    606  kbds(19) = 0
    +
    607 C SECOND ORDER PACKED VALUE POINTER
    +
    608  isoptr = 0
    +
    609 C =======================================================
    +
    610 C
    +
    611 C DATA IS IN IWORK
    +
    612 C
    +
    613  kbds(11) = kwide
    +
    614 C
    +
    615 C DATA PACKING
    +
    616 C
    +
    617  iter = 0
    +
    618  inext = 1
    +
    619  istart = 1
    +
    620 C -----------------------------------------------------------
    +
    621  kount = 0
    +
    622 C DO 1 I = 1, NPTS, 10
    +
    623 C PRINT *,I,(IWORK(K),K=I, I+9)
    +
    624 C 1 CONTINUE
    +
    625  2000 CONTINUE
    +
    626  iter = iter + 1
    +
    627 C PRINT *,'NEXT ITERATION STARTS AT',ISTART
    +
    628  IF (istart.GT.npts) THEN
    +
    629  GO TO 4000
    +
    630  ELSE IF (istart.EQ.npts) THEN
    +
    631  kpts = 1
    +
    632  mxdiff = 0
    +
    633  GO TO 2200
    +
    634  END IF
    +
    635 C
    +
    636 C LOOK FOR REPITITIONS OF A SINGLE VALUE
    +
    637  CALL fi7502 (iwork,istart,npts,isame)
    +
    638  IF (isame.GE.15) THEN
    +
    639  kount = kount + 1
    +
    640 C PRINT *,'FI7501 - FOUND IDENTICAL SET OF ',ISAME
    +
    641  mxdiff = 0
    +
    642  kpts = isame
    +
    643  ELSE
    +
    644 C
    +
    645 C LOOK FOR SETS OF VALUES IN TREND SELECTED RANGE
    +
    646  CALL fi7513 (iwork,istart,npts,nmax,nmin,inrnge)
    +
    647 C PRINT *,'ISTART ',ISTART,' INRNGE',INRNGE,NMAX,NMIN
    +
    648  iend = istart + inrnge - 1
    +
    649 C DO 2199 NM = ISTART, IEND, 10
    +
    650 C PRINT *,' ',(IWORK(NM+JK),JK=0,9)
    +
    651 C2199 CONTINUE
    +
    652  mxdiff = nmax - nmin
    +
    653  kpts = inrnge
    +
    654  END IF
    +
    655  2200 CONTINUE
    +
    656 C PRINT *,' RANGE ',MXDIFF,' MAX',NMAX,' MIN',NMIN
    +
    657 C INCREMENT NUMBER OF FIRST ORDER VALUES
    +
    658  kbds(17) = kbds(17) + 1
    +
    659 C ENTER FIRST ORDER VALUE
    +
    660  IF (mxdiff.GT.0) THEN
    +
    661  DO 2220 lk = 0, kpts-1
    +
    662  iwork(istart+lk) = iwork(istart+lk) - nmin
    +
    663  2220 CONTINUE
    +
    664  CALL sbytec (ifoval,nmin,ifoptr,kbds(11))
    +
    665  ELSE
    +
    666  CALL sbytec (ifoval,iwork(istart),ifoptr,kbds(11))
    +
    667  END IF
    +
    668  ifoptr = ifoptr + kbds(11)
    +
    669 C PROCESS SECOND ORDER BIT WIDTH
    +
    670  IF (mxdiff.GT.0) THEN
    +
    671  DO 2330 kwide = 1, 31
    +
    672  IF (mxdiff.LE.ibits(kwide)) THEN
    +
    673  GO TO 2331
    +
    674  END IF
    +
    675  2330 CONTINUE
    +
    676  2331 CONTINUE
    +
    677  ELSE
    +
    678  kwide = 0
    +
    679  END IF
    +
    680  CALL sbytec (isowid,kwide,iwdptr,8)
    +
    681  iwdptr = iwdptr + 8
    +
    682 C PRINT *,KWIDE,' IFOVAL=',NMIN,IWORK(ISTART),KPTS
    +
    683 C IF KWIDE NE 0, SAVE SECOND ORDER VALUE
    +
    684  IF (kwide.GT.0) THEN
    +
    685  CALL sbytesc (isoval,iwork(istart),isoptr,kwide,0,kpts)
    +
    686  isoptr = isoptr + kpts * kwide
    +
    687  kbds(19) = kbds(19) + kpts
    +
    688 C PRINT *,' SECOND ORDER VALUES'
    +
    689 C PRINT *,(IWORK(ISTART+I),I=0,KPTS-1)
    +
    690  END IF
    +
    691 C ADD TO SECOND ORDER BITMAP
    +
    692  CALL sbytec (isobmp,1,ibmp2p,1)
    +
    693  ibmp2p = ibmp2p + kpts
    +
    694  istart = istart + kpts
    +
    695  GO TO 2000
    +
    696 C --------------------------------------------------------------
    +
    697  4000 CONTINUE
    +
    698 C PRINT *,'THERE WERE ',ITER,' SECOND ORDER GROUPS'
    +
    699 C PRINT *,'THERE WERE ',KOUNT,' STRINGS OF CONSTANTS'
    +
    700 C CONCANTENATE ALL FIELDS FOR BDS
    +
    701 C
    +
    702 C REMAINDER GOES INTO IPFLD
    +
    703  iptr = 0
    +
    704 C BYTES 12-13
    +
    705 C VALUE FOR N1
    +
    706 C LEAVE SPACE FOR THIS
    +
    707  iptr = iptr + 16
    +
    708 C BYTE 14
    +
    709 C EXTENDED FLAGS
    +
    710  CALL sbytec (ipfld,ibdsfl(5),iptr,1)
    +
    711  iptr = iptr + 1
    +
    712  CALL sbytec (ipfld,ibdsfl(6),iptr,1)
    +
    713  iptr = iptr + 1
    +
    714  CALL sbytec (ipfld,ibdsfl(7),iptr,1)
    +
    715  iptr = iptr + 1
    +
    716  CALL sbytec (ipfld,ibdsfl(8),iptr,1)
    +
    717  iptr = iptr + 1
    +
    718  CALL sbytec (ipfld,ibdsfl(9),iptr,1)
    +
    719  iptr = iptr + 1
    +
    720  CALL sbytec (ipfld,ibdsfl(10),iptr,1)
    +
    721  iptr = iptr + 1
    +
    722  CALL sbytec (ipfld,ibdsfl(11),iptr,1)
    +
    723  iptr = iptr + 1
    +
    724  CALL sbytec (ipfld,ibdsfl(12),iptr,1)
    +
    725  iptr = iptr + 1
    +
    726 C BYTES 15-16
    +
    727 C SKIP OVER VALUE FOR N2
    +
    728  iptr = iptr + 16
    +
    729 C BYTES 17-18
    +
    730 C P1
    +
    731  CALL sbytec (ipfld,kbds(17),iptr,16)
    +
    732  iptr = iptr + 16
    +
    733 C BYTES 19-20
    +
    734 C P2
    +
    735  CALL sbytec (ipfld,kbds(19),iptr,16)
    +
    736  iptr = iptr + 16
    +
    737 C BYTE 21 - RESERVED LOCATION
    +
    738  CALL sbytec (ipfld,0,iptr,8)
    +
    739  iptr = iptr + 8
    +
    740 C BYTES 22 - ?
    +
    741 C WIDTHS OF SECOND ORDER PACKING
    +
    742  ix = (iwdptr + 32) / 32
    +
    743 C CALL SBYTESC (IPFLD,ISOWID,IPTR,32,0,IX)
    +
    744  ijk=iwdptr/8
    +
    745  jst=(iptr/8)+1
    +
    746  ipfld(jst:jst+ijk)=isowid(1:ijk)
    +
    747  iptr = iptr + iwdptr
    +
    748 C SECONDARY BIT MAP
    +
    749  ij = (ibmp2p + 32) / 32
    +
    750 C CALL SBYTESC (IPFLD,ISOBMP,IPTR,32,0,IJ)
    +
    751  ijk=(ibmp2p/8)+1
    +
    752  jst=(iptr/8)+1
    +
    753  ipfld(jst:jst+ijk)=isobmp(1:ijk)
    +
    754  iptr = iptr + ibmp2p
    +
    755  IF (mod(iptr,8).NE.0) THEN
    +
    756  iptr = iptr + 8 - mod(iptr,8)
    +
    757  END IF
    +
    758 C DETERMINE LOCATION FOR START
    +
    759 C OF FIRST ORDER PACKED VALUES
    +
    760  kbds(12) = iptr / 8 + 12
    +
    761 C STORE LOCATION
    +
    762  CALL sbytec (ipfld,kbds(12),0,16)
    +
    763 C MOVE IN FIRST ORDER PACKED VALUES
    +
    764  ipass = (ifoptr + 32) / 32
    +
    765 C CALL SBYTESC (IPFLD,IFOVAL,IPTR,32,0,IPASS)
    +
    766  ijk=(ifoptr/8)+1
    +
    767  jst=(iptr/8)+1
    +
    768  ipfld(jst:jst+ijk)=ifoval(1:ijk)
    +
    769  iptr = iptr + ifoptr
    +
    770  IF (mod(iptr,8).NE.0) THEN
    +
    771  iptr = iptr + 8 - mod(iptr,8)
    +
    772  END IF
    +
    773 C PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR
    +
    774 C DETERMINE LOCATION FOR START
    +
    775 C OF SECOND ORDER VALUES
    +
    776  kbds(15) = iptr / 8 + 12
    +
    777 C SAVE LOCATION OF SECOND ORDER VALUES
    +
    778  CALL sbytec (ipfld,kbds(15),24,16)
    +
    779 C MOVE IN SECOND ORDER PACKED VALUES
    +
    780  ix = (isoptr + 32) / 32
    +
    781 c CALL SBYTESC (IPFLD,ISOVAL,IPTR,32,0,IX)
    +
    782  ijk=(isoptr/8)+1
    +
    783  jst=(iptr/8)+1
    +
    784  ipfld(jst:jst+ijk)=isoval(1:ijk)
    +
    785  iptr = iptr + isoptr
    +
    786  nleft = mod(iptr+88,16)
    +
    787  IF (nleft.NE.0) THEN
    +
    788  nleft = 16 - nleft
    +
    789  iptr = iptr + nleft
    +
    790  END IF
    +
    791 C COMPUTE LENGTH OF DATA PORTION
    +
    792  len = iptr / 8
    +
    793 C COMPUTE LENGTH OF BDS
    +
    794  lenbds = len + 11
    +
    795 C -----------------------------------
    +
    796 C BYTES 1-3
    +
    797 C THIS FUNCTION COMPLETED BELOW
    +
    798 C WHEN LENGTH OF BDS IS KNOWN
    +
    799  CALL sbytec (bds11,lenbds,0,24)
    +
    800 C BYTE 4
    +
    801  CALL sbytec (bds11,ibdsfl(1),24,1)
    +
    802  CALL sbytec (bds11,ibdsfl(2),25,1)
    +
    803  CALL sbytec (bds11,ibdsfl(3),26,1)
    +
    804  CALL sbytec (bds11,ibdsfl(4),27,1)
    +
    805 C ENTER NUMBER OF FILL BITS
    +
    806  CALL sbytec (bds11,nleft,28,4)
    +
    807 C BYTE 5-6
    +
    808  IF (iscal2.LT.0) THEN
    +
    809  CALL sbytec (bds11,1,32,1)
    +
    810  iscal2 = - iscal2
    +
    811  ELSE
    +
    812  CALL sbytec (bds11,0,32,1)
    +
    813  END IF
    +
    814  CALL sbytec (bds11,iscal2,33,15)
    +
    815 C
    +
    816 C$ FILL OCTET 7-10 WITH THE REFERENCE VALUE
    +
    817 C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT
    +
    818 C FLOATING POINT NUMBER
    +
    819 C REFERENCE VALUE
    +
    820 C FIRST TEST TO SEE IF
    +
    821 C ON 32 OR 64 BIT COMPUTER
    +
    822 C CALL W3FI01(LW)
    +
    823  IF (bit_size(lw).EQ.32) THEN
    +
    824  CALL w3fi76 (refnce,iexp,imant,32)
    +
    825  ELSE
    +
    826  CALL w3fi76 (refnce,iexp,imant,64)
    +
    827  END IF
    +
    828  CALL sbytec (bds11,iexp,48,8)
    +
    829  CALL sbytec (bds11,imant,56,24)
    +
    830 C
    +
    831 C BYTE 11
    +
    832 C
    +
    833  CALL sbytec (bds11,kbds(11),80,8)
    +
    834 C
    +
    835  RETURN
    +
    836  END
    +
    837 C
    +
    838 C> @brief Second order same value collection.
    +
    839 C> @author Bill Cavanaugh @date 1993-06-23
    +
    840 
    +
    841 C> Collect sequential same values for processing
    +
    842 C> as second order value for grib messages.
    +
    843 C>
    +
    844 C> Program history log:
    +
    845 C> - Bill Cavanaugh 1993-06-23
    +
    846 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    847 C>
    +
    848 C> @param[in] IWORK Array containing source data
    +
    849 C> @param[in] ISTART Starting location for this test
    +
    850 C> @param[in] NPTS Number of points in iwork
    +
    851 C> @param[out] ISAME Number of sequential points having the same value
    +
    852 C>
    +
    853 C> @note Subprogram can be called from a multiprocessing environment.
    +
    854 C>
    +
    855 C> @author Bill Cavanaugh @date 1993-06-23
    +
    856  SUBROUTINE fi7502 (IWORK,ISTART,NPTS,ISAME)
    +
    857 
    +
    858  INTEGER IWORK(*)
    +
    859  INTEGER ISTART
    +
    860  INTEGER ISAME
    +
    861  INTEGER K
    +
    862  INTEGER NPTS
    +
    863 C -------------------------------------------------------------
    +
    864  isame = 0
    +
    865  DO 100 k = istart, npts
    +
    866  IF (iwork(k).NE.iwork(istart)) THEN
    +
    867  RETURN
    +
    868  END IF
    +
    869  isame = isame + 1
    +
    870  100 CONTINUE
    +
    871  RETURN
    +
    872  END
    +
    873 C
    +
    874 C> @brief Row by row, col by col packing.
    +
    875 C> @author Bill Cavanaugh @date 1993-08-06
    +
    876 
    +
    877 C> Perform row by row or column by column packing
    +
    878 C> generating all bds information.
    +
    879 C>
    +
    880 C> Program history log:
    +
    881 C> - Bill Cavanaugh 1993-08-06
    +
    882 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    883 C>
    +
    884 C> @param[in] IWORK Integer source array
    +
    885 C> @param[in] NPTS Number of points in iwork
    +
    886 C> @param[in] IBDSFL Flags
    +
    887 C> @param[out] IPFLD Contains bds from byte 12 on
    +
    888 C> @param[out] BDS11 Contains first 11 bytes for bds
    +
    889 C> @param[out] LEN Number of bytes from 12 on
    +
    890 C> @param[out] LENBDS Total length of bds
    +
    891 C> @param PDS
    +
    892 C> @param REFNCE
    +
    893 C> @param ISCAL2
    +
    894 C> @param KWIDE
    +
    895 C> @param IGDS
    +
    896 C>
    +
    897 C> @note Subprogram can be called from a multiprocessing environment.
    +
    898 C>
    +
    899 C> @author Bill Cavanaugh @date 1993-08-06
    +
    900  SUBROUTINE fi7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11,
    +
    901  * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS)
    +
    902 
    +
    903  CHARACTER*1 BDS11(*),PDS(*),IPFLD(*)
    +
    904 C
    +
    905  REAL REFNCE
    +
    906 C
    +
    907  INTEGER ISCAL2,KWIDE
    +
    908  INTEGER LENBDS
    +
    909  INTEGER IGDS(*)
    +
    910  INTEGER LEN,KBDS(22)
    +
    911  INTEGER IWORK(*)
    +
    912 C OCTET NUMBER IN SECTION, FIRST ORDER PACKING
    +
    913 C INTEGER KBDS(12)
    +
    914 C FLAGS
    +
    915  INTEGER IBDSFL(*)
    +
    916 C EXTENDED FLAGS
    +
    917 C INTEGER KBDS(14)
    +
    918 C OCTET NUMBER FOR SECOND ORDER PACKING
    +
    919 C INTEGER KBDS(15)
    +
    920 C NUMBER OF FIRST ORDER VALUES
    +
    921 C INTEGER KBDS(17)
    +
    922 C NUMBER OF SECOND ORDER PACKED VALUES
    +
    923 C INTEGER KBDS(19)
    +
    924 C WIDTH OF SECOND ORDER PACKING
    +
    925  character(len=1) ISOWID(400000)
    +
    926 C SECONDARY BIT MAP
    +
    927  character(len=1) ISOBMP(65600)
    +
    928 C FIRST ORDER PACKED VALUES
    +
    929  character(len=1) IFOVAL(400000)
    +
    930 C SECOND ORDER PACKED VALUES
    +
    931  character(len=1) ISOVAL(800000)
    +
    932 C
    +
    933 C INTEGER KBDS(11)
    +
    934 C ----------------------------------
    +
    935 C INITIALIZE ARRAYS
    +
    936 C
    +
    937  DO i = 1, 400000
    +
    938  ifoval(i) = char(0)
    +
    939  isowid(i) = char(0)
    +
    940  ENDDO
    +
    941 C
    +
    942  DO 101 i = 1, 65600
    +
    943  isobmp(i) = char(0)
    +
    944  101 CONTINUE
    +
    945  DO 102 i = 1, 800000
    +
    946  isoval(i) = char(0)
    +
    947  102 CONTINUE
    +
    948 C INITIALIZE POINTERS
    +
    949 C SECONDARY BIT WIDTH POINTER
    +
    950  iwdptr = 0
    +
    951 C SECONDARY BIT MAP POINTER
    +
    952  ibmp2p = 0
    +
    953 C FIRST ORDER VALUE POINTER
    +
    954  ifoptr = 0
    +
    955 C BYTE POINTER TO START OF 1ST ORDER VALUES
    +
    956  kbds(12) = 0
    +
    957 C BYTE POINTER TO START OF 2ND ORDER VALUES
    +
    958  kbds(15) = 0
    +
    959 C TO CONTAIN NUMBER OF FIRST ORDER VALUES
    +
    960  kbds(17) = 0
    +
    961 C TO CONTAIN NUMBER OF SECOND ORDER VALUES
    +
    962  kbds(19) = 0
    +
    963 C SECOND ORDER PACKED VALUE POINTER
    +
    964  isoptr = 0
    +
    965 C =======================================================
    +
    966 C BUILD SECOND ORDER BIT MAP IN EITHER
    +
    967 C ROW BY ROW OR COL BY COL FORMAT
    +
    968  IF (iand(igds(13),32).NE.0) THEN
    +
    969 C COLUMN BY COLUMN
    +
    970  kout = igds(4)
    +
    971  kin = igds(5)
    +
    972 C PRINT *,'COLUMN BY COLUMN',KOUT,KIN
    +
    973  ELSE
    +
    974 C ROW BY ROW
    +
    975  kout = igds(5)
    +
    976  kin = igds(4)
    +
    977 C PRINT *,'ROW BY ROW',KOUT,KIN
    +
    978  END IF
    +
    979  kbds(17) = kout
    +
    980  kbds(19) = npts
    +
    981 C
    +
    982 C DO 4100 J = 1, NPTS, 53
    +
    983 C WRITE (6,4101) (IWORK(K),K=J,J+52)
    +
    984  4101 FORMAT (1x,25i4)
    +
    985 C PRINT *,' '
    +
    986 C4100 CONTINUE
    +
    987 C
    +
    988 C INITIALIZE BIT MAP POINTER
    +
    989  ibmp2p = 0
    +
    990 C CONSTRUCT WORKING BIT MAP
    +
    991  DO 2000 i = 1, kout
    +
    992  DO 1000 j = 1, kin
    +
    993  IF (j.EQ.1) THEN
    +
    994  CALL sbytec (isobmp,1,ibmp2p,1)
    +
    995  ELSE
    +
    996  CALL sbytec (isobmp,0,ibmp2p,1)
    +
    997  END IF
    +
    998  ibmp2p = ibmp2p + 1
    +
    999  1000 CONTINUE
    +
    1000  2000 CONTINUE
    +
    1001  len = ibmp2p / 32 + 1
    +
    1002 C CALL BINARY(ISOBMP,LEN)
    +
    1003 C
    +
    1004 C PROCESS OUTER LOOP OF ROW BY ROW OR COL BY COL
    +
    1005 C
    +
    1006  kptr = 1
    +
    1007  kbds(11) = kwide
    +
    1008  DO 6000 i = 1, kout
    +
    1009 C IN CURRENT ROW OR COL
    +
    1010 C FIND FIRST ORDER VALUE
    +
    1011  jptr = kptr
    +
    1012  lowest = iwork(jptr)
    +
    1013  DO 4000 j = 1, kin
    +
    1014  IF (iwork(jptr).LT.lowest) THEN
    +
    1015  lowest = iwork(jptr)
    +
    1016  END IF
    +
    1017  jptr = jptr + 1
    +
    1018  4000 CONTINUE
    +
    1019 C SAVE FIRST ORDER VALUE
    +
    1020  CALL sbytec (ifoval,lowest,ifoptr,kwide)
    +
    1021  ifoptr = ifoptr + kwide
    +
    1022 C PRINT *,'FOVAL',I,LOWEST,KWIDE
    +
    1023 C SUBTRACT FIRST ORDER VALUE FROM OTHER VALS
    +
    1024 C GETTING SECOND ORDER VALUES
    +
    1025  jptr = kptr
    +
    1026  ibig = iwork(jptr) - lowest
    +
    1027  DO 4200 j = 1, kin
    +
    1028  iwork(jptr) = iwork(jptr) - lowest
    +
    1029  IF (iwork(jptr).GT.ibig) THEN
    +
    1030  ibig = iwork(jptr)
    +
    1031  END IF
    +
    1032  jptr = jptr + 1
    +
    1033  4200 CONTINUE
    +
    1034 C HOW MANY BITS TO CONTAIN LARGEST SECOND
    +
    1035 C ORDER VALUE IN SEGMENT
    +
    1036  CALL fi7505 (ibig,nwide)
    +
    1037 C SAVE BIT WIDTH
    +
    1038  CALL sbytec (isowid,nwide,iwdptr,8)
    +
    1039  iwdptr = iwdptr + 8
    +
    1040 C PRINT *,I,'SOVAL',IBIG,' IN',NWIDE,' BITS'
    +
    1041 C WRITE (6,4101) (IWORK(K),K=KPTR,KPTR+52)
    +
    1042 C SAVE SECOND ORDER VALUES OF THIS SEGMENT
    +
    1043  DO 5000 j = 0, kin-1
    +
    1044  CALL sbytec (isoval,iwork(kptr+j),isoptr,nwide)
    +
    1045  isoptr = isoptr + nwide
    +
    1046  5000 CONTINUE
    +
    1047  kptr = kptr + kin
    +
    1048  6000 CONTINUE
    +
    1049 C =======================================================
    +
    1050 C CONCANTENATE ALL FIELDS FOR BDS
    +
    1051 C
    +
    1052 C REMAINDER GOES INTO IPFLD
    +
    1053  iptr = 0
    +
    1054 C BYTES 12-13
    +
    1055 C VALUE FOR N1
    +
    1056 C LEAVE SPACE FOR THIS
    +
    1057  iptr = iptr + 16
    +
    1058 C BYTE 14
    +
    1059 C EXTENDED FLAGS
    +
    1060  CALL sbytec (ipfld,ibdsfl(5),iptr,1)
    +
    1061  iptr = iptr + 1
    +
    1062  CALL sbytec (ipfld,ibdsfl(6),iptr,1)
    +
    1063  iptr = iptr + 1
    +
    1064  CALL sbytec (ipfld,ibdsfl(7),iptr,1)
    +
    1065  iptr = iptr + 1
    +
    1066  CALL sbytec (ipfld,ibdsfl(8),iptr,1)
    +
    1067  iptr = iptr + 1
    +
    1068  CALL sbytec (ipfld,ibdsfl(9),iptr,1)
    +
    1069  iptr = iptr + 1
    +
    1070  CALL sbytec (ipfld,ibdsfl(10),iptr,1)
    +
    1071  iptr = iptr + 1
    +
    1072  CALL sbytec (ipfld,ibdsfl(11),iptr,1)
    +
    1073  iptr = iptr + 1
    +
    1074  CALL sbytec (ipfld,ibdsfl(12),iptr,1)
    +
    1075  iptr = iptr + 1
    +
    1076 C BYTES 15-16
    +
    1077 C SKIP OVER VALUE FOR N2
    +
    1078  iptr = iptr + 16
    +
    1079 C BYTES 17-18
    +
    1080 C P1
    +
    1081  CALL sbytec (ipfld,kbds(17),iptr,16)
    +
    1082  iptr = iptr + 16
    +
    1083 C BYTES 19-20
    +
    1084 C P2
    +
    1085  CALL sbytec (ipfld,kbds(19),iptr,16)
    +
    1086  iptr = iptr + 16
    +
    1087 C BYTE 21 - RESERVED LOCATION
    +
    1088  CALL sbytec (ipfld,0,iptr,8)
    +
    1089  iptr = iptr + 8
    +
    1090 C BYTES 22 - ?
    +
    1091 C WIDTHS OF SECOND ORDER PACKING
    +
    1092  ix = (iwdptr + 32) / 32
    +
    1093 C CALL SBYTESC (IPFLD,ISOWID,IPTR,32,0,IX)
    +
    1094  ijk=iwdptr/8
    +
    1095  jst=(iptr/8)+1
    +
    1096  ipfld(jst:jst+ijk)=isowid(1:ijk)
    +
    1097  iptr = iptr + iwdptr
    +
    1098 C PRINT *,'ISOWID',IWDPTR,IX
    +
    1099 C CALL BINARY (ISOWID,IX)
    +
    1100 C
    +
    1101 C NO SECONDARY BIT MAP
    +
    1102 
    +
    1103 C DETERMINE LOCATION FOR START
    +
    1104 C OF FIRST ORDER PACKED VALUES
    +
    1105  kbds(12) = iptr / 8 + 12
    +
    1106 C STORE LOCATION
    +
    1107  CALL sbytec (ipfld,kbds(12),0,16)
    +
    1108 C MOVE IN FIRST ORDER PACKED VALUES
    +
    1109  ipass = (ifoptr + 32) / 32
    +
    1110 c CALL SBYTESC (IPFLD,IFOVAL,IPTR,32,0,IPASS)
    +
    1111  ijk=(ifoptr/8)+1
    +
    1112  jst=(iptr/8)+1
    +
    1113  ipfld(jst:jst+ijk)=ifoval(1:ijk)
    +
    1114  iptr = iptr + ifoptr
    +
    1115 C PRINT *,'IFOVAL',IFOPTR,IPASS,KWIDE
    +
    1116 C CALL BINARY (IFOVAL,IPASS)
    +
    1117  IF (mod(iptr,8).NE.0) THEN
    +
    1118  iptr = iptr + 8 - mod(iptr,8)
    +
    1119  END IF
    +
    1120 C PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR
    +
    1121 C DETERMINE LOCATION FOR START
    +
    1122 C OF SECOND ORDER VALUES
    +
    1123  kbds(15) = iptr / 8 + 12
    +
    1124 C SAVE LOCATION OF SECOND ORDER VALUES
    +
    1125  CALL sbytec (ipfld,kbds(15),24,16)
    +
    1126 C MOVE IN SECOND ORDER PACKED VALUES
    +
    1127  ix = (isoptr + 32) / 32
    +
    1128 C CALL SBYTESC (IPFLD,ISOVAL,IPTR,32,0,IX)
    +
    1129  ijk=(isoptr/8)+1
    +
    1130  jst=(iptr/8)+1
    +
    1131  ipfld(jst:jst+ijk)=isoval(1:ijk)
    +
    1132  iptr = iptr + isoptr
    +
    1133 C PRINT *,'ISOVAL',ISOPTR,IX
    +
    1134 C CALL BINARY (ISOVAL,IX)
    +
    1135  nleft = mod(iptr+88,16)
    +
    1136  IF (nleft.NE.0) THEN
    +
    1137  nleft = 16 - nleft
    +
    1138  iptr = iptr + nleft
    +
    1139  END IF
    +
    1140 C COMPUTE LENGTH OF DATA PORTION
    +
    1141  len = iptr / 8
    +
    1142 C COMPUTE LENGTH OF BDS
    +
    1143  lenbds = len + 11
    +
    1144 C -----------------------------------
    +
    1145 C BYTES 1-3
    +
    1146 C THIS FUNCTION COMPLETED BELOW
    +
    1147 C WHEN LENGTH OF BDS IS KNOWN
    +
    1148  CALL sbytec (bds11,lenbds,0,24)
    +
    1149 C BYTE 4
    +
    1150  CALL sbytec (bds11,ibdsfl(1),24,1)
    +
    1151  CALL sbytec (bds11,ibdsfl(2),25,1)
    +
    1152  CALL sbytec (bds11,ibdsfl(3),26,1)
    +
    1153  CALL sbytec (bds11,ibdsfl(4),27,1)
    +
    1154 C ENTER NUMBER OF FILL BITS
    +
    1155  CALL sbytec (bds11,nleft,28,4)
    +
    1156 C BYTE 5-6
    +
    1157  IF (iscal2.LT.0) THEN
    +
    1158  CALL sbytec (bds11,1,32,1)
    +
    1159  iscal2 = - iscal2
    +
    1160  ELSE
    +
    1161  CALL sbytec (bds11,0,32,1)
    +
    1162  END IF
    +
    1163  CALL sbytec (bds11,iscal2,33,15)
    +
    1164 C
    +
    1165 C$ FILL OCTET 7-10 WITH THE REFERENCE VALUE
    +
    1166 C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT
    +
    1167 C FLOATING POINT NUMBER
    +
    1168 C REFERENCE VALUE
    +
    1169 C FIRST TEST TO SEE IF
    +
    1170 C ON 32 OR 64 BIT COMPUTER
    +
    1171 C CALL W3FI01(LW)
    +
    1172  IF (bit_size(lw).EQ.32) THEN
    +
    1173  CALL w3fi76 (refnce,iexp,imant,32)
    +
    1174  ELSE
    +
    1175  CALL w3fi76 (refnce,iexp,imant,64)
    +
    1176  END IF
    +
    1177  CALL sbytec (bds11,iexp,48,8)
    +
    1178  CALL sbytec (bds11,imant,56,24)
    +
    1179 C
    +
    1180 C BYTE 11
    +
    1181 C
    +
    1182  CALL sbytec (bds11,kbds(11),80,8)
    +
    1183 C
    +
    1184  klen = lenbds / 4 + 1
    +
    1185 C PRINT *,'BDS11 LISTING',4,LENBDS
    +
    1186 C CALL BINARY (BDS11,4)
    +
    1187 C PRINT *,'IPFLD LISTING'
    +
    1188 C CALL BINARY (IPFLD,KLEN)
    +
    1189  RETURN
    +
    1190  END
    +
    1191 C
    +
    1192 C> @brief Determine number of bits to contain value.
    +
    1193 C> @author Bill Cavanaugh @date 1993-06-23
    +
    1194 
    +
    1195 C> Calculate number of bits to contain value n, with a maximum of 32 bits.
    +
    1196 C>
    +
    1197 C> Program history log:
    +
    1198 C> - Bill Cavanaugh 1993-06-23
    +
    1199 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    1200 C>
    +
    1201 C> @param[in] N Integer value
    +
    1202 C> @param[out] NBITS Number of bits to contain n
    +
    1203 C>
    +
    1204 C> @note Subprogram can be called from a multiprocessing environment.
    +
    1205 C>
    +
    1206 C> @author Bill Cavanaugh @date 1993-06-23
    +
    1207  SUBROUTINE fi7505 (N,NBITS)
    +
    1208 
    +
    1209  INTEGER N,NBITS
    +
    1210  INTEGER IBITS(31)
    +
    1211 C
    +
    1212  DATA ibits/1,3,7,15,31,63,127,255,511,1023,2047,
    +
    1213  * 4095,8191,16383,32767,65535,131071,262143,
    +
    1214  * 524287,1048575,2097151,4194303,8388607,
    +
    1215  * 16777215,33554431,67108863,134217727,268435455,
    +
    1216  * 536870911,1073741823,2147483647/
    +
    1217 C ----------------------------------------------------------------
    +
    1218 C
    +
    1219  DO 1000 nbits = 1, 31
    +
    1220  IF (n.LE.ibits(nbits)) THEN
    +
    1221  RETURN
    +
    1222  END IF
    +
    1223  1000 CONTINUE
    +
    1224  RETURN
    +
    1225  END
    +
    1226 C
    +
    1227 C> @brief Select block of data for packing.
    +
    1228 C> @author Bill Cavanaugh @date 1994-01-21
    +
    1229 
    +
    1230 C> Select a block of data for packing
    +
    1231 C>
    +
    1232 C> Program history log:
    +
    1233 C> - Bill Cavanaugh 1994-01-21
    +
    1234 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    1235 C>
    +
    1236 C> - Return address if encounter set of same values
    +
    1237 C> @param[in] IWORK
    +
    1238 C> @param[in] ISTART
    +
    1239 C> @param[in] NPTS
    +
    1240 C> @param[out] MAX
    +
    1241 C> @param[out] MIN
    +
    1242 C> @param[out] INRNGE
    +
    1243 C>
    +
    1244 C> @note Subprogram can be called from a multiprocessing environment.
    +
    1245 C>
    +
    1246 C> @author Bill Cavanaugh @date 1994-01-21
    +
    1247  SUBROUTINE fi7513 (IWORK,ISTART,NPTS,MAX,MIN,INRNGE)
    +
    1248 
    +
    1249  INTEGER IWORK(*),NPTS,ISTART,INRNGE,INRNGA,INRNGB
    +
    1250  INTEGER MAX,MIN,MXVAL,MAXB,MINB,MXVALB
    +
    1251  INTEGER IBITS(31)
    +
    1252 C
    +
    1253  DATA ibits/1,3,7,15,31,63,127,255,511,1023,2047,
    +
    1254  * 4095,8191,16383,32767,65535,131071,262143,
    +
    1255  * 524287,1048575,2097151,4194303,8388607,
    +
    1256  * 16777215,33554431,67108863,134217727,268435455,
    +
    1257  * 536870911,1073741823,2147483647/
    +
    1258 C ----------------------------------------------------------------
    +
    1259 C IDENTIFY NEXT BLOCK OF DATA FOR PACKING AND
    +
    1260 C RETURN TO CALLER
    +
    1261 C ********************************************************************
    +
    1262  istrta = istart
    +
    1263 C
    +
    1264 C GET BLOCK A
    +
    1265  CALL fi7516 (iwork,npts,inrnga,istrta,
    +
    1266  * max,min,mxval,lwide)
    +
    1267 C ********************************************************************
    +
    1268 C
    +
    1269  istrtb = istrta + inrnga
    +
    1270  2000 CONTINUE
    +
    1271 C IF HAVE PROCESSED ALL DATA, RETURN
    +
    1272  IF (istrtb.GT.npts) THEN
    +
    1273 C NO MORE DATA TO LOOK AT
    +
    1274  inrnge = inrnga
    +
    1275  RETURN
    +
    1276  END IF
    +
    1277 C GET BLOCK B
    +
    1278  CALL fi7502 (iwork,istrtb,npts,isame)
    +
    1279  IF (isame.GE.15) THEN
    +
    1280 C PRINT *,'BLOCK B HAS ALL IDENTICAL VALUES'
    +
    1281 C PRINT *,'BLOCK A HAS INRNGE =',INRNGA
    +
    1282 C BLOCK B CONTAINS ALL IDENTICAL VALUES
    +
    1283  inrnge = inrnga
    +
    1284 C EXIT WITH BLOCK A
    +
    1285  RETURN
    +
    1286  END IF
    +
    1287 C GET BLOCK B
    +
    1288 C
    +
    1289  istrtb = istrta + inrnga
    +
    1290  CALL fi7516 (iwork,npts,inrngb,istrtb,
    +
    1291  * maxb,minb,mxvalb,lwideb)
    +
    1292 C PRINT *,'BLOCK A',INRNGA,' BLOCK B',INRNGB
    +
    1293 C ********************************************************************
    +
    1294 C PERFORM TREND ANALYSIS TO DETERMINE
    +
    1295 C IF DATA COLLECTION CAN BE IMPROVED
    +
    1296 C
    +
    1297  ktrnd = lwide - lwideb
    +
    1298 C PRINT *,'TREND',LWIDE,LWIDEB
    +
    1299  IF (ktrnd.LE.0) THEN
    +
    1300 C PRINT *,'BLOCK A - SMALLER, SHOULD EXTEND INTO BLOCK B'
    +
    1301  mxval = ibits(lwide)
    +
    1302 C
    +
    1303 C IF BLOCK A REQUIRES THE SAME OR FEWER BITS
    +
    1304 C LOOK AHEAD
    +
    1305 C AND GATHER THOSE DATA POINTS THAT CAN
    +
    1306 C BE RETAINED IN BLOCK A
    +
    1307 C BECAUSE THIS BLOCK OF DATA
    +
    1308 C USES FEWER BITS
    +
    1309 C
    +
    1310  CALL fi7518 (iret,iwork,npts,istrta,inrnga,inrngb,
    +
    1311  * max,min,lwide,mxval)
    +
    1312  IF(iret.EQ.1) GO TO 8000
    +
    1313 C PRINT *,'18 INRNGA IS NOW ',INRNGA
    +
    1314  IF (inrngb.LT.20) THEN
    +
    1315  RETURN
    +
    1316  ELSE
    +
    1317  GO TO 2000
    +
    1318  END IF
    +
    1319  ELSE
    +
    1320 C PRINT *,'BLOCK A - LARGER, B SHOULD EXTEND BACK INTO A'
    +
    1321  mxvalb = ibits(lwideb)
    +
    1322 C
    +
    1323 C IF BLOCK B REQUIRES FEWER BITS
    +
    1324 C LOOK BACK
    +
    1325 C SHORTEN BLOCK A BECAUSE NEXT BLOCK OF DATA
    +
    1326 C USES FEWER BITS
    +
    1327 C
    +
    1328  CALL fi7517 (iret,iwork,npts,istrtb,inrnga,
    +
    1329  * maxb,minb,lwideb,mxvalb)
    +
    1330  IF(iret.EQ.1) GO TO 8000
    +
    1331 C PRINT *,'17 INRNGA IS NOW ',INRNGA
    +
    1332  END IF
    +
    1333 C
    +
    1334 C PACK UP BLOCK A
    +
    1335 C UPDATA POINTERS
    +
    1336  8000 CONTINUE
    +
    1337  inrnge = inrnga
    +
    1338 C GET NEXT BLOCK A
    +
    1339  9000 CONTINUE
    +
    1340  RETURN
    +
    1341  END
    +
    1342 C
    +
    1343 C> @brief Scan number of points.
    +
    1344 C> @author Bill Cavanaugh @date 1994-01-21
    +
    1345 
    +
    1346 C> Scan forward from current position. collect points and
    +
    1347 C> determine maximum and minimum values and the number
    +
    1348 C> of points that are included. Forward search is terminated
    +
    1349 C> by encountering a set of identical values, by reaching
    +
    1350 C> the number of points selected or by reaching the end
    +
    1351 C> of data.
    +
    1352 C>
    +
    1353 C> Program history log:
    +
    1354 C> - Bill Cavavnaugh 1994-01-21
    +
    1355 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    1356 C>
    +
    1357 C> - Return address if encounter set of same values
    +
    1358 C> @param[in] IWORK Data array
    +
    1359 C> @param[in] NPTS Number of points in data array
    +
    1360 C> @param[in] ISTART Starting location in data
    +
    1361 C> @param[out] INRNG Number of points selected
    +
    1362 C> @param[out] MAX Maximum value of points
    +
    1363 C> @param[out] MIN Minimum value of points
    +
    1364 C> @param[out] MXVAL Maximum value that can be contained in lwidth bits
    +
    1365 C> @param[out] LWIDTH Number of bits to contain max diff
    +
    1366 C>
    +
    1367 C> @note Subprogram can be called from a multiprocessing environment.
    +
    1368 C>
    +
    1369 C> @author Bill Cavanaugh @date 1994-01-21
    +
    1370  SUBROUTINE fi7516 (IWORK,NPTS,INRNG,ISTART,MAX,MIN,MXVAL,LWIDTH)
    +
    1371 
    +
    1372  INTEGER IWORK(*),NPTS,ISTART,INRNG,MAX,MIN,LWIDTH,MXVAL
    +
    1373  INTEGER IBITS(31)
    +
    1374 C
    +
    1375  DATA ibits/1,3,7,15,31,63,127,255,511,1023,2047,
    +
    1376  * 4095,8191,16383,32767,65535,131071,262143,
    +
    1377  * 524287,1048575,2097151,4194303,8388607,
    +
    1378  * 16777215,33554431,67108863,134217727,268435455,
    +
    1379  * 536870911,1073741823,2147483647/
    +
    1380 C ----------------------------------------------------------------
    +
    1381 C
    +
    1382  inrng = 1
    +
    1383  jq = istart + 19
    +
    1384  max = iwork(istart)
    +
    1385  min = iwork(istart)
    +
    1386  DO 1000 i = istart+1, jq
    +
    1387  CALL fi7502 (iwork,i,npts,isame)
    +
    1388  IF (isame.GE.15) THEN
    +
    1389  GO TO 5000
    +
    1390  END IF
    +
    1391  inrng = inrng + 1
    +
    1392  IF (iwork(i).GT.max) THEN
    +
    1393  max = iwork(i)
    +
    1394  ELSE IF (iwork(i).LT.min) THEN
    +
    1395  min = iwork(i)
    +
    1396  END IF
    +
    1397  1000 CONTINUE
    +
    1398  5000 CONTINUE
    +
    1399  krng = max - min
    +
    1400 C
    +
    1401  DO 9000 lwidth = 1, 31
    +
    1402  IF (krng.LE.ibits(lwidth)) THEN
    +
    1403 C PRINT *,'RETURNED',INRNG,' VALUES'
    +
    1404  RETURN
    +
    1405  END IF
    +
    1406  9000 CONTINUE
    +
    1407  RETURN
    +
    1408  END
    +
    1409 C
    +
    1410 C> @brief Scan backward.
    +
    1411 C> @author Bill Cavanaugh @date 1994-01-21
    +
    1412 
    +
    1413 C> Scan backwards until a value exceeds range of group b this may shorten group a
    +
    1414 C>
    +
    1415 C> Program history log:
    +
    1416 C> - Bill Cavanaugh 1994-01-21
    +
    1417 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    1418 C> - Mark Iredell 1998-06-17 Removed alternate return
    +
    1419 C>
    +
    1420 C> @param[in] IWORK
    +
    1421 C> @param[in] ISTRTB
    +
    1422 C> @param[in] NPTS
    +
    1423 C> @param[in] INRNGA
    +
    1424 C> @param[out] IRET
    +
    1425 C> @param[out] MAXB
    +
    1426 C> @param[out] MINB
    +
    1427 C> @param MXVALB
    +
    1428 C> @param LWIDEB
    +
    1429 C>
    +
    1430 C> @note Subprogram can be called from a multiprocessing environment.
    +
    1431 C>
    +
    1432 C> @author Bill Cavanaugh @date 1994-01-21
    +
    1433  SUBROUTINE fi7517 (IRET,IWORK,NPTS,ISTRTB,INRNGA,
    +
    1434  * MAXB,MINB,MXVALB,LWIDEB)
    +
    1435 
    +
    1436  INTEGER IWORK(*),NPTS,ISTRTB,INRNGA
    +
    1437  INTEGER MAXB,MINB,LWIDEB,MXVALB
    +
    1438  INTEGER IBITS(31)
    +
    1439 C
    +
    1440  DATA ibits/1,3,7,15,31,63,127,255,511,1023,2047,
    +
    1441  * 4095,8191,16383,32767,65535,131071,262143,
    +
    1442  * 524287,1048575,2097151,4194303,8388607,
    +
    1443  * 16777215,33554431,67108863,134217727,268435455,
    +
    1444  * 536870911,1073741823,2147483647/
    +
    1445 C ----------------------------------------------------------------
    +
    1446  iret=0
    +
    1447 C PRINT *,' FI7517'
    +
    1448  npos = istrtb - 1
    +
    1449  itst = 0
    +
    1450  kset = inrnga
    +
    1451 C
    +
    1452  1000 CONTINUE
    +
    1453 C PRINT *,'TRY NPOS',NPOS,IWORK(NPOS),MAXB,MINB
    +
    1454  itst = itst + 1
    +
    1455  IF (itst.LE.kset) THEN
    +
    1456  IF (iwork(npos).GT.maxb) THEN
    +
    1457  IF ((iwork(npos)-minb).GT.mxvalb) THEN
    +
    1458 C PRINT *,'WENT OUT OF RANGE AT',NPOS
    +
    1459  iret=1
    +
    1460  RETURN
    +
    1461  ELSE
    +
    1462  maxb = iwork(npos)
    +
    1463  END IF
    +
    1464  ELSE IF (iwork(npos).LT.minb) THEN
    +
    1465  IF ((maxb-iwork(npos)).GT.mxvalb) THEN
    +
    1466 C PRINT *,'WENT OUT OF RANGE AT',NPOS
    +
    1467  iret=1
    +
    1468  RETURN
    +
    1469  ELSE
    +
    1470  minb = iwork(npos)
    +
    1471  END IF
    +
    1472  END IF
    +
    1473  inrnga = inrnga - 1
    +
    1474  npos = npos - 1
    +
    1475  GO TO 1000
    +
    1476  END IF
    +
    1477 C ----------------------------------------------------------------
    +
    1478 C
    +
    1479  9000 CONTINUE
    +
    1480  RETURN
    +
    1481  END
    +
    1482 C
    +
    1483 C> @brief Scan forward.
    +
    1484 C> @author Bill Cavanaugh @date 1994-01-21
    +
    1485 
    +
    1486 C> Scan forward from start of block b towards end of block b
    +
    1487 C> if next point under test forces a larger maxvala then
    +
    1488 C> terminate indicating last point tested for inclusion
    +
    1489 C> into block a.
    +
    1490 C>
    +
    1491 C> Program history log:
    +
    1492 C> - Bill Cavanaugh 1994-01-21
    +
    1493 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    1494 C> - Mark Iredell 1998-06-17 Removed alternate return
    +
    1495 C>
    +
    1496 C> @param IWORK
    +
    1497 C> @param ISTRTA
    +
    1498 C> @param INRNGA
    +
    1499 C> @param INRNGB
    +
    1500 C> @param MAXA
    +
    1501 C> @param MINA
    +
    1502 C> @param LWIDEA
    +
    1503 C> @param MXVALA
    +
    1504 C> @param[in] NPTS
    +
    1505 C> @param[out] IRET
    +
    1506 C>
    +
    1507 C> @note Subprogram can be called from a multiprocessing environment.
    +
    1508 C>
    +
    1509 C> @author Bill Cavanaugh @date 1994-01-21
    +
    1510  SUBROUTINE fi7518 (IRET,IWORK,NPTS,ISTRTA,INRNGA,INRNGB,
    +
    1511  * MAXA,MINA,LWIDEA,MXVALA)
    +
    1512 
    +
    1513  INTEGER IWORK(*),NPTS,ISTRTA,INRNGA
    +
    1514  INTEGER MAXA,MINA,LWIDEA,MXVALA
    +
    1515  INTEGER IBITS(31)
    +
    1516 C
    +
    1517  DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047,
    +
    1518  * 4095,8191,16383,32767,65535,131071,262143,
    +
    1519  * 524287,1048575,2097151,4194303,8388607,
    +
    1520  * 16777215,33554431,67108863,134217727,268435455,
    +
    1521  * 536870911,1073741823,2147483647/
    +
    1522 C ----------------------------------------------------------------
    +
    1523  iret=0
    +
    1524 C PRINT *,' FI7518'
    +
    1525  npos = istrta + inrnga
    +
    1526  itst = 0
    +
    1527 C
    +
    1528  1000 CONTINUE
    +
    1529  itst = itst + 1
    +
    1530  IF (itst.LE.inrngb) THEN
    +
    1531 C PRINT *,'TRY NPOS',NPOS,IWORK(NPOS),MAXA,MINA
    +
    1532  IF (iwork(npos).GT.maxa) THEN
    +
    1533  IF ((iwork(npos)-mina).GT.mxvala) THEN
    +
    1534 C PRINT *,'FI7518A -',ITST,' RANGE EXCEEDS MAX'
    +
    1535  iret=1
    +
    1536  RETURN
    +
    1537  ELSE
    +
    1538  maxa = iwork(npos)
    +
    1539  END IF
    +
    1540  ELSE IF (iwork(npos).LT.mina) THEN
    +
    1541  IF ((maxa-iwork(npos)).GT.mxvala) THEN
    +
    1542 C PRINT *,'FI7518B -',ITST,' RANGE EXCEEDS MAX'
    +
    1543  iret=1
    +
    1544  RETURN
    +
    1545  ELSE
    +
    1546  mina = iwork(npos)
    +
    1547  END IF
    +
    1548  END IF
    +
    1549  inrnga = inrnga + 1
    +
    1550 C PRINT *,' ',ITST,INRNGA
    +
    1551  npos = npos +1
    +
    1552  GO TO 1000
    +
    1553  END IF
    +
    1554 C ----------------------------------------------------------------
    +
    1555  9000 CONTINUE
    +
    1556  RETURN
    +
    1557  END
    +
    +
    +
    fi7513
    subroutine fi7513(IWORK, ISTART, NPTS, MAX, MIN, INRNGE)
    Select block of data for packing.
    Definition: w3fi75.f:1248
    +
    fi7502
    subroutine fi7502(IWORK, ISTART, NPTS, ISAME)
    Second order same value collection.
    Definition: w3fi75.f:857
    +
    fi7517
    subroutine fi7517(IRET, IWORK, NPTS, ISTRTB, INRNGA, MAXB, MINB, MXVALB, LWIDEB)
    Scan backward.
    Definition: w3fi75.f:1435
    +
    w3fi76
    subroutine w3fi76(PVAL, KEXP, KMANT, KBITS)
    Converts floating point number from machine representation to grib representation (ibm370 32 bit f....
    Definition: w3fi76.f:24
    +
    fi7501
    subroutine fi7501(IWORK, IPFLD, NPTS, IBDSFL, BDS11, LEN, LENBDS, PDS, REFNCE, ISCAL2, KWIDE)
    BDS second order packing.
    Definition: w3fi75.f:537
    +
    w3fi82
    subroutine w3fi82(IFLD, FVAL1, FDIFF1, NPTS, PDS, IGDS)
    Accept an input array, convert to array of second differences.
    Definition: w3fi82.f:31
    +
    w3fi59
    subroutine w3fi59(FIELD, NPTS, NBITS, NWORK, NPFLD, ISCALE, LEN, RMIN)
    Converts an array of single precision real numbers into an array of positive scaled differences (numb...
    Definition: w3fi59.f:48
    +
    w3fi75
    subroutine w3fi75(IBITL, ITYPE, ITOSS, FLD, IFLD, IBMAP, IBDSFL, NPTS, BDS11, IPFLD, PFLD, LEN, LENBDS, IBERR, PDS, IGDS)
    This routine packs a grib field and forms octets(1-11) of the binary data section (bds).
    Definition: w3fi75.f:90
    +
    gbytec
    subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
    Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
    Definition: gbytec.f:14
    +
    fi7516
    subroutine fi7516(IWORK, NPTS, INRNG, ISTART, MAX, MIN, MXVAL, LWIDTH)
    Scan number of points.
    Definition: w3fi75.f:1371
    +
    fi7503
    subroutine fi7503(IWORK, IPFLD, NPTS, IBDSFL, BDS11, LEN, LENBDS, PDS, REFNCE, ISCAL2, KWIDE, IGDS)
    Row by row, col by col packing.
    Definition: w3fi75.f:902
    +
    w3fi58
    subroutine w3fi58(IFIELD, NPTS, NWORK, NPFLD, NBITS, LEN, KMIN)
    Converts an array of integer numbers into an array of positive differences (number(s) - minimum value...
    Definition: w3fi58.f:39
    +
    fi7518
    subroutine fi7518(IRET, IWORK, NPTS, ISTRTA, INRNGA, INRNGB, MAXA, MINA, LWIDEA, MXVALA)
    Scan forward.
    Definition: w3fi75.f:1512
    +
    fi7505
    subroutine fi7505(N, NBITS)
    Determine number of bits to contain value.
    Definition: w3fi75.f:1208
    +
    sbytesc
    subroutine sbytesc(OUT, IN, ISKIP, NBYTE, NSKIP, N)
    Store bytes - pack bits: Put arbitrary size values into a packed bit string, taking the low order bit...
    Definition: sbytesc.f:17
    +
    sbytec
    subroutine sbytec(OUT, IN, ISKIP, NBYTE)
    This is a wrapper for sbytesc()
    Definition: sbytec.f:14
    + + + + diff --git a/ver-2.10.0/w3fi76_8f.html b/ver-2.10.0/w3fi76_8f.html new file mode 100644 index 00000000..f2ff995e --- /dev/null +++ b/ver-2.10.0/w3fi76_8f.html @@ -0,0 +1,185 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi76.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi76.f File Reference
    +
    +
    + +

    Convert to ibm370 floating point. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi76 (PVAL, KEXP, KMANT, KBITS)
     Converts floating point number from machine representation to grib representation (ibm370 32 bit f.p.). More...
     
    +

    Detailed Description

    +

    Convert to ibm370 floating point.

    +
    Author
    John Hennessy
    +
    Date
    1985-09-15
    + +

    Definition in file w3fi76.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi76()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi76 (real PVAL,
    integer KEXP,
    integer KMANT,
    integer KBITS 
    )
    +
    + +

    Converts floating point number from machine representation to grib representation (ibm370 32 bit f.p.).

    +

    Program history log:

      +
    • John Hennessy 1985-09-15
      • +
    • Ralph Jones 1992-09-23 Change name, add doc block
      • +
    • Ralph Jones 1993-10-27 Change to agree with hennessy changes
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints
      • +
    • Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive
      • +
    +
    Parameters
    + + + + + +
    [in]PVALFloating point number to be converted
    [in]KBITSNumber of bits in computer word (32 or 64)
    [out]KEXP8 Bit signed exponent
    [out]KMANT24 Bit mantissa (fraction)
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment.
    +
    Author
    John Hennessy
    +
    Date
    1985-09-15
    + +

    Definition at line 24 of file w3fi76.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi76_8f.js b/ver-2.10.0/w3fi76_8f.js new file mode 100644 index 00000000..317baf2c --- /dev/null +++ b/ver-2.10.0/w3fi76_8f.js @@ -0,0 +1,4 @@ +var w3fi76_8f = +[ + [ "w3fi76", "w3fi76_8f.html#a5af5a733105c5ce75ddfe99f7249f999", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi76_8f_source.html b/ver-2.10.0/w3fi76_8f_source.html new file mode 100644 index 00000000..bf4bfa0d --- /dev/null +++ b/ver-2.10.0/w3fi76_8f_source.html @@ -0,0 +1,224 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi76.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi76.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert to ibm370 floating point
    +
    3 C> @author John Hennessy @date 1985-09-15
    +
    4 
    +
    5 C> Converts floating point number from machine
    +
    6 C> representation to grib representation (ibm370 32 bit f.p.).
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - John Hennessy 1985-09-15
    +
    10 C> - Ralph Jones 1992-09-23 Change name, add doc block
    +
    11 C> - Ralph Jones 1993-10-27 Change to agree with hennessy changes
    +
    12 C> - Mark Iredell 1995-10-31 Removed saves and prints
    +
    13 C> - Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive
    +
    14 C>
    +
    15 C> @param[in] PVAL Floating point number to be converted
    +
    16 C> @param[in] KBITS Number of bits in computer word (32 or 64)
    +
    17 C> @param[out] KEXP 8 Bit signed exponent
    +
    18 C> @param[out] KMANT 24 Bit mantissa (fraction)
    +
    19 C>
    +
    20 C> @note Subprogram can be called from a multiprocessing environment.
    +
    21 C>
    +
    22 C> @author John Hennessy @date 1985-09-15
    +
    23  SUBROUTINE w3fi76(PVAL,KEXP,KMANT,KBITS)
    +
    24 C
    +
    25 C********************************************************************
    +
    26 C*
    +
    27 C* NAME : CONFP3
    +
    28 C*
    +
    29 C* FUNCTION : CONVERT FLOATING POINT NUMBER FROM MACHINE
    +
    30 C* REPRESENTATION TO GRIB REPRESENTATION.
    +
    31 C*
    +
    32 C* INPUT : PVAL - FLOATING POINT NUMBER TO BE CONVERTED.
    +
    33 C* KBITS : KBITS - NUMBER OF BITS IN COMPUTER WORD
    +
    34 C*
    +
    35 C* OUTPUT : KEXP - 8 BIT SIGNED EXPONENT
    +
    36 C* KMANT - 24 BIT MANTISSA
    +
    37 C* PVAL - UNCHANGED.
    +
    38 C*
    +
    39 C* JOHN HENNESSY , ECMWF 18.06.91
    +
    40 C*
    +
    41 C********************************************************************
    +
    42 C
    +
    43 C
    +
    44 C IMPLICIT NONE
    +
    45 C
    +
    46  INTEGER IEXP
    +
    47  INTEGER ISIGN
    +
    48 C
    +
    49  INTEGER KBITS
    +
    50  INTEGER KEXP
    +
    51  INTEGER KMANT
    +
    52 C
    +
    53  REAL PVAL
    +
    54  REAL ZEPS
    +
    55  REAL ZREF
    +
    56 C
    +
    57 C TEST FOR FLOATING POINT ZERO
    +
    58 C
    +
    59  IF (pval.EQ.0.0) THEN
    +
    60  kexp = 0
    +
    61  kmant = 0
    +
    62  GO TO 900
    +
    63  ENDIF
    +
    64 C
    +
    65 C SET ZEPS TO 1.0E-12 FOR 64 BIT COMPUTERS (CRAY)
    +
    66 C SET ZEPS TO 1.0E-8 FOR 32 BIT COMPUTERS
    +
    67 C
    +
    68  IF (kbits.EQ.32) THEN
    +
    69  zeps = 1.0e-8
    +
    70  ELSE
    +
    71  zeps = 1.0e-12
    +
    72  ENDIF
    +
    73  zref = pval
    +
    74 C
    +
    75 C SIGN OF VALUE
    +
    76 C
    +
    77  isign = 0
    +
    78  IF (zref.LT.0.0) THEN
    +
    79  isign = 128
    +
    80  zref = - zref
    +
    81  ENDIF
    +
    82 C
    +
    83 C EXPONENT
    +
    84 C
    +
    85  iexp = int(alog(zref)*(1.0/alog(16.0))+64.0+1.0+zeps)
    +
    86 C
    +
    87  IF (iexp.LT.0 ) iexp = 0
    +
    88  IF (iexp.GT.127) iexp = 127
    +
    89 C
    +
    90 C MANTISSA
    +
    91 C
    +
    92 C CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER
    +
    93 C (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER).
    +
    94 C
    +
    95  kmant = nint(zref/16.0**(iexp-70))
    +
    96 C
    +
    97 C CHECK THAT MANTISSA VALUE DOES NOT EXCEED 24 BITS
    +
    98 C 16777215 = 2**24 - 1
    +
    99 C
    +
    100  IF (kmant.GT.16777215) THEN
    +
    101  iexp = iexp + 1
    +
    102 C
    +
    103 C CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER
    +
    104 C (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER).
    +
    105 C
    +
    106  kmant = nint(zref/16.0**(iexp-70))
    +
    107 C
    +
    108 C CHECK MANTISSA VALUE DOES NOT EXCEED 24 BITS AGAIN
    +
    109 C
    +
    110  IF (kmant.GT.16777215) THEN
    +
    111  print *,'BAD MANTISSA VALUE FOR PVAL = ',pval
    +
    112  ENDIF
    +
    113  ENDIF
    +
    114 C
    +
    115 C ADD SIGN BIT TO EXPONENT.
    +
    116 C
    +
    117  kexp = iexp + isign
    +
    118 C
    +
    119  900 CONTINUE
    +
    120 C
    +
    121  RETURN
    +
    122  END
    +
    +
    +
    w3fi76
    subroutine w3fi76(PVAL, KEXP, KMANT, KBITS)
    Converts floating point number from machine representation to grib representation (ibm370 32 bit f....
    Definition: w3fi76.f:24
    + + + + diff --git a/ver-2.10.0/w3fi78_8f.html b/ver-2.10.0/w3fi78_8f.html new file mode 100644 index 00000000..650cb0ef --- /dev/null +++ b/ver-2.10.0/w3fi78_8f.html @@ -0,0 +1,1630 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi78.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi78.f File Reference
    +
    +
    + +

    BUFR Message decoder. +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

    +Functions/Subroutines

    subroutine fi7801 (IPTR, IDENT, MSGA, ISTACK, IWORK, ANAME, KDATA, IVALS, MSTACK, AUNITS, KDESC, MWIDTH, MREF, MSCALE, KNR, INDEX, MAXR, MAXD, IUNITB, IUNITD)
     Data extraction. More...
     
    subroutine fi7802 (IPTR, IDENT, MSGA, KDATA, KDESC, LL, MSTACK, AUNITS, MWIDTH, MREF, MSCALE, JDESC, IVALS, J, MAXR, MAXD)
     Process standard descriptor. More...
     
    subroutine fi7803 (IPTR, IDENT, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, JDESC, MAXR, MAXD)
     Process compressed data. More...
     
    subroutine fi7804 (IPTR, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, LL, JDESC, MAXR, MAXD)
     Process serial data. More...
     
    subroutine fi7805 (IPTR, IDENT, MSGA, IWORK, LX, LY, KDATA, LL, KNR, MSTACK, MAXR, MAXD)
     Process a replication descriptor. More...
     
    subroutine fi7806 (IPTR, LX, LY, IDENT, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, LL, KDESC, IWORK, JDESC, MAXR, MAXD)
     Process operator descriptors. More...
     
    subroutine fi7807 (IPTR, IWORK, ITBLD, JDESC, MAXD)
     Process queue descriptor. More...
     
    subroutine fi7808 (IPTR, IWORK, LF, LX, LY, JDESC, MAXD)
     Program history log: More...
     
    subroutine fi7809 (IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
     Reformat profiler w hgt increments. More...
     
    subroutine fi7810 (IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
     Reformat profiler edition 2 data. More...
     
    subroutine w3fi78 (IPTR, IDENT, MSGA, ISTACK, MSTACK, KDATA, KNR, INDEX, MAXR, MAXD, IUNITB, IUNITD)
     This set of routines will decode a BUFR message and place information extracted from the BUFR message into selected arrays for the user.The array kdata can now be sized by the user by indicating the maximum number of substes and the maximum number of descriptors that are expected in the course of decoding selected input data. More...
     
    +

    Detailed Description

    +

    BUFR Message decoder.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-08-31
    + +

    Definition in file w3fi78.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ fi7801()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7801 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(*) ISTACK,
    integer, dimension(*) IWORK,
    character*40, dimension(*) ANAME,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) IVALS,
    integer, dimension(2,maxd) MSTACK,
    character*24, dimension(*) AUNITS,
    integer, dimension(*) KDESC,
    integer, dimension(*) MWIDTH,
    integer, dimension(700,3) MREF,
    integer, dimension(*) MSCALE,
    integer, dimension(maxr) KNR,
    integer INDEX,
     MAXR,
     MAXD,
     IUNITB,
     IUNITD 
    )
    +
    + +

    Data extraction.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Control the extraction of data from section 4 based on data descriptors.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed data.
      • +
    • Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with delayed replication.
      • +
    • Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + + + + + + + +
    [in]IPTRSee w3fi78() routine docblock
    [in]IDENTSee w3fi78() routine docblock
    [in]MSGAArray containing bufr message
    [in,out]ISTACKOriginal array of descriptors extracted from source bufr message.
    [in]MSTACKWorking array of descriptors (expanded)and scaling factor
    [in,out]KDESCImage of current descriptor
    [in]INDEX
    [in]MAXRmaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1600, but for most other data a value for maxd of 500 will suffice
    [in]IUNITBUnit number of data set holding table b
    [in]IUNITDUnit number of data set holding table d
    [out]IWORKWorking descriptor list
    [out]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd) arrays containing data from table b
    [out]ANAMEDescriptor name
    [out]AUNITSUnits for descriptor
    [out]MSCALEScale for value of descriptor
    [out]MREFReference value for descriptor
    [out]MWIDTHBit width for value of descriptor
    IVALS
    KNRError return: IPTR(1)
      +
    • = 8 Error reading table b
      • +
    • = 9 Error reading table d
      • +
    • = 11 Error opening table b
      • +
    +
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 678 of file w3fi78.f.

    + +
    +
    + +

    ◆ fi7802()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7802 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) KDESC,
     LL,
    integer, dimension(2,maxd) MSTACK,
    character*24, dimension(*) AUNITS,
    integer, dimension(*) MWIDTH,
    integer, dimension(700,3) MREF,
    integer, dimension(*) MSCALE,
    integer JDESC,
    integer, dimension(*) IVALS,
    integer J,
     MAXR,
     MAXD 
    )
    +
    + +

    Process standard descriptor.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Process a standard descriptor (f = 0) and store data in output array.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-04-04 Changed to pass width of text fields in bytes
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + + + +
    [in]IPTRSee w3fi78 routine docblock
    [in]IDENTSee w3fi78 routine docblock
    [in]MSGAArray containing bufr message
    [in,out]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd)
    [in,out]KDESCImage of current descriptor
    [in]MSTACK
    [in]MAXRmaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1600, but for most other data a value for maxd of 500 will suffice Arrays containing data from table B
    [out]AUNITSUnits for descriptor
    [out]MSCALEScale for value of descriptor
    [out]MREFReference value for descriptor
    [out]MWIDTHBit width for value of descriptor
    LL
    JDESC
    IVALS
    JError return: IPTR(1) = 3 - Message contains a descriptor with f=0 that does not exist in table b.
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 995 of file w3fi78.f.

    + +
    +
    + +

    ◆ fi7803()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7803 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) IVALS,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(*) MWIDTH,
    integer, dimension(700,3) MREF,
    integer, dimension(*) MSCALE,
    integer J,
    integer JDESC,
     MAXR,
     MAXD 
    )
    +
    + +

    Process compressed data.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Process compressed data and place individual elements into output array.
    +

    PROGRAM HISTORY LOG:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-04-04 Text handling portion of this routine modified to hanle width of fields in bytes.
      • +
    • Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed and uncompressed form gave different results. This has been corrected.
      • +
    • Bill Cavanaugh 1991-06-21 Processing of text data has been changed to provide exact reproduction of all characters.
      • +
    +
    Parameters
    + + + + + + + + + + + + + + +
    [in]IPTRSee w3fi78() routine docblock
    [in]IDENTSee w3fi78() routine docblock
    [in]MSGAArray containing bufr message,mstack,
    [in]IVALSArray of single parameter values
    [in,out]J
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message.
    [in]MAXDMaximum number of descriptor combinations that may be processed; Upper air data and some satellite data require a value for maxd of 1600, but for most other data a value for maxd of 500 will suffice.
    [out]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd) Arrays containing data from table B.
    [out]MSCALEScale for value of descriptor
    [out]MREFReference value for descriptor
    [out]MWIDTHBit width for value of descriptor
    MSTACK
    JDESC
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1151 of file w3fi78.f.

    + +
    +
    + +

    ◆ fi7804()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7804 (integer, dimension(*) IPTR,
    integer, dimension(*) MSGA,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) IVALS,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(*) MWIDTH,
    integer, dimension(700,3) MREF,
    integer, dimension(*) MSCALE,
    integer J,
    integer LL,
    integer JDESC,
     MAXR,
     MAXD 
    )
    +
    + +

    Process serial data.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Process data that is not compressed.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-01-18 Modified to properly handle non-compressed data.
      • +
    • Bill Cavanaugh 1991-04-04 Text handling portion of this routine modified to handle field width in bytes.
      • +
    • Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed and uncompressed form gave different results. this has been corrected.
      • +
    +
    Parameters
    + + + + + + + + + + + + + + +
    [in]IPTRSee w3fi78 routine docblock
    [in]MSGAArray containing bufr message
    [in,out]IVALSArray of single parameter values
    [in,out]J
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1600, but for most other data a value for maxd of 500 will suffice
    [out]KDATAArray containing decoded reports from bufr message. KDATA(report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd) arrays containing data from table B
    [out]MSCALEScale for value of descriptor
    [out]MREFReference value for descriptor
    [out]MWIDTHBit width for value of descriptor
    MSTACK
    LL
    JDESCError return: IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1420 of file w3fi78.f.

    + +
    +
    + +

    ◆ fi7805()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7805 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(maxd) IWORK,
    integer LX,
    integer LY,
    integer, dimension(maxr,maxd) KDATA,
    integer LL,
    integer, dimension(maxr) KNR,
    integer, dimension(2,maxd) MSTACK,
     MAXR,
     MAXD 
    )
    +
    + +

    Process a replication descriptor.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Process a replication descriptor, must extract number of replications of n descriptors from the data stream.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    +
    Parameters
    + + + + + + + + + + + + + +
    [in]IWORKWorking descriptor list
    [in]IPTRSee w3fi78 routine docblock
    [in]IDENTSee w3fi78 routine docblock
    [in,out]LXX portion of current descriptor
    [in,out]LYY portion of current descriptor
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message.
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1600, but for most other data a value for maxd of 500 will suffice
    [out]KDATAArray containing decoded reports from bufr message. KDATA(report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd)
    MSGA
    LL
    KNR
    MSTACKError return: IPTR(1):
      +
    • = 12 Data descriptor qualifier does not follow delayed replication descriptor
      • +
    • = 20 Exceeded count for delayed replication pass
      • +
    +
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1589 of file w3fi78.f.

    + +
    +
    + +

    ◆ fi7806()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7806 (integer, dimension(*) IPTR,
    integer LX,
    integer LY,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) IVALS,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(*) MWIDTH,
    integer, dimension(700,3) MREF,
    integer, dimension(*) MSCALE,
    integer J,
    integer LL,
    integer, dimension(*) KDESC,
    integer, dimension(*) IWORK,
    integer JDESC,
     MAXR,
     MAXD 
    )
    +
    + +

    Process operator descriptors.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Extract and save indicated change values for use until changes are rescinded, or extract text strings indicated through 2 05 yyy.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
      • +
    • Bill Cavanaugh 1991-05-10 Coding has been added to process proposed table c descriptor 2 06 yyy.
      • +
    • Bill Cavanaugh 1991-11-21 Coding has been added to properly process table c descriptor 2 03 yyy, the change to new reference value for selected descriptors.
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + + + + + +
    [in]IPTRSee w3fi78 routine docblock
    [in]LXX portion of current descriptor
    [in]LYY portion of current descriptor
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1600, but for most other data a value for maxd of 500 will suffice
    [out]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd) Arrays containing data from table b
    [out]MSCALEScale for value of descriptor
    [out]MREFReference value for descriptor
    [out]MWIDTHBit width for value of descriptor
    IDENT
    MSGA
    IVALS
    MSTACK
    J
    LL
    KDESC
    JDESC
    IWORKError return: IPTR(1) = 5 - Erroneous X value in data descriptor operator
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1762 of file w3fi78.f.

    + +
    +
    + +

    ◆ fi7807()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7807 (integer, dimension(*) IPTR,
    integer, dimension(*) IWORK,
    integer, dimension(500,11) ITBLD,
    integer JDESC,
     MAXD 
    )
    +
    + +

    Process queue descriptor.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Substitute descriptor queue for queue descriptor.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors.
      • +
    • Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors. based on tests with live data.
      • +
    +
    Parameters
    + + + + + + +
    [in]IWORKWorking descriptor list
    [in]IPTRSee w3fi78 routine docblock
    MAXD
    [in]ITBLDArray containing descriptor queues
    [in]JDESCQueue descriptor to be expanded
    +
    +
    + +

    Definition at line 1903 of file w3fi78.f.

    + +
    +
    + +

    ◆ fi7808()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7808 (integer, dimension(*) IPTR,
    integer, dimension(*) IWORK,
    integer LF,
    integer LX,
    integer LY,
    integer JDESC,
     MAXD 
    )
    +
    + +

    Program history log:

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 - Bill Cavanaugh 1988-09-01
    +
    Parameters
    + + + + + + + + +
    [in,out]IPTRSee w3fi78() routine docblock
    [in]IWORKWorking descriptor list
    LF
    LX
    LY
    JDESC
    MAXD
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 2009 of file w3fi78.f.

    + +
    +
    + +

    ◆ fi7809()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7809 (integer, dimension(*) IDENT,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) IPTR,
     MAXR,
     MAXD 
    )
    +
    + +

    Reformat profiler w hgt increments.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1990-02-14 Reformat decoded profiler data to show heights instead of height increments.
    +

    Program history log:

      +
    • Bill Cavanaugh 1990-02-14
      • +
    +
    Parameters
    + + + + + + + +
    [in]IDENTArray contains message information extracted from BUFR message:
      +
    • IDENT(1)- Edition number (byte 4, section 1)
      • +
    • IDENT(2)- Originating center (bytes 5-6, section 1)
      • +
    • IDENT(3)- Update sequence (byte 7, section 1)
      • +
    • IDENT(4)- (byte 8, section 1)
      • +
    • IDENT(5)- Bufr message type (byte 9, section 1)
      • +
    • IDENT(6)- Bufr msg sub-type (byte 10, section 1)
      • +
    • IDENT(7)- (bytes 11-12, section 1)
      • +
    • IDENT(8)- Year of century (byte 13, section 1)
      • +
    • IDENT(9)- Month of year (byte 14, section 1)
      • +
    • IDENT(10)- Day of month (byte 15, section 1)
      • +
    • IDENT(11)- Hour of day (byte 16, section 1)
      • +
    • IDENT(12)- Minute of hour (byte 17, section 1)
      • +
    • IDENT(13)- Rsvd by adp centers(byte 18, section 1)
      • +
    • IDENT(14)- Nr of data subsets (byte 5-6, section 3)
      • +
    • IDENT(15)- Observed flag (byte 7, bit 1, section 3)
      • +
    • IDENT(16)- Compression flag (byte 7, bit 2, section 3)
      • +
    +
    [in]MSTACKWorking descriptor list and scaling factor
    [in]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd)
    [in]IPTRSee w3fi78
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1600, but for most other data a value for maxd of 500 will suffice.
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1990-02-14
    + +

    Definition at line 2067 of file w3fi78.f.

    + +
    +
    + +

    ◆ fi7810()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi7810 (integer, dimension(*) IDENT,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) IPTR,
     MAXR,
     MAXD 
    )
    +
    + +

    Reformat profiler edition 2 data.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-01-21 Reformat profiler data in edition 2.
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-01-27
      • +
    +
    Parameters
    + + + + + + + +
    [in]IDENTArray contains message information extracted from bufr message:
      +
    • IDENT(1) - Edition number (byte 4, section 1)
      • +
    • IDENT(2) - Originating center (bytes 5-6, section 1)
      • +
    • IDENT(3) - Update sequence (byte 7, section 1)
      • +
    • IDENT(4) - (byte 8, section 1)
      • +
    • IDENT(5) - Bufr message type (byte 9, section 1)
      • +
    • IDENT(6) - Bufr msg sub-type (byte 10, section 1)
      • +
    • IDENT(7) - (bytes 11-12, section 1)
      • +
    • IDENT(8) - Year of century (byte 13, section 1)
      • +
    • IDENT(9) - Month of year (byte 14, section 1)
      • +
    • IDENT(10) - Day of month (byte 15, section 1)
      • +
    • IDENT(11) - Hour of day (byte 16, section 1)
      • +
    • IDENT(12) - Minute of hour (byte 17, section 1)
      • +
    • IDENT(13) - Rsvd by adp centers (byte 18, section 1)
      • +
    • IDENT(14) - Nr of data subsets (byte 5-6, section 3)
      • +
    • IDENT(15) - Observed flag (byte 7, bit 1, section 3)
      • +
    • IDENT(16) - Compression flag (byte 7, bit 2, section 3)
      • +
    +
    [in]MSTACKWorking descriptor list and scaling factor
    [in]KDATAArray containing decoded reports from bufr message. kdata(report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd)
    [in]IPTRSee w3fi78
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1600, but for most other data a value for maxd of 500 will suffice
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-01-21
    + +

    Definition at line 2460 of file w3fi78.f.

    + +
    +
    + +

    ◆ w3fi78()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi78 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(*) ISTACK,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(maxr) KNR,
    integer INDEX,
     MAXR,
     MAXD,
     IUNITB,
     IUNITD 
    )
    +
    + +

    This set of routines will decode a BUFR message and place information extracted from the BUFR message into selected arrays for the user.The array kdata can now be sized by the user by indicating the maximum number of substes and the maximum number of descriptors that are expected in the course of decoding selected input data.

    +

    This allows for realistic sizing of kdata and the mstack arrays. This version also allows for the inclusion of the unit numbers for tables b and d into the argument list. This routine does not include ifod processing.

    +

    Program history log:

      +
    • Bill Cavanaugh 88-08-31
      • +
    • Bill Cavanaugh 90-12-07 Now utilizing gbyte routines to gather and separate bit fields. This should improve (decrease) the time it takes to decode any BUFR message. Have entered coding that will permit processing BUFR editions 1 and 2. improved and corrected the conversion into ifod format of decoded BUFR messages.
      • +
    • Bill Cavanaugh 91-01-18 Program/routines modified to properly handle serial profiler data.
      • +
    • Bill Cavanaugh 91-04-04 Modified to handle text supplied thru descriptor 2 05 yyy.
      • +
    • Bill Cavanaugh 91-04-17 Errors in extracting and scaling data corrected. Improved handling of nested queue descriptors is added.
      • +
    • Bill Cavanaugh 91-05-10 Array 'data' has been enlarged to real*8 to better contain very large numbers more accurately. the preious size real*4 could not contain sufficient significant digits. Coding has been introduced to process new table c descriptor 2 06 yyy which permits in line processing of a local descriptor even if the descriptor is not contained in the users table b. A second routine to process ifod messages (ifod0) has been removed in favor of the improved processing of the one remaining (ifod1). New coding has been introduced to permit processing of BUFR messages based on BUFR edition up to and including edition 2. Please note increased size requirements for arrays ident(20) and iptr(40).
      • +
    • Bill Cavanaugh 91-07-26 Add array mtime to calling sequence to permit inclusion of receipt/transfer times to ifod messages.
      • +
    • Bill Cavanaugh 91-09-25 All processing of decoded BUFR data into ifod (a local use reformat of BUFR data) has been isolated from this set of routines. For those interested in the ifod form, see w3fl05() in the w3lib routines. Processing of BUFR messages containing delayed replication has been altered so that single subsets (reports) and and a matching descriptor list for that particular subset will be passed to the user will be passed to the user one at a time to assure that each subset can be fully defined with a minimum of reprocessing. Processing of associated fields has been tested with messages containing non-compressed data. In order to facilitate user processing a matching list of scale factors are included with the expanded descriptor list (mstack).
      • +
    • Bill Cavanaugh 91-11-21 Processing of descriptor 2 03 yyy has corrected to agree with fm94 standards.
      • +
    • Bill Cavanaugh 91-12-19 Calls to fi7803() and fi7804() have been corrected to agree called program argument list. Some additional entries have been included for communicating with data access routines. Additional error exit provided for the case where table b is damaged.
      • +
    • Bill Cavanaugh 92-01-24 Routines fi7801(), fi7803() and fi7804() have been modified to handle associated fields all descriptors are set to echo to mstack(1,n)
      • +
    • Bill Cavanaugh 92-05-21 Further expansion of information collected from within upper air soundings has produced the necessity to expand some of the processing and output arrays. (see remarks below)
      • +
    • Bill Cavanaugh 92-06-29 Corrected descriptor denoting height of each wind level for profiler conversions.
      • +
    • Bill Cavanaugh 92-07-23 Expansion of table b requires adjustment of arrays to contain table b values needed to assist in the decoding process. ARRAYS CONTAINING DATA FROM TABLE B
      • +
    • KDESC Descriptor
      • +
    • ANAME Descriptor name
      • +
    • AUNITS Units for descriptor
      • +
    • MSCALE Scale for value of descriptor
      • +
    • MREF Reference value for descriptor
      • +
    • MWIDTH Bit width for value of descriptor
      • +
    • Bill Cavanaugh 92-09-09 First encounter with operator descriptor 2 05 yyy showed error in decoding. That error is corrected with this implementation. Further testing of upper air data has encountered the condition of large (many level) soundings arrays in the decoder have been expanded (again) to allow for this condition.
      • +
    • Bill Cavanaugh 92-10-02 Modified routine to reformat profiler data (fi7809) to show descriptors, scale value and data in proper order. Corrected an error that prevented user from assigning the second dimension of kdata(500,*).
      • +
    • Bill Cavanaugh 92-10-20 Removed error that prevented full implementation of previous corrections and made corrections to table b to bring it up to date. changes include proper reformat of profiler data and user capability for assigning second dimension of kdata array.
      • +
    • Bill Cavanaugh 92-12-09 Thanks to dennis keyser for the suggestions and coding, this implementation will allow the inclusion of unit numbers for tables b & d, and in addition allows for realistic sizing of kdata and mstack arrays by the user. As of this implementation, the upper size limit for a BUFR message allows for a message size greater than 10000 bytes.
      • +
    • Bill Cavanaugh 93-01-26 Subroutine fi7810() has been added to permit reformatting of profiler data in edition 2.
      • +
    +
    Parameters
    + + + + + + + + + + + + + +
    [in]MSGAArray containing supposed BUFR message size is determined by user, can be greater than 10000 bytes.
    [in]MAXRMaximum number of reports/subsets that may be contained in a BUFR message.
    [in]MAXDMaximum number of descriptor combinations that may be processed; Upper air data and some satellite data require a value for maxd of 1600, but for most other data a value for maxd of 500 will suffice.
    [in]IUNITBUnit number of data set holding table b
    [in]IUNITDUnit number of data set holding table d
    KNR
    [out]ISTACKOriginal array of descriptors extracted from source BUFR message.
    [out]MSTACK(A,B)
      +
    • Level b - descriptor number (limited to value of input argument maxd)
      • +
    • level a = 1 descriptor = 2 10**N Scaling to return to original value
      • +
    +
    [out]IPTRUtility array
      +
    • IPTR( 1)- Error return.
      • +
    • IPTR( 2)- Byte count section 1.
      • +
    • IPTR( 3)- Pointer to start of section 1.
      • +
    • IPTR( 4)- Byte count section 2.
      • +
    • IPTR( 5)- Pointer to start of section 2.
      • +
    • IPTR( 6)- Byte count section 3.
      • +
    • IPTR( 7)- Pointer to start of section 3.
      • +
    • IPTR( 8)- Byte count section 4.
      • +
    • IPTR( 9)- Pointer to start of section 4.
      • +
    • IPTR(10)- Start of requested subset, reserved for dar.
      • +
    • IPTR(11)- Current descriptor ptr in iwork.
      • +
    • IPTR(12)- Last descriptor pos in iwork.
      • +
    • IPTR(13)- Last descriptor pos in istack.
      • +
    • IPTR(14)- Number of table b entries.
      • +
    • IPTR(15)- Requested subset pointer, reserved for dar.
      • +
    • IPTR(16)- Indicator for existance of section 2.
      • +
    • IPTR(17)- Number of reports processed.
      • +
    • IPTR(18)- Ascii/text event.
      • +
    • IPTR(19)- Pointer to start of BUFR message.
      • +
    • IPTR(20)- Number of lines from table d.
      • +
    • IPTR(21)- Table b switch.
      • +
    • IPTR(22)- Table d switch.
      • +
    • IPTR(23)- Code/flag table switch.
      • +
    • IPTR(24)- Aditional words added by text info.
      • +
    • IPTR(25)- Current bit number.
      • +
    • IPTR(26)- Data width change.
      • +
    • IPTR(27)- Data scale change.
      • +
    • IPTR(28)- Data reference value change.
      • +
    • IPTR(29)- Add data associated field.
      • +
    • IPTR(30)- Signify characters.
      • +
    • IPTR(31)- Number of expanded descriptors in mstack.
      • +
    • IPTR(32)- Current descriptor segment f.
      • +
    • IPTR(33)- Current descriptor segment x.
      • +
    • IPTR(34)- Current descriptor segment y.
      • +
    • IPTR(35)- Unused.
      • +
    • IPTR(36)- Next descriptor may be undecipherable.
      • +
    • IPTR(37)- Unused.
      • +
    • IPTR(38)- Unused.
      • +
    • IPTR(39)- Delayed replication flag.
        +
      • 0 No delayed replication.
        • +
      • 1 Message contains delayed replication.
        • +
      +
      • +
    • IPTR(40)- Number of characters in text for curr descriptor.
      • +
    +
    [out]IDENTArray contains message information extracted from BUFR Message.
      +
    • IDENT(1) Edition number (byte 4, section 1)
      • +
    • IDENT(2) Originating center (bytes 5-6, section 1)
      • +
    • IDENT(3) Update sequence (byte 7, section 1)
      • +
    • IDENT(4) Optional section (byte 8, section 1)
      • +
    • IDENT(5) BUFR message type (byte 9, section 1)
        +
      • 0 = Surface (land).
        • +
      • 1 = Surface (ship).
        • +
      • 2 = Vertical soundings other than satellite.
        • +
      • 3 = Vertical soundings (satellite).
        • +
      • 4 = Sngl lvl upper-air other than satellite.
        • +
      • 5 = Sngl lvl upper-air (satellite).
        • +
      • 6 = Radar.
        • +
      +
      • +
    • IDENT(6) BUFR msg sub-type (byte 10, section 1). + + + + +
      TYPE SBTYP
      2 7 = PROFILER
      +
      • +
    • IDENT(7) (bytes 11-12, section 1).
      • +
    • IDENT(8) Year of century (byte 13, section 1).
      • +
    • IDENT(9) Month of year (byte 14, section 1).
      • +
    • IDENT(10) Day of month (byte 15, section 1).
      • +
    • IDENT(11) Hour of day (byte 16, section 1).
      • +
    • IDENT(12) Minute of hour (byte 17, section 1).
      • +
    • IDENT(13) Rsvd by adp centers (byte 18, section 1).
      • +
    • IDENT(14) Nr of data subsets (byte 5-6, section 3).
      • +
    • IDENT(15) Observed flag (byte 7, bit 1, section 3).
      • +
    • IDENT(16) Compression flag (byte 7, bit 2, section 3).
      • +
    • IDENT(17) Master table number(byte 4, section 1, ed 2 or gtr).
      • +
    +
    [out]KDATAArray containing decoded reports from BUFR message. KDATA(report number,parameter number) (Report number limited to value of input argument maxr and parameter number limited to value of input argument maxd) Arrays containing data from table b:
      +
    • ANAME Descriptor name
      • +
    • AUNITS Units for descriptor
      • +
    • MSCALE Scale for value of descriptor
      • +
    • MREF Reference value for descriptor
      • +
    • MWIDTH Bit width for value of descriptor
      • +
    +
    [out]INDEXPointer to available subset
    +
    +
    +

    Error returns: IPTR(1):

      +
    • 1 'BUFR' Not found in first 125 characters
      • +
    • 2 '7777' Not found in location determined by by using counts found in each section. one or more sections have an erroneous byte count or characters '7777' are not in test message.
      • +
    • 3 Message contains a descriptor with f=0 that does not exist in table b.
      • +
    • 4 Message contains a descriptor with f=3 that does not exist in table d.
      • +
    • 5 Message contains a descriptor with f=2 with the value of x outside the range 1-5.
      • +
    • 6 Descriptor element indicated to have a flag value does not have an entry in the flag table. (to be activated)
      • +
    • 7 Descriptor indicated to have a code value does not have an entry in the code table. (to be activated)
      • +
    • 8 Error reading table d
      • +
    • 9 Error reading table b
      • +
    • 10 Error reading code/flag table
      • +
    • 11 Descriptor 2 04 004 not followed by 0 31 021
      • +
    • 12 Data descriptor operator qualifier does not follow delayed replication descriptor.
      • +
    • 13 Bit width on ascii characters not a multiple of 8
      • +
    • 14 Subsets = 0, no content bulletin
      • +
    • 20 Exceeded count for delayed replication pass
      • +
    • 21 Exceeded count for non-delayed replication pass
      • +
    • 27 Non zero lowest on text data
      • +
    • 28 Nbinc not nr of characters
      • +
    • 29 Table b appears to be damaged
      • +
    • 99 No more subsets (reports) available in current BUFR mesage
      • +
    • 400 Number of subsets exceeds the value of input argument maxr; must increase maxr to value of ident(14) in calling program
      • +
    • 401 Number of parameters (and associated fields) exceeds limits of this program.
      • +
    • 500 Value for nbinc has been found that exceeds standard width plus any bit width change. check all bit widths up to point of error.
      • +
    • 501 Corrected width for descriptor is 0 or less
      • +
    +

    On the initial call to w3fi78() with a BUFR message the argument index must be set to zero (index = 0). On the return from w3fi78() 'index' will be set to the next available subset/report. When there are no more subsets available a 99 err return will occur.

    +

    If the original BUFR message does not contain delayed replication the BUFR message will be completely decoded and 'index' will point to the first decoded subset. The users will then have the option of indexing through the subsets on their own or by recalling this routine (without resetting 'index') to have the routine do the indexing.

    +

    If the original BUFR message does contain delayed replication one subset/report will be decoded at a time and passed back to the user. This is not an option.

    +
    +

    +TO USE THIS ROUTINE

    +
      +
    • 1. Read in BUFR message
      • +
    • 2. Set index = 0
      • +
    • 3. CALL W3FI78()
      • +
    • 4.
      IF (iptr(1).EQ.99) THEN
      +
      no more subsets
      +
      either GO TO 1
      +
      or terminate in no more bufr messages
      +
      END IF
      +
      • +
    • 5.
      IF (iptr(1).NE.0) THEN
      +
      error condition
      +
      either GO TO 1
      +
      or terminate in no more bufr messages
      +
      END IF
      +
      • +
    • 6. The value of index indicates the active subset so
      IF interested in generating an ifod message
      +
      w3fl05( )
      +
      ELSE
      +
      process decoded information as required
      +
      END IF
      +
      • +
    • 7. GO TO 3
      • +
    +

    The arrays to contain the output information are defined as follows:

      +
    • KDATA(A,B) Is the a data entry (integer value) where a is the maximum number of reports/subsets that may be contained in the bufr message (this is now set to "maxr" which is passed as an input argument to w3fi78()), and where b is the maximum number of descriptor combinations that may be processed (this is now set to "maxd" which is also passed as an input argument to w3fi78(); Upper air data and some satellite data require a value for maxd of 1600, but for most other data a value for maxd of 500 will suffice).
      • +
    • MSTACK(1,B) Contains the descriptor that matches the data entry (max. value for b is now "maxd" which is passed as an input argument to w3fi78())
      • +
    • MSTACK(2,B) Is the scale (power of 10) to be applied to the data (max. value for b is now "maxd" which is passed as an input argument to w3fi78())
      • +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-08-31
    + +

    Definition at line 309 of file w3fi78.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi78_8f.js b/ver-2.10.0/w3fi78_8f.js new file mode 100644 index 00000000..2ee1d783 --- /dev/null +++ b/ver-2.10.0/w3fi78_8f.js @@ -0,0 +1,14 @@ +var w3fi78_8f = +[ + [ "fi7801", "w3fi78_8f.html#a78a1ba5576bfc184dbcde9db7647f2c0", null ], + [ "fi7802", "w3fi78_8f.html#afe2cebe5fb34bedc4e028fcaeec3eb0b", null ], + [ "fi7803", "w3fi78_8f.html#abd85631fd2ddaae2c69a597dada4bad5", null ], + [ "fi7804", "w3fi78_8f.html#adde456d0a3cdfb2ada7e27dac62ff5b4", null ], + [ "fi7805", "w3fi78_8f.html#aef0cfcae2b4b6aecddae061ef55c23f7", null ], + [ "fi7806", "w3fi78_8f.html#a759ea3357b94bf332300d7ae6b6e073e", null ], + [ "fi7807", "w3fi78_8f.html#ac6daf60e47a8949569927e2dbe795dc7", null ], + [ "fi7808", "w3fi78_8f.html#aa9b1b7dfb8dd609828a6e0db3271351f", null ], + [ "fi7809", "w3fi78_8f.html#aa30ef437f8f02bfaf3482c3c496d4af5", null ], + [ "fi7810", "w3fi78_8f.html#a1c0312bb81a0d948725334348ba1cbc0", null ], + [ "w3fi78", "w3fi78_8f.html#a9c08a6a24a9527776d2b533108dbf261", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi78_8f_source.html b/ver-2.10.0/w3fi78_8f_source.html new file mode 100644 index 00000000..db3c1a81 --- /dev/null +++ b/ver-2.10.0/w3fi78_8f_source.html @@ -0,0 +1,2873 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi78.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi78.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief BUFR Message decoder.
    +
    3 C> @author Bill Cavanaugh @date 1988-08-31
    +
    4 
    +
    5 C> This set of routines will decode a BUFR message and
    +
    6 C> place information extracted from the BUFR message into selected
    +
    7 C> arrays for the user.The array kdata can now be sized by the user
    +
    8 C> by indicating the maximum number of substes and the maximum
    +
    9 C> number of descriptors that are expected in the course of decoding
    +
    10 C> selected input data. This allows for realistic sizing of kdata
    +
    11 C> and the mstack arrays. This version also allows for the inclusion
    +
    12 C> of the unit numbers for tables b and d into the
    +
    13 C> argument list. This routine does not include ifod processing.
    +
    14 C>
    +
    15 C> Program history log:
    +
    16 C> - Bill Cavanaugh 88-08-31
    +
    17 C> - Bill Cavanaugh 90-12-07 Now utilizing gbyte routines to gather
    +
    18 C> and separate bit fields. This should improve
    +
    19 C> (decrease) the time it takes to decode any
    +
    20 C> BUFR message. Have entered coding that will
    +
    21 C> permit processing BUFR editions 1 and 2.
    +
    22 C> improved and corrected the conversion into
    +
    23 C> ifod format of decoded BUFR messages.
    +
    24 C> - Bill Cavanaugh 91-01-18 Program/routines modified to properly handle
    +
    25 C> serial profiler data.
    +
    26 C> - Bill Cavanaugh 91-04-04 Modified to handle text supplied thru
    +
    27 C> descriptor 2 05 yyy.
    +
    28 C> - Bill Cavanaugh 91-04-17 Errors in extracting and scaling data
    +
    29 C> corrected. Improved handling of nested queue descriptors is added.
    +
    30 C> - Bill Cavanaugh 91-05-10 Array 'data' has been enlarged to real*8
    +
    31 C> to better contain very large numbers more accurately. the preious size
    +
    32 C> real*4 could not contain sufficient significant digits. Coding has been
    +
    33 C> introduced to process new table c descriptor 2 06 yyy which permits in
    +
    34 C> line processing of a local descriptor even if the descriptor is not
    +
    35 C> contained in the users table b. A second routine to process ifod messages
    +
    36 C> (ifod0) has been removed in favor of the improved processing of the one
    +
    37 C> remaining (ifod1). New coding has been introduced to permit processing of
    +
    38 C> BUFR messages based on BUFR edition up to and including edition 2. Please
    +
    39 C> note increased size requirements for arrays ident(20) and iptr(40).
    +
    40 C> - Bill Cavanaugh 91-07-26 Add array mtime to calling sequence to
    +
    41 C> permit inclusion of receipt/transfer times to ifod messages.
    +
    42 C> - Bill Cavanaugh 91-09-25 All processing of decoded BUFR data into
    +
    43 C> ifod (a local use reformat of BUFR data) has been isolated from this set
    +
    44 C> of routines. For those interested in the ifod form, see w3fl05() in the
    +
    45 C> w3lib routines.
    +
    46 C> Processing of BUFR messages containing delayed replication has been altered
    +
    47 C> so that single subsets (reports) and and a matching descriptor list for
    +
    48 C> that particular subset will be passed to the user will be passed to the
    +
    49 C> user one at a time to assure that each subset can be fully defined with a
    +
    50 C> minimum of reprocessing.
    +
    51 C> Processing of associated fields has been tested with messages containing
    +
    52 C> non-compressed data.
    +
    53 C> In order to facilitate user processing a matching list of scale factors are
    +
    54 C> included with the expanded descriptor list (mstack).
    +
    55 C> - Bill Cavanaugh 91-11-21 Processing of descriptor 2 03 yyy
    +
    56 C> has corrected to agree with fm94 standards.
    +
    57 C> - Bill Cavanaugh 91-12-19 Calls to fi7803() and fi7804() have been
    +
    58 C> corrected to agree called program argument list. Some additional entries
    +
    59 C> have been included for communicating with data access routines. Additional
    +
    60 C> error exit provided for the case where table b is damaged.
    +
    61 C> - Bill Cavanaugh 92-01-24 Routines fi7801(), fi7803() and fi7804()
    +
    62 C> have been modified to handle associated fields all descriptors are set to
    +
    63 C> echo to mstack(1,n)
    +
    64 C> - Bill Cavanaugh 92-05-21 Further expansion of information collected
    +
    65 C> from within upper air soundings has produced the necessity to expand some
    +
    66 C> of the processing and output arrays. (see remarks below)
    +
    67 C> - Bill Cavanaugh 92-06-29 Corrected descriptor denoting height of
    +
    68 C> each wind level for profiler conversions.
    +
    69 C> - Bill Cavanaugh 92-07-23 Expansion of table b requires adjustment
    +
    70 C> of arrays to contain table b values needed to assist in the decoding
    +
    71 C> process.
    +
    72 C> ARRAYS CONTAINING DATA FROM TABLE B
    +
    73 C> - KDESC Descriptor
    +
    74 C> - ANAME Descriptor name
    +
    75 C> - AUNITS Units for descriptor
    +
    76 C> - MSCALE Scale for value of descriptor
    +
    77 C> - MREF Reference value for descriptor
    +
    78 C> - MWIDTH Bit width for value of descriptor
    +
    79 C> - Bill Cavanaugh 92-09-09 First encounter with operator descriptor
    +
    80 C> 2 05 yyy showed error in decoding. That error is corrected with this
    +
    81 C> implementation. Further testing of upper air data has encountered
    +
    82 C> the condition of large (many level) soundings arrays in the decoder have
    +
    83 C> been expanded (again) to allow for this condition.
    +
    84 C> - Bill Cavanaugh 92-10-02 Modified routine to reformat profiler data
    +
    85 C> (fi7809) to show descriptors, scale value and data in proper order.
    +
    86 C> Corrected an error that prevented user from assigning the second dimension
    +
    87 C> of kdata(500,*).
    +
    88 C> - Bill Cavanaugh 92-10-20 Removed error that prevented full implementation
    +
    89 C> of previous corrections and made corrections to table b to bring it up to
    +
    90 C> date. changes include proper reformat of profiler data and user capability
    +
    91 C> for assigning second dimension of kdata array.
    +
    92 C> - Bill Cavanaugh 92-12-09 Thanks to dennis keyser for the suggestions and
    +
    93 C> coding, this implementation will allow the inclusion of unit numbers for
    +
    94 C> tables b & d, and in addition allows for realistic sizing of kdata and
    +
    95 C> mstack arrays by the user. As of this implementation, the upper size limit
    +
    96 C> for a BUFR message allows for a message size greater than 10000 bytes.
    +
    97 C> - Bill Cavanaugh 93-01-26 Subroutine fi7810() has been added to permit
    +
    98 C> reformatting of profiler data in edition 2.
    +
    99 C>
    +
    100 C> @param[in] MSGA Array containing supposed BUFR message size is determined
    +
    101 C> by user, can be greater than 10000 bytes.
    +
    102 C> @param[in] MAXR Maximum number of reports/subsets that may be contained in
    +
    103 C> a BUFR message.
    +
    104 C> @param[in] MAXD Maximum number of descriptor combinations that may be
    +
    105 C> processed; Upper air data and some satellite data require a value for maxd
    +
    106 C> of 1600, but for most other data a value for maxd of 500 will suffice.
    +
    107 C> @param[in] IUNITB Unit number of data set holding table b
    +
    108 C> @param[in] IUNITD Unit number of data set holding table d
    +
    109 C> @param KNR
    +
    110 C> @param[out] ISTACK Original array of descriptors extracted from source
    +
    111 C> BUFR message.
    +
    112 C> @param[out] MSTACK (A,B)
    +
    113 C> - Level b - descriptor number (limited to value of
    +
    114 C> input argument maxd)
    +
    115 C> - level a = 1 descriptor = 2 10**N Scaling to return to original value
    +
    116 C> @param[out] IPTR Utility array
    +
    117 C> - IPTR( 1)- Error return.
    +
    118 C> - IPTR( 2)- Byte count section 1.
    +
    119 C> - IPTR( 3)- Pointer to start of section 1.
    +
    120 C> - IPTR( 4)- Byte count section 2.
    +
    121 C> - IPTR( 5)- Pointer to start of section 2.
    +
    122 C> - IPTR( 6)- Byte count section 3.
    +
    123 C> - IPTR( 7)- Pointer to start of section 3.
    +
    124 C> - IPTR( 8)- Byte count section 4.
    +
    125 C> - IPTR( 9)- Pointer to start of section 4.
    +
    126 C> - IPTR(10)- Start of requested subset, reserved for dar.
    +
    127 C> - IPTR(11)- Current descriptor ptr in iwork.
    +
    128 C> - IPTR(12)- Last descriptor pos in iwork.
    +
    129 C> - IPTR(13)- Last descriptor pos in istack.
    +
    130 C> - IPTR(14)- Number of table b entries.
    +
    131 C> - IPTR(15)- Requested subset pointer, reserved for dar.
    +
    132 C> - IPTR(16)- Indicator for existance of section 2.
    +
    133 C> - IPTR(17)- Number of reports processed.
    +
    134 C> - IPTR(18)- Ascii/text event.
    +
    135 C> - IPTR(19)- Pointer to start of BUFR message.
    +
    136 C> - IPTR(20)- Number of lines from table d.
    +
    137 C> - IPTR(21)- Table b switch.
    +
    138 C> - IPTR(22)- Table d switch.
    +
    139 C> - IPTR(23)- Code/flag table switch.
    +
    140 C> - IPTR(24)- Aditional words added by text info.
    +
    141 C> - IPTR(25)- Current bit number.
    +
    142 C> - IPTR(26)- Data width change.
    +
    143 C> - IPTR(27)- Data scale change.
    +
    144 C> - IPTR(28)- Data reference value change.
    +
    145 C> - IPTR(29)- Add data associated field.
    +
    146 C> - IPTR(30)- Signify characters.
    +
    147 C> - IPTR(31)- Number of expanded descriptors in mstack.
    +
    148 C> - IPTR(32)- Current descriptor segment f.
    +
    149 C> - IPTR(33)- Current descriptor segment x.
    +
    150 C> - IPTR(34)- Current descriptor segment y.
    +
    151 C> - IPTR(35)- Unused.
    +
    152 C> - IPTR(36)- Next descriptor may be undecipherable.
    +
    153 C> - IPTR(37)- Unused.
    +
    154 C> - IPTR(38)- Unused.
    +
    155 C> - IPTR(39)- Delayed replication flag.
    +
    156 C> - 0 No delayed replication.
    +
    157 C> - 1 Message contains delayed replication.
    +
    158 C> - IPTR(40)- Number of characters in text for curr descriptor.
    +
    159 C> @param[out] IDENT Array contains message information extracted from BUFR
    +
    160 C> Message.
    +
    161 C> - IDENT(1) Edition number (byte 4, section 1)
    +
    162 C> - IDENT(2) Originating center (bytes 5-6, section 1)
    +
    163 C> - IDENT(3) Update sequence (byte 7, section 1)
    +
    164 C> - IDENT(4) Optional section (byte 8, section 1)
    +
    165 C> - IDENT(5) BUFR message type (byte 9, section 1)
    +
    166 C> - 0 = Surface (land).
    +
    167 C> - 1 = Surface (ship).
    +
    168 C> - 2 = Vertical soundings other than satellite.
    +
    169 C> - 3 = Vertical soundings (satellite).
    +
    170 C> - 4 = Sngl lvl upper-air other than satellite.
    +
    171 C> - 5 = Sngl lvl upper-air (satellite).
    +
    172 C> - 6 = Radar.
    +
    173 C> - IDENT(6) BUFR msg sub-type (byte 10, section 1).
    +
    174 C> | TYPE | SBTYP |
    +
    175 C> | :--- | :---- |
    +
    176 C> | 2 | 7 = PROFILER |
    +
    177 C> - IDENT(7) (bytes 11-12, section 1).
    +
    178 C> - IDENT(8) Year of century (byte 13, section 1).
    +
    179 C> - IDENT(9) Month of year (byte 14, section 1).
    +
    180 C> - IDENT(10) Day of month (byte 15, section 1).
    +
    181 C> - IDENT(11) Hour of day (byte 16, section 1).
    +
    182 C> - IDENT(12) Minute of hour (byte 17, section 1).
    +
    183 C> - IDENT(13) Rsvd by adp centers (byte 18, section 1).
    +
    184 C> - IDENT(14) Nr of data subsets (byte 5-6, section 3).
    +
    185 C> - IDENT(15) Observed flag (byte 7, bit 1, section 3).
    +
    186 C> - IDENT(16) Compression flag (byte 7, bit 2, section 3).
    +
    187 C> - IDENT(17) Master table number(byte 4, section 1, ed 2 or gtr).
    +
    188 C> @param[out] KDATA Array containing decoded reports from BUFR message.
    +
    189 C> KDATA(report number,parameter number)
    +
    190 C> (Report number limited to value of input argument maxr and parameter number
    +
    191 C> limited to value of input argument maxd)
    +
    192 C> Arrays containing data from table b:
    +
    193 C> - ANAME Descriptor name
    +
    194 C> - AUNITS Units for descriptor
    +
    195 C> - MSCALE Scale for value of descriptor
    +
    196 C> - MREF Reference value for descriptor
    +
    197 C> - MWIDTH Bit width for value of descriptor
    +
    198 C> @param[out] INDEX Pointer to available subset
    +
    199 C>
    +
    200 C> Error returns:
    +
    201 C> IPTR(1):
    +
    202 C> - 1 'BUFR' Not found in first 125 characters
    +
    203 C> - 2 '7777' Not found in location determined by
    +
    204 C> by using counts found in each section. one or
    +
    205 C> more sections have an erroneous byte count or
    +
    206 C> characters '7777' are not in test message.
    +
    207 C> - 3 Message contains a descriptor with f=0 that does
    +
    208 C> not exist in table b.
    +
    209 C> - 4 Message contains a descriptor with f=3 that does
    +
    210 C> not exist in table d.
    +
    211 C> - 5 Message contains a descriptor with f=2 with the
    +
    212 C> value of x outside the range 1-5.
    +
    213 C> - 6 Descriptor element indicated to have a flag value
    +
    214 C> does not have an entry in the flag table.
    +
    215 C> (to be activated)
    +
    216 C> - 7 Descriptor indicated to have a code value does
    +
    217 C> not have an entry in the code table.
    +
    218 C> (to be activated)
    +
    219 C> - 8 Error reading table d
    +
    220 C> - 9 Error reading table b
    +
    221 C> - 10 Error reading code/flag table
    +
    222 C> - 11 Descriptor 2 04 004 not followed by 0 31 021
    +
    223 C> - 12 Data descriptor operator qualifier does not follow
    +
    224 C> delayed replication descriptor.
    +
    225 C> - 13 Bit width on ascii characters not a multiple of 8
    +
    226 C> - 14 Subsets = 0, no content bulletin
    +
    227 C> - 20 Exceeded count for delayed replication pass
    +
    228 C> - 21 Exceeded count for non-delayed replication pass
    +
    229 C> - 27 Non zero lowest on text data
    +
    230 C> - 28 Nbinc not nr of characters
    +
    231 C> - 29 Table b appears to be damaged
    +
    232 C> - 99 No more subsets (reports) available in current
    +
    233 C> BUFR mesage
    +
    234 C> - 400 Number of subsets exceeds the value of input
    +
    235 C> argument maxr; must increase maxr to value of
    +
    236 C> ident(14) in calling program
    +
    237 C> - 401 Number of parameters (and associated fields)
    +
    238 C> exceeds limits of this program.
    +
    239 C> - 500 Value for nbinc has been found that exceeds
    +
    240 C> standard width plus any bit width change.
    +
    241 C> check all bit widths up to point of error.
    +
    242 C> - 501 Corrected width for descriptor is 0 or less
    +
    243 C>
    +
    244 C> On the initial call to w3fi78() with a BUFR message the argument
    +
    245 C> index must be set to zero (index = 0). On the return from w3fi78()
    +
    246 C> 'index' will be set to the next available subset/report. When
    +
    247 C> there are no more subsets available a 99 err return will occur.
    +
    248 C>
    +
    249 C> If the original BUFR message does not contain delayed replication
    +
    250 C> the BUFR message will be completely decoded and 'index' will point
    +
    251 C> to the first decoded subset. The users will then have the option
    +
    252 C> of indexing through the subsets on their own or by recalling this
    +
    253 C> routine (without resetting 'index') to have the routine do the
    +
    254 C> indexing.
    +
    255 C>
    +
    256 C> If the original BUFR message does contain delayed replication
    +
    257 C> one subset/report will be decoded at a time and passed back to
    +
    258 C> the user. This is not an option.
    +
    259 C>
    +
    260 C> =============================================
    +
    261 C> TO USE THIS ROUTINE
    +
    262 C> --------------------------------
    +
    263 C> - 1. Read in BUFR message
    +
    264 C> - 2. Set index = 0
    +
    265 C> - 3. CALL W3FI78()
    +
    266 C> - 4.
    +
    267 C> @code
    +
    268 C> IF (IPTR(1).EQ.99) THEN
    +
    269 C> NO MORE SUBSETS
    +
    270 C> EITHER GO TO 1
    +
    271 C> OR TERMINATE IN NO MORE BUFR MESSAGES
    +
    272 C> END IF
    +
    273 C> @endcode
    +
    274 C> - 5.
    +
    275 C> @code
    +
    276 C> IF (IPTR(1).NE.0) THEN
    +
    277 C> ERROR CONDITION
    +
    278 C> EITHER GO TO 1
    +
    279 C> OR TERMINATE IN NO MORE BUFR MESSAGES
    +
    280 C> END IF
    +
    281 C> @endcode
    +
    282 C> - 6. The value of index indicates the active subset so
    +
    283 C> @code
    +
    284 C> IF INTERESTED IN GENERATING AN IFOD MESSAGE
    +
    285 C> W3FL05 ( )
    +
    286 C> ELSE
    +
    287 C> PROCESS DECODED INFORMATION AS REQUIRED
    +
    288 C> END IF
    +
    289 C> @endcode
    +
    290 C> - 7. GO TO 3
    +
    291 C>
    +
    292 C> The arrays to contain the output information are defined as follows:
    +
    293 C> - KDATA(A,B) Is the a data entry (integer value) where a is the maximum
    +
    294 C> number of reports/subsets that may be contained in the bufr message (this
    +
    295 C> is now set to "maxr" which is passed as an input argument to w3fi78()), and
    +
    296 C> where b is the maximum number of descriptor combinations that may be
    +
    297 C> processed (this is now set to "maxd" which is also passed as an input
    +
    298 C> argument to w3fi78(); Upper air data and some satellite data require a
    +
    299 C> value for maxd of 1600, but for most other data a value for maxd of 500
    +
    300 C> will suffice).
    +
    301 C> - MSTACK(1,B) Contains the descriptor that matches the data entry (max.
    +
    302 C> value for b is now "maxd" which is passed as an input argument to w3fi78())
    +
    303 C> - MSTACK(2,B) Is the scale (power of 10) to be applied to the data (max.
    +
    304 C> value for b is now "maxd" which is passed as an input argument to w3fi78())
    +
    305 C>
    +
    306 C> @author Bill Cavanaugh @date 1988-08-31
    +
    307  SUBROUTINE w3fi78(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
    +
    308  * MAXR,MAXD,IUNITB,IUNITD)
    +
    309 C
    +
    310  CHARACTER*40 ANAME(700)
    +
    311  CHARACTER*24 AUNITS(700)
    +
    312 C
    +
    313 C
    +
    314 C
    +
    315  INTEGER MSGA(*)
    +
    316  INTEGER IPTR(*)
    +
    317  INTEGER KDATA(MAXR,MAXD)
    +
    318  INTEGER MSTACK(2,MAXD)
    +
    319 C
    +
    320  INTEGER IVALS(1000)
    +
    321  INTEGER KNR(MAXR)
    +
    322  INTEGER IDENT(*)
    +
    323  INTEGER KDESC(2000)
    +
    324  INTEGER ISTACK(*)
    +
    325  INTEGER IWORK(2000)
    +
    326  INTEGER MSCALE(700)
    +
    327  INTEGER MREF(700,3)
    +
    328  INTEGER MWIDTH(700)
    +
    329  INTEGER INDEX
    +
    330 C
    +
    331  CHARACTER*4 DIRID(2)
    +
    332 C
    +
    333  LOGICAL SEC2
    +
    334 C
    +
    335  SAVE
    +
    336 C
    +
    337 C PRINT *,' W3FI78 DECODER'
    +
    338 C INITIALIZE ERROR RETURN
    +
    339  iptr(1) = 0
    +
    340  IF (index.GT.0) THEN
    +
    341 C HAVE RE-ENTRY
    +
    342  index = index + 1
    +
    343 C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX
    +
    344  IF (index.GT.ident(14)) THEN
    +
    345 C ALL SUBSETS PROCESSED
    +
    346  iptr(1) = 99
    +
    347  iptr(39) = 0
    +
    348  ELSE IF (index.LE.ident(14)) THEN
    +
    349  IF (iptr(39).NE.0) THEN
    +
    350  CALL fi7801(iptr,ident,msga,istack,iwork,aname,kdata,
    +
    351 C
    +
    352  * ivals,mstack,
    +
    353  * aunits,kdesc,mwidth,mref,mscale,knr,index,maxr,maxd,
    +
    354  * iunitb,iunitd)
    +
    355 C
    +
    356  END IF
    +
    357  END IF
    +
    358  RETURN
    +
    359  ELSE
    +
    360  index = 1
    +
    361 C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE'
    +
    362  END IF
    +
    363  iptr(39) = 0
    +
    364 C FIND 'BUFR' IN FIRST 125 CHARACTERS
    +
    365  DO 1000 knofst = 0, 999, 8
    +
    366  inofst = knofst
    +
    367  CALL gbyte (msga,ivals,inofst,8)
    +
    368  IF (ivals(1).EQ.66) THEN
    +
    369  iptr(19) = inofst
    +
    370  inofst = inofst + 8
    +
    371  CALL gbyte (msga,ivals,inofst,24)
    +
    372  IF (ivals(1).EQ.5588562) THEN
    +
    373 C PRINT *,'FOUND BUFR AT',IPTR(19)
    +
    374  inofst = inofst + 24
    +
    375  GO TO 1500
    +
    376  END IF
    +
    377  END IF
    +
    378  1000 CONTINUE
    +
    379  print *,'BUFR - START OF BUFR MESSAGE NOT FOUND'
    +
    380  iptr(1) = 1
    +
    381  RETURN
    +
    382  1500 CONTINUE
    +
    383  ident(1) = 0
    +
    384 C TEST FOR EDITION NUMBER
    +
    385 C ======================
    +
    386  CALL gbyte (msga,ident(1),inofst+24,8)
    +
    387 C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE'
    +
    388 C
    +
    389  IF (ident(1).GE.2) THEN
    +
    390 C GET TOTAL COUNT
    +
    391  CALL gbyte (msga,ivals,inofst,24)
    +
    392  itotal = ivals(1)
    +
    393  kender = itotal * 8 - 32 + iptr(19)
    +
    394  CALL gbyte (msga,ilast,kender,32)
    +
    395 C IF (ILAST.EQ.926365495) THEN
    +
    396 C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1)
    +
    397 C END IF
    +
    398  inofst = inofst + 32
    +
    399 C GET SECTION 1 COUNT
    +
    400  iptr(3) = inofst
    +
    401  CALL gbyte (msga,ivals,inofst,24)
    +
    402 C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
    +
    403  inofst = inofst + 24
    +
    404  iptr( 2) = ivals(1)
    +
    405 C GET MASTER TABLE
    +
    406  CALL gbyte (msga,ivals,inofst,8)
    +
    407  inofst = inofst + 8
    +
    408  ident(17) = ivals(1)
    +
    409 C PRINT *,'BUFR MASTER TABLE NR',IDENT(17)
    +
    410  ELSE
    +
    411  iptr(3) = inofst
    +
    412 C GET SECTION 1 COUNT
    +
    413  CALL gbyte (msga,ivals,inofst,24)
    +
    414 C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
    +
    415  inofst = inofst + 32
    +
    416  iptr( 2) = ivals(1)
    +
    417  END IF
    +
    418 C ======================
    +
    419 C ORIGINATING CENTER
    +
    420  CALL gbyte (msga,ivals,inofst,16)
    +
    421  inofst = inofst + 16
    +
    422  ident(2) = ivals(1)
    +
    423 C UPDATE SEQUENCE
    +
    424  CALL gbyte (msga,ivals,inofst,8)
    +
    425  inofst = inofst + 8
    +
    426  ident(3) = ivals(1)
    +
    427 C OPTIONAL SECTION FLAG
    +
    428  CALL gbyte (msga,ivals,inofst,1)
    +
    429  ident(4) = ivals(1)
    +
    430  IF (ident(4).GT.0) THEN
    +
    431  sec2 = .true.
    +
    432  ELSE
    +
    433 C PRINT *,' NO OPTIONAL SECTION 2'
    +
    434  sec2 = .false.
    +
    435  END IF
    +
    436  inofst = inofst + 8
    +
    437 C MESSAGE TYPE
    +
    438  CALL gbyte (msga,ivals,inofst,8)
    +
    439  ident(5) = ivals(1)
    +
    440  inofst = inofst + 8
    +
    441 C MESSAGE SUB-TYPE
    +
    442  CALL gbyte (msga,ivals,inofst,8)
    +
    443  ident(6) = ivals(1)
    +
    444  inofst = inofst + 8
    +
    445 C IF BUFR EDITION 0 OR 1 THEN
    +
    446 C NEXT 2 BYTES ARE BUFR TABLE VERSION
    +
    447 C ELSE
    +
    448 C BYTE 11 IS VER NR OF MASTER TABLE
    +
    449 C BYTE 12 IS VER NR OF LOCAL TABLE
    +
    450  IF (ident(1).LT.2) THEN
    +
    451  CALL gbyte (msga,ivals,inofst,16)
    +
    452  ident(7) = ivals(1)
    +
    453  inofst = inofst + 16
    +
    454  ELSE
    +
    455 C BYTE 11 IS VER NR OF MASTER TABLE
    +
    456  CALL gbyte (msga,ivals,inofst,8)
    +
    457  ident(18) = ivals(1)
    +
    458  inofst = inofst + 8
    +
    459 C BYTE 12 IS VER NR OF LOCAL TABLE
    +
    460  CALL gbyte (msga,ivals,inofst,8)
    +
    461  ident(19) = ivals(1)
    +
    462  inofst = inofst + 8
    +
    463 
    +
    464  END IF
    +
    465 C YEAR OF CENTURY
    +
    466  CALL gbyte (msga,ivals,inofst,8)
    +
    467  ident(8) = ivals(1)
    +
    468  inofst = inofst + 8
    +
    469 C MONTH
    +
    470  CALL gbyte (msga,ivals,inofst,8)
    +
    471  ident(9) = ivals(1)
    +
    472  inofst = inofst + 8
    +
    473 C DAY
    +
    474 C PRINT *,'DAY AT ',INOFST
    +
    475  CALL gbyte (msga,ivals,inofst,8)
    +
    476  ident(10) = ivals(1)
    +
    477  inofst = inofst + 8
    +
    478 C HOUR
    +
    479  CALL gbyte (msga,ivals,inofst,8)
    +
    480  ident(11) = ivals(1)
    +
    481  inofst = inofst + 8
    +
    482 C MINUTE
    +
    483  CALL gbyte (msga,ivals,inofst,8)
    +
    484  ident(12) = ivals(1)
    +
    485 C RESET POINTER (INOFST) TO START OF
    +
    486 C NEXT SECTION
    +
    487 C (SECTION 2 OR SECTION 3)
    +
    488  inofst = iptr(3) + iptr(2) * 8
    +
    489  iptr(4) = 0
    +
    490  iptr(5) = inofst
    +
    491  IF (sec2) THEN
    +
    492 C SECTION 2 COUNT
    +
    493  CALL gbyte (msga,iptr(4),inofst,24)
    +
    494  inofst = inofst + 32
    +
    495 C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4)
    +
    496  kentry = (iptr(4) - 4) / 14
    +
    497 C PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS'
    +
    498  IF (ident(2).EQ.7) THEN
    +
    499  DO 2000 i = 1, kentry
    +
    500  CALL gbyte (msga,kdspl ,inofst,16)
    +
    501  inofst = inofst + 16
    +
    502  CALL gbyte (msga,lat ,inofst,16)
    +
    503  inofst = inofst + 16
    +
    504  CALL gbyte (msga,lon ,inofst,16)
    +
    505  inofst = inofst + 16
    +
    506  CALL gbyte (msga,kdahr ,inofst,16)
    +
    507  inofst = inofst + 16
    +
    508  CALL gbyte (msga,dirid(1),inofst,32)
    +
    509  inofst = inofst + 32
    +
    510  CALL gbyte (msga,dirid(2),inofst,16)
    +
    511  inofst = inofst + 16
    +
    512 C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2)
    +
    513  2000 CONTINUE
    +
    514  END IF
    +
    515 C RESET POINTER (INOFST) TO START OF
    +
    516 C SECTION 3
    +
    517  inofst = iptr(5) + iptr(4) * 8
    +
    518  END IF
    +
    519 C BIT OFFSET TO START OF SECTION 3
    +
    520  iptr( 7) = inofst
    +
    521 C SECTION 3 COUNT
    +
    522  CALL gbyte (msga,iptr(6),inofst,24)
    +
    523 C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6)
    +
    524  inofst = inofst + 24
    +
    525 C SKIP RESERVED BYTE
    +
    526  inofst = inofst + 8
    +
    527 C NUMBER OF DATA SUBSETS
    +
    528  CALL gbyte (msga,ident(14),inofst,16)
    +
    529 C
    +
    530  IF (ident(14).GT.maxr) THEN
    +
    531  print *,'THE NUMBER OF SUBSETS EXCEEDS THE MAXIMUM OF',maxr
    +
    532  print *,'PASSED INTO W3FI78; MAXR MUST BE INCREASED IN '
    +
    533  print *,'THE CALLING PROGRAM TO AT LEAST THE VALUE OF'
    +
    534  print *,ident(14),'TO BE ABLE TO PROCESS THIS DATA'
    +
    535 C
    +
    536  iptr(1) = 400
    +
    537  RETURN
    +
    538  END IF
    +
    539  inofst = inofst + 16
    +
    540 C OBSERVED DATA FLAG
    +
    541  CALL gbyte (msga,ivals,inofst,1)
    +
    542  ident(15) = ivals(1)
    +
    543  inofst = inofst + 1
    +
    544 C COMPRESSED DATA FLAG
    +
    545  CALL gbyte (msga,ivals,inofst,1)
    +
    546  ident(16) = ivals(1)
    +
    547  inofst = inofst + 7
    +
    548 C CALCULATE NUMBER OF DESCRIPTORS
    +
    549  nrdesc = (iptr( 6) - 8) / 2
    +
    550  iptr(12) = nrdesc
    +
    551  iptr(13) = nrdesc
    +
    552 C EXTRACT DESCRIPTORS
    +
    553  CALL gbytes (msga,istack,inofst,16,0,nrdesc)
    +
    554 C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS'
    +
    555  DO 10 l = 1, nrdesc
    +
    556  iwork(l) = istack(l)
    +
    557 C PRINT *,L,ISTACK(L)
    +
    558  10 CONTINUE
    +
    559  iptr(13) = nrdesc
    +
    560 C RESET POINTER TO START OF SECTION 4
    +
    561  inofst = iptr(7) + iptr(6) * 8
    +
    562 C BIT OFFSET TO START OF SECTION 4
    +
    563  iptr( 9) = inofst
    +
    564 C SECTION 4 COUNT
    +
    565  CALL gbyte (msga,ivals,inofst,24)
    +
    566 C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1)
    +
    567  iptr( 8) = ivals(1)
    +
    568  inofst = inofst + 32
    +
    569 C SET FOR STARTING BIT OF DATA
    +
    570  iptr(25) = inofst
    +
    571 C FIND OUT IF '7777' TERMINATOR IS THERE
    +
    572  inofst = iptr(9) + iptr(8) * 8
    +
    573  CALL gbyte (msga,ivals,inofst,32)
    +
    574 C PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1)
    +
    575  IF (ivals(1).NE.926365495) THEN
    +
    576  print *,'BAD SECTION COUNT'
    +
    577  iptr(1) = 2
    +
    578  RETURN
    +
    579  ELSE
    +
    580  iptr(1) = 0
    +
    581  END IF
    +
    582 C
    +
    583  CALL fi7801(iptr,ident,msga,istack,iwork,aname,kdata,ivals,mstack,
    +
    584  * aunits,kdesc,mwidth,mref,mscale,knr,index,maxr,maxd,
    +
    585  * iunitb,iunitd)
    +
    586 C
    +
    587 C PRINT *,'HAVE RETURNED FROM FI7801'
    +
    588 C IF (IPTR(1).NE.0) THEN
    +
    589 C RETURN
    +
    590 C END IF
    +
    591 C FURTHER PROCESSING REQUIRED FOR PROFILER DATA
    +
    592  IF (ident(5).EQ.2) THEN
    +
    593  IF (ident(6).EQ.7) THEN
    +
    594 C PRINT *,'BASIC PROFILER DATA'
    +
    595 C DO 153 I = 1, KNR(INDEX)
    +
    596 C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
    +
    597 C 153 CONTINUE
    +
    598 C PRINT *,'REFORMAT PROFILER DATA'
    +
    599 C
    +
    600  IF (ident(1).LT.2) THEN
    +
    601  CALL fi7809(ident,mstack,kdata,iptr,maxr,maxd)
    +
    602  ELSE
    +
    603  CALL fi7810(ident,mstack,kdata,iptr,maxr,maxd)
    +
    604  END IF
    +
    605 C DO 151 I = 1, 40
    +
    606 C IF (I.LE.20) THEN
    +
    607 C PRINT *,'IPTR(',I,')=',IPTR(I),
    +
    608 C * ' IDENT(',I,')= ',IDENT(I)
    +
    609 C ELSE
    +
    610 C PRINT *,'IPTR(',I,')=',IPTR(I)
    +
    611 C END IF
    +
    612 C 151 CONTINUE
    +
    613  IF (iptr(1).NE.0) THEN
    +
    614  RETURN
    +
    615  END IF
    +
    616 C
    +
    617 C DO 154 I = 1, IPTR(31)
    +
    618 C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
    +
    619 C 154 CONTINUE
    +
    620  END IF
    +
    621  END IF
    +
    622  RETURN
    +
    623  END
    +
    624 C
    +
    625 C> @brief Data extraction
    +
    626 C> @author Bill Cavanaugh @date 1988-09-01
    +
    627 
    +
    628 C> Control the extraction of data from section 4 based on data descriptors.
    +
    629 C>
    +
    630 C> Program history log:
    +
    631 C> - Bill Cavanaugh 1988-09-01
    +
    632 C> - Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed
    +
    633 C> data.
    +
    634 C> - Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with
    +
    635 C> delayed replication.
    +
    636 C> - Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
    +
    637 C>
    +
    638 C> @param[in] IPTR See w3fi78() routine docblock
    +
    639 C> @param[in] IDENT See w3fi78() routine docblock
    +
    640 C> @param[in] MSGA Array containing bufr message
    +
    641 C> @param[inout] ISTACK Original array of descriptors extracted from
    +
    642 C> source bufr message.
    +
    643 C> @param[in] MSTACK Working array of descriptors (expanded)and scaling
    +
    644 C> factor
    +
    645 C> @param[inout] KDESC Image of current descriptor
    +
    646 C> @param[in] INDEX
    +
    647 C> @param[in] MAXR maximum number of reports/subsets that may be
    +
    648 C> contained in a bufr message
    +
    649 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    650 C> may be processed; upper air data and some satellite data require a value
    +
    651 C> for maxd of 1600, but for most other data a value for maxd of 500 will suffice
    +
    652 C> @param[in] IUNITB Unit number of data set holding table b
    +
    653 C> @param[in] IUNITD Unit number of data set holding table d
    +
    654 C> @param[out] IWORK Working descriptor list
    +
    655 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    656 C> KDATA(Report number,parameter number)
    +
    657 C> (report number limited to value of input argument maxr and parameter
    +
    658 C> number limited to value of input argument maxd)
    +
    659 C> arrays containing data from table b
    +
    660 C> @param[out] ANAME Descriptor name
    +
    661 C> @param[out] AUNITS Units for descriptor
    +
    662 C> @param[out] MSCALE Scale for value of descriptor
    +
    663 C> @param[out] MREF Reference value for descriptor
    +
    664 C> @param[out] MWIDTH Bit width for value of descriptor
    +
    665 C> @param IVALS
    +
    666 C> @param KNR
    +
    667 C>
    +
    668 C> Error return:
    +
    669 C> IPTR(1)
    +
    670 C> - = 8 Error reading table b
    +
    671 C> - = 9 Error reading table d
    +
    672 C> - = 11 Error opening table b
    +
    673 C>
    +
    674 C> @author Bill Cavanaugh @date 1988-09-01
    +
    675  SUBROUTINE fi7801(IPTR,IDENT,MSGA,ISTACK,IWORK,ANAME,KDATA,IVALS,
    +
    676  * MSTACK,AUNITS,KDESC,MWIDTH,MREF,MSCALE,KNR,INDEX,MAXR,MAXD,
    +
    677  * IUNITB,IUNITD)
    +
    678 
    +
    679  SAVE
    +
    680 C
    +
    681  CHARACTER*40 ANAME(*)
    +
    682  CHARACTER*24 AUNITS(*)
    +
    683 C
    +
    684 C
    +
    685  INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*)
    +
    686 C
    +
    687  INTEGER MSCALE(*),KNR(MAXR)
    +
    688  INTEGER LX,LY,LL,J
    +
    689  INTEGER MREF(700,3)
    +
    690  INTEGER MWIDTH(*)
    +
    691  INTEGER IHOLD(33)
    +
    692  INTEGER ITBLD(500,11)
    +
    693  INTEGER IPTR(*)
    +
    694  INTEGER IDENT(*)
    +
    695  INTEGER KDESC(*)
    +
    696  INTEGER ISTACK(*),IWORK(*)
    +
    697 C
    +
    698  INTEGER MSTACK(2,MAXD),KK
    +
    699 C
    +
    700  INTEGER JDESC
    +
    701  INTEGER INDEX
    +
    702  INTEGER ITEST(30)
    +
    703 C
    +
    704  DATA itest /1,3,7,15,31,63,127,255,
    +
    705  * 511,1023,2047,4095,8191,16383,
    +
    706  * 32767, 65535,131071,262143,524287,
    +
    707  * 1048575,2097151,4194303,8388607,
    +
    708  * 16777215,33554431,67108863,134217727,
    +
    709  * 268435455,536870911,1073741823/
    +
    710 C
    +
    711 C PRINT *,' DECOLL FI7801'
    +
    712  IF (index.GT.1) THEN
    +
    713  GO TO 1000
    +
    714  END IF
    +
    715 C --------- DECOLL ---------------
    +
    716  iptr(23) = 0
    +
    717  iptr(26) = 0
    +
    718  iptr(27) = 0
    +
    719  iptr(28) = 0
    +
    720  iptr(29) = 0
    +
    721  iptr(30) = 0
    +
    722  iptr(36) = 0
    +
    723 C INITIALIZE OUTPUT AREA
    +
    724 C SET POINTER TO BEGINNING OF DATA
    +
    725 C SET BIT
    +
    726  iptr(17) = 1
    +
    727  1000 CONTINUE
    +
    728 C IPTR(12) = IPTR(13)
    +
    729  ll = 0
    +
    730  iptr(11) = 1
    +
    731  IF (iptr(10).EQ.0) THEN
    +
    732 C RE-ENTRY POINT FOR MULTIPLE
    +
    733 C NON-COMPRESSED REPORTS
    +
    734  ELSE
    +
    735  index = iptr(15)
    +
    736  iptr(17) = index
    +
    737  iptr(25) = iptr(10)
    +
    738  iptr(10) = 0
    +
    739  iptr(15) = 0
    +
    740  END IF
    +
    741 C PRINT *,'FI7801 - RPT',IPTR(17),' STARTS AT',IPTR(25)
    +
    742  iptr(24) = 0
    +
    743  iptr(31) = 0
    +
    744 C POINTING AT NEXT AVAILABLE DESCRIPTOR
    +
    745  mm = 0
    +
    746  IF (iptr(21).EQ.0) THEN
    +
    747 C PRINT *,' READING TABLE B'
    +
    748  DO 150 i = 1, 700
    +
    749  iptr(21) = i
    +
    750 C
    +
    751  READ(unit=iunitb,fmt=20,err=9999,END=175)MF,
    +
    752  * mx,my,
    +
    753  * (aname(i)(k:k),k=1,40),
    +
    754  * (aunits(i)(k:k),k=1,24),
    +
    755  * mscale(i),mref(i,1),mwidth(i)
    +
    756  20 FORMAT(i1,i2,i3,40a1,24a1,i5,i15,1x,i4)
    +
    757  IF (mwidth(i).EQ.0) THEN
    +
    758  iptr(1) = 29
    +
    759  RETURN
    +
    760  END IF
    +
    761  mref(i,2) = 0
    +
    762  iptr(14) = i
    +
    763  kdesc(i) = mf*16384 + mx*256 + my
    +
    764 C PRINT *,I
    +
    765 C WRITE(6,21) MF,MX,MY,KDESC(I),
    +
    766 C * (ANAME(I)(K:K),K=1,40),
    +
    767 C * (AUNITS(I)(K:K),K=1,24),
    +
    768 C * MSCALE(I),MREF(I,1),MWIDTH(I)
    +
    769  21 FORMAT(1x,i1,i2,i3,1x,i6,1x,40a1,
    +
    770  * 2x,24a1,2x,i5,2x,i15,1x,i4)
    +
    771  150 CONTINUE
    +
    772  print *,'HAVE READ LIMIT OF 700 TABLE B DESCRIPTORS'
    +
    773  print *,'IF THERE ARE MORE THAT THAT, CORRECT READ LOOP'
    +
    774  175 CONTINUE
    +
    775 C
    +
    776 C CLOSE(UNIT=IUNITB,STATUS='KEEP')
    +
    777 C
    +
    778  iptr(21) = 1
    +
    779  END IF
    +
    780 C DO WHILE MM <= MAXD
    +
    781  10 CONTINUE
    +
    782 C PROCESS THRU THE FOLLOWING
    +
    783 C DEPENDING UPON THE VALUE OF 'F' (LF)
    +
    784  mm = mm + 1
    +
    785  12 CONTINUE
    +
    786  IF (mm.GT.maxd) THEN
    +
    787  GO TO 200
    +
    788  END IF
    +
    789 C END OF CYCLE TEST (SERIAL/SEQUENTIAL)
    +
    790  IF (iptr(11).GT.iptr(12)) THEN
    +
    791 C PRINT *,' HAVE COMPLETED REPORT SEQUENCE'
    +
    792  IF (ident(16).NE.0) THEN
    +
    793 C PRINT *,' PROCESSING COMPRESSED REPORTS'
    +
    794 C REFORMAT DATA FROM DESCRIPTOR
    +
    795 C FORM TO USER FORM
    +
    796  RETURN
    +
    797  ELSE
    +
    798 C WRITE (6,1)
    +
    799 C 1 FORMAT (1H1)
    +
    800 C PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25)
    +
    801  iptr(17) = iptr(17) + 1
    +
    802  IF (iptr(17).GT.ident(14)) THEN
    +
    803  iptr(17) = iptr(17) - 1
    +
    804  GO TO 200
    +
    805  END IF
    +
    806  DO 300 i = 1, iptr(13)
    +
    807  iwork(i) = istack(i)
    +
    808  300 CONTINUE
    +
    809 C RESET POINTERS
    +
    810  ll = 0
    +
    811  iptr(1) = 0
    +
    812  iptr(11) = 1
    +
    813  iptr(12) = iptr(13)
    +
    814 C IS THIS LAST REPORT ?
    +
    815 C PRINT *,'READY',IPTR(39),INDEX
    +
    816  IF (iptr(39).GT.0) THEN
    +
    817  IF (index.GT.0) THEN
    +
    818 C PRINT *,'HERE IS SUBSET NR',INDEX
    +
    819  RETURN
    +
    820  END IF
    +
    821  END IF
    +
    822  GO TO 1000
    +
    823  END IF
    +
    824  END IF
    +
    825  14 CONTINUE
    +
    826 C GET NEXT DESCRIPTOR
    +
    827  CALL fi7808 (iptr,iwork,lf,lx,ly,jdesc,maxd)
    +
    828 C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ',
    +
    829 C * IPTR(11),IWORK(IPTR(11)),IPTR(31)
    +
    830 C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY,
    +
    831 C * ' FOR LOC',IPTR(17),IPTR(25)
    +
    832  IF (iptr(11).GT.1600) THEN
    +
    833  iptr(1) = 401
    +
    834  RETURN
    +
    835  END IF
    +
    836 C
    +
    837  kprm = iptr(31) + iptr(24)
    +
    838  IF (kprm.GT.1600) THEN
    +
    839  IF (kprm.GT.kold) THEN
    +
    840  print *,'EXCEEDED ARRAY SIZE',kprm,iptr(31),
    +
    841  * iptr(24)
    +
    842  kold = kprm
    +
    843  END IF
    +
    844  END IF
    +
    845 C REPLICATION PROCESSING
    +
    846  IF (lf.EQ.1) THEN
    +
    847 C ---------- F1 ---------
    +
    848  iptr(31) = iptr(31) + 1
    +
    849  kprm = iptr(31) + iptr(24)
    +
    850  mstack(1,kprm) = jdesc
    +
    851  mstack(2,kprm) = 0
    +
    852  kdata(iptr(17),kprm) = 0
    +
    853 C PRINT *,'FI7801-1',KPRM,MSTACK(1,KPRM),
    +
    854 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    855  CALL fi7805(iptr,ident,msga,iwork,lx,ly,
    +
    856  * kdata,ll,knr,mstack,maxr,maxd)
    +
    857  IF (iptr(1).NE.0) THEN
    +
    858  RETURN
    +
    859  ELSE
    +
    860  GO TO 12
    +
    861  END IF
    +
    862 C
    +
    863 C DATA DESCRIPTION OPERATORS
    +
    864  ELSE IF (lf.EQ.2)THEN
    +
    865  IF (lx.EQ.5) THEN
    +
    866  ELSE IF (lx.EQ.4) THEN
    +
    867  iptr(31) = iptr(31) + 1
    +
    868  kprm = iptr(31) + iptr(24)
    +
    869  mstack(1,kprm) = jdesc
    +
    870  mstack(2,kprm) = 0
    +
    871  kdata(iptr(17),kprm) = 0
    +
    872 C PRINT *,'FI7801-2',KPRM,MSTACK(1,KPRM),
    +
    873 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    874  END IF
    +
    875  CALL fi7806 (iptr,lx,ly,ident,msga,kdata,ivals,mstack,
    +
    876  * mwidth,mref,mscale,j,ll,kdesc,iwork,jdesc,maxr,maxd)
    +
    877  IF (iptr(1).NE.0) THEN
    +
    878  RETURN
    +
    879  END IF
    +
    880  GO TO 12
    +
    881 C DESCRIPTOR SEQUENCE STRINGS
    +
    882  ELSE IF (lf.EQ.3) THEN
    +
    883 C PRINT *,'F3 SEQUENCE DESCRIPTOR'
    +
    884  IF (iptr(22).EQ.0) THEN
    +
    885 C READ IN TABLE D, BUT JUST ONCE
    +
    886  ierr = 0
    +
    887 C PRINT *,' READING TABLE D'
    +
    888  DO 50 i = 1, 500
    +
    889  READ(iunitd,15,err=9998,END=75 )
    +
    890  * (ihold(j),j=1,33)
    +
    891  15 FORMAT(11(i1,i2,i3,1x),3x)
    +
    892  iptr(20) = i
    +
    893  DO 25 jj = 1, 31, 3
    +
    894  kk = (jj/3) + 1
    +
    895  itbld(i,kk) = ihold(jj)*16384 +
    +
    896  * ihold(jj+1)*256 + ihold(jj+2)
    +
    897  IF (itbld(i,kk).EQ.0) THEN
    +
    898 C PRINT 16,(ITBLD(I,L),L=1,11)
    +
    899  GO TO 50
    +
    900  END IF
    +
    901  25 CONTINUE
    +
    902 C PRINT 16,(ITBLD(I,L),L=1,11)
    +
    903  50 CONTINUE
    +
    904  16 FORMAT(1x,11(i6,1x))
    +
    905  75 CONTINUE
    +
    906  CLOSE(unit=iunitd,status='KEEP')
    +
    907  iptr(22) = 1
    +
    908  ENDIF
    +
    909  CALL fi7807(iptr,iwork,itbld,jdesc,maxd)
    +
    910  IF (iptr(1).GT.0) THEN
    +
    911  RETURN
    +
    912  END IF
    +
    913  GO TO 14
    +
    914 C
    +
    915 C STANDARD DESCRIPTOR PROCESSING
    +
    916  ELSE
    +
    917 C PRINT *,'ENTRY',IPTR(31),JDESC,' AT',IPTR(25)
    +
    918  kprm = iptr(31) + iptr(24)
    +
    919  CALL fi7802(iptr,ident,msga,kdata,kdesc,ll,mstack,
    +
    920  * aunits,mwidth,mref,mscale,jdesc,ivals,j,maxr,maxd)
    +
    921 C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR
    +
    922  iptr(36) = 0
    +
    923  IF (iptr(1).GT.0) THEN
    +
    924  RETURN
    +
    925  ELSE
    +
    926  IF (ident(16).EQ.0) THEN
    +
    927  knr(iptr(17)) = iptr(31)
    +
    928  ELSE
    +
    929  DO 310 kj = 1, maxr
    +
    930  knr(kj) = iptr(31)
    +
    931  310 CONTINUE
    +
    932  END IF
    +
    933  GO TO 10
    +
    934  END IF
    +
    935  END IF
    +
    936 C END IF
    +
    937 C END DO WHILE
    +
    938  200 CONTINUE
    +
    939  IF (ident(16).NE.0) THEN
    +
    940 C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
    +
    941  ELSE
    +
    942 C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS'
    +
    943  END IF
    +
    944  RETURN
    +
    945  9998 CONTINUE
    +
    946  print *,' ERROR READING TABLE D'
    +
    947  iptr(1) = 8
    +
    948  RETURN
    +
    949  9999 CONTINUE
    +
    950  print *,' ERROR READING TABLE B'
    +
    951  iptr(1) = 9
    +
    952  RETURN
    +
    953  END
    +
    954 C> @brief Process standard descriptor
    +
    955 C> @author Bill Cavanaugh @date 1988-09-01
    +
    956 
    +
    957 C> Process a standard descriptor (f = 0) and store data
    +
    958 C> in output array.
    +
    959 C>
    +
    960 C> Program history log:
    +
    961 C> - Bill Cavanaugh 1988-09-01
    +
    962 C> - Bill Cavanaugh 1991-04-04 Changed to pass width of text fields in bytes
    +
    963 C>
    +
    964 C> @param[in] IPTR See w3fi78 routine docblock
    +
    965 C> @param[in] IDENT See w3fi78 routine docblock
    +
    966 C> @param[in] MSGA Array containing bufr message
    +
    967 C> @param[inout] KDATA Array containing decoded reports from bufr message.
    +
    968 C> KDATA(Report number,parameter number)
    +
    969 C> (report number limited to value of input argument maxr and parameter
    +
    970 C> number limited to value of input argument maxd)
    +
    971 C> @param[inout] KDESC Image of current descriptor
    +
    972 C> @param[in] MSTACK
    +
    973 C> @param[in] MAXR maximum number of reports/subsets that may be contained in
    +
    974 C> a bufr message
    +
    975 C> @param[in] MAXD Maximum number of descriptor combinations that may be
    +
    976 C> processed; upper air data and some satellite data require a value for maxd
    +
    977 C> of 1600, but for most other data a value for maxd of 500 will suffice
    +
    978 C> Arrays containing data from table B
    +
    979 C> @param[out] AUNITS Units for descriptor
    +
    980 C> @param[out] MSCALE Scale for value of descriptor
    +
    981 C> @param[out] MREF Reference value for descriptor
    +
    982 C> @param[out] MWIDTH Bit width for value of descriptor
    +
    983 C> @param LL
    +
    984 C> @param JDESC
    +
    985 C> @param IVALS
    +
    986 C> @param J
    +
    987 C>
    +
    988 C> Error return:
    +
    989 C> IPTR(1) = 3 - Message contains a descriptor with f=0 that does not exist
    +
    990 C> in table b.
    +
    991 C>
    +
    992 C> @author Bill Cavanaugh @date 1988-09-01
    +
    993  SUBROUTINE fi7802(IPTR,IDENT,MSGA,KDATA,KDESC,LL,MSTACK,AUNITS,
    +
    994  * MWIDTH,MREF,MSCALE,JDESC,IVALS,J,MAXR,MAXD)
    +
    995  SAVE
    +
    996 C TABLE B ENTRY
    +
    997  CHARACTER*24 ASKEY
    +
    998  CHARACTER*24 AUNITS(*)
    +
    999 C TABLE B ENTRY
    +
    1000  INTEGER MSGA(*)
    +
    1001  INTEGER IPTR(*)
    +
    1002  INTEGER IDENT(*)
    +
    1003  INTEGER J
    +
    1004  INTEGER JDESC
    +
    1005  INTEGER KDESC(*)
    +
    1006  INTEGER MWIDTH(*),MSTACK(2,MAXD),MSCALE(*)
    +
    1007  INTEGER MREF(700,3),KDATA(MAXR,MAXD),IVALS(*)
    +
    1008 C TABLE B ENTRY
    +
    1009 C
    +
    1010  DATA askey /'CCITT IA5 '/
    +
    1011 C
    +
    1012 C PRINT *,' FI7802 - STANDARD DESCRIPTOR PROCESSOR'
    +
    1013 C GET A MATCH BETWEEN CURRENT
    +
    1014 C DESCRIPTOR (JDESC) AND
    +
    1015 C TABLE B ENTRY
    +
    1016 C IF (KDESC(356).EQ.0) THEN
    +
    1017 C PRINT *,'FI7802 - KDESC(356) WENT TO ZER0'
    +
    1018 C IPTR(1) = 600
    +
    1019 C RETURN
    +
    1020 C END IF
    +
    1021  k = 1
    +
    1022  kk = iptr(14)
    +
    1023  IF (jdesc.GT.kdesc(kk)) THEN
    +
    1024  k = kk + 1
    +
    1025  END IF
    +
    1026  10 CONTINUE
    +
    1027  IF (k.GT.kk) THEN
    +
    1028  IF (iptr(36).NE.0) THEN
    +
    1029 C HAVE SKIP FLAG
    +
    1030  IF (ident(16).NE.0) THEN
    +
    1031 C SKIP OVER COMPRESSED DATA
    +
    1032 C LOWEST
    +
    1033  iptr(25) = iptr(25) + iptr(36)
    +
    1034 C NBINC
    +
    1035  CALL gbyte (msga,ihold,iptr(25),6)
    +
    1036  iptr(25) = iptr(25) + 6
    +
    1037  iptr(31) = iptr(31) + 1
    +
    1038  kprm = iptr(31) + iptr(24)
    +
    1039  mstack(1,kprm) = jdesc
    +
    1040  mstack(2,kprm) = 0
    +
    1041  DO 50 i = 1, iptr(14)
    +
    1042  kdata(i,kprm) = 99999
    +
    1043  50 CONTINUE
    +
    1044 C PROCESS DIFFERENCES
    +
    1045  IF (ihold.NE.0) THEN
    +
    1046  ibits = ihold * ident(14)
    +
    1047  iptr(25) = iptr(25) + ibits
    +
    1048  END IF
    +
    1049  ELSE
    +
    1050  iptr(31) = iptr(31) + 1
    +
    1051  kprm = iptr(31) + iptr(24)
    +
    1052  mstack(1,kprm) = jdesc
    +
    1053  mstack(2,kprm) = 0
    +
    1054  kdata(iptr(17),kprm) = 99999
    +
    1055 C SKIP OVER NON-COMPRESSED DATA
    +
    1056 C PRINT *,'SKIP NON-COMPRESSED DATA'
    +
    1057  iptr(25) = iptr(25) + iptr(36)
    +
    1058  END IF
    +
    1059  RETURN
    +
    1060  ELSE
    +
    1061  print *,'FI7802 - ERROR = 3'
    +
    1062  print *,jdesc,k,kk,j,kdesc(j)
    +
    1063  print *,' '
    +
    1064  print *,'TABLE B'
    +
    1065 C DO 20 LL = 1, IPTR(14)
    +
    1066 C PRINT *,LL,KDESC(LL)
    +
    1067 C 20 CONTINUE
    +
    1068  iptr(1) = 3
    +
    1069  RETURN
    +
    1070  END IF
    +
    1071  ELSE
    +
    1072  j = ((kk - k) / 2) + k
    +
    1073  END IF
    +
    1074  IF (jdesc.EQ.kdesc(k)) THEN
    +
    1075  j = k
    +
    1076  GO TO 15
    +
    1077  ELSE IF (jdesc.EQ.kdesc(kk))THEN
    +
    1078  j = kk
    +
    1079  GO TO 15
    +
    1080  ELSE IF (jdesc.LT.kdesc(j)) THEN
    +
    1081  k = k + 1
    +
    1082  kk = j - 1
    +
    1083  GO TO 10
    +
    1084  ELSE IF (jdesc.GT.kdesc(j)) THEN
    +
    1085  k = j + 1
    +
    1086  kk = kk - 1
    +
    1087  GO TO 10
    +
    1088  END IF
    +
    1089  15 CONTINUE
    +
    1090 C HAVE A MATCH
    +
    1091 C SET FLAG IF TEXT EVENT
    +
    1092  IF (askey(1:9).EQ.aunits(j)(1:9)) THEN
    +
    1093  iptr(18) = 1
    +
    1094  iptr(40) = mwidth(j) / 8
    +
    1095  ELSE
    +
    1096  iptr(18) = 0
    +
    1097  END IF
    +
    1098  IF (ident(16).NE.0) THEN
    +
    1099 C COMPRESSED
    +
    1100  CALL fi7803(iptr,ident,msga,kdata,ivals,mstack,
    +
    1101  * mwidth,mref,mscale,j,jdesc,maxr,maxd)
    +
    1102  IF (iptr(1).NE.0) THEN
    +
    1103  RETURN
    +
    1104  END IF
    +
    1105  ELSE
    +
    1106 C NOT COMPRESSED
    +
    1107  CALL fi7804(iptr,msga,kdata,ivals,mstack,
    +
    1108  * mwidth,mref,mscale,j,ll,jdesc,maxr,maxd)
    +
    1109  END IF
    +
    1110  RETURN
    +
    1111  END
    +
    1112 C> @brief Process compressed data
    +
    1113 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1114 
    +
    1115 C> Process compressed data and place individual elements
    +
    1116 C> into output array.
    +
    1117 C>
    +
    1118 C> PROGRAM HISTORY LOG:
    +
    1119 C> - Bill Cavanaugh 1988-09-01
    +
    1120 C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
    +
    1121 C> modified to hanle width of fields in bytes.
    +
    1122 C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
    +
    1123 C> and uncompressed form gave different results. This has been corrected.
    +
    1124 C> - Bill Cavanaugh 1991-06-21 Processing of text data has been changed to
    +
    1125 C> provide exact reproduction of all characters.
    +
    1126 C>
    +
    1127 C> @param[in] IPTR See w3fi78() routine docblock
    +
    1128 C> @param[in] IDENT See w3fi78() routine docblock
    +
    1129 C> @param[in] MSGA Array containing bufr message,mstack,
    +
    1130 C> @param[in] IVALS Array of single parameter values
    +
    1131 C> @param[inout] J
    +
    1132 C> @param[in] MAXR Maximum number of reports/subsets that may be contained in
    +
    1133 C> a bufr message.
    +
    1134 C> @param[in] MAXD Maximum number of descriptor combinations that may be
    +
    1135 C> processed; Upper air data and some satellite data require a value for maxd
    +
    1136 C> of 1600, but for most other data a value for maxd of 500 will suffice.
    +
    1137 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1138 C> KDATA(Report number,parameter number)
    +
    1139 C> (report number limited to value of input argument maxr and parameter number
    +
    1140 C> limited to value of input argument maxd)
    +
    1141 C> Arrays containing data from table B.
    +
    1142 C> @param[out] MSCALE Scale for value of descriptor
    +
    1143 C> @param[out] MREF Reference value for descriptor
    +
    1144 C> @param[out] MWIDTH Bit width for value of descriptor
    +
    1145 C> @param MSTACK
    +
    1146 C> @param JDESC
    +
    1147 C>
    +
    1148 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1149  SUBROUTINE fi7803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
    +
    1150  * MWIDTH,MREF,MSCALE,J,JDESC,MAXR,MAXD)
    +
    1151 
    +
    1152  SAVE
    +
    1153 C
    +
    1154  INTEGER MSGA(*),JDESC,MSTACK(2,MAXD)
    +
    1155  INTEGER IPTR(*),IVALS(*),KDATA(MAXR,MAXD)
    +
    1156  INTEGER NRVALS,JWIDE,IDATA
    +
    1157  INTEGER IDENT(*)
    +
    1158  INTEGER MSCALE(*)
    +
    1159  INTEGER MREF(700,3)
    +
    1160  INTEGER J
    +
    1161  INTEGER MWIDTH(*)
    +
    1162  INTEGER KLOW(256)
    +
    1163 C
    +
    1164  LOGICAL TEXT
    +
    1165 C
    +
    1166  INTEGER MSK(28)
    +
    1167 C
    +
    1168 C
    +
    1169  DATA msk /1,3,7,15,31,63,127,
    +
    1170 C 1 2 3 4 5 6 7
    +
    1171  * 255,511,1023,2047,4095,
    +
    1172 C 8 9 10 11 12
    +
    1173  * 8191,16383,32767,65535,
    +
    1174 C 13 14 15 16
    +
    1175  * 131071,262143,524287,
    +
    1176 C 17 18 19
    +
    1177  * 1048575,2097151,4194303,
    +
    1178 C 20 21 22
    +
    1179  * 8388607,16777215,33554431,
    +
    1180 C 23 24 25
    +
    1181  * 67108863,134217727,268435455/
    +
    1182 C 26 27 28
    +
    1183 C
    +
    1184 C PRINT *,' FI7803 COMPR J=',J,' MWIDTH(J) =',MWIDTH(J),
    +
    1185 C * ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25)
    +
    1186  IF (iptr(18).EQ.0) THEN
    +
    1187  text = .false.
    +
    1188  ELSE
    +
    1189  text = .true.
    +
    1190  END IF
    +
    1191 C PRINT *,'DESCRIPTOR',KPRM
    +
    1192  IF (.NOT.text) THEN
    +
    1193  IF (iptr(29).GT.0) THEN
    +
    1194 C WORKING WITH ASSOCIATED FIELDS HERE
    +
    1195  iptr(31) = iptr(31) + 1
    +
    1196  kprm = iptr(31) + iptr(24)
    +
    1197 C GET LOWEST
    +
    1198  CALL gbyte (msga,lowest,iptr(25),iptr(29))
    +
    1199  iptr(25) = iptr(25) + iptr(29)
    +
    1200 C GET NBINC
    +
    1201  CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1202  iptr(25) = iptr(25) + 6
    +
    1203 C EXTRACT DATA FOR ASSOCIATED FIELD
    +
    1204  IF (nbinc.GT.0) THEN
    +
    1205  CALL gbytes (msga,ivals,iptr(25),nbinc,0,iptr(14))
    +
    1206  iptr(25) = iptr(25) + nbinc * iptr(14)
    +
    1207  DO 50 i = 1, iptr(14)
    +
    1208  kdata(i,kprm) = ivals(i) + lowest
    +
    1209  IF (kdata(i,kprm).GE.msk(nbinc)) THEN
    +
    1210  kdata(i,kprm) = 999999
    +
    1211  END IF
    +
    1212  50 CONTINUE
    +
    1213  ELSE
    +
    1214  DO 51 i = 1, iptr(14)
    +
    1215  IF (lowest.GE.msk(nbinc)) THEN
    +
    1216  kdata(i,kprm) = 999999
    +
    1217  ELSE
    +
    1218  kdata(i,kprm) = lowest
    +
    1219  END IF
    +
    1220  51 CONTINUE
    +
    1221  END IF
    +
    1222  END IF
    +
    1223 C SET PARAMETER
    +
    1224 C ISOLATE STANDARD BIT WIDTH
    +
    1225  jwide = mwidth(j) + iptr(26)
    +
    1226 C SINGLE VALUE FOR LOWEST
    +
    1227  nrvals = 1
    +
    1228 C LOWEST
    +
    1229 C PRINT *,'PARAM',KPRM
    +
    1230  CALL gbyte (msga,lowest,iptr(25),jwide)
    +
    1231 C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25)
    +
    1232  iptr(25) = iptr(25) + jwide
    +
    1233 C ISOLATE COMPRESSED BIT WIDTH
    +
    1234  CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1235 C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25)
    +
    1236  IF (iptr(32).EQ.2.AND.iptr(33).EQ.5) THEN
    +
    1237  ELSE
    +
    1238  IF (nbinc.GT.jwide) THEN
    +
    1239 C PRINT *,'FOR DESCRIPTOR',JDESC
    +
    1240 C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' MWIDTH(J)=',
    +
    1241 C * MWIDTH(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25)
    +
    1242 C DO 110 I = 1, KPRM
    +
    1243 C WRITE (6,111)I,(KDATA(J,I),J=1,6)
    +
    1244 C 110 CONTINUE
    +
    1245  111 FORMAT (1x,5hdata ,i3,6(2x,i10))
    +
    1246  iptr(1) = 500
    +
    1247 C RETURN
    +
    1248  print *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE',
    +
    1249  * ' B PLUS WIDTH CHANGES'
    +
    1250  END IF
    +
    1251  END IF
    +
    1252  iptr(25) = iptr(25) + 6
    +
    1253 C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC
    +
    1254 C IF TEXT EVENT, PROCESS TEXT
    +
    1255 C GET COMPRESSED VALUES
    +
    1256 C PRINT *,'COMPRESSED VALUES - NONTEXT'
    +
    1257  nrvals = ident(14)
    +
    1258  iptr(31) = iptr(31) + 1
    +
    1259  kprm = iptr(31) + iptr(24)
    +
    1260  IF (nbinc.NE.0) THEN
    +
    1261  CALL gbytes (msga,ivals,iptr(25),nbinc,0,nrvals)
    +
    1262  iptr(25) = iptr(25) + nbinc * nrvals
    +
    1263 C RECALCULATE TO ORIGINAL VALUES
    +
    1264  DO 100 i = 1, nrvals
    +
    1265 C PRINT *,IVALS(I),MSK(NBINC),NBINC
    +
    1266  IF (ivals(i).GE.msk(nbinc)) THEN
    +
    1267  kdata(i,kprm) = 999999
    +
    1268  ELSE
    +
    1269  IF (mref(j,2).EQ.0) THEN
    +
    1270  kdata(i,kprm) = ivals(i) + lowest + mref(j,1)
    +
    1271  ELSE
    +
    1272  kdata(i,kprm) = ivals(i) + lowest + mref(j,3)
    +
    1273  END IF
    +
    1274  END IF
    +
    1275  100 CONTINUE
    +
    1276 C PRINT *,I,JDESC,LOWEST,MREF(J,1),MREF(J,3)
    +
    1277  ELSE
    +
    1278  IF (lowest.EQ.msk(mwidth(j))) THEN
    +
    1279  DO 105 i = 1, nrvals
    +
    1280  kdata(i,kprm) = 999999
    +
    1281  105 CONTINUE
    +
    1282  ELSE
    +
    1283  IF (mref(j,2).EQ.0) THEN
    +
    1284  icomb = lowest + mref(j,1)
    +
    1285  ELSE
    +
    1286  icomb = lowest + mref(j,3)
    +
    1287  END IF
    +
    1288  DO 106 i = 1, nrvals
    +
    1289  kdata(i,kprm) = icomb
    +
    1290  106 CONTINUE
    +
    1291  END IF
    +
    1292  END IF
    +
    1293 C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25)
    +
    1294  mstack(1,kprm) = jdesc
    +
    1295  IF (iptr(27).NE.0) THEN
    +
    1296  mstack(2,kprm) = iptr(27)
    +
    1297  ELSE
    +
    1298  mstack(2,kprm) = mscale(j)
    +
    1299  END IF
    +
    1300 C WRITE (6,80) (DATA(I,KPRM),I=1,10)
    +
    1301 C 80 FORMAT(2X,10(F10.2,1X))
    +
    1302  ELSE IF (text) THEN
    +
    1303 C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40)
    +
    1304 C GET LOWEST
    +
    1305 C PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40))
    +
    1306  DO 1906 k = 1, iptr(40)
    +
    1307  CALL gbyte (msga,klow,iptr(25),8)
    +
    1308  iptr(25) = iptr(25) + 8
    +
    1309  IF (klow(k).NE.0) THEN
    +
    1310  iptr(1) = 27
    +
    1311  print *,'NON-ZERO LOWEST ON TEXT DATA'
    +
    1312  RETURN
    +
    1313  END IF
    +
    1314  1906 CONTINUE
    +
    1315 C GET NBINC
    +
    1316  CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1317 C PRINT *,'NBINC =',NBINC
    +
    1318  iptr(25) = iptr(25) + 6
    +
    1319  IF (nbinc.NE.iptr(40)) THEN
    +
    1320  iptr(1) = 28
    +
    1321  print *,'NBINC IS NOT THE NUMBER OF CHARACTERS',nbinc
    +
    1322  RETURN
    +
    1323  END IF
    +
    1324 C FOR NUMBER OF OBSERVATIONS
    +
    1325  iptr(31) = iptr(31) + 1
    +
    1326  kprm = iptr(31) + iptr(24)
    +
    1327  istart = kprm
    +
    1328  i24 = iptr(24)
    +
    1329  DO 1900 n = 1, ident(14)
    +
    1330  kprm = istart
    +
    1331  iptr(24) = i24
    +
    1332  nbits = iptr(40) * 8
    +
    1333  1700 CONTINUE
    +
    1334 C PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS
    +
    1335  IF (nbits.GT.32) THEN
    +
    1336  CALL gbyte (msga,idata,iptr(25),32)
    +
    1337  iptr(25) = iptr(25) + 32
    +
    1338  nbits = nbits - 32
    +
    1339 C CONVERTS ASCII TO EBCIDIC
    +
    1340 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1341 C PRINT *,IDATA
    +
    1342 C CALL W3AI39 (IDATA,4)
    +
    1343  mstack(1,kprm) = jdesc
    +
    1344  mstack(2,kprm) = 0
    +
    1345  kdata(n,kprm) = idata
    +
    1346 C SET FOR NEXT PART
    +
    1347  kprm = kprm + 1
    +
    1348  iptr(24) = iptr(24) + 1
    +
    1349 C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
    +
    1350  1701 FORMAT (1x,i1,1x,6hkdata=,a4,2x,i5,2x,i5,2x,i5,2x,i12)
    +
    1351  GO TO 1700
    +
    1352  ELSE IF (nbits.GT.0) THEN
    +
    1353  CALL gbyte (msga,idata,iptr(25),nbits)
    +
    1354  iptr(25) = iptr(25) + nbits
    +
    1355  ibuf = (32 - nbits) / 8
    +
    1356  IF (ibuf.GT.0) THEN
    +
    1357  DO 1750 mp = 1, ibuf
    +
    1358  idata = idata * 256 + 32
    +
    1359  1750 CONTINUE
    +
    1360  END IF
    +
    1361 C CONVERTS ASCII TO EBCIDIC
    +
    1362 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1363 C CALL W3AI39 (IDATA,4)
    +
    1364  mstack(1,kprm) = jdesc
    +
    1365  mstack(2,kprm) = 0
    +
    1366  kdata(n,kprm) = idata
    +
    1367 C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
    +
    1368  nbits = 0
    +
    1369  END IF
    +
    1370 C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
    +
    1371 C1800 FORMAT (2X,I4,2X,3A4)
    +
    1372  1900 CONTINUE
    +
    1373  END IF
    +
    1374  RETURN
    +
    1375  END
    +
    1376 
    +
    1377 C> @brief Process serial data.
    +
    1378 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1379 
    +
    1380 C> Process data that is not compressed.
    +
    1381 C>
    +
    1382 C> Program history log:
    +
    1383 C> - Bill Cavanaugh 1988-09-01
    +
    1384 C> - Bill Cavanaugh 1991-01-18 Modified to properly handle non-compressed
    +
    1385 C> data.
    +
    1386 C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
    +
    1387 C> modified to handle field width in bytes.
    +
    1388 C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
    +
    1389 C> and uncompressed form gave different results.
    +
    1390 C> this has been corrected.
    +
    1391 C>
    +
    1392 C> @param[in] IPTR See w3fi78 routine docblock
    +
    1393 C> @param[in] MSGA Array containing bufr message
    +
    1394 C> @param[inout] IVALS Array of single parameter values
    +
    1395 C> @param[inout] J
    +
    1396 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    1397 C> contained in a bufr message
    +
    1398 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    1399 C> may be processed; upper air data and some satellite
    +
    1400 C> data require a value for maxd of 1600, but for most
    +
    1401 C> other data a value for maxd of 500 will suffice
    +
    1402 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1403 C> KDATA(report number,parameter number)
    +
    1404 C> (report number limited to value of input argument maxr and parameter number
    +
    1405 C> limited to value of input argument maxd)
    +
    1406 C> arrays containing data from table B
    +
    1407 C> @param[out] MSCALE Scale for value of descriptor
    +
    1408 C> @param[out] MREF Reference value for descriptor
    +
    1409 C> @param[out] MWIDTH Bit width for value of descriptor
    +
    1410 C> @param MSTACK
    +
    1411 C> @param LL
    +
    1412 C> @param JDESC
    +
    1413 C>
    +
    1414 C> Error return:
    +
    1415 C> IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8
    +
    1416 C>
    +
    1417 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1418  SUBROUTINE fi7804(IPTR,MSGA,KDATA,IVALS,MSTACK,
    +
    1419  * MWIDTH,MREF,MSCALE,J,LL,JDESC,MAXR,MAXD)
    +
    1420  SAVE
    +
    1421 C
    +
    1422  INTEGER MSGA(*)
    +
    1423  INTEGER IPTR(*),MREF(700,3),MSCALE(*)
    +
    1424  INTEGER MWIDTH(*),JDESC
    +
    1425  INTEGER IVALS(*)
    +
    1426  INTEGER LSTBLK(3)
    +
    1427  INTEGER KDATA(MAXR,MAXD),MSTACK(2,MAXD)
    +
    1428  INTEGER J,LL
    +
    1429  LOGICAL LKEY
    +
    1430 C
    +
    1431 C
    +
    1432  INTEGER ITEST(30)
    +
    1433  DATA itest /1,3,7,15,31,63,127,255,
    +
    1434  * 511,1023,2047,4095,8191,16383,
    +
    1435  * 32767, 65535,131071,262143,524287,
    +
    1436  * 1048575,2097151,4194303,8388607,
    +
    1437  * 16777215,33554431,67108863,134217727,
    +
    1438  * 268435455,536870911,1073741823/
    +
    1439 C
    +
    1440 C PRINT *,' FI7804 NOCMP',J,JDESC,MWIDTH(J),IPTR(26),IPTR(25)
    +
    1441  IF ((iptr(26)+mwidth(j)).LT.1) THEN
    +
    1442  iptr(1) = 501
    +
    1443  RETURN
    +
    1444  END IF
    +
    1445 C -------- NOCMP --------
    +
    1446 C ISOLATE BIT WIDTH
    +
    1447  jwide = mwidth(j) + iptr(26)
    +
    1448 C IF NOT TEXT EVENT, PROCESS
    +
    1449  IF (iptr(18).NE.1) THEN
    +
    1450 C IF ASSOCIATED FIELD SW ON
    +
    1451  IF (iptr(29).GT.0) THEN
    +
    1452  IF (jdesc.NE.7957.AND.jdesc.NE.7937) THEN
    +
    1453  iptr(31) = iptr(31) + 1
    +
    1454  kprm = iptr(31) + iptr(24)
    +
    1455  mstack(1,kprm) = 33792 + iptr(29)
    +
    1456  mstack(2,kprm) = 0
    +
    1457  CALL gbyte (msga,ivals,iptr(25),iptr(29))
    +
    1458  iptr(25) = iptr(25) + iptr(29)
    +
    1459  kdata(iptr(17),kprm) = ivals(1)
    +
    1460 C PRINT *,'FI7804-A',KPRM,MSTACK(1,KPRM),
    +
    1461 C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
    +
    1462  END IF
    +
    1463  END IF
    +
    1464  iptr(31) = iptr(31) + 1
    +
    1465  kprm = iptr(31) + iptr(24)
    +
    1466  mstack(1,kprm) = jdesc
    +
    1467  IF (iptr(27).NE.0) THEN
    +
    1468  mstack(2,kprm) = iptr(27)
    +
    1469  ELSE
    +
    1470  mstack(2,kprm) = mscale(j)
    +
    1471  END IF
    +
    1472 C GET VALUES
    +
    1473 C CALL TO GET DATA OF GIVEN BIT WIDTH
    +
    1474  CALL gbyte (msga,ivals,iptr(25),jwide)
    +
    1475 C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25)
    +
    1476  iptr(25) = iptr(25) + jwide
    +
    1477 C RETURN WITH SINGLE VALUE
    +
    1478  IF (ivals(1).EQ.itest(jwide)) THEN
    +
    1479  kdata(iptr(17),kprm) = 999999
    +
    1480  ELSE
    +
    1481  IF (mref(j,2).EQ.0) THEN
    +
    1482  kdata(iptr(17),kprm) = ivals(1) + mref(j,1)
    +
    1483  ELSE
    +
    1484  kdata(iptr(17),kprm) = ivals(1) + mref(j,3)
    +
    1485  END IF
    +
    1486  END IF
    +
    1487 C PRINT *,'FI7804-B',KPRM,MSTACK(1,KPRM),
    +
    1488 C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
    +
    1489 C IF(JDESC.EQ.2049) THEN
    +
    1490 C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM)
    +
    1491 C END IF
    +
    1492 C PRINT *,'FI7804 ',KPRM,MSTACK(1,KPRM),
    +
    1493 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1494  ELSE
    +
    1495 C IF TEXT EVENT, PROCESS TEXT
    +
    1496 C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
    +
    1497  nrchrs = iptr(40)
    +
    1498  nrbits = nrchrs * 8
    +
    1499 C PRINT *,'CHARS =',NRCHRS,' BITS =',NRBITS
    +
    1500  iptr(31) = iptr(31) + 1
    +
    1501  kany = 0
    +
    1502  1800 CONTINUE
    +
    1503  kany = kany + 1
    +
    1504  IF (nrbits.GT.32) THEN
    +
    1505  CALL gbyte (msga,idata,iptr(25),32)
    +
    1506 C PRINT 1801,KANY,IDATA,IPTR(17),KPRM
    +
    1507 C1801 FORMAT (1X,I2,4X,Z8,2(4X,I4))
    +
    1508 C CONVERTS ASCII TO EBCIDIC
    +
    1509 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1510 C CALL W3AI39 (IDATA,4)
    +
    1511  kprm = iptr(31) + iptr(24)
    +
    1512  kdata(iptr(17),kprm) = idata
    +
    1513  mstack(1,kprm) = jdesc
    +
    1514  mstack(2,kprm) = 0
    +
    1515 C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
    +
    1516 C * KDATA(IPTR(17),KPRM)
    +
    1517  iptr(25) = iptr(25) + 32
    +
    1518  nrbits = nrbits - 32
    +
    1519  iptr(24) = iptr(24) + 1
    +
    1520  GO TO 1800
    +
    1521  ELSE IF (nrbits.GT.0) THEN
    +
    1522 C PRINT *,'LAST TEXT WORD'
    +
    1523  CALL gbyte (msga,idata,iptr(25),nrbits)
    +
    1524  iptr(25) = iptr(25) + nrbits
    +
    1525 C CONVERTS ASCII TO EBCIDIC
    +
    1526 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1527 C CALL W3AI39 (IDATA,4)
    +
    1528  kprm = iptr(31) + iptr(24)
    +
    1529  kshft = 32 - nrbits
    +
    1530  IF (kshft.GT.0) THEN
    +
    1531  ktry = kshft / 8
    +
    1532  DO 1722 lak = 1, ktry
    +
    1533  idata = idata * 256 + 64
    +
    1534 C PRINT 1723,IDATA
    +
    1535  1723 FORMAT (12x,z8)
    +
    1536  1722 CONTINUE
    +
    1537  END IF
    +
    1538  kdata(iptr(17),kprm) = idata
    +
    1539 C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM
    +
    1540  mstack(1,kprm) = jdesc
    +
    1541  mstack(2,kprm) = 0
    +
    1542 C PRINT *,KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
    +
    1543 C * KDATA(IPTR(17),KPRM)
    +
    1544  END IF
    +
    1545 C TURN OFF TEXT
    +
    1546  iptr(18) = 0
    +
    1547  END IF
    +
    1548  RETURN
    +
    1549  END
    +
    1550 C> @brief Process a replication descriptor.
    +
    1551 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1552 
    +
    1553 C> Process a replication descriptor, must extract number
    +
    1554 C> of replications of n descriptors from the data stream.
    +
    1555 C>
    +
    1556 C> Program history log:
    +
    1557 C> - Bill Cavanaugh 1988-09-01
    +
    1558 C>
    +
    1559 C> @param[in] IWORK Working descriptor list
    +
    1560 C> @param[in] IPTR See w3fi78 routine docblock
    +
    1561 C> @param[in] IDENT See w3fi78 routine docblock
    +
    1562 C> @param[inout] LX X portion of current descriptor
    +
    1563 C> @param[inout] LY Y portion of current descriptor
    +
    1564 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    1565 C> contained in a bufr message.
    +
    1566 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    1567 C> may be processed; upper air data and some satellite
    +
    1568 C> data require a value for maxd of 1600, but for most
    +
    1569 C> other data a value for maxd of 500 will suffice
    +
    1570 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1571 C> KDATA(report number,parameter number)
    +
    1572 C> (report number limited to value of input argument
    +
    1573 C> maxr and parameter number limited to value of input
    +
    1574 C> argument maxd)
    +
    1575 C> @param MSGA
    +
    1576 C> @param LL
    +
    1577 C> @param KNR
    +
    1578 C> @param MSTACK
    +
    1579 C>
    +
    1580 C> Error return:
    +
    1581 C> IPTR(1):
    +
    1582 C> - = 12 Data descriptor qualifier does not follow delayed replication
    +
    1583 C> descriptor
    +
    1584 C> - = 20 Exceeded count for delayed replication pass
    +
    1585 C>
    +
    1586 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1587  SUBROUTINE fi7805(IPTR,IDENT,MSGA,IWORK,LX,LY,
    +
    1588  * KDATA,LL,KNR,MSTACK,MAXR,MAXD)
    +
    1589 
    +
    1590  SAVE
    +
    1591 C
    +
    1592  INTEGER IPTR(*)
    +
    1593  INTEGER KNR(MAXR)
    +
    1594  INTEGER ITEMP(2000)
    +
    1595  INTEGER LL
    +
    1596  INTEGER KTEMP(2000)
    +
    1597  INTEGER KDATA(MAXR,MAXD)
    +
    1598  INTEGER LX,MSTACK(2,MAXD)
    +
    1599  INTEGER LY
    +
    1600  INTEGER MSGA(*)
    +
    1601  INTEGER KVALS(1000)
    +
    1602  INTEGER IWORK(MAXD)
    +
    1603  INTEGER IDENT(*)
    +
    1604 C
    +
    1605 C PRINT *,' REPLICATION FI7805'
    +
    1606 C DO 100 I = 1, IPTR(13)
    +
    1607 C PRINT *,I,IWORK(I)
    +
    1608 C 100 CONTINUE
    +
    1609 C NUMBER OF DESCRIPTORS
    +
    1610  nrset = lx
    +
    1611 C NUMBER OF REPLICATIONS
    +
    1612  nrreps = ly
    +
    1613  icurr = iptr(11) - 1
    +
    1614  ipick = iptr(11) - 1
    +
    1615 C
    +
    1616  IF (nrreps.EQ.0) THEN
    +
    1617  iptr(39) = 1
    +
    1618 C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR
    +
    1619 C IPTR(31) = IPTR(31) + 1
    +
    1620 C KPRM = IPTR(31) + IPTR(24)
    +
    1621 C MSTACK(1,KPRM) = JDESC
    +
    1622 C MSTACK(2,KPRM) = 0
    +
    1623 C KDATA(IPTR(17),KPRM) = 0
    +
    1624 C PRINT *,'FI7805-1',KPRM,MSTACK(1,KPRM),
    +
    1625 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1626 C DELAYED REPLICATION - MUST GET NUMBER OF
    +
    1627 C REPLICATIONS FROM DATA.
    +
    1628 C GET NEXT DESCRIPTOR
    +
    1629  CALL fi7808(iptr,iwork,lf,lx,ly,jdesc,maxd)
    +
    1630 C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC
    +
    1631 C MUST BE DATA DESCRIPTION
    +
    1632 C OPERATION QUALIFIER
    +
    1633  IF (jdesc.EQ.7937.OR.jdesc.EQ.7947) THEN
    +
    1634  jwide = 8
    +
    1635  ELSE IF (jdesc.EQ.7938.OR.jdesc.EQ.7948) THEN
    +
    1636  jwide = 16
    +
    1637  ELSE
    +
    1638  iptr(1) = 12
    +
    1639  RETURN
    +
    1640  END IF
    +
    1641 
    +
    1642 C SET SINGLE VALUE FOR SEQUENTIAL,
    +
    1643 C MULTIPLE VALUES FOR COMPRESSED
    +
    1644  IF (ident(16).EQ.0) THEN
    +
    1645 C NON COMPRESSED
    +
    1646  CALL gbyte (msga,kvals,iptr(25),jwide)
    +
    1647 C PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1)
    +
    1648  iptr(25) = iptr(25) + jwide
    +
    1649  iptr(31) = iptr(31) + 1
    +
    1650  kprm = iptr(31) + iptr(24)
    +
    1651  mstack(1,kprm) = jdesc
    +
    1652  mstack(2,kprm) = 0
    +
    1653  kdata(iptr(17),kprm) = kvals(1)
    +
    1654  nrreps = kvals(1)
    +
    1655 C PRINT *,'FI7805-2',KPRM,MSTACK(1,KPRM),
    +
    1656 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1657  ELSE
    +
    1658  nrvals = ident(14)
    +
    1659  CALL gbytes (msga,kvals,iptr(25),jwide,0,nrvals)
    +
    1660  iptr(25) = iptr(25) + jwide * nrvals
    +
    1661  iptr(31) = iptr(31) + 1
    +
    1662  kprm = iptr(31) + iptr(24)
    +
    1663  mstack(1,kprm) = jdesc
    +
    1664  mstack(2,kprm) = 0
    +
    1665  kdata(iptr(17),kprm) = kvals(1)
    +
    1666  DO 100 i = 1, nrvals
    +
    1667  kdata(i,kprm) = kvals(i)
    +
    1668  100 CONTINUE
    +
    1669  nrreps = kvals(1)
    +
    1670  END IF
    +
    1671  ELSE
    +
    1672 C PRINT *,'NOT DELAYED REPLICATION'
    +
    1673  END IF
    +
    1674 C RESTRUCTURE WORKING STACK W/REPLICATIONS
    +
    1675 C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
    +
    1676 C PICK UP DESCRIPTORS TO BE REPLICATED
    +
    1677  DO 1000 i = 1, nrset
    +
    1678  CALL fi7808(iptr,iwork,lf,lx,ly,jdesc,maxd)
    +
    1679  itemp(i) = jdesc
    +
    1680 C PRINT *,'REPLICATION ',I,ITEMP(I)
    +
    1681  1000 CONTINUE
    +
    1682 C MOVE TRAILING DESCRIPTORS TO HOLD AREA
    +
    1683  lax = iptr(12) - iptr(11) + 1
    +
    1684 C PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12)
    +
    1685  DO 2000 i = 1, lax
    +
    1686  CALL fi7808(iptr,iwork,lf,lx,ly,jdesc,maxd)
    +
    1687  ktemp(i) = jdesc
    +
    1688 C PRINT *,' ',I,KTEMP(I)
    +
    1689  2000 CONTINUE
    +
    1690 C REPLICATIONS INTO ISTACK
    +
    1691 C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES'
    +
    1692 C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR
    +
    1693  DO 4000 i = 1, nrreps
    +
    1694  DO 3000 j = 1, nrset
    +
    1695  iwork(icurr) = itemp(j)
    +
    1696 C PRINT *,'FI7805 A',ICURR,IWORK(ICURR)
    +
    1697  icurr = icurr + 1
    +
    1698  3000 CONTINUE
    +
    1699  4000 CONTINUE
    +
    1700 C PRINT *,' TO LOC',ICURR-1
    +
    1701 C RESTORE TRAILING DESCRIPTORS
    +
    1702 C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR
    +
    1703  DO 5000 i = 1, lax
    +
    1704  iwork(icurr) = ktemp(i)
    +
    1705 C PRINT *,'FI7805 B',ICURR,IWORK(ICURR)
    +
    1706  icurr = icurr + 1
    +
    1707  5000 CONTINUE
    +
    1708  iptr(12) = icurr - 1
    +
    1709  iptr(11) = ipick
    +
    1710  RETURN
    +
    1711  END
    +
    1712 C> @brief Process operator descriptors
    +
    1713 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1714 
    +
    1715 C> Extract and save indicated change values for use
    +
    1716 C> until changes are rescinded, or extract text strings indicated
    +
    1717 C> through 2 05 yyy.
    +
    1718 C>
    +
    1719 C> Program history log:
    +
    1720 C> - Bill Cavanaugh 1988-09-01
    +
    1721 C> - Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
    +
    1722 C> - Bill Cavanaugh 1991-05-10 Coding has been added to process proposed
    +
    1723 C> table c descriptor 2 06 yyy.
    +
    1724 C> - Bill Cavanaugh 1991-11-21 Coding has been added to properly process
    +
    1725 C> table c descriptor 2 03 yyy, the change
    +
    1726 C> to new reference value for selected
    +
    1727 C> descriptors.
    +
    1728 C>
    +
    1729 C> @param[in] IPTR See w3fi78 routine docblock
    +
    1730 C> @param[in] LX X portion of current descriptor
    +
    1731 C> @param[in] LY Y portion of current descriptor
    +
    1732 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    1733 C> contained in a bufr message
    +
    1734 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    1735 C> may be processed; upper air data and some satellite
    +
    1736 C> data require a value for maxd of 1600, but for most
    +
    1737 C> other data a value for maxd of 500 will suffice
    +
    1738 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1739 C> KDATA(Report number,parameter number)
    +
    1740 C> (report number limited to value of input argument maxr and parameter number
    +
    1741 C> limited to value of input argument maxd)
    +
    1742 C> Arrays containing data from table b
    +
    1743 C> @param[out] MSCALE Scale for value of descriptor
    +
    1744 C> @param[out] MREF Reference value for descriptor
    +
    1745 C> @param[out] MWIDTH Bit width for value of descriptor
    +
    1746 C> @param IDENT
    +
    1747 C> @param MSGA
    +
    1748 C> @param IVALS
    +
    1749 C> @param MSTACK
    +
    1750 C> @param J
    +
    1751 C> @param LL
    +
    1752 C> @param KDESC
    +
    1753 C> @param JDESC
    +
    1754 C> @param IWORK
    +
    1755 C>
    +
    1756 C> Error return:
    +
    1757 C> IPTR(1) = 5 - Erroneous X value in data descriptor operator
    +
    1758 C>
    +
    1759 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1760  SUBROUTINE fi7806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
    +
    1761  * MWIDTH,MREF,MSCALE,J,LL,KDESC,IWORK,JDESC,MAXR,MAXD)
    +
    1762 
    +
    1763  SAVE
    +
    1764  INTEGER IPTR(*),KDATA(MAXR,MAXD),IVALS(*)
    +
    1765  INTEGER IDENT(*),IWORK(*)
    +
    1766  INTEGER MSGA(*),MSTACK(2,MAXD)
    +
    1767  INTEGER MREF(700,3),KDESC(*)
    +
    1768  INTEGER MSCALE(*),MWIDTH(*)
    +
    1769  INTEGER J,JDESC
    +
    1770  INTEGER LL
    +
    1771  INTEGER LX
    +
    1772  INTEGER LY
    +
    1773 C
    +
    1774 C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR'
    +
    1775  IF (lx.EQ.1) THEN
    +
    1776 C CHANGE BIT WIDTH
    +
    1777  IF (ly.EQ.0) THEN
    +
    1778 C PRINT *,' RETURN TO NORMAL WIDTH'
    +
    1779  iptr(26) = 0
    +
    1780  ELSE
    +
    1781 C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS'
    +
    1782  iptr(26) = ly - 128
    +
    1783  END IF
    +
    1784  ELSE IF (lx.EQ.2) THEN
    +
    1785 C CHANGE SCALE
    +
    1786  IF (ly.EQ.0) THEN
    +
    1787 C RESET TO STANDARD SCALE
    +
    1788  iptr(27) = 0
    +
    1789  ELSE
    +
    1790 C SET NEW SCALE
    +
    1791  iptr(27) = ly - 128
    +
    1792  END IF
    +
    1793  ELSE IF (lx.EQ.3) THEN
    +
    1794 C CHANGE REFERENCE VALUE
    +
    1795 C FOR EACH OF THOSE DESCRIPTORS BETWEEN
    +
    1796 C 2 03 YYY WHERE Y LT 255 AND
    +
    1797 C 2 03 255, EXTRACT THE NEW REFERENCE
    +
    1798 C VALUE (BIT WIDTH YYY) AND PLACE
    +
    1799 C IN TERTIARY TABLE B REF VAL POSITION,
    +
    1800 C SET FLAG IN SECONDARY REFVAL POSITION
    +
    1801 C THOSE DESCRIPTORS DO NOT HAVE DATA
    +
    1802 C ASSOCIATED WITH THEM, BUT ONLY
    +
    1803 C IDENTIFY THE TABLE B ENTRIES THAT
    +
    1804 C ARE GETTING NEW REFERENCE VALUES.
    +
    1805  kyyy = ly
    +
    1806  IF (kyyy.GT.0.AND.kyyy.LT.255) THEN
    +
    1807 C START CYCLING THRU DESCRIPTORS UNTIL
    +
    1808 C TERMINATE NEW REF VALS IS FOUND
    +
    1809  300 CONTINUE
    +
    1810  CALL fi7808 (iptr,iwork,lf,lx,ly,jdesc,maxd)
    +
    1811  IF (jdesc.EQ.33791) THEN
    +
    1812 C IF 2 03 255 THEN RETURN
    +
    1813  RETURN
    +
    1814  ELSE
    +
    1815 C FIND MATCHING TABLE B ENTRY
    +
    1816  DO 500 lj = 1, iptr(14)
    +
    1817  IF (jdesc.EQ.kdesc(lj)) THEN
    +
    1818 C TURN ON NEW REF VAL FLAG
    +
    1819  mref(lj,2) = 1
    +
    1820 C INSERT NEW REF VAL
    +
    1821  CALL gbyte (msga,mref(lj,3),iptr(25),kyyy)
    +
    1822 C GO GET NEXT DESCRIPTOR
    +
    1823  GO TO 300
    +
    1824  END IF
    +
    1825  500 CONTINUE
    +
    1826 C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR
    +
    1827  print *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND'
    +
    1828  stop 203
    +
    1829  END IF
    +
    1830  ELSE IF (kyyy.EQ.0) THEN
    +
    1831 C MUST TURN OFF ALL NEW
    +
    1832 C REFERENCE VALUES
    +
    1833  DO 400 i = 1, iptr(14)
    +
    1834  mref(i,2) = 0
    +
    1835  400 CONTINUE
    +
    1836  END IF
    +
    1837 C LX = 3
    +
    1838 C MUST BE CONCLUDED WITH Y=255
    +
    1839  ELSE IF (lx.EQ.4) THEN
    +
    1840 C ASSOCIATED VALUES
    +
    1841  IF (ly.EQ.0) THEN
    +
    1842  iptr(29) = 0
    +
    1843 C PRINT *,'RESET ASSOCIATED VALUES',IPTR(29)
    +
    1844  ELSE
    +
    1845  iptr(29) = ly
    +
    1846  IF (iwork(iptr(11)).NE.7957) THEN
    +
    1847  print *,'2 04 YYY NOT FOLLOWED BY 0 31 021'
    +
    1848  iptr(1) = 11
    +
    1849  END IF
    +
    1850 C PRINT *,'SET ASSOCIATED VALUES',IPTR(29)
    +
    1851  END IF
    +
    1852  ELSE IF (lx.EQ.5) THEN
    +
    1853 C PROCESS TEXT DATA
    +
    1854  iptr(40) = ly
    +
    1855  iptr(18) = 1
    +
    1856  IF (ident(16).EQ.0) THEN
    +
    1857 C PRINT *,'2 05 YYY - TEXT - NONCOMPRESSED MODE'
    +
    1858  CALL fi7804(iptr,msga,kdata,ivals,mstack,
    +
    1859  * mwidth,mref,mscale,j,ll,jdesc,maxr,maxd)
    +
    1860  ELSE
    +
    1861 C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE'
    +
    1862  CALL fi7803(iptr,ident,msga,kdata,ivals,mstack,
    +
    1863  * mwidth,mref,mscale,j,jdesc,maxr,maxd)
    +
    1864  IF (iptr(1).NE.0) THEN
    +
    1865  RETURN
    +
    1866  END IF
    +
    1867  ENDIF
    +
    1868  iptr(18) = 0
    +
    1869  ELSE IF (lx.EQ.6) THEN
    +
    1870 C SKIP NEXT DESCRIPTOR
    +
    1871 C SET TO PASS OVER DESCRIPTOR AND DATA
    +
    1872 C IF DESCRIPTOR NOT IN TABLE B
    +
    1873  iptr(36) = ly
    +
    1874 C PRINT *,'SET TO SKIP',LY,' BIT FIELD'
    +
    1875  iptr(31) = iptr(31) + 1
    +
    1876  kprm = iptr(31) + iptr(24)
    +
    1877  mstack(1,kprm) = 34304 + ly
    +
    1878  mstack(2,kprm) = 0
    +
    1879  ELSE
    +
    1880  iptr(1) = 5
    +
    1881  ENDIF
    +
    1882  RETURN
    +
    1883  END
    +
    1884 C> @brief Process queue descriptor.
    +
    1885 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1886 
    +
    1887 C> Substitute descriptor queue for queue descriptor.
    +
    1888 C>
    +
    1889 C> Program history log:
    +
    1890 C> - Bill Cavanaugh 1988-09-01
    +
    1891 C> - Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors.
    +
    1892 C> - Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors.
    +
    1893 C> based on tests with live data.
    +
    1894 C>
    +
    1895 C> @param[in] IWORK Working descriptor list
    +
    1896 C> @param[in] IPTR See w3fi78 routine docblock
    +
    1897 C> @param MAXD
    +
    1898 C> @param[in] ITBLD Array containing descriptor queues
    +
    1899 C> @param[in] JDESC Queue descriptor to be expanded
    +
    1900 C>
    +
    1901 C$$$
    +
    1902  SUBROUTINE fi7807(IPTR,IWORK,ITBLD,JDESC,MAXD)
    +
    1903 
    +
    1904  SAVE
    +
    1905 C
    +
    1906  INTEGER IPTR(*),JDESC
    +
    1907  INTEGER IWORK(*),IHOLD(2000)
    +
    1908  INTEGER ITBLD(500,11)
    +
    1909 C
    +
    1910 C PRINT *,' FI7807 F3 ENTRY',IPTR(11),IPTR(12)
    +
    1911 C SET FOR BINARY SEARCH IN TABLE D
    +
    1912 C DO 2020 I = 1, IPTR(12)
    +
    1913 C PRINT *,'ENTRY IWORK',I,IWORK(I)
    +
    1914 C2020 CONTINUE
    +
    1915  jlo = 1
    +
    1916  jhi = iptr(20)
    +
    1917 C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC
    +
    1918  10 CONTINUE
    +
    1919  jmid = (jlo + jhi) / 2
    +
    1920 C PRINT *,JLO,ITBLD(JLO,1),JMID,ITBLD(JMID,1),JHI,ITBLD(JHI,1)
    +
    1921 C
    +
    1922  IF (jdesc.LT.itbld(jmid,1)) THEN
    +
    1923  IF (jdesc.EQ.itbld(jlo,1)) THEN
    +
    1924  jmid = jlo
    +
    1925  GO TO 100
    +
    1926  ELSE
    +
    1927  jlo = jlo + 1
    +
    1928  jhi = jmid - 1
    +
    1929  IF (jlo.GT.jmid) THEN
    +
    1930  iptr(1) = 4
    +
    1931  RETURN
    +
    1932  END IF
    +
    1933  GO TO 10
    +
    1934  END IF
    +
    1935  ELSE IF (jdesc.GT.itbld(jmid,1)) THEN
    +
    1936  IF (jdesc.EQ.itbld(jhi,1)) THEN
    +
    1937  jmid = jhi
    +
    1938  GO TO 100
    +
    1939  ELSE
    +
    1940  jlo = jmid + 1
    +
    1941  jhi = jhi - 1
    +
    1942  IF (jlo.GT.jhi) THEN
    +
    1943  iptr(1) = 4
    +
    1944  RETURN
    +
    1945  END IF
    +
    1946  GO TO 10
    +
    1947  END IF
    +
    1948  END IF
    +
    1949  100 CONTINUE
    +
    1950 C HAVE TABLE D MATCH
    +
    1951 C PRINT *,'D ',(ITBLD(JMID,LL),LL=1,11)
    +
    1952 C PRINT *,'TABLE D TO IHOLD'
    +
    1953  ik = 0
    +
    1954  jk = 0
    +
    1955  DO 200 ki = 2, 11
    +
    1956  IF (itbld(jmid,ki).NE.0) THEN
    +
    1957  ik = ik + 1
    +
    1958  ihold(ik) = itbld(jmid,ki)
    +
    1959 C PRINT *,IK,IHOLD(IK)
    +
    1960  ELSE
    +
    1961  GO TO 300
    +
    1962  END IF
    +
    1963  200 CONTINUE
    +
    1964  300 CONTINUE
    +
    1965  kk = iptr(11)
    +
    1966  IF (kk.GT.iptr(12)) THEN
    +
    1967 C NOTHING MORE TO APPEND
    +
    1968 C PRINT *,'NOTHING MORE TO APPEND'
    +
    1969  ELSE
    +
    1970 C APPEND TRAILING IWORK TO IHOLD
    +
    1971 C PRINT *,'APPEND FROM ',KK,' TO',IPTR(12)
    +
    1972  DO 500 i = kk, iptr(12)
    +
    1973  ik = ik + 1
    +
    1974  ihold(ik) = iwork(i)
    +
    1975  500 CONTINUE
    +
    1976  END IF
    +
    1977 C RESET IHOLD TO IWORK
    +
    1978 C PRINT *,' RESET IWORK STACK'
    +
    1979  kk = iptr(11) - 2
    +
    1980  DO 1000 i = 1, ik
    +
    1981  kk = kk + 1
    +
    1982  iwork(kk) = ihold(i)
    +
    1983  1000 CONTINUE
    +
    1984  iptr(12) = kk
    +
    1985 C PRINT *,' FI7807 F3 EXIT ',IPTR(11),IPTR(12)
    +
    1986 C DO 2000 I = 1, IPTR(12)
    +
    1987 C PRINT *,'EXIT IWORK',I,IWORK(I)
    +
    1988 C2000 CONTINUE
    +
    1989 C RESET POINTERS
    +
    1990  iptr(11) = iptr(11) - 1
    +
    1991  RETURN
    +
    1992  END
    +
    1993 C> @brief
    +
    1994 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1995 
    +
    1996 C> Program history log:
    +
    1997 C> - Bill Cavanaugh 1988-09-01
    +
    1998 C>
    +
    1999 C> @param[inout] IPTR See w3fi78() routine docblock
    +
    2000 C> @param[in] IWORK Working descriptor list
    +
    2001 C> @param LF
    +
    2002 C> @param LX
    +
    2003 C> @param LY
    +
    2004 C> @param JDESC
    +
    2005 C> @param MAXD
    +
    2006 C>
    +
    2007 C> @author Bill Cavanaugh @date 1988-09-01
    +
    2008  SUBROUTINE fi7808(IPTR,IWORK,LF,LX,LY,JDESC,MAXD)
    +
    2009 
    +
    2010  SAVE
    +
    2011  INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC
    +
    2012 C
    +
    2013 C PRINT *,' FI7808 NEW DESCRIPTOR PICKUP'
    +
    2014  JDESC = iwork(iptr(11))
    +
    2015  ly = mod(jdesc,256)
    +
    2016  iptr(34) = ly
    +
    2017  lx = mod((jdesc/256),64)
    +
    2018  iptr(33) = lx
    +
    2019  lf = jdesc / 16384
    +
    2020  iptr(32) = lf
    +
    2021 C PRINT *,' CURRENT DESCRIPTOR BEING TESTED IS',LF,LX,LY
    +
    2022  iptr(11) = iptr(11) + 1
    +
    2023  RETURN
    +
    2024  END
    +
    2025 C> @brief Reformat profiler w hgt increments.
    +
    2026 C> @author Bill Cavanaugh @date 1990-02-14
    +
    2027 
    +
    2028 C> Reformat decoded profiler data to show heights instead of
    +
    2029 C> height increments.
    +
    2030 C>
    +
    2031 C> Program history log:
    +
    2032 C> - Bill Cavanaugh 1990-02-14
    +
    2033 C>
    +
    2034 C> @param[in] IDENT Array contains message information extracted from BUFR
    +
    2035 C> message:
    +
    2036 C> - IDENT(1)- Edition number (byte 4, section 1)
    +
    2037 C> - IDENT(2)- Originating center (bytes 5-6, section 1)
    +
    2038 C> - IDENT(3)- Update sequence (byte 7, section 1)
    +
    2039 C> - IDENT(4)- (byte 8, section 1)
    +
    2040 C> - IDENT(5)- Bufr message type (byte 9, section 1)
    +
    2041 C> - IDENT(6)- Bufr msg sub-type (byte 10, section 1)
    +
    2042 C> - IDENT(7)- (bytes 11-12, section 1)
    +
    2043 C> - IDENT(8)- Year of century (byte 13, section 1)
    +
    2044 C> - IDENT(9)- Month of year (byte 14, section 1)
    +
    2045 C> - IDENT(10)- Day of month (byte 15, section 1)
    +
    2046 C> - IDENT(11)- Hour of day (byte 16, section 1)
    +
    2047 C> - IDENT(12)- Minute of hour (byte 17, section 1)
    +
    2048 C> - IDENT(13)- Rsvd by adp centers(byte 18, section 1)
    +
    2049 C> - IDENT(14)- Nr of data subsets (byte 5-6, section 3)
    +
    2050 C> - IDENT(15)- Observed flag (byte 7, bit 1, section 3)
    +
    2051 C> - IDENT(16)- Compression flag (byte 7, bit 2, section 3)
    +
    2052 C> @param[in] MSTACK Working descriptor list and scaling factor
    +
    2053 C> @param[in] KDATA Array containing decoded reports from bufr message.
    +
    2054 C> KDATA(Report number,parameter number)
    +
    2055 C> (report number limited to value of input argument maxr and parameter number
    +
    2056 C> limited to value of input argument maxd)
    +
    2057 C> @param[in] IPTR See w3fi78
    +
    2058 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    2059 C> contained in a bufr message
    +
    2060 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    2061 C> may be processed; upper air data and some satellite
    +
    2062 C> data require a value for maxd of 1600, but for most
    +
    2063 C> other data a value for maxd of 500 will suffice.
    +
    2064 C>
    +
    2065 C> @author Bill Cavanaugh @date 1990-02-14
    +
    2066  SUBROUTINE fi7809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
    +
    2067 
    +
    2068  SAVE
    +
    2069 C ----------------------------------------------------------------
    +
    2070 C
    +
    2071  INTEGER ISW
    +
    2072  INTEGER IDENT(*),KDATA(MAXR,MAXD)
    +
    2073  INTEGER MSTACK(2,MAXD),IPTR(*)
    +
    2074  INTEGER KPROFL(1600)
    +
    2075  INTEGER KPROF2(1600)
    +
    2076  INTEGER KSET2(1600)
    +
    2077 C
    +
    2078 C ----------------------------------------------------------
    +
    2079 C PRINT *,'FI7809'
    +
    2080 C LOOP FOR NUMBER OF SUBSETS/REPORTS
    +
    2081  DO 3000 i = 1, ident(14)
    +
    2082 C INIT FOR DATA INPUT ARRAY
    +
    2083  mk = 1
    +
    2084 C INIT FOR DESC OUTPUT ARRAY
    +
    2085  jk = 0
    +
    2086 C LOCATION
    +
    2087  isw = 0
    +
    2088  DO 200 j = 1, 3
    +
    2089 C LATITUDE
    +
    2090  IF (mstack(1,mk).EQ.1282) THEN
    +
    2091  isw = isw + 1
    +
    2092  GO TO 100
    +
    2093 C LONGITUDE
    +
    2094  ELSE IF (mstack(1,mk).EQ.1538) THEN
    +
    2095  isw = isw + 2
    +
    2096  GO TO 100
    +
    2097 C HEIGHT ABOVE SEA LEVEL
    +
    2098  ELSE IF (mstack(1,mk).EQ.1793) THEN
    +
    2099  ihgt = kdata(i,mk)
    +
    2100  isw = isw + 4
    +
    2101  GO TO 100
    +
    2102  END IF
    +
    2103  GO TO 200
    +
    2104  100 CONTINUE
    +
    2105  jk = jk + 1
    +
    2106 C SAVE DESCRIPTOR
    +
    2107  kprofl(jk) = mstack(1,mk)
    +
    2108 C SAVE SCALE
    +
    2109  kprof2(jk) = mstack(2,mk)
    +
    2110 C SAVE DATA
    +
    2111  kset2(jk) = kdata(i,mk)
    +
    2112  mk = mk + 1
    +
    2113  200 CONTINUE
    +
    2114  IF (isw.NE.7) THEN
    +
    2115  print *,'LOCATION ERROR PROCESSING PROFILER'
    +
    2116  iptr(1) = 200
    +
    2117  RETURN
    +
    2118  END IF
    +
    2119 C TIME
    +
    2120  isw = 0
    +
    2121  DO 400 j = 1, 7
    +
    2122 C YEAR
    +
    2123  IF (mstack(1,mk).EQ.1025) THEN
    +
    2124  isw = isw + 1
    +
    2125  GO TO 300
    +
    2126 C MONTH
    +
    2127  ELSE IF (mstack(1,mk).EQ.1026) THEN
    +
    2128  isw = isw + 2
    +
    2129  GO TO 300
    +
    2130 C DAY
    +
    2131  ELSE IF (mstack(1,mk).EQ.1027) THEN
    +
    2132  isw = isw + 4
    +
    2133  GO TO 300
    +
    2134 C HOUR
    +
    2135  ELSE IF (mstack(1,mk).EQ.1028) THEN
    +
    2136  isw = isw + 8
    +
    2137  GO TO 300
    +
    2138 C MINUTE
    +
    2139  ELSE IF (mstack(1,mk).EQ.1029) THEN
    +
    2140  isw = isw + 16
    +
    2141  GO TO 300
    +
    2142 C TIME SIGNIFICANCE
    +
    2143  ELSE IF (mstack(1,mk).EQ.2069) THEN
    +
    2144  isw = isw + 32
    +
    2145  GO TO 300
    +
    2146  ELSE IF (mstack(1,mk).EQ.1049) THEN
    +
    2147  isw = isw + 64
    +
    2148  GO TO 300
    +
    2149  END IF
    +
    2150  GO TO 400
    +
    2151  300 CONTINUE
    +
    2152  jk = jk + 1
    +
    2153 C SAVE DESCRIPTOR
    +
    2154  kprofl(jk) = mstack(1,mk)
    +
    2155 C SAVE SCALE
    +
    2156  kprof2(jk) = mstack(2,mk)
    +
    2157 C SAVE DATA
    +
    2158  kset2(jk) = kdata(i,mk)
    +
    2159  mk = mk + 1
    +
    2160  400 CONTINUE
    +
    2161  IF (isw.NE.127) THEN
    +
    2162  print *,'TIME ERROR PROCESSING PROFILER',isw
    +
    2163  iptr(1) = 201
    +
    2164  RETURN
    +
    2165  END IF
    +
    2166 C SURFACE DATA
    +
    2167  krg = 0
    +
    2168  isw = 0
    +
    2169  DO 600 j = 1, 10
    +
    2170 C WIND SPEED
    +
    2171  IF (mstack(1,mk).EQ.2818) THEN
    +
    2172  isw = isw + 1
    +
    2173  GO TO 500
    +
    2174 C WIND DIRECTION
    +
    2175  ELSE IF (mstack(1,mk).EQ.2817) THEN
    +
    2176  isw = isw + 2
    +
    2177  GO TO 500
    +
    2178 C PRESS REDUCED TO MSL
    +
    2179  ELSE IF (mstack(1,mk).EQ.2611) THEN
    +
    2180  isw = isw + 4
    +
    2181  GO TO 500
    +
    2182 C TEMPERATURE
    +
    2183  ELSE IF (mstack(1,mk).EQ.3073) THEN
    +
    2184  isw = isw + 8
    +
    2185  GO TO 500
    +
    2186 C RAINFALL RATE
    +
    2187  ELSE IF (mstack(1,mk).EQ.3342) THEN
    +
    2188  isw = isw + 16
    +
    2189  GO TO 500
    +
    2190 C RELATIVE HUMIDITY
    +
    2191  ELSE IF (mstack(1,mk).EQ.3331) THEN
    +
    2192  isw = isw + 32
    +
    2193  GO TO 500
    +
    2194 C 1ST RANGE GATE OFFSET
    +
    2195  ELSE IF (mstack(1,mk).EQ.1982.OR.
    +
    2196  * mstack(1,mk).EQ.1983) THEN
    +
    2197 C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE
    +
    2198 C VALUE FOR LATER USE
    +
    2199  IF (mstack(1,mk).EQ.1983) THEN
    +
    2200  ihgt = kdata(i,mk)
    +
    2201  mk = mk + 1
    +
    2202  krg = 1
    +
    2203  ELSE
    +
    2204  IF (krg.EQ.0) THEN
    +
    2205  incrht = kdata(i,mk)
    +
    2206  mk = mk + 1
    +
    2207  krg = 1
    +
    2208 C PRINT *,'INITIAL INCR =',INCRHT
    +
    2209  ELSE
    +
    2210  lhgt = 500 + ihgt - kdata(i,mk)
    +
    2211  isw = isw + 64
    +
    2212 C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT
    +
    2213  END IF
    +
    2214  END IF
    +
    2215 C MODE #1
    +
    2216  ELSE IF (mstack(1,mk).EQ.8128) THEN
    +
    2217  isw = isw + 128
    +
    2218  GO TO 500
    +
    2219 C MODE #2
    +
    2220  ELSE IF (mstack(1,mk).EQ.8129) THEN
    +
    2221  isw = isw + 256
    +
    2222  GO TO 500
    +
    2223  END IF
    +
    2224  GO TO 600
    +
    2225  500 CONTINUE
    +
    2226 C SAVE DESCRIPTOR
    +
    2227  jk = jk + 1
    +
    2228  kprofl(jk) = mstack(1,mk)
    +
    2229 C SAVE SCALE
    +
    2230  kprof2(jk) = mstack(2,mk)
    +
    2231 C SAVE DATA
    +
    2232  kset2(jk) = kdata(i,mk)
    +
    2233 C IF (I.EQ.1) THEN
    +
    2234 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
    +
    2235 C END IF
    +
    2236  mk = mk + 1
    +
    2237  600 CONTINUE
    +
    2238  650 CONTINUE
    +
    2239  IF (isw.NE.511) THEN
    +
    2240  print *,'SURFACE ERROR PROCESSING PROFILER',isw
    +
    2241  iptr(1) = 202
    +
    2242  RETURN
    +
    2243  END IF
    +
    2244 C 43 LEVELS
    +
    2245  DO 2000 l = 1, 43
    +
    2246  2020 CONTINUE
    +
    2247  isw = 0
    +
    2248 C HEIGHT INCREMENT
    +
    2249  IF (mstack(1,mk).EQ.1982) THEN
    +
    2250 C PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK)
    +
    2251  incrht = kdata(i,mk)
    +
    2252  mk = mk + 1
    +
    2253  IF (lhgt.LT.(9250+ihgt)) THEN
    +
    2254  lhgt = ihgt + 500 - incrht
    +
    2255  ELSE
    +
    2256  lhgt = ihgt + 9250 - incrht
    +
    2257  END IF
    +
    2258  END IF
    +
    2259 C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA
    +
    2260 C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE
    +
    2261  lhgt = lhgt + incrht
    +
    2262 C PRINT *,'LEVEL ',L,LHGT
    +
    2263  IF (l.EQ.37) THEN
    +
    2264  lhgt = lhgt + incrht
    +
    2265  END IF
    +
    2266  jk = jk + 1
    +
    2267 C SAVE DESCRIPTOR
    +
    2268  kprofl(jk) = 1798
    +
    2269 C SAVE SCALE
    +
    2270  kprof2(jk) = 0
    +
    2271 C SAVE DATA
    +
    2272  kset2(jk) = lhgt
    +
    2273 C IF (I.EQ.10) THEN
    +
    2274 C PRINT *,' '
    +
    2275 C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK)
    +
    2276 C END IF
    +
    2277  isw = 0
    +
    2278  DO 800 j = 1, 9
    +
    2279  750 CONTINUE
    +
    2280  IF (mstack(1,mk).EQ.1982) THEN
    +
    2281  GO TO 2020
    +
    2282 C U VECTOR VALUE
    +
    2283  ELSE IF (mstack(1,mk).EQ.3008) THEN
    +
    2284  isw = isw + 1
    +
    2285  IF (kdata(i,mk).GE.2047) THEN
    +
    2286  vectu = 32767
    +
    2287  ELSE
    +
    2288  vectu = kdata(i,mk)
    +
    2289  END IF
    +
    2290  mk = mk + 1
    +
    2291  GO TO 800
    +
    2292 C V VECTOR VALUE
    +
    2293  ELSE IF (mstack(1,mk).EQ.3009) THEN
    +
    2294  isw = isw + 2
    +
    2295  IF (kdata(i,mk).GE.2047) THEN
    +
    2296  vectv = 32767
    +
    2297  ELSE
    +
    2298  vectv = kdata(i,mk)
    +
    2299  END IF
    +
    2300  mk = mk + 1
    +
    2301 C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF
    +
    2302 C DESCRIPTORS AND DATA
    +
    2303  IF (iand(isw,1).NE.0) THEN
    +
    2304  IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
    +
    2305 C SAVE DD DESCRIPTOR
    +
    2306  jk = jk + 1
    +
    2307  kprofl(jk) = 2817
    +
    2308 C SAVE SCALE
    +
    2309  kprof2(jk) = 0
    +
    2310 C SAVE DD DATA
    +
    2311  kset2(jk) = 32767
    +
    2312 C SAVE FFF DESCRIPTOR
    +
    2313  jk = jk + 1
    +
    2314  kprofl(jk) = 2818
    +
    2315 C SAVE SCALE
    +
    2316  kprof2(jk) = 1
    +
    2317 C SAVE FFF DATA
    +
    2318  kset2(jk) = 32767
    +
    2319  ELSE
    +
    2320 C GENERATE DDFFF
    +
    2321  CALL w3fc05 (vectu,vectv,dir,spd)
    +
    2322  ndir = dir
    +
    2323  spd = spd
    +
    2324  nspd = spd
    +
    2325 C PRINT *,' ',NDIR,NSPD
    +
    2326 C SAVE DD DESCRIPTOR
    +
    2327  jk = jk + 1
    +
    2328  kprofl(jk) = 2817
    +
    2329 C SAVE SCALE
    +
    2330  kprof2(jk) = 0
    +
    2331 C SAVE DD DATA
    +
    2332  kset2(jk) = dir
    +
    2333 C IF (I.EQ.1) THEN
    +
    2334 C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
    +
    2335 C END IF
    +
    2336 C SAVE FFF DESCRIPTOR
    +
    2337  jk = jk + 1
    +
    2338  kprofl(jk) = 2818
    +
    2339 C SAVE SCALE
    +
    2340  kprof2(jk) = 1
    +
    2341 C SAVE FFF DATA
    +
    2342  kset2(jk) = spd
    +
    2343 C IF (I.EQ.1) THEN
    +
    2344 C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
    +
    2345 C END IF
    +
    2346  END IF
    +
    2347  END IF
    +
    2348  GO TO 800
    +
    2349 C W VECTOR VALUE
    +
    2350  ELSE IF (mstack(1,mk).EQ.3010) THEN
    +
    2351  isw = isw + 4
    +
    2352  GO TO 700
    +
    2353 C Q/C TEST RESULTS
    +
    2354  ELSE IF (mstack(1,mk).EQ.8130) THEN
    +
    2355  isw = isw + 8
    +
    2356  GO TO 700
    +
    2357 C U,V QUALITY IND
    +
    2358  ELSE IF(iand(isw,16).EQ.0.AND.mstack(1,mk).EQ.2070) THEN
    +
    2359  isw = isw + 16
    +
    2360  GO TO 700
    +
    2361 C W QUALITY IND
    +
    2362  ELSE IF(iand(isw,32).EQ.0.AND.mstack(1,mk).EQ.2070) THEN
    +
    2363  isw = isw + 32
    +
    2364  GO TO 700
    +
    2365 C SPECTRAL PEAK POWER
    +
    2366  ELSE IF (mstack(1,mk).EQ.5568) THEN
    +
    2367  isw = isw + 64
    +
    2368  GO TO 700
    +
    2369 C U,V VARIABILITY
    +
    2370  ELSE IF (mstack(1,mk).EQ.3011) THEN
    +
    2371  isw = isw + 128
    +
    2372  GO TO 700
    +
    2373 C W VARIABILITY
    +
    2374  ELSE IF (mstack(1,mk).EQ.3013) THEN
    +
    2375  isw = isw + 256
    +
    2376  GO TO 700
    +
    2377  ELSE IF ((mstack(1,mk)/16384).NE.0) THEN
    +
    2378  mk = mk + 1
    +
    2379  GO TO 750
    +
    2380  END IF
    +
    2381  GO TO 800
    +
    2382  700 CONTINUE
    +
    2383  jk = jk + 1
    +
    2384 C SAVE DESCRIPTOR
    +
    2385  kprofl(jk) = mstack(1,mk)
    +
    2386 C SAVE SCALE
    +
    2387  kprof2(jk) = mstack(2,mk)
    +
    2388 C SAVE DATA
    +
    2389  kset2(jk) = kdata(i,mk)
    +
    2390  mk = mk + 1
    +
    2391 C IF (I.EQ.1) THEN
    +
    2392 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
    +
    2393 C END IF
    +
    2394  800 CONTINUE
    +
    2395  850 CONTINUE
    +
    2396  IF (isw.NE.511) THEN
    +
    2397  print *,'LEVEL ERROR PROCESSING PROFILER',isw
    +
    2398  iptr(1) = 203
    +
    2399  RETURN
    +
    2400  END IF
    +
    2401  2000 CONTINUE
    +
    2402 C MOVE DATA BACK INTO KDATA ARRAY
    +
    2403  DO 4000 ll = 1, jk
    +
    2404  kdata(i,ll) = kset2(ll)
    +
    2405  4000 CONTINUE
    +
    2406  3000 CONTINUE
    +
    2407 C PRINT *,'REBUILT ARRAY'
    +
    2408  DO 5000 ll = 1, jk
    +
    2409 C DESCRIPTOR
    +
    2410  mstack(1,ll) = kprofl(ll)
    +
    2411 C SCALE
    +
    2412  mstack(2,ll) = kprof2(ll)
    +
    2413 C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7)
    +
    2414  5000 CONTINUE
    +
    2415 C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY
    +
    2416  iptr(31) = jk
    +
    2417  RETURN
    +
    2418  END
    +
    2419 C> @brief Reformat profiler edition 2 data.
    +
    2420 C> @author Bill Cavanaugh @date 1993-01-21
    +
    2421 
    +
    2422 C> Reformat profiler data in edition 2.
    +
    2423 C>
    +
    2424 C> Program history log:
    +
    2425 C> - Bill Cavanaugh 1993-01-27
    +
    2426 C>
    +
    2427 C> @param[in] IDENT Array contains message information extracted from
    +
    2428 C> bufr message:
    +
    2429 C> - IDENT(1) - Edition number (byte 4, section 1)
    +
    2430 C> - IDENT(2) - Originating center (bytes 5-6, section 1)
    +
    2431 C> - IDENT(3) - Update sequence (byte 7, section 1)
    +
    2432 C> - IDENT(4) - (byte 8, section 1)
    +
    2433 C> - IDENT(5) - Bufr message type (byte 9, section 1)
    +
    2434 C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
    +
    2435 C> - IDENT(7) - (bytes 11-12, section 1)
    +
    2436 C> - IDENT(8) - Year of century (byte 13, section 1)
    +
    2437 C> - IDENT(9) - Month of year (byte 14, section 1)
    +
    2438 C> - IDENT(10) - Day of month (byte 15, section 1)
    +
    2439 C> - IDENT(11) - Hour of day (byte 16, section 1)
    +
    2440 C> - IDENT(12) - Minute of hour (byte 17, section 1)
    +
    2441 C> - IDENT(13) - Rsvd by adp centers (byte 18, section 1)
    +
    2442 C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
    +
    2443 C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
    +
    2444 C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
    +
    2445 C> @param[in] MSTACK Working descriptor list and scaling factor
    +
    2446 C> @param[in] KDATA Array containing decoded reports from bufr message.
    +
    2447 c> kdata(report number,parameter number)
    +
    2448 c> (report number limited to value of input argument maxr and parameter number
    +
    2449 C> limited to value of input argument maxd)
    +
    2450 C> @param[in] IPTR See w3fi78
    +
    2451 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    2452 C> contained in a bufr message
    +
    2453 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    2454 C> may be processed; upper air data and some satellite
    +
    2455 C> data require a value for maxd of 1600, but for most
    +
    2456 C> other data a value for maxd of 500 will suffice
    +
    2457 C>
    +
    2458 C> @author Bill Cavanaugh @date 1993-01-21
    +
    2459  SUBROUTINE fi7810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
    +
    2460 
    +
    2461  INTEGER ISW
    +
    2462  INTEGER IDENT(*),KDATA(MAXR,MAXD)
    +
    2463  INTEGER MSTACK(2,MAXD),IPTR(*)
    +
    2464  INTEGER KPROFL(1600)
    +
    2465  INTEGER KPROF2(1600)
    +
    2466  INTEGER KSET2(1600)
    +
    2467 C LOOP FOR NUMBER OF SUBSETS
    +
    2468  DO 3000 i = 1, ident(14)
    +
    2469  mk = 1
    +
    2470  jk = 0
    +
    2471  isw = 0
    +
    2472 C PRINT *,'IDENTIFICATION'
    +
    2473  DO 200 j = 1, 5
    +
    2474  IF (mstack(1,mk).EQ.257) THEN
    +
    2475 C BLOCK NUMBER
    +
    2476  isw = isw + 1
    +
    2477  ELSE IF (mstack(1,mk).EQ.258) THEN
    +
    2478 C STATION NUMBER
    +
    2479  isw = isw + 2
    +
    2480  ELSE IF (mstack(1,mk).EQ.1282) THEN
    +
    2481 C LATITUDE
    +
    2482  isw = isw + 4
    +
    2483  ELSE IF (mstack(1,mk).EQ.1538) THEN
    +
    2484 C LONGITUDE
    +
    2485  isw = isw + 8
    +
    2486  ELSE IF (mstack(1,mk).EQ.1793) THEN
    +
    2487 C HEIGHT OF STATION
    +
    2488  isw = isw + 16
    +
    2489  ihgt = kdata(i,mk)
    +
    2490  ELSE
    +
    2491  mk = mk + 1
    +
    2492  GO TO 200
    +
    2493  END IF
    +
    2494  jk = jk + 1
    +
    2495  kprofl(jk) = mstack(1,mk)
    +
    2496  kprof2(jk) = mstack(2,mk)
    +
    2497  kset2(jk) = kdata(i,mk)
    +
    2498 C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2499  mk = mk + 1
    +
    2500  200 CONTINUE
    +
    2501 C PRINT *,'LOCATION ',ISW
    +
    2502  IF (isw.NE.31) THEN
    +
    2503  print *,'LOCATION ERROR PROCESSING PROFILER'
    +
    2504  iptr(10) = 200
    +
    2505  RETURN
    +
    2506  END IF
    +
    2507 C PROCESS TIME ELEMENTS
    +
    2508  isw = 0
    +
    2509  DO 400 j = 1, 7
    +
    2510  IF (mstack(1,mk).EQ.1025) THEN
    +
    2511 C YEAR
    +
    2512  isw = isw + 1
    +
    2513  ELSE IF (mstack(1,mk).EQ.1026) THEN
    +
    2514 C MONTH
    +
    2515  isw = isw + 2
    +
    2516  ELSE IF (mstack(1,mk).EQ.1027) THEN
    +
    2517 C DAY
    +
    2518  isw = isw + 4
    +
    2519  ELSE IF (mstack(1,mk).EQ.1028) THEN
    +
    2520 C HOUR
    +
    2521  isw = isw + 8
    +
    2522  ELSE IF (mstack(1,mk).EQ.1029) THEN
    +
    2523 C MINUTE
    +
    2524  isw = isw + 16
    +
    2525  ELSE IF (mstack(1,mk).EQ.2069) THEN
    +
    2526 C TIME SIGNIFICANCE
    +
    2527  isw = isw + 32
    +
    2528  ELSE IF (mstack(1,mk).EQ.1049) THEN
    +
    2529 C TIME DISPLACEMENT
    +
    2530  isw = isw + 64
    +
    2531  ELSE
    +
    2532  mk = mk + 1
    +
    2533  GO TO 400
    +
    2534  END IF
    +
    2535  jk = jk + 1
    +
    2536  kprofl(jk) = mstack(1,mk)
    +
    2537  kprof2(jk) = mstack(2,mk)
    +
    2538  kset2(jk) = kdata(i,mk)
    +
    2539 C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2540  mk = mk + 1
    +
    2541  400 CONTINUE
    +
    2542 C PRINT *,'TIME ',ISW
    +
    2543  IF (isw.NE.127) THEN
    +
    2544  print *,'TIME ERROR PROCESSING PROFILER'
    +
    2545  iptr(1) = 201
    +
    2546  RETURN
    +
    2547  END IF
    +
    2548 C SURFACE DATA
    +
    2549  isw = 0
    +
    2550 C PRINT *,'SURFACE'
    +
    2551  DO 600 k = 1, 8
    +
    2552 C PRINT *,MK,MSTACK(1,MK),JK,ISW
    +
    2553  IF (mstack(1,mk).EQ.2817) THEN
    +
    2554  isw = isw + 1
    +
    2555  ELSE IF (mstack(1,mk).EQ.2818) THEN
    +
    2556  isw = isw + 2
    +
    2557  ELSE IF (mstack(1,mk).EQ.2611) THEN
    +
    2558  isw = isw + 4
    +
    2559  ELSE IF (mstack(1,mk).EQ.3073) THEN
    +
    2560  isw = isw + 8
    +
    2561  ELSE IF (mstack(1,mk).EQ.3342) THEN
    +
    2562  isw = isw + 16
    +
    2563  ELSE IF (mstack(1,mk).EQ.3331) THEN
    +
    2564  isw = isw + 32
    +
    2565  ELSE IF (mstack(1,mk).EQ.1797) THEN
    +
    2566  incrht = kdata(i,mk)
    +
    2567  isw = isw + 64
    +
    2568 C PRINT *,'INITIAL INCREMENT = ',INCRHT
    +
    2569  mk = mk + 1
    +
    2570 C PRINT *,JK,KPROFL(JK),KSET2(JK),' ISW=',ISW
    +
    2571  GO TO 600
    +
    2572  ELSE IF (mstack(1,mk).EQ.6433) THEN
    +
    2573  isw = isw + 128
    +
    2574  END IF
    +
    2575  jk = jk + 1
    +
    2576  kprofl(jk) = mstack(1,mk)
    +
    2577  kprof2(jk) = mstack(2,mk)
    +
    2578  kset2(jk) = kdata(i,mk)
    +
    2579 C PRINT *,JK,KPROFL(JK),KSET2(JK),'ISW=',ISW
    +
    2580  mk = mk + 1
    +
    2581  600 CONTINUE
    +
    2582  IF (isw.NE.255) THEN
    +
    2583  print *,'ERROR PROCESSING PROFILER',isw
    +
    2584  iptr(1) = 204
    +
    2585  RETURN
    +
    2586  END IF
    +
    2587  IF (mstack(1,mk).NE.1797) THEN
    +
    2588  print *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER'
    +
    2589  iptr(1) = 205
    +
    2590  RETURN
    +
    2591  END IF
    +
    2592 C MUST SAVE THIS HEIGHT VALUE
    +
    2593  lhgt = 500 + ihgt - kdata(i,mk)
    +
    2594 C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT
    +
    2595  mk = mk + 1
    +
    2596  IF (mstack(1,mk).GE.16384) THEN
    +
    2597  mk = mk + 1
    +
    2598  END IF
    +
    2599 C PROCESS LEVEL DATA
    +
    2600 C PRINT *,'LEVEL DATA'
    +
    2601  DO 2000 l = 1, 43
    +
    2602  2020 CONTINUE
    +
    2603 C PRINT *,'DESC',MK,MSTACK(1,MK),JK
    +
    2604  isw = 0
    +
    2605 C HEIGHT INCREMENT
    +
    2606  IF (mstack(1,mk).EQ.1797) THEN
    +
    2607  incrht = kdata(i,mk)
    +
    2608 C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT
    +
    2609  mk = mk + 1
    +
    2610  IF (lhgt.LT.(9250+ihgt)) THEN
    +
    2611  lhgt = ihgt + 500 - incrht
    +
    2612  ELSE
    +
    2613  lhgt = ihgt + 9250 -incrht
    +
    2614  END IF
    +
    2615  END IF
    +
    2616 C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA
    +
    2617 C AT THIS POINT
    +
    2618  lhgt = lhgt + incrht
    +
    2619 C PRINT *,'LEVEL ',L,LHGT
    +
    2620  IF (l.EQ.37) THEN
    +
    2621  lhgt = lhgt + incrht
    +
    2622  END IF
    +
    2623  jk = jk + 1
    +
    2624 C SAVE DESCRIPTOR
    +
    2625  kprofl(jk) = 1798
    +
    2626 C SAVE SCALE
    +
    2627  kprof2(jk) = 0
    +
    2628 C SAVE DATA
    +
    2629  kset2(jk) = lhgt
    +
    2630 C PRINT *,KPROFL(JK),KSET2(JK),JK
    +
    2631  isw = 0
    +
    2632  icon = 1
    +
    2633  DO 800 j = 1, 10
    +
    2634 750 CONTINUE
    +
    2635  IF (mstack(1,mk).EQ.1797) THEN
    +
    2636  GO TO 2020
    +
    2637  ELSE IF (mstack(1,mk).EQ.6432) THEN
    +
    2638 C HI/LO MODE
    +
    2639  isw = isw + 1
    +
    2640  ELSE IF (mstack(1,mk).EQ.6434) THEN
    +
    2641 C Q/C TEST
    +
    2642  isw = isw + 2
    +
    2643  ELSE IF (mstack(1,mk).EQ.2070) THEN
    +
    2644  IF (icon.EQ.1) THEN
    +
    2645 C FIRST PASS - U,V CONSENSUS
    +
    2646  isw = isw + 4
    +
    2647  icon = icon + 1
    +
    2648  ELSE
    +
    2649 C SECOND PASS - W CONSENSUS
    +
    2650  isw = isw + 64
    +
    2651  END IF
    +
    2652  ELSE IF (mstack(1,mk).EQ.2819) THEN
    +
    2653 C U VECTOR VALUE
    +
    2654  isw = isw + 8
    +
    2655  IF (kdata(i,mk).GE.2047) THEN
    +
    2656  vectu = 32767
    +
    2657  ELSE
    +
    2658  vectu = kdata(i,mk)
    +
    2659  END IF
    +
    2660  mk = mk + 1
    +
    2661  GO TO 800
    +
    2662  ELSE IF (mstack(1,mk).EQ.2820) THEN
    +
    2663 C V VECTOR VALUE
    +
    2664  isw = isw + 16
    +
    2665  IF (kdata(i,mk).GE.2047) THEN
    +
    2666  vectv = 32767
    +
    2667  ELSE
    +
    2668  vectv = kdata(i,mk)
    +
    2669  END IF
    +
    2670  IF (iand(isw,1).NE.0) THEN
    +
    2671  IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
    +
    2672 C SAVE DD DESCRIPTOR
    +
    2673  jk = jk + 1
    +
    2674  kprofl(jk) = 2817
    +
    2675  kprof2(jk) = 0
    +
    2676  kset2(jk) = 32767
    +
    2677 C SAVE FFF DESCRIPTOR
    +
    2678  jk = jk + 1
    +
    2679  kprofl(jk) = 2818
    +
    2680  kprof2(jk) = 1
    +
    2681  kset2(jk) = 32767
    +
    2682  ELSE
    +
    2683  CALL w3fc05 (vectu,vectv,dir,spd)
    +
    2684  ndir = dir
    +
    2685  spd = spd
    +
    2686  nspd = spd
    +
    2687 C PRINT *,' ',NDIR,NSPD
    +
    2688 C SAVE DD DESCRIPTOR
    +
    2689  jk = jk + 1
    +
    2690  kprofl(jk) = 2817
    +
    2691  kprof2(jk) = 0
    +
    2692  kset2(jk) = ndir
    +
    2693 C IF (I.EQ.1) THEN
    +
    2694 C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
    +
    2695 C ENDIF
    +
    2696 C SAVE FFF DESCRIPTOR
    +
    2697  jk = jk + 1
    +
    2698  kprofl(jk) = 2818
    +
    2699  kprof2(jk) = 1
    +
    2700  kset2(jk) = nspd
    +
    2701 C IF (I.EQ.1) THEN
    +
    2702 C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
    +
    2703 C ENDIF
    +
    2704  END IF
    +
    2705  mk = mk + 1
    +
    2706  GO TO 800
    +
    2707  END IF
    +
    2708  ELSE IF (mstack(1,mk).EQ.2866) THEN
    +
    2709 C SPEED STD DEVIATION
    +
    2710  isw = isw + 32
    +
    2711 C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568
    +
    2712  ELSE IF (mstack(1,mk).EQ.5568) THEN
    +
    2713 C SIGNAL POWER
    +
    2714  isw = isw + 128
    +
    2715  ELSE IF (mstack(1,mk).EQ.2822) THEN
    +
    2716 C W COMPONENT
    +
    2717  isw = isw + 256
    +
    2718  ELSE IF (mstack(1,mk).EQ.2867) THEN
    +
    2719 C VERT STD DEVIATION
    +
    2720  isw = isw + 512
    +
    2721  ELSE
    +
    2722  mk = mk + 1
    +
    2723  GO TO 750
    +
    2724  END IF
    +
    2725  jk = jk + 1
    +
    2726 C SAVE DESCRIPTOR
    +
    2727  kprofl(jk) = mstack(1,mk)
    +
    2728 C SAVE SCALE
    +
    2729  kprof2(jk) = mstack(2,mk)
    +
    2730 C SAVE DATA
    +
    2731  kset2(jk) = kdata(i,mk)
    +
    2732  mk = mk + 1
    +
    2733 C PRINT *,L,'TEST ',JK,KPROFL(JK),KSET2(JK)
    +
    2734  800 CONTINUE
    +
    2735  850 CONTINUE
    +
    2736  IF (isw.NE.1023) THEN
    +
    2737  print *,'LEVEL ERROR PROCESSING PROFILER',isw
    +
    2738  iptr(1) = 202
    +
    2739  RETURN
    +
    2740  END IF
    +
    2741  2000 CONTINUE
    +
    2742 C MOVE DATA BACK INTO KDATA ARRAY
    +
    2743  DO 5000 ll = 1, jk
    +
    2744 C DATA
    +
    2745  kdata(i,ll) = kset2(ll)
    +
    2746  5000 CONTINUE
    +
    2747  3000 CONTINUE
    +
    2748  DO 5005 ll = 1, jk
    +
    2749 C DESCRIPTOR
    +
    2750  mstack(1,ll) = kprofl(ll)
    +
    2751 C SCALE
    +
    2752  mstack(2,ll) = kprof2(ll)
    +
    2753 C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP
    +
    2754 C PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4)
    +
    2755  5005 CONTINUE
    +
    2756  iptr(31) = jk
    +
    2757  RETURN
    +
    2758  END
    +
    +
    +
    gbytes
    subroutine gbytes(IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
    Program history log:
    Definition: gbytes.f:26
    +
    fi7810
    subroutine fi7810(IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
    Reformat profiler edition 2 data.
    Definition: w3fi78.f:2460
    +
    fi7801
    subroutine fi7801(IPTR, IDENT, MSGA, ISTACK, IWORK, ANAME, KDATA, IVALS, MSTACK, AUNITS, KDESC, MWIDTH, MREF, MSCALE, KNR, INDEX, MAXR, MAXD, IUNITB, IUNITD)
    Data extraction.
    Definition: w3fi78.f:678
    +
    fi7807
    subroutine fi7807(IPTR, IWORK, ITBLD, JDESC, MAXD)
    Process queue descriptor.
    Definition: w3fi78.f:1903
    +
    w3fi78
    subroutine w3fi78(IPTR, IDENT, MSGA, ISTACK, MSTACK, KDATA, KNR, INDEX, MAXR, MAXD, IUNITB, IUNITD)
    This set of routines will decode a BUFR message and place information extracted from the BUFR message...
    Definition: w3fi78.f:309
    +
    fi7808
    subroutine fi7808(IPTR, IWORK, LF, LX, LY, JDESC, MAXD)
    Program history log:
    Definition: w3fi78.f:2009
    +
    fi7805
    subroutine fi7805(IPTR, IDENT, MSGA, IWORK, LX, LY, KDATA, LL, KNR, MSTACK, MAXR, MAXD)
    Process a replication descriptor.
    Definition: w3fi78.f:1589
    +
    fi7806
    subroutine fi7806(IPTR, LX, LY, IDENT, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, LL, KDESC, IWORK, JDESC, MAXR, MAXD)
    Process operator descriptors.
    Definition: w3fi78.f:1762
    +
    w3fc05
    subroutine w3fc05(U, V, DIR, SPD)
    Given the true (Earth oriented) wind components compute the wind direction and speed.
    Definition: w3fc05.f:29
    +
    fi7802
    subroutine fi7802(IPTR, IDENT, MSGA, KDATA, KDESC, LL, MSTACK, AUNITS, MWIDTH, MREF, MSCALE, JDESC, IVALS, J, MAXR, MAXD)
    Process standard descriptor.
    Definition: w3fi78.f:995
    +
    fi7803
    subroutine fi7803(IPTR, IDENT, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, JDESC, MAXR, MAXD)
    Process compressed data.
    Definition: w3fi78.f:1151
    +
    gbyte
    subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
    This is the fortran version of gbyte.
    Definition: gbyte.f:27
    +
    fi7809
    subroutine fi7809(IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
    Reformat profiler w hgt increments.
    Definition: w3fi78.f:2067
    +
    fi7804
    subroutine fi7804(IPTR, MSGA, KDATA, IVALS, MSTACK, MWIDTH, MREF, MSCALE, J, LL, JDESC, MAXR, MAXD)
    Process serial data.
    Definition: w3fi78.f:1420
    + + + + diff --git a/ver-2.10.0/w3fi82_8f.html b/ver-2.10.0/w3fi82_8f.html new file mode 100644 index 00000000..71a198d7 --- /dev/null +++ b/ver-2.10.0/w3fi82_8f.html @@ -0,0 +1,206 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi82.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi82.f File Reference
    +
    +
    + +

    Convert to second diff array. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi82 (IFLD, FVAL1, FDIFF1, NPTS, PDS, IGDS)
     Accept an input array, convert to array of second differences. More...
     
    +

    Detailed Description

    +

    Convert to second diff array.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-07-14
    + +

    Definition in file w3fi82.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi82()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi82 (integer, dimension(*) IFLD,
    real FVAL1,
    real FDIFF1,
    integer NPTS,
    character*1, dimension(*) PDS,
    integer, dimension(*) IGDS 
    )
    +
    + +

    Accept an input array, convert to array of second differences.

    +

    return the original first value and the first first-difference as separate values. align data in boustrephedonic style, (alternate row reversal).

    +

    Program history log:

      +
    • Bill Cavanaugh 1993-07-14
      • +
    • Bill Cavanaugh 1994-01-27 Added reversal of even numbered rows (boustrophedonic processing)
      • +
    • Bill Cavanaugh 1994-03-02 Corrected improper ordering of even numbered rows
      • +
    • Ebisuzaki 1999-12-06 Linux port
      • +
    +
    Parameters
    + + + + + + + +
    [in,out]IFLD
      +
    • [in] Integer input array
      • +
    • [out] Second differenced field
      • +
    +
    [in]NPTSNumber of points in array
    [in]IGDS
      +
    • (5) Number of rows in array
      • +
    • (4) Number of columns in array
      • +
    +
    [in]PDS(8) Flag indicating presence of gds section
    [out]FVAL1Floating point original first value
    [out]FDIFF1Floating point first first-difference
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-07-14
    + +

    Definition at line 31 of file w3fi82.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi82_8f.js b/ver-2.10.0/w3fi82_8f.js new file mode 100644 index 00000000..211de566 --- /dev/null +++ b/ver-2.10.0/w3fi82_8f.js @@ -0,0 +1,4 @@ +var w3fi82_8f = +[ + [ "w3fi82", "w3fi82_8f.html#a9d5c017171cdbf13bde5edff05dcd997", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi82_8f_source.html b/ver-2.10.0/w3fi82_8f_source.html new file mode 100644 index 00000000..96892ee2 --- /dev/null +++ b/ver-2.10.0/w3fi82_8f_source.html @@ -0,0 +1,191 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi82.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi82.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert to second diff array
    +
    3 C> @author Bill Cavanaugh @date 1993-07-14
    +
    4 
    +
    5 C> Accept an input array, convert to array of second
    +
    6 C> differences. return the original first value and the first
    +
    7 C> first-difference as separate values. align data in
    +
    8 C> boustrephedonic style, (alternate row reversal).
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - Bill Cavanaugh 1993-07-14
    +
    12 C> - Bill Cavanaugh 1994-01-27 Added reversal of even numbered rows
    +
    13 C> (boustrophedonic processing)
    +
    14 C> - Bill Cavanaugh 1994-03-02 Corrected improper ordering of even
    +
    15 C> numbered rows
    +
    16 C> - Ebisuzaki 1999-12-06 Linux port
    +
    17 C>
    +
    18 C> @param[inout] IFLD
    +
    19 C> - [in] Integer input array
    +
    20 C> - [out] Second differenced field
    +
    21 C> @param[in] NPTS Number of points in array
    +
    22 C> @param[in] IGDS
    +
    23 C> - (5) Number of rows in array
    +
    24 C> - (4) Number of columns in array
    +
    25 C> @param[in] PDS (8) Flag indicating presence of gds section
    +
    26 C> @param[out] FVAL1 Floating point original first value
    +
    27 C> @param[out] FDIFF1 Floating point first first-difference
    +
    28 C>
    +
    29 C> @author Bill Cavanaugh @date 1993-07-14
    +
    30  SUBROUTINE w3fi82 (IFLD,FVAL1,FDIFF1,NPTS,PDS,IGDS)
    +
    31 C
    +
    32  REAL FVAL1,FDIFF1
    +
    33 C
    +
    34  INTEGER IFLD(*),NPTS,NBOUST(300),IGDS(*)
    +
    35 C
    +
    36  CHARACTER*1 PDS(*)
    +
    37 C
    +
    38 C ---------------------------------------------
    +
    39 C TEST FOR PRESENCE OF GDS
    +
    40 C
    +
    41 c looks like an error CALL GBYTE(PDS,IQQ,56,8)
    +
    42  call gbytec(pds,iqq,56,1)
    +
    43  IF (iqq.NE.0) THEN
    +
    44  nrow = igds(5)
    +
    45  ncol = igds(4)
    +
    46 C
    +
    47 C LAY OUT DATA BOUSTROPHEDONIC STYLE
    +
    48 C
    +
    49 C PRINT*, ' DATA SET UP BOUSTROPHEDON'
    +
    50 C
    +
    51  DO 210 i = 2, nrow, 2
    +
    52 C
    +
    53 C REVERSE THE EVEN NUMBERED ROWS
    +
    54 C
    +
    55  DO 200 j = 1, ncol
    +
    56  npos = i * ncol - j + 1
    +
    57  nboust(j) = ifld(npos)
    +
    58  200 CONTINUE
    +
    59  DO 201 j = 1, ncol
    +
    60  npos = ncol * (i-1) + j
    +
    61  ifld(npos) = nboust(j)
    +
    62  201 CONTINUE
    +
    63  210 CONTINUE
    +
    64 C
    +
    65 C
    +
    66  END IF
    +
    67 C =================================================================
    +
    68  DO 4000 i = npts, 2, -1
    +
    69  ifld(i) = ifld(i) - ifld(i-1)
    +
    70  4000 CONTINUE
    +
    71  DO 5000 i = npts, 3, -1
    +
    72  ifld(i) = ifld(i) - ifld(i-1)
    +
    73  5000 CONTINUE
    +
    74 C
    +
    75 C SPECIAL FOR GRIB
    +
    76 C FLOAT OUTPUT OF FIRST POINTS TO ANTICIPATE
    +
    77 C GRIB FLOATING POINT OUTPUT
    +
    78 C
    +
    79  fval1 = ifld(1)
    +
    80  fdiff1 = ifld(2)
    +
    81 C
    +
    82 C SET FIRST TWO POINTS TO SECOND DIFF VALUE FOR BETTER PACKING
    +
    83 C
    +
    84  ifld(1) = ifld(3)
    +
    85  ifld(2) = ifld(3)
    +
    86 C -----------------------------------------------------------
    +
    87  RETURN
    +
    88  END
    +
    +
    +
    w3fi82
    subroutine w3fi82(IFLD, FVAL1, FDIFF1, NPTS, PDS, IGDS)
    Accept an input array, convert to array of second differences.
    Definition: w3fi82.f:31
    +
    gbytec
    subroutine gbytec(IN, IOUT, ISKIP, NBYTE)
    Wrapper for gbytesc() limiting NSKIP and N to 0 and 1.
    Definition: gbytec.f:14
    + + + + diff --git a/ver-2.10.0/w3fi83_8f.html b/ver-2.10.0/w3fi83_8f.html new file mode 100644 index 00000000..4ad9ec69 --- /dev/null +++ b/ver-2.10.0/w3fi83_8f.html @@ -0,0 +1,217 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi83.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi83.f File Reference
    +
    +
    + +

    Restore delta packed data to original. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi83 (DATA, NPTS, FVAL1, FDIFF1, ISCAL2, ISC10, KPDS, KGDS)
     Restore delta packed data to original values restore from boustrephedonic alignment. More...
     
    +

    Detailed Description

    +

    Restore delta packed data to original.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-08-18
    + +

    Definition in file w3fi83.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi83()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi83 (real, dimension(*) DATA,
    integer NPTS,
    real FVAL1,
    real FDIFF1,
     ISCAL2,
    integer ISC10,
    integer, dimension(*) KPDS,
    integer, dimension(*) KGDS 
    )
    +
    + +

    Restore delta packed data to original values restore from boustrephedonic alignment.

    +

    Program history log:

      +
    • Bill Cavanaugh 1993-07-14
      • +
    • John Satckpole 1993-07-22 Additions to fix scaling.
      • +
    • Bill Cavanaugh 1994-01-27 Added reversal of even numbered rows (boustrophedonic processing) to restore data to original sequence.
      • +
    • Bill Cavanaugh 1994-03-02 Corrected reversal of even numbered rows.
      • +
    • Mark Iredell 1995-10-31 Removed saves and prints.
      • +
    +
    Parameters
    + + + + + + + + + +
    [in,out]DATA
      +
    • [in] Second order differences.
      • +
    • [out] Expanded original data values.
      • +
    +
    [in]NPTSNumber of points in array.
    [in]FVAL1Original first entry in array.
    [in]FDIFF1Original first first-difference.
    [in]ISCAL2Power-of-two exponent for unscaling.
    [in]ISC10Power-of-ten exponent for unscaling.
    [in]KPDSArray of information for pds.
    [in]KGDSArray of information for gds.
    +
    +
    +
    Note
    Subprogram can be called from a multiprocessing environment.
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-08-18
    + +

    Definition at line 33 of file w3fi83.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi83_8f.js b/ver-2.10.0/w3fi83_8f.js new file mode 100644 index 00000000..1663fec1 --- /dev/null +++ b/ver-2.10.0/w3fi83_8f.js @@ -0,0 +1,4 @@ +var w3fi83_8f = +[ + [ "w3fi83", "w3fi83_8f.html#abaae8db75615b215003d0b2591b4e49d", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi83_8f_source.html b/ver-2.10.0/w3fi83_8f_source.html new file mode 100644 index 00000000..148c982a --- /dev/null +++ b/ver-2.10.0/w3fi83_8f_source.html @@ -0,0 +1,201 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi83.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi83.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Restore delta packed data to original.
    +
    3 C> @author Bill Cavanaugh @date 1993-08-18
    +
    4 
    +
    5 C> Restore delta packed data to original values
    +
    6 C> restore from boustrephedonic alignment.
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> - Bill Cavanaugh 1993-07-14
    +
    10 C> - John Satckpole 1993-07-22 Additions to fix scaling.
    +
    11 C> - Bill Cavanaugh 1994-01-27 Added reversal of even numbered rows
    +
    12 C> (boustrophedonic processing) to restore
    +
    13 C> data to original sequence.
    +
    14 C> - Bill Cavanaugh 1994-03-02 Corrected reversal of even numbered rows.
    +
    15 C> - Mark Iredell 1995-10-31 Removed saves and prints.
    +
    16 C>
    +
    17 C> @param[inout] DATA
    +
    18 C> - [in] Second order differences.
    +
    19 C> - [out] Expanded original data values.
    +
    20 C> @param[in] NPTS Number of points in array.
    +
    21 C> @param[in] FVAL1 Original first entry in array.
    +
    22 C> @param[in] FDIFF1 Original first first-difference.
    +
    23 C> @param[in] ISCAL2 Power-of-two exponent for unscaling.
    +
    24 C> @param[in] ISC10 Power-of-ten exponent for unscaling.
    +
    25 C> @param[in] KPDS Array of information for pds.
    +
    26 C> @param[in] KGDS Array of information for gds.
    +
    27 C>
    +
    28 C> @note Subprogram can be called from a multiprocessing environment.
    +
    29 C>
    +
    30 C> @author Bill Cavanaugh @date 1993-08-18
    +
    31  SUBROUTINE w3fi83 (DATA,NPTS,FVAL1,FDIFF1,ISCAL2,
    +
    32  * ISC10,KPDS,KGDS)
    +
    33 C
    +
    34  REAL FVAL1,FDIFF1
    +
    35  REAL DATA(*),BOUST(200)
    +
    36  INTEGER NPTS,NROW,NCOL,KPDS(*),KGDS(*),ISC10
    +
    37 C ---------------------------------------
    +
    38 C
    +
    39 C REMOVE DECIMAL UN-SCALING INTRODUCED DURING UNPACKING
    +
    40 C
    +
    41  dscal = 10.0 ** isc10
    +
    42  IF (dscal.EQ.0.0) THEN
    +
    43  DO 50 i=1,npts
    +
    44  DATA(i) = 1.0
    +
    45  50 CONTINUE
    +
    46  ELSE IF (dscal.EQ.1.0) THEN
    +
    47  ELSE
    +
    48  DO 51 i=1,npts
    +
    49  DATA(i) = DATA(i) * dscal
    +
    50  51 CONTINUE
    +
    51  END IF
    +
    52 C
    +
    53  DATA(1) = fval1
    +
    54  DATA(2) = fdiff1
    +
    55  DO 200 j = 3,2,-1
    +
    56  DO 100 k = j, npts
    +
    57  DATA(k) = DATA(k) + DATA(k-1)
    +
    58  100 CONTINUE
    +
    59  200 CONTINUE
    +
    60 C
    +
    61 C NOW REMOVE THE BINARY SCALING FROM THE RECONSTRUCTED FIELD
    +
    62 C AND THE DECIMAL SCALING TOO
    +
    63 C
    +
    64  IF (dscal.EQ.0) THEN
    +
    65  scale = 0.0
    +
    66  ELSE
    +
    67  scale =(2.0**iscal2)/dscal
    +
    68  END IF
    +
    69  DO 300 i=1,npts
    +
    70  DATA(i) = DATA(i) * scale
    +
    71  300 CONTINUE
    +
    72 C ==========================================================
    +
    73  IF (iand(kpds(4),128).NE.0) THEN
    +
    74  nrow = kgds(3)
    +
    75  ncol = kgds(2)
    +
    76 C
    +
    77 C DATA LAID OUT BOUSTROPHEDONIC STYLE
    +
    78 C
    +
    79 C
    +
    80 C PRINT*, ' REVERSE BOUSTROPHEDON'
    +
    81  DO 210 i = 2, nrow, 2
    +
    82 C
    +
    83 C REVERSE THE EVEN NUMBERED ROWS
    +
    84 C
    +
    85  DO 201 j = 1, ncol
    +
    86  npos = i * ncol - j + 1
    +
    87  boust(j) = DATA(npos)
    +
    88  201 CONTINUE
    +
    89  DO 202 j = 1, ncol
    +
    90  npos = ncol * (i-1) + j
    +
    91  DATA(npos) = boust(j)
    +
    92  202 CONTINUE
    +
    93  210 CONTINUE
    +
    94 C
    +
    95 C
    +
    96  END IF
    +
    97 C =================================================================
    +
    98  RETURN
    +
    99  END
    +
    +
    +
    w3fi83
    subroutine w3fi83(DATA, NPTS, FVAL1, FDIFF1, ISCAL2, ISC10, KPDS, KGDS)
    Restore delta packed data to original values restore from boustrephedonic alignment.
    Definition: w3fi83.f:33
    + + + + diff --git a/ver-2.10.0/w3fi85_8f.html b/ver-2.10.0/w3fi85_8f.html new file mode 100644 index 00000000..10347955 --- /dev/null +++ b/ver-2.10.0/w3fi85_8f.html @@ -0,0 +1,1837 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi85.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi85.f File Reference
    +
    +
    + +

    Generate bufr message. +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

    +Functions/Subroutines

    subroutine fi8501 (KARY, ISTEP, KCLASS, KSEG, IDATA, RDATA, KDATA, NSUB, KDESC, NRDESC, IERRTN)
     Perform replication of descriptors. More...
     
    subroutine fi8502 (, KBUFR, KCLASS, KSEG, KDESC, NRDESC, I, ISTEP, KARY, KDATA, ISECT3, KRFVSW, NEWRFV, LDESC, IERRTN, INDEXB)
     Process an operator descriptor. More...
     
    subroutine fi8503 (I, KDESC, NRDESC, ISECT3, IUNITD, KSEQ, KNUM, KLIST, IERRTN)
     Expand sequence descriptor. More...
     
    subroutine fi8505 (MIF, MDESC, NR, IERRTN)
     Convert descriptors fxy to decimal. More...
     
    subroutine fi8506 (ISTEP, ISECT3, KARY, JDESC, NEWNR, KDESC, NRDESC, LDESC, ANAME, AUNITS, KSCALE, KRFVAL, KWIDTH, KRFVSW, NEWRFV, KSEQ, KNUM, KLIST, IBFSIZ, KDATA, KBUFR, IERRTN, INDEXB)
     Process data in non-compressed format. More...
     
    subroutine fi8508 (ISTEP, IUNITB, IDATA, KDESC, NRDESC, ATEXT, KSUB, KARY, KDATA, LDESC, ANAME, AUNITS, KSCALE, KRFVAL, KRFVSW, ISECT3, KWIDTH, KASSOC, IUNITD, KSEQ, KNUM, KLIST, IERRTN, INDEXB)
     Combine integer/text data. More...
     
    subroutine fi8509 (ISTEP, IUNITB, RDATA, KDESC, NRDESC, ATEXT, KSUB, KARY, KDATA, LDESC, ANAME, AUNITS, KSCALE, KRFVAL, KRFVSW, ISECT3, KWIDTH, KASSOC, IUNITD, KSEQ, KNUM, KLIST, IERRTN, INDEXB)
     Convert real/text input to integer. More...
     
    subroutine fi8511 (ISECT3, KARY, JIF, JDESC, NEWNR, KIF, KDESC, NRDESC, IERRTN)
     Rebuild kdesc from jdesc. More...
     
    subroutine fi8512 (IUNITB, ISECT3, KDESC, NRDESC, KARY, IERRTN, LDESC, ANAME, AUNITS, KSCALE, KRFVAL, KWIDTH, KRFVSW, IUNITD, KSEQ, KNUM, KLIST, INDEXB)
     Read in table B. More...
     
    subroutine fi8513 (IUNITD, ISECT3, KSEQ, KNUM, KLIST, IERRTN)
     Read in table D. More...
     
    subroutine w3fi85 (ISTEP, IUNITB, IUNITD, IBFSIZ, ISECT1, ISECT3, JIF, JDESC, NEWNR, IDATA, RDATA, ATEXT, KASSOC, KIF, KDESC, NRDESC, ISEC2D, ISEC2B, KDATA, KARY, KBUFR, IERRTN)
     Using information available in supplied arrays, generate a bufr message (wmo code fm94). More...
     
    +

    Detailed Description

    +

    Generate bufr message.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-09-29
    + +

    Definition in file w3fi85.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ fi8501()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8501 (integer, dimension(*) KARY,
    integer ISTEP,
    integer KCLASS,
    integer KSEG,
    integer, dimension(*) IDATA,
    real, dimension(*) RDATA,
    integer, dimension(500,*) KDATA,
     NSUB,
    integer, dimension(3,*) KDESC,
    integer NRDESC,
    integer IERRTN 
    )
    +
    + +

    Perform replication of descriptors.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03 Have encountered a replication descriptor. It may include delayed replication or not. That decision should have been made prior to calling this routine.
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-12-03
      • +
    • J. Hoppa 1994-03-25 Added line to initialize nxtptr to correct an error in the standard replication.
      • +
    • J. Hoppa 1994-03-28 Corrected an error in the standard replication that was adding extra zeros to the bufr message after the replicated data.
      • +
    • J. Hoppa 1994-03-31 Added the subset number to the parameter list. corrected the equation for the number of replications with delayed replication. (istart and k don't exist)
      • +
    • J. Hoppa 1994-04-19 Switched the variables next and nxtprt
      • +
    • J. Hoppa 1994-04-20 Added the kdata parameter counter to the parameter list. In the assignment of nreps when have delayed replication, changed index in kdata from n to k.
      • +
    • J. Hoppa 1994-04-29 Removed n and k from the input list changed n to kary(11) and k to kary(2)
      • +
    +
    Parameters
    + + + + + + + + + + + + +
    [in]ISTEP
    [in]KCLASS
    [in]KSEG
    [in]IDATA
    [in]RDATA
    [in]KDATA
    [in]NSUBCurrent subset
    [in,out]KDESC(modified [out]) List of descriptors
    [in,out]NRDESCNumber of (new [out]) descriptors in kdesc
    [out]IERRTNError return value
    KARY
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03
    + +

    Definition at line 981 of file w3fi85.f.

    + +
    +
    + +

    ◆ fi8502()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8502 ( KBUFR,
    integer KCLASS,
    integer KSEG,
    integer, dimension(3,*) KDESC,
    integer NRDESC,
    integer I,
     ISTEP,
    integer, dimension(*) KARY,
    integer, dimension(500,*) KDATA,
    integer, dimension(*) ISECT3,
    integer, dimension(*) KRFVSW,
    integer, dimension(*) NEWRFV,
    integer, dimension(*) LDESC,
    integer IERRTN,
     INDEXB 
    )
    +
    + +

    Process an operator descriptor.

    +
    Author
    Bill Cavanaugh
    +
    Date
    193-12-03 Have encountered an operator descriptor.
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-12-03
      • +
    • J. Hoppa 1994-04-15 Added kbufr to input parameter list. added block of data to correctly use sbyte when writing a 205yyy descriptor to the bufr message. The previous way didn't work because kdata was getting incremeted by the ksub value, not the param value.
      • +
    • J. Hoppa 1994-04-29 Changed k to kary(2) removed a line that became obsolete with above change
      • +
    • J. Hoppa 1994-05-18 Added a kary(2) increment
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + + +
    [in]KCLASS
    [in]KSEG
    [in,out]KDESC
    [in,out]NRDESC
    [in]I
    [in]ISTEP
    [in,out]KARY
    [out]IERRTNError return value
    KBUFR
    KDATA
    ISECT3
    KRFVSW
    NEWRFV
    LDESC
    INDEXB
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    193-12-03
    + +

    Definition at line 1116 of file w3fi85.f.

    + +
    +
    + +

    ◆ fi8503()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8503 (integer I,
    integer, dimension(3,*) KDESC,
    integer NRDESC,
    integer, dimension(*) ISECT3,
    integer IUNITD,
    integer, dimension(*) KSEQ,
    integer, dimension(*) KNUM,
    integer, dimension(300,*) KLIST,
    integer IERRTN 
    )
    +
    + +

    Expand sequence descriptor.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03 Have encountered a sequence descriptor. must perform proper replacment of descriptors in line.
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-12-03
      • +
    +
    Parameters
    + + + + + + + + + + +
    [in,out]ICurrent position in descriptor list
    [in,out]KDESCList (modified [out]) of descriptors
    [in,out]NRDESCNumber (new [out]) of descriptors in kdesc
    [in]IUNITD
    [in]KSEQ
    [in]KNUM
    [in]KLIST
    [out]IERRTNError return value
    ISECT3
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03
    + +

    Definition at line 1307 of file w3fi85.f.

    + +
    +
    + +

    ◆ fi8505()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8505 ( MIF,
    integer, dimension(3,*) MDESC,
    integer NR,
     IERRTN 
    )
    +
    + +

    Convert descriptors fxy to decimal.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03 Construct decimal descriptor values from f x and y segments
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-12-03
      • +
    +
    Parameters
    + + + + + +
    [in]MIFinput flag
    [in,out]MDESClist of descriptors in f x y (decimal [out]) form
    [in]NRnumber of descriptors in mdesc
    [out]IERRTNerror return value
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03
    + +

    Definition at line 1393 of file w3fi85.f.

    + +
    +
    + +

    ◆ fi8506()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8506 (integer ISTEP,
    integer, dimension(*) ISECT3,
    integer, dimension(*) KARY,
    integer, dimension(3,*) JDESC,
    integer NEWNR,
    integer, dimension(3,*) KDESC,
    integer NRDESC,
    integer, dimension(*) LDESC,
    character*40, dimension(*) ANAME,
    character*25, dimension(*) AUNITS,
    integer, dimension(*) KSCALE,
    integer, dimension(*) KRFVAL,
    integer, dimension(*) KWIDTH,
    integer, dimension(*) KRFVSW,
    integer, dimension(*) NEWRFV,
    integer, dimension(*) KSEQ,
    integer, dimension(*) KNUM,
    integer, dimension(300,*) KLIST,
     IBFSIZ,
    integer, dimension(500,*) KDATA,
    integer, dimension(*) KBUFR,
    integer IERRTN,
    integer, dimension(*) INDEXB 
    )
    +
    + +

    Process data in non-compressed format.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03 Process data into non-compressed format for inclusion into section 4 of the bufr message
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-12-03
      • +
    • J. Hoppa 1994-03-24 Changed the inner loop from a do loop to a goto loop so nrdesc isn't a set value. corrected a value in the call to fi8503().
      • +
    • J. Hoppa 1994-03-31 Corrected an error in sending the subset number rather than the descriptor number to subroutine fi8501(). Added the subset number to the fi8501() parameter list.
      • +
    • J. Hoppa 1994-04015 Added line to keep the parameter pointer kary(2) up to date. this variable is used in subroutine fi8502(). added kbufr to the parameter list in the call to subroutine fi8502(). corrected an infinite loop when have an operator descriptor that was caused by a correction made 94-03-24
      • +
    • J. Hoppa 1994-04-20 Added k to call to subroutine w3fi01
      • +
    • J. Hoppa 1994-04-29 Changed n to kary(11) and k to kary(2) removed k and n from the call to fi8501()
      • +
    • J. Hoppa 1994-05-03 Added an increment to kary(11) to prevent and infinite loop when have a missing value
      • +
    • J. Hoppa 1994-05-18 Changed so increments kary(2) after each call to sbyte and deleted kary(2) = kary(11) + kary(18)
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + + + + + + + + + + +
    [in]ISTEP
    [in]ISECT3
    [in]KARY
    [in]JDESC
    [in]NEWNR
    [in]KDESC
    [in]NRDESC
    [in]LDESC
    [in]ANAME
    [in]AUNITS
    [in]KSCALE
    [in]KRFVAL
    [in]KWIDTH
    [in]KRFVSW
    [in]NEWRFV
    [in]KSEQ
    [in]KNUM
    [in]KLIST
    [out]KDATA
    [out]KBUFR
    [out]IERRTN
    IBFSIZ
    INDEXB
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03
    + +

    Definition at line 1473 of file w3fi85.f.

    + +
    +
    + +

    ◆ fi8508()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8508 (integer ISTEP,
    integer IUNITB,
    integer, dimension(*) IDATA,
    integer, dimension(3,*) KDESC,
    integer NRDESC,
    character*1, dimension(*) ATEXT,
    integer KSUB,
    integer, dimension(*) KARY,
    integer, dimension(500,*) KDATA,
    integer, dimension(*) LDESC,
    character*40, dimension(*) ANAME,
    character*25, dimension(*) AUNITS,
    integer, dimension(*) KSCALE,
    integer, dimension(*) KRFVAL,
    integer, dimension(*) KRFVSW,
    integer, dimension(*) ISECT3,
    integer, dimension(*) KWIDTH,
    integer, dimension(*) KASSOC,
    integer IUNITD,
    integer, dimension(*) KSEQ,
    integer, dimension(*) KNUM,
    integer, dimension(300,*) KLIST,
     IERRTN,
    integer, dimension(*) INDEXB 
    )
    +
    + +

    Combine integer/text data.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03 Construct integer subset from real and text data
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-12-03
      • +
    • J. Hoppa 1994-03-31 added ksub to fi8501() parameter list.
      • +
    • J. Hoppa 1994-04-18 added dummy variable idum to fi8502() parameter list.
      • +
    • J. Hoppa 1994-04-20 added dummy variable ll to fi8501() parameter list.
      • +
    • J. Hoppa 1994-04-29 changed i to kary(11) added a kary(2) assignment so have something to pass to subroutines ** test this ** removed i and ll from call to fi8501()
      • +
    • J. Hoppa 1994-05-13 added code to calculate kwords when kfunc=2
      • +
    • J. Hoppa 1994-05-18 deleted kary(2) assignment
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + + + + + + + + + + + +
    [in]ISTEP
    [in]IUNITBUnit number of device containing table b
    [in]IDATAInteger working array
    [in]KDESCExpanded descriptor set
    [in]NRDESCNumber of descriptors in kdesc
    [in]ATEXTText data for ccitt ia5 and text operator fields
    [in]KSUBSubset number
    [in]KARYWorking array
    [in]ISECT3
    [out]KDATAArray containing integer subsets
    [out]LDESCList of table b descriptors (decimal)
    [out]ANAMEList of descriptor names
    [out]AUNITSUnits for each descriptor
    [out]KSCALEBase 10 scale factor for each descriptor
    [out]KRFVALReference value for each descriptor
    [out]KRFVSW
    [out]KWIDTHStandard bit width to contain each value for specific descriptor
    [out]KASSOC
    [out]IERRTNError return flag
    IUNITD
    KSEQ
    KNUM
    KLIST
    INDEXB
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03
    + +

    Definition at line 1752 of file w3fi85.f.

    + +
    +
    + +

    ◆ fi8509()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8509 (integer ISTEP,
    integer IUNITB,
    real, dimension(*) RDATA,
    integer, dimension(3,*) KDESC,
    integer NRDESC,
    character*1, dimension(*) ATEXT,
    integer KSUB,
    integer, dimension(*) KARY,
    integer, dimension(500,*) KDATA,
    integer, dimension(*) LDESC,
    character*40, dimension(*) ANAME,
    character*25, dimension(*) AUNITS,
    integer, dimension(*) KSCALE,
    integer, dimension(*) KRFVAL,
    integer, dimension(*) KRFVSW,
    integer, dimension(*) ISECT3,
    integer, dimension(*) KWIDTH,
    integer, dimension(*) KASSOC,
    integer IUNITD,
    integer, dimension(*) KSEQ,
    integer, dimension(*) KNUM,
    integer, dimension(300,*) KLIST,
    integer IERRTN,
    integer, dimension(*) INDEXB 
    )
    +
    + +

    Convert real/text input to integer.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03 Construct integer subset from real and text data.
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-12-03
      • +
    • J. Hoppa 1994-03-31 Added ksub to the fi8501 parameter list.
      • +
    • J. Hoppa 1994-04-18 Added dummy variable idum to fi8502 parameter list.
      • +
    • J. Hoppa 1994-04-20 Added dummy variable ll to fi8501 parameter list.
      • +
    • J. Hoppa 1994-04-29 Changed i to kary(11) added a kary(2) assignment so have something to pass to subroutines ** test this ** removed i and ll from call to fi8501
      • +
    • J. Hoppa 1994-05-18 Deleted kary(2) assignment
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + + + + + + + + + + + +
    [in]IUNITBunit number of device containing table b
    [in]RDATAreal working array
    [in]KDESCexpanded descriptor set
    [in]NRDESCnumber of descriptors in kdesc
    [in]ATEXTtext data for ccitt ia5 and text operator fields
    [in]KSUBsubset number
    [in]KARYworking array
    [in]ISECT3
    [in]IUNITD
    [out]KDATAArray containing integer subsets
    [out]LDESCList of table b descriptors (decimal)
    [out]ANAMEList of descriptor names
    [out]AUNITSUnits for each descriptor
    [out]KSCALEBase 10 scale factor for each descriptor
    [out]KRFVALReference value for each descriptor
    [out]KRFVSW
    [out]KASSOC
    [out]KWIDTHStandard bit width to contain each value for specific descriptor
    [out]IERRTNError return flag
    [out]KNUM
    [out]KLIST
    ISTEP
    KSEQ
    INDEXB
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03
    + +

    Definition at line 1976 of file w3fi85.f.

    + +
    +
    + +

    ◆ fi8511()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8511 (integer, dimension(*) ISECT3,
    integer, dimension(*) KARY,
    integer JIF,
    integer, dimension(3,*) JDESC,
    integer NEWNR,
    integer KIF,
    integer, dimension(3,*) KDESC,
    integer NRDESC,
    integer IERRTN 
    )
    +
    + +

    Rebuild kdesc from jdesc.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03 Construct working descriptor list from list of descriptors in section 3.
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-12-03
      • +
    +
    Parameters
    + + + + + + + + + + +
    [in]ISECT3
    [in]KARYUtility - array see main routine
    [in]JIFDescriptor input form flag
    [in]JDESCList of descriptors for section 3
    [in]NEWNRNumber of descriptors in jdesc
    [out]KIFDescriptor form
    [out]KDESCWorking list of descriptors
    [out]NRDESCNumber of descriptors in kdesc
    [out]IERRTNError return
      +
    • IERRTN = 0 Normal return
      • +
    • IERRTN = 5 Found delayed replication during expansion
      • +
    +
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03
    + +

    Definition at line 2205 of file w3fi85.f.

    + +
    +
    + +

    ◆ fi8512()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8512 (integer IUNITB,
    integer, dimension(*) ISECT3,
    integer, dimension(3,*) KDESC,
    integer NRDESC,
    integer, dimension(*) KARY,
    integer IERRTN,
    integer, dimension(*) LDESC,
    character*40, dimension(*) ANAME,
    character*25, dimension(*) AUNITS,
    integer, dimension(*) KSCALE,
    integer, dimension(*) KRFVAL,
    integer, dimension(*) KWIDTH,
    integer, dimension(*) KRFVSW,
    integer IUNITD,
    integer, dimension(*) KSEQ,
    integer, dimension(*) KNUM,
    integer, dimension(300,*) KLIST,
    integer, dimension(*) INDEXB 
    )
    +
    + +

    Read in table B.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03 Read in tailored set of table B descriptors.
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-12-03
      • +
    • J. Hoppa 1994-04-18 An error has been corrected to prevent later searching table b if there are only operator descriptors in the descriptor list.
      • +
    • J. Hoppa 1994-05-17 Changed the loop for expanding sequence descriptors from a do loop to a goto loop
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + + + + + +
    [in]IUNITBUnit where table b entries reside
    [in]KDESCWorking descriptor list
    [in]NRDESCNumber of descriptors in kdesc
    [in]IUNITDUnit where table d entries reside
    [out]KARY
    [out]IERRTN
    [out]LDESCDescriptors in table b (decimal values)
    [out]ANAMEArray containing names of descriptors
    [out]AUNITSArray containing units of descriptors
    [out]KSCALEScale values for each descriptor
    [out]KRFVALReference values for each descriptor
    [out]KWIDTHBit width of each descriptor
    [out]KRFVSWNew reference value switch
    [out]KSEQSequence descriptor
    [out]KNUMNumber of descriptors in sequence
    [out]KLISTSequence of descriptors
    ISECT3
    INDEXB
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03
    + +

    Definition at line 2271 of file w3fi85.f.

    + +
    +
    + +

    ◆ fi8513()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8513 (integer IUNITD,
    integer, dimension(*) ISECT3,
    integer, dimension(*) KSEQ,
    integer, dimension(*) KNUM,
    integer, dimension(300,*) KLIST,
     IERRTN 
    )
    +
    + +

    Read in table D.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03 Read in table D
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-12-03
      • +
    +
    Parameters
    + + + + + + + +
    [in]IUNITDUnit number of input device
    [out]KSEQKey for sequence descriptors
    [out]KNUMNumber if descriptors in list
    [out]KLISTDescriptors list
    [out]IERRTNError return flag
    ISECT3
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-12-03
    + +

    Definition at line 2423 of file w3fi85.f.

    + +
    +
    + +

    ◆ w3fi85()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi85 ( ISTEP,
     IUNITB,
     IUNITD,
     IBFSIZ,
    integer, dimension(*) ISECT1,
    integer, dimension(*) ISECT3,
     JIF,
    integer, dimension(3,*) JDESC,
    integer NEWNR,
    integer, dimension(*) IDATA,
    real, dimension(*) RDATA,
    character*1, dimension(*) ATEXT,
    integer, dimension(*) KASSOC,
     KIF,
    integer, dimension(3,*) KDESC,
     NRDESC,
    integer, dimension(255) ISEC2D,
    integer ISEC2B,
    integer, dimension(500,*) KDATA,
    integer, dimension(*) KARY,
    integer, dimension(*) KBUFR,
     IERRTN 
    )
    +
    + +

    Using information available in supplied arrays, generate a bufr message (wmo code fm94).

    +

    there may be a section 2 included in the bufr message if the user follows proper procedure. messages are constructed in accordance with bufr edition 2. entries for section 1 must be passed to this routine in the isect1 array. entries for section 3 must be passed to this routine in isect3.

    +

    In the event that the user requests a reduction of reports in a bufr message if a particular message becomes oversized, the possibility exists of the last block of data producing an oversized message. the user must verify that isect3(6) does in fact equal zero to assure that all of the data has been included as output.

    +

    Program history log:

      +
    • Bill Cavanaugh 1993-09-29
      • +
    • J. Hoppa 1994-03-22 Corrected an error when writing the descriptors into the bufr message
      • +
    • J. Hoppa 1994-03-31 Added the subset number to the parameter list of subroutine fi8501()
      • +
    • J. Hoppa 1994-04-15 Added kbufr to the parameter list of subroutine fi8502()
      • +
    • J. Hoppa 1994-04-20 Added the kdata parameter counter to the parameter list of subroutine fi8501()
      • +
    • J. Hoppa 1995-04-29 Changed nq and n to kary(2) changed jk to kary(11) added an assignment to kary(2) so have something to pass to subroutines deleted jk and ll from call to fi8501()
      • +
    +
    Parameters
    + + + + + + + +
    [in]ISTEPKey for selection of processing step
      +
    • 1 = Process integer/text array into kdata.
      • +
    • 2 = Process real/text array into kdata.
      • +
    • 3 = Construct bufr message.
      • +
    +
    [in]IUNITBUnit number of device containing table b
    [in]IUNITDUnit number of device containing table d
    [in]IBFSIZSize in bytes of bufr message array (kbufr) should be a multiple of word size.
    [in]ISECT1Contains information to enter into section 1 (1) Edition number (2) Bufr master table number 0 = meteorological others not yet defined (3) Originating center - subcenter number (4) Originating center number (5) Update sequence number (6) Optional section flag should be set to zero unless user write additional code to enter local information into section 3 (7) Bufr message type (8) Bufr message sub_type (9) Master table version number (10) Local table version number (11) Year of century - representative of data (12) Month - representative of data (13) Day - representative of data (14) Hour - representative of data (15) Minute - representative of data (16)-(20) Unused
    [in]ISECT3Values to be inserted into section 3, and to control report reduction for oversized messages
      +
    • (1) Number of subsets Defines the number of subsets being passed to the encoder routine for inclusion into a bufr message. If the user has specified the use of the subset/report reduction activation switch, then a part of those subsets may be used for the current message and the remainder retained for a subsequent message.
      • +
    • (2) Observed flag
        +
      • 0 = observed data
        • +
      • 1 = other data
        • +
      +
      • +
    • (3) Compressed flag
        +
      • 0 = noncompressed
        • +
      • 1 = compressed
        • +
      +
      • +
    • (4) Subset/report reduction activation switch used to control the number of reports entered into a bufr message when maximum message size is exceeded
        +
      • 0 = option not active
        • +
      • 1 = option is active. unused subsets will be shifted to low order positions of entry array.
        • +
      • 2 = option is active. unused subsets will remain in entry positions.
        • +
      +
      • +
    +
    +
    +
    +
    Note
    If this flag is set to any other values, program will be terminated with an error condition.
      +
    • (5) Number of reports to decrement by, if oversized message (minimum value = one). If zero is entered, it will be replaced by one.
      • +
    • (6) Number of unused reports returned to user
      • +
    • (7) Number of reports included in message
      • +
    • (8) Number of table b entries available to decoder
      • +
    • (9) Number of table d entries available to decoder
      • +
    • (10) Text input flag
        +
      • 0 = ASCII input
        • +
      • 1 = EBCIDIC input
        • +
      +
      • +
    +
    +
    Parameters
    + + + + + + + + + + + + + + + + + +
    [in]JIFJDESC input format flag
      +
    • 0 = F X Y
      • +
    • 1 = Decimal format
      • +
    +
    [in]JDESCList of descriptors to go into section 3 Each descriptor = F * 16384 + X * 256 + Y They may or may not be an exact match of the working descriptor list in kdesc. This set of descriptors may contain sequence descriptors to provide additional compression within the bufr message. There may be as few as one sequence descriptor, or as many descriptors as there are in kdesc.
    [in]NEWNRNR of descriptors in JDESC
    [in]IDATAInteger array dimensioned by the number of descriptors to be used
    [in]RDATAReal array dimensioned by the number of descriptors to be used
    [in]ATEXTArray containing all text data associated with a specific report. All data identified as text data must be in ASCII.
    [in]KASSOCInteger array dimensioned by the number of descriptors to be used, containing the associated field values for any entry in the descriptor list.
    [in]KIFKDESC input format flag
      +
    • 0 = F X Y
      • +
    • 1 = DECIMAL FORMAT
      • +
    +
    [in]KDESCList of descriptors to go into section 3 fully expanded set of working descriptors. there should be an element descriptor for every data entry, but there should be no sequence descriptors.
    [in]NRDESCNR of descriptors in kdesc
    [in]ISEC2DData or text to be entered into section 2
    [in]ISEC2BNumber of bytes of data in isec2d
    [out]KDATASource data array . a 2-dimension integer array where kdata(subset,param) subset = subset number param = parameter number.
    [out]KARYWorking array for message under construction
      +
    • (1) unused
      • +
    • (2) parameter pointer
      • +
    • (3) message bit pointer
      • +
    • (4) delayed replication flag
        +
      • 0 = no delayed replication
        • +
      • 1 = contains delayed replication
        • +
      +
      • +
    • (5) bit pointer for start of section 4
      • +
    • (6) unused
      • +
    • (7) nr of bits for parameter/data packing
      • +
    • (8) total bits for ascii data
      • +
    • (9) scale change value
      • +
    • (10) indicator (used in w3fi85)
        +
      • 1 = numeric data
        • +
      • 2 = text data
        • +
      +
      • +
    • (11) pointer to current pos in kdesc
      • +
    • (12) unused
      • +
    • (13) unused
      • +
    • (14) unused
      • +
    • (15) data type
      • +
    • (16) unused
      • +
    • (17) unused
      • +
    • (18) words added for text or associated fields
      • +
    • (19) location for total byte count
      • +
    • (20) size of section 0
      • +
    • (21) size of section 1
      • +
    • (22) size of section 2
      • +
    • (23) size of section 3
      • +
    • (24) size of section 4
      • +
    • (25) size of section 5
      • +
    • (26) nr bits added by table c operator
      • +
    • (27) bit width of associated field
      • +
    • (28) jdesc input form flag
        +
      • 0 = Descriptor in f x y form
          +
        • F in JDESC(1,I)
          • +
        • X in JDESC(2,I)
          • +
        • Y in JDESC(3,I)
          • +
        +
        • +
      • 1 = DEscriptor in decimal form in jdesc(1,i)
        • +
      +
      • +
    • (29) kdesc input form flag
        +
      • 0 = Descriptor in F X Y form
          +
        • F in KDESC(1,I)
          • +
        • X in KDESC(2,I)
          • +
        • Y in KDESC(3,I)
          • +
        +
        • +
      • 1 = Descriptor in decimal form in kdesc(1,i)
        • +
      +
      • +
    • (30) bufr message total byte count
      • +
    +
    [out]KBUFRArray to contain completed bufr message
    [out]IERRTNError return flag
    +
    +
    +

    IERRTN:

      +
    • = 0 Normal return, bufr message resides in kbufr
        +
      • if isect3(4)= 0, all reports have been processed into a bufr message
        • +
      • if isect3(4)= 1, a bufr message has been generated with all or part of the data passed to this routine. isect3(6) contains the number of reports that were not used but are being held for the next message.
        • +
      +
      • +
    • = 1 bufr message construction was halted because contents exceeded maximum size (only when isect3(4) = 0)
      • +
    • = 2 bufr message construction was halted because of encounter with a descriptor not found in table b.
      • +
    • = 3 routine was called with no subsets
      • +
    • = 4 error occured while reading table b
      • +
    • = 5 an attempt was made to expand jdesc into kdesc, but a descriptor indicating delayed replication was encountered
      • +
    • = 6 error occured while reading table d
      • +
    • = 7 data value could not be contained in specified bit width
      • +
    • = 8 delayed replication not permitted in compressed data format
      • +
    • = 9 an operator descriptor 2 04 yyy opening an associated field (yyy not eq zero) was not followed by the defining descriptor 0 31 021 (7957 decimal).
      • +
    • = 10 delayed replication descriptor was not followed by descriptor for delayed replication factor.
        +
      • 0 31 001
        • +
      • 0 31 002
        • +
      • 0 31 011
        • +
      • 0 31 012
        • +
      +
      • +
    • = 11 encountered a reference value that forced a data element to become negative
      • +
    • = 12 no matching table d entry for sequence descriptor.
      • +
    • = 13 encountered a non-acceptable data entry flag. isect3(6) should be 0 or 1.
      • +
    • = 14 converting descriptors fxy->decimal, number to convert = 0
      • +
    • = 15 no descriptors specified for section 3
      • +
    • = 16 incomplete table b, number of descriptors in table b does not match number of descriptors needed to construct bufr message
      • +
    • = 20 incorrect entry of replication or sequence descriptor in list of reference value changes
      • +
    • = 21 incorrect operator descriptor in list of reference value changes
      • +
    • = 22 attempting to enter new reference value into table b, but descriptor does not exist in current modified table b
      • +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-09-29
    + +

    Definition at line 214 of file w3fi85.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi85_8f.js b/ver-2.10.0/w3fi85_8f.js new file mode 100644 index 00000000..79aabc01 --- /dev/null +++ b/ver-2.10.0/w3fi85_8f.js @@ -0,0 +1,14 @@ +var w3fi85_8f = +[ + [ "fi8501", "w3fi85_8f.html#a2dfac12c57c3882ab71df73ae85329ef", null ], + [ "fi8502", "w3fi85_8f.html#aa2db7280cff113d09e4ade7687aaca1a", null ], + [ "fi8503", "w3fi85_8f.html#a65ffb3c26f568c33248204db13547c2f", null ], + [ "fi8505", "w3fi85_8f.html#a52f6aae9ed57d3745d0e142b54366427", null ], + [ "fi8506", "w3fi85_8f.html#a909b8c9399363ed4f51c78bedb57f3cd", null ], + [ "fi8508", "w3fi85_8f.html#a97892186cc13a9f697d5cc447131db26", null ], + [ "fi8509", "w3fi85_8f.html#a43fe930255ffb0865c2329031d294786", null ], + [ "fi8511", "w3fi85_8f.html#ae5983e91fa36267f15a462c84a649de3", null ], + [ "fi8512", "w3fi85_8f.html#ab388b83b7f0918bbae5097408882c6b9", null ], + [ "fi8513", "w3fi85_8f.html#a17405ce8ebd7d06c0bedf0bea6ae2105", null ], + [ "w3fi85", "w3fi85_8f.html#a952501a26ebad493c05a3b8028fc6cd7", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi85_8f_source.html b/ver-2.10.0/w3fi85_8f_source.html new file mode 100644 index 00000000..424a9848 --- /dev/null +++ b/ver-2.10.0/w3fi85_8f_source.html @@ -0,0 +1,2578 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi85.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi85.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Generate bufr message
    +
    3 C> @author Bill Cavanaugh @date 1993-09-29
    +
    4 
    +
    5 C> Using information available in supplied arrays, generate
    +
    6 C> a bufr message (wmo code fm94). there may be a section 2
    +
    7 C> included in the bufr message if the user follows proper procedure.
    +
    8 C> messages are constructed in accordance with bufr edition 2. entries
    +
    9 C> for section 1 must be passed to this routine in the isect1 array.
    +
    10 C> entries for section 3 must be passed to this routine in isect3.
    +
    11 C>
    +
    12 C>
    +
    13 C> In the event that the user requests a reduction of reports
    +
    14 C> in a bufr message if a particular message becomes oversized, the
    +
    15 C> possibility exists of the last block of data producing an oversized
    +
    16 C> message. the user must verify that isect3(6) does in fact equal
    +
    17 C> zero to assure that all of the data has been included as output.
    +
    18 C>
    +
    19 C> Program history log:
    +
    20 C> - Bill Cavanaugh 1993-09-29
    +
    21 C> - J. Hoppa 1994-03-22 Corrected an error when writing the
    +
    22 C> descriptors into the bufr message
    +
    23 C> - J. Hoppa 1994-03-31 Added the subset number to the parameter list
    +
    24 C> of subroutine fi8501()
    +
    25 C> - J. Hoppa 1994-04-15 Added kbufr to the parameter list of
    +
    26 C> subroutine fi8502()
    +
    27 C> - J. Hoppa 1994-04-20 Added the kdata parameter counter to the
    +
    28 C> parameter list of subroutine fi8501()
    +
    29 C> - J. Hoppa 1995-04-29 Changed nq and n to kary(2) changed jk to kary(11)
    +
    30 C> added an assignment to kary(2) so have something to pass to subroutines
    +
    31 C> deleted jk and ll from call to fi8501()
    +
    32 C>
    +
    33 C> @param[in] ISTEP Key for selection of processing step
    +
    34 C> - 1 = Process integer/text array into kdata.
    +
    35 C> - 2 = Process real/text array into kdata.
    +
    36 C> - 3 = Construct bufr message.
    +
    37 C> @param[in] IUNITB Unit number of device containing table b
    +
    38 C> @param[in] IUNITD Unit number of device containing table d
    +
    39 C> @param[in] IBFSIZ Size in bytes of bufr message array (kbufr)
    +
    40 C> should be a multiple of word size.
    +
    41 C> @param[in] ISECT1 Contains information to enter into section 1
    +
    42 C> (1) Edition number
    +
    43 C> (2) Bufr master table number
    +
    44 C> 0 = meteorological
    +
    45 C> others not yet defined
    +
    46 C> (3) Originating center - subcenter number
    +
    47 C> (4) Originating center number
    +
    48 C> (5) Update sequence number
    +
    49 C> (6) Optional section flag should be set to zero unless user write
    +
    50 C> additional code to enter local information into section 3
    +
    51 C> (7) Bufr message type
    +
    52 C> (8) Bufr message sub_type
    +
    53 C> (9) Master table version number
    +
    54 C> (10) Local table version number
    +
    55 C> (11) Year of century - representative of data
    +
    56 C> (12) Month - representative of data
    +
    57 C> (13) Day - representative of data
    +
    58 C> (14) Hour - representative of data
    +
    59 C> (15) Minute - representative of data
    +
    60 C> (16)-(20) Unused
    +
    61 C> @param[in] ISECT3 Values to be inserted into section 3, and to control
    +
    62 C> report reduction for oversized messages
    +
    63 C> - (1) Number of subsets
    +
    64 C> Defines the number of subsets being passed to the encoder routine for
    +
    65 C> inclusion into a bufr message. If the user has specified the use of the
    +
    66 C> subset/report reduction activation switch, then a part of those subsets may
    +
    67 C> be used for the current message and the remainder retained for a subsequent
    +
    68 C> message.
    +
    69 C> - (2) Observed flag
    +
    70 C> - 0 = observed data
    +
    71 C> - 1 = other data
    +
    72 C> - (3) Compressed flag
    +
    73 C> - 0 = noncompressed
    +
    74 C> - 1 = compressed
    +
    75 C> - (4) Subset/report reduction activation switch used to control the number
    +
    76 C> of reports entered into a bufr message when maximum message size is exceeded
    +
    77 C> - 0 = option not active
    +
    78 C> - 1 = option is active. unused subsets will be shifted to low order
    +
    79 C> positions of entry array.
    +
    80 C> - 2 = option is active. unused subsets will remain in entry positions.
    +
    81 C> @note If this flag is set to any other values, program will be terminated
    +
    82 C> with an error condition.
    +
    83 C> - (5) Number of reports to decrement by, if oversized message
    +
    84 C> (minimum value = one). If zero is entered, it will
    +
    85 C> be replaced by one.
    +
    86 C> - (6) Number of unused reports returned to user
    +
    87 C> - (7) Number of reports included in message
    +
    88 C> - (8) Number of table b entries available to decoder
    +
    89 C> - (9) Number of table d entries available to decoder
    +
    90 C> - (10) Text input flag
    +
    91 C> - 0 = ASCII input
    +
    92 C> - 1 = EBCIDIC input
    +
    93 C> @param[in] JIF JDESC input format flag
    +
    94 C> - 0 = F X Y
    +
    95 C> - 1 = Decimal format
    +
    96 C> @param[in] JDESC List of descriptors to go into section 3
    +
    97 C> Each descriptor = F * 16384 + X * 256 + Y
    +
    98 C> They may or may not be an exact match of the working descriptor list in kdesc.
    +
    99 C> This set of descriptors may contain sequence descriptors to provide additional
    +
    100 C> compression within the bufr message. There may be as few as one sequence
    +
    101 C> descriptor, or as many descriptors as there are in kdesc.
    +
    102 C> @param[in] NEWNR NR of descriptors in JDESC
    +
    103 C> @param[in] IDATA Integer array dimensioned by the number of descriptors to
    +
    104 C> be used
    +
    105 C> @param[in] RDATA Real array dimensioned by the number of descriptors to be
    +
    106 C> used
    +
    107 C> @param[in] ATEXT Array containing all text data associated with a specific
    +
    108 C> report. All data identified as text data must be in ASCII.
    +
    109 C> @param[in] KASSOC Integer array dimensioned by the number of descriptors
    +
    110 C> to be used, containing the associated field values for any entry in the
    +
    111 C> descriptor list.
    +
    112 C> @param[in] KIF KDESC input format flag
    +
    113 C> - 0 = F X Y
    +
    114 C> - 1 = DECIMAL FORMAT
    +
    115 C> @param[in] KDESC List of descriptors to go into section 3 fully expanded set of working
    +
    116 C> descriptors. there should be an element descriptor for every data entry, but
    +
    117 C> there should be no sequence descriptors.
    +
    118 C> @param[in] NRDESC NR of descriptors in kdesc
    +
    119 C> @param[in] ISEC2D Data or text to be entered into section 2
    +
    120 C> @param[in] ISEC2B Number of bytes of data in isec2d
    +
    121 C> @param[out] KDATA Source data array . a 2-dimension integer array where
    +
    122 C> kdata(subset,param) subset = subset number param = parameter number.
    +
    123 C> @param[out] KARY Working array for message under construction
    +
    124 C> - (1) unused
    +
    125 C> - (2) parameter pointer
    +
    126 C> - (3) message bit pointer
    +
    127 C> - (4) delayed replication flag
    +
    128 C> - 0 = no delayed replication
    +
    129 C> - 1 = contains delayed replication
    +
    130 C> - (5) bit pointer for start of section 4
    +
    131 C> - (6) unused
    +
    132 C> - (7) nr of bits for parameter/data packing
    +
    133 C> - (8) total bits for ascii data
    +
    134 C> - (9) scale change value
    +
    135 C> - (10) indicator (used in w3fi85)
    +
    136 C> - 1 = numeric data
    +
    137 C> - 2 = text data
    +
    138 C> - (11) pointer to current pos in kdesc
    +
    139 C> - (12) unused
    +
    140 C> - (13) unused
    +
    141 C> - (14) unused
    +
    142 C> - (15) data type
    +
    143 C> - (16) unused
    +
    144 C> - (17) unused
    +
    145 C> - (18) words added for text or associated fields
    +
    146 C> - (19) location for total byte count
    +
    147 C> - (20) size of section 0
    +
    148 C> - (21) size of section 1
    +
    149 C> - (22) size of section 2
    +
    150 C> - (23) size of section 3
    +
    151 C> - (24) size of section 4
    +
    152 C> - (25) size of section 5
    +
    153 C> - (26) nr bits added by table c operator
    +
    154 C> - (27) bit width of associated field
    +
    155 C> - (28) jdesc input form flag
    +
    156 C> - 0 = Descriptor in f x y form
    +
    157 C> - F in JDESC(1,I)
    +
    158 C> - X in JDESC(2,I)
    +
    159 C> - Y in JDESC(3,I)
    +
    160 C> - 1 = DEscriptor in decimal form in jdesc(1,i)
    +
    161 C> - (29) kdesc input form flag
    +
    162 C> - 0 = Descriptor in F X Y form
    +
    163 C> - F in KDESC(1,I)
    +
    164 C> - X in KDESC(2,I)
    +
    165 C> - Y in KDESC(3,I)
    +
    166 C> - 1 = Descriptor in decimal form in kdesc(1,i)
    +
    167 C> - (30) bufr message total byte count
    +
    168 C> @param[out] KBUFR Array to contain completed bufr message
    +
    169 C> @param[out] IERRTN Error return flag
    +
    170 C>
    +
    171 C> IERRTN:
    +
    172 C> - = 0 Normal return, bufr message resides in kbufr
    +
    173 C> - if isect3(4)= 0, all reports have been processed into a bufr message
    +
    174 C> - if isect3(4)= 1, a bufr message has been generated with all or part of
    +
    175 C> the data passed to this routine. isect3(6) contains the number of reports
    +
    176 C> that were not used but are being held for the next message.
    +
    177 C> - = 1 bufr message construction was halted because contents exceeded maximum size
    +
    178 C> (only when isect3(4) = 0)
    +
    179 C> - = 2 bufr message construction was halted because of encounter with a
    +
    180 C> descriptor not found in table b.
    +
    181 C> - = 3 routine was called with no subsets
    +
    182 C> - = 4 error occured while reading table b
    +
    183 C> - = 5 an attempt was made to expand jdesc into kdesc, but a descriptor indicating
    +
    184 C> delayed replication was encountered
    +
    185 C> - = 6 error occured while reading table d
    +
    186 C> - = 7 data value could not be contained in specified bit width
    +
    187 C> - = 8 delayed replication not permitted in compressed data format
    +
    188 C> - = 9 an operator descriptor 2 04 yyy opening an associated field (yyy not eq zero)
    +
    189 C> was not followed by the defining descriptor 0 31 021 (7957 decimal).
    +
    190 C> - = 10 delayed replication descriptor was not followed by descriptor for delayed
    +
    191 C> replication factor.
    +
    192 C> - 0 31 001
    +
    193 C> - 0 31 002
    +
    194 C> - 0 31 011
    +
    195 C> - 0 31 012
    +
    196 C> - = 11 encountered a reference value that forced a data element to become negative
    +
    197 C> - = 12 no matching table d entry for sequence descriptor.
    +
    198 C> - = 13 encountered a non-acceptable data entry flag. isect3(6) should be 0 or 1.
    +
    199 C> - = 14 converting descriptors fxy->decimal, number to convert = 0
    +
    200 C> - = 15 no descriptors specified for section 3
    +
    201 C> - = 16 incomplete table b, number of descriptors in table b does not match number of
    +
    202 C> descriptors needed to construct bufr message
    +
    203 C> - = 20 incorrect entry of replication or sequence descriptor in list of reference
    +
    204 C> value changes
    +
    205 C> - = 21 incorrect operator descriptor in list of reference value changes
    +
    206 C> - = 22 attempting to enter new reference value into table b, but descriptor
    +
    207 C> does not exist in current modified table b
    +
    208 C>
    +
    209 C> @author Bill Cavanaugh @date 1993-09-29
    +
    210  SUBROUTINE w3fi85(ISTEP,IUNITB,IUNITD,IBFSIZ,ISECT1,ISECT3,
    +
    211  * JIF,JDESC,NEWNR,IDATA,RDATA,ATEXT,KASSOC,
    +
    212  * KIF,KDESC,NRDESC,ISEC2D,ISEC2B,
    +
    213  * KDATA,KARY,KBUFR,IERRTN)
    +
    214 C
    +
    215  REAL RDATA(*)
    +
    216 C
    +
    217  INTEGER IDATA(*),LOWEST,MAXVAL,JSTART
    +
    218  INTEGER KARY(*),MISG,LL
    +
    219  INTEGER KDESC(3,*),KASSOC(*)
    +
    220  INTEGER IBITS(32)
    +
    221  INTEGER ZEROS(255)
    +
    222  INTEGER INDEXB(16383)
    +
    223  CHARACTER*9 CCITT
    +
    224  CHARACTER*4 AHOLD(2)
    +
    225  CHARACTER*1 ATEXT(*)
    +
    226  LOGICAL*1 TEXT
    +
    227  LOGICAL*1 MSGFLG,DUPFLG
    +
    228 C =====================================
    +
    229 C INFORMATION REQUIRED FOR CONSTRUCTION OF BUFR MESSAGE
    +
    230  INTEGER ISECT1(*)
    +
    231  INTEGER ISEC2B,ISEC2D(255)
    +
    232  INTEGER ISECT3(*)
    +
    233  INTEGER JDESC(3,*)
    +
    234  INTEGER NEWNR
    +
    235  INTEGER KDATA(500,*)
    +
    236  INTEGER KBUFR(*)
    +
    237 C =====================================
    +
    238 C TABLE B INFORMATION
    +
    239  INTEGER LDESC(800),KT(800)
    +
    240  INTEGER KSCALE(800)
    +
    241  INTEGER KRFVAL(800),KRFVSW(800),NEWRFV(800)
    +
    242  INTEGER KWIDTH(800)
    +
    243  CHARACTER*40 ANAME(800)
    +
    244  CHARACTER*25 AUNITS(800)
    +
    245 C =====================================
    +
    246 C TABLE D INFORMATION
    +
    247  INTEGER KSEQ(300),KNUM(300)
    +
    248  INTEGER KLIST(300,10)
    +
    249 C =====================================
    +
    250  SAVE
    +
    251 C
    +
    252  DATA ccitt /'CCITT IA5'/
    +
    253  DATA ibits / 1, 3, 7, 15,
    +
    254  * 31, 63, 127, 255,
    +
    255  * 511, 1023, 2047, 4095,
    +
    256  * 8191, 16383, 32767, 65535,
    +
    257  * z'0001FFFF',z'0003FFFF',z'0007FFFF',z'000FFFFF',
    +
    258  * z'001FFFFF',z'003FFFFF',z'007FFFFF',z'00FFFFFF',
    +
    259  * z'01FFFFFF',z'03FFFFFF',z'07FFFFFF',z'0FFFFFFF',
    +
    260  * z'1FFFFFFF',z'3FFFFFFF',z'7FFFFFFF',z'FFFFFFFF'/
    +
    261  DATA ll /0/
    +
    262  DATA misg /99999/
    +
    263  DATA zeros /255*0/
    +
    264 C =====================================
    +
    265 C THERE MUST BE DESCRIPTORS IN JDESC
    +
    266 C AND A COUNT IN NEWNR
    +
    267 C =====================================
    +
    268  IF (newnr.EQ.0) THEN
    +
    269  ierrtn = 15
    +
    270  RETURN
    +
    271  END IF
    +
    272 C =====================================
    +
    273 C IF INPUT FORM IS F X Y SEGMENTS THEN
    +
    274 C CONVERT INPUT FORM OF JDESC FROM FXY TO DECIMAL
    +
    275 C =====================================
    +
    276  IF (jif.EQ.0) THEN
    +
    277 C CONVERT TO DECIMAL
    +
    278  CALL fi8505(jif,jdesc,newnr,ierrtn)
    +
    279  IF (ierrtn.NE.0) THEN
    +
    280  RETURN
    +
    281  END IF
    +
    282  END IF
    +
    283 C =====================================
    +
    284 C IF PROCESSING DELAYED REPLICATION, MUST RELOAD
    +
    285 C KDESC FROM JDESC
    +
    286 C =====================================
    +
    287  IF (kary(4).NE.0) THEN
    +
    288  nrdesc = 0
    +
    289  END IF
    +
    290 C =====================================
    +
    291 C IF ONLY HAVE JDESC, NEWNR CREATE KDESC, NRDESC
    +
    292 C =====================================
    +
    293 C IF ONLY HAVE JDESC, NEWNR CREATE KDESC, NRDESC
    +
    294  IF (nrdesc.EQ.0) THEN
    +
    295  DO 50 i = 1, newnr
    +
    296  kdesc(1,i) = jdesc(1,i)
    +
    297  50 CONTINUE
    +
    298  nrdesc = newnr
    +
    299  kif = 1
    +
    300  ELSE IF (nrdesc.NE.0) THEN
    +
    301 C KDESC ALL READY EXISTS
    +
    302  IF (kif.EQ.0) THEN
    +
    303 C CONVERT INPUT FORM OF KDESC FROM FXY TO DECIMAL
    +
    304  CALL fi8505(kif,kdesc,nrdesc,ierrtn)
    +
    305  IF (ierrtn.NE.0) THEN
    +
    306  RETURN
    +
    307  END IF
    +
    308  END IF
    +
    309  END IF
    +
    310 C =====================================
    +
    311 C READ IN TABLE B SUBSET, IF NOT ALL READY IN PLACE
    +
    312 C =====================================
    +
    313  IF (isect3(8).EQ.0) THEN
    +
    314  CALL fi8512(iunitb,isect3,kdesc,nrdesc,kary,ierrtn,
    +
    315  * ldesc,aname,aunits,kscale,krfval,kwidth,krfvsw,
    +
    316  * iunitd,kseq,knum,klist,indexb)
    +
    317  IF (ierrtn.NE.0) GO TO 9000
    +
    318  END IF
    +
    319 C =====================================
    +
    320 C ROUTE TO SELECTED PROCESSING
    +
    321 C =====================================
    +
    322  ksub = isect3(1)
    +
    323  IF (istep.EQ.1) THEN
    +
    324 C PROCESSING INTEGER DATA INPUT
    +
    325  CALL fi8508(istep,iunitb,idata,kdesc,nrdesc,atext,ksub,kary,
    +
    326  * kdata,ldesc,aname,aunits,kscale,krfval,krfvsw,isect3,
    +
    327  * kwidth,kassoc,iunitd,kseq,knum,klist,ierrtn,indexb)
    +
    328  RETURN
    +
    329  ELSE IF (istep.EQ.2) THEN
    +
    330 C PROCESSING REAL DATA INPUT
    +
    331  CALL fi8509(istep,iunitb,rdata,kdesc,nrdesc,atext,ksub,kary,
    +
    332  * kdata,ldesc,aname,aunits,kscale,krfval,krfvsw,isect3,
    +
    333  * kwidth,kassoc,iunitd,kseq,knum,klist,ierrtn,indexb)
    +
    334  RETURN
    +
    335  ELSE IF (istep.NE.3) THEN
    +
    336  ierrtn = 20
    +
    337  RETURN
    +
    338  END IF
    +
    339 C =====================================
    +
    340 C IF INDICATING ZERO SUBSETS, HAVE AN ERROR CONDITION
    +
    341 C =====================================
    +
    342  IF (isect3(1).LE.0) THEN
    +
    343  ierrtn = 3
    +
    344  RETURN
    +
    345  END IF
    +
    346 C =====================================
    +
    347 C SET FOR BUFR MESSAGE
    +
    348 C =====================================
    +
    349 C
    +
    350 C CLEAR OUTPUT AREA
    +
    351 C BYTES IN EACH FULL WORD
    +
    352  kword = 4
    +
    353 C
    +
    354 C GET NUMBER OF SUBSETS
    +
    355 C
    +
    356  mxrpts = isect3(1)
    +
    357  isect3(7) = isect3(1)
    +
    358  isect3(6) = isect3(1)
    +
    359 C
    +
    360 C RE-START POINT FOR PACKING FEWER SUBSETS ?
    +
    361 C
    +
    362  5 CONTINUE
    +
    363 C
    +
    364  kary(18) = 0
    +
    365  kary(26) = 0
    +
    366 C =====================================
    +
    367 C ENTER 'BUFR' - SECTION 0
    +
    368 C CONSTRUCT UNDER RULES OF EDITION 2
    +
    369 C =====================================
    +
    370  kary(3) = 0
    +
    371  nbufr = 1112884818
    +
    372  CALL sbyte (kbufr,nbufr,kary(3),32)
    +
    373  kary(3) = kary(3) + 32
    +
    374 C SAVE POINTER FOR TOTAL BYTE COUNT
    +
    375 C IN MESSAGE
    +
    376  kary(19) = kary(3)
    +
    377  kary(3) = kary(3) + 24
    +
    378 C SET EDITION NR IN PLACE
    +
    379  CALL sbyte (kbufr,2,kary(3),8)
    +
    380  kary(3) = kary(3) + 8
    +
    381  kary(20) = 8
    +
    382 C PRINT *,'SECTION 0'
    +
    383 C =====================================
    +
    384 C COMPLETE ENTRIES FOR - SECTION 1
    +
    385 C =====================================
    +
    386 C ----- 1,3 SECTION COUNT
    +
    387  kary(21) = 18
    +
    388  CALL sbyte (kbufr,kary(21),kary(3),24)
    +
    389  kary(3) = kary(3) + 24
    +
    390 C ----- 4 RESERVED
    +
    391  CALL sbyte (kbufr,0,kary(3),8)
    +
    392  kary(3) = kary(3) + 8
    +
    393 C ----- 5 ORIGINATING SUB-CENTER
    +
    394  CALL sbyte (kbufr,isect1(3),kary(3),8)
    +
    395  kary(3) = kary(3) + 8
    +
    396 C ----- 6 ORIGINATING CENTER
    +
    397  CALL sbyte (kbufr,isect1(4),kary(3),8)
    +
    398  kary(3) = kary(3) + 8
    +
    399 C ----- 7 UPDATE SEQUENCE NUMBER
    +
    400  CALL sbyte (kbufr,isect1(5),kary(3),8)
    +
    401  kary(3) = kary(3) + 8
    +
    402 C ----- 8
    +
    403 C INDICATE NO SECTION 2
    +
    404  CALL sbyte (kbufr,isect1(6),kary(3),1)
    +
    405  kary(3) = kary(3) + 1
    +
    406  CALL sbyte (kbufr,0,kary(3),7)
    +
    407  kary(3) = kary(3) + 7
    +
    408 C ----- 9 BUFR MESSAGE TYPE
    +
    409  CALL sbyte (kbufr,isect1(7),kary(3),8)
    +
    410  kary(3) = kary(3) + 8
    +
    411 C ----- 10 BUFR MESSAGE SUB-TYPE
    +
    412  CALL sbyte (kbufr,isect1(8),kary(3),8)
    +
    413  kary(3) = kary(3) + 8
    +
    414 C ----- 11 VERSION OF MASTER TABLE
    +
    415  CALL sbyte (kbufr,isect1(9),kary(3),8)
    +
    416  kary(3) = kary(3) + 8
    +
    417 C ----- 12 VERSION OF LOCAL TABLE
    +
    418  CALL sbyte (kbufr,isect1(10),kary(3),8)
    +
    419  kary(3) = kary(3) + 8
    +
    420 C ----- 13 YEAR
    +
    421  CALL sbyte (kbufr,isect1(11),kary(3),8)
    +
    422  kary(3) = kary(3) + 8
    +
    423 C ----- 14 MONTH
    +
    424  CALL sbyte (kbufr,isect1(12),kary(3),8)
    +
    425  kary(3) = kary(3) + 8
    +
    426 C ---- 15 DAY
    +
    427  CALL sbyte (kbufr,isect1(13),kary(3),8)
    +
    428  kary(3) = kary(3) + 8
    +
    429 C ----- 16 HOUR
    +
    430  CALL sbyte (kbufr,isect1(14),kary(3),8)
    +
    431  kary(3) = kary(3) + 8
    +
    432 C ----- 17 MINUTE
    +
    433  CALL sbyte (kbufr,isect1(15),kary(3),8)
    +
    434  kary(3) = kary(3) + 8
    +
    435 C ----- 18 FILL
    +
    436  CALL sbyte (kbufr,0,kary(3),8)
    +
    437  kary(3) = kary(3) + 8
    +
    438 C PRINT *,'SECTION 1'
    +
    439 C =====================================
    +
    440 C SKIP - SECTION 2
    +
    441 C =====================================
    +
    442  IF (isect1(6).NE.0) THEN
    +
    443 C BUILD SECTION COUNT
    +
    444  kary(22) = 4 + isec2b
    +
    445  IF (mod(kary(22),2).NE.0) kary(22) = kary(22) + 1
    +
    446 C INSERT SECTION COUNT
    +
    447  CALL sbyte (kbufr,kary(22),kary(3),24)
    +
    448  kary(3) = kary(3) + 24
    +
    449 C INSERT RESERVED POSITION
    +
    450  CALL sbyte (kbufr,0,kary(3),8)
    +
    451  kary(3) = kary(3) + 8
    +
    452 C INSERT SECTION 2 DATA
    +
    453  CALL sbytes(kbufr,isec2d,kary(3),8,0,isec2b)
    +
    454  kary(3) = kary(3) + (isec2b * 8)
    +
    455  IF (mod(isec2b,2).NE.0) THEN
    +
    456  CALL sbyte (kbufr,0,kary(3),8)
    +
    457  kary(3) = kary(3) + 8
    +
    458  END IF
    +
    459  ELSE
    +
    460  kary(22) = 0
    +
    461  END IF
    +
    462 C =====================================
    +
    463 C MAKE PREPARATIONS FOR SECTION 3 DESCRIPTORS
    +
    464 C =====================================
    +
    465  kary(23) = 7 + newnr*2 + 1
    +
    466 C SECTION 3 SIZE
    +
    467  CALL sbyte (kbufr,kary(23),kary(3),24)
    +
    468  kary(3) = kary(3) + 24
    +
    469 C RESERVED BYTE
    +
    470  CALL sbyte (kbufr,0,kary(3),8)
    +
    471  kary(3) = kary(3) + 8
    +
    472 C NUMBER OF SUBSETS
    +
    473  CALL sbyte (kbufr,isect3(1),kary(3),16)
    +
    474  kary(3) = kary(3) + 16
    +
    475 C SET OBSERVED DATA SWITCH
    +
    476  CALL sbyte (kbufr,isect3(2),kary(3),1)
    +
    477  kary(3) = kary(3) + 1
    +
    478 C SET COMPRESSED DATA SWITCH
    +
    479  CALL sbyte (kbufr,isect3(3),kary(3),1)
    +
    480  kary(3) = kary(3) + 1
    +
    481  CALL sbyte (kbufr,0,kary(3),6)
    +
    482  kary(3) = kary(3) + 6
    +
    483 C =====================================
    +
    484 C DESCRIPTORS - SECTION 3
    +
    485 C =====================================
    +
    486  DO 37 kh = 1, newnr
    +
    487 C PRINT *,'INSERTING',JDESC(1,KH),' INTO SECTION 3'
    +
    488  CALL sbyte (kbufr,jdesc(1,kh),kary(3),16)
    +
    489  kary(3) = kary(3) + 16
    +
    490  37 CONTINUE
    +
    491 C FILL TO TWO BYTE BOUNDARY
    +
    492  CALL sbyte (kbufr,0,kary(3),8)
    +
    493  kary(3) = kary(3) + 8
    +
    494 C PRINT *,'SECTION 3'
    +
    495 C =====================================
    +
    496 C INITIALIZE FOR - SECTION 4
    +
    497 C =====================================
    +
    498 C SAVE POINTER TO COUNT POSITION
    +
    499 C PRINT *,'START OF SECTION 4',KARY(3)
    +
    500  kary(5) = kary(3)
    +
    501  kary(3) = kary(3) + 24
    +
    502  CALL sbyte (kbufr,0,kary(3),8)
    +
    503  kary(3) = kary(3) + 8
    +
    504 C SKIP TO FIRST DATA POSITION
    +
    505 C =====================================
    +
    506 C BIT PATTERNS - SECTION 4
    +
    507 C =====================================
    +
    508  kend4 = ibfsiz * 8 - 32
    +
    509 C PACK ALL DATA INTO BUFR MESSAGE
    +
    510 C
    +
    511  IF (isect3(3).EQ.0) THEN
    +
    512 C **********************************************
    +
    513 C * *
    +
    514 C * PROCESS AS NON-COMPRESSED MESSAGE *
    +
    515 C * *
    +
    516 C **********************************************
    +
    517  CALL fi8506(istep,isect3,kary,jdesc,newnr,kdesc,nrdesc,
    +
    518  * ldesc,aname,aunits,kscale,krfval,kwidth,krfvsw,newrfv,
    +
    519  * kseq,knum,klist,ibfsiz,
    +
    520  * kdata,kbufr,ierrtn,indexb)
    +
    521  IF (ierrtn.NE.0) THEN
    +
    522  IF (ierrtn.EQ.1) GO TO 5500
    +
    523  RETURN
    +
    524  END IF
    +
    525  ELSE
    +
    526 C **********************************************
    +
    527 C * *
    +
    528 C * PROCESS AS COMPRESSED MESSAGE *
    +
    529 C * *
    +
    530 C **********************************************
    +
    531  kary(18) = 0
    +
    532 C MUST LOOK AT EVERY DESCRIPTOR IN KDESC
    +
    533  kary(11) = 1
    +
    534  3000 CONTINUE
    +
    535  IF (kary(11).GT.nrdesc) THEN
    +
    536  GO TO 5200
    +
    537  ELSE
    +
    538 C DO 5000 JK = 1, NRDESC
    +
    539 C RE-ENTRY POINT FOR INSERTION OF
    +
    540 C REPLICATION OR SEQUENCES
    +
    541  4000 CONTINUE
    +
    542 C ISOLATE TABLE
    +
    543  kfunc = kdesc(1,kary(11)) / 16384
    +
    544 C ISOLATE CLASS
    +
    545  kclass = mod(kdesc(1,kary(11)),16384) / 256
    +
    546  kseg = mod(kdesc(1,kary(11)),256)
    +
    547  kary(2) = kary(11) + kary(18)
    +
    548  IF (kfunc.EQ.1) THEN
    +
    549 C DELAYED REPLICATION NOT ALLOWED
    +
    550 C IN COMPRESSED MESSAGE
    +
    551  IF (kseg.EQ.0) THEN
    +
    552  ierrtn = 8
    +
    553  RETURN
    +
    554  END IF
    +
    555 C REPLICATION DESCRIPTOR
    +
    556  CALL fi8501(kary,istep,kclass,kseg,idata,rdata,
    +
    557  * kdata,ll,kdesc,nrdesc,ierrtn)
    +
    558 C GO TO 4000
    +
    559  ELSE IF (kfunc.EQ.2) THEN
    +
    560  CALL fi8502(*4000,kbufr,kclass,kseg,
    +
    561  * kdesc,nrdesc,i,istep,
    +
    562  * kary,kdata,isect3,krfvsw,newrfv,ldesc,ierrtn,indexb)
    +
    563  IF (ierrtn.NE.0) THEN
    +
    564  RETURN
    +
    565  END IF
    +
    566  GO TO 5000
    +
    567  ELSE IF (kfunc.EQ.3) THEN
    +
    568  CALL fi8503(kary(11),kdesc,nrdesc,
    +
    569  * isect3,iunitd,kseq,knum,klist,ierrtn)
    +
    570  IF (ierrtn.NE.0) THEN
    +
    571  RETURN
    +
    572  END IF
    +
    573  GO TO 4000
    +
    574  END IF
    +
    575 C FALL THRU WITH ELEMENT DESCRIPTOR
    +
    576 C POINT TO CORRECT TABLE B ENTRY
    +
    577  l = indexb(kdesc(1,kary(11)))
    +
    578  IF (l.LT.0) THEN
    +
    579  ierrtn = 2
    +
    580 C PRINT *,'W3FI85 - IERRTN = 2'
    +
    581  RETURN
    +
    582  END IF
    +
    583 C
    +
    584  IF (aunits(l)(1:9).EQ.ccitt) THEN
    +
    585  text = .true.
    +
    586  ELSE
    +
    587  text = .false.
    +
    588  END IF
    +
    589  kary(7) = kwidth(l)
    +
    590 C
    +
    591  IF (text) THEN
    +
    592 C PROCESS TEXT DATA
    +
    593  kbz = kary(3) + (isect3(1) + 1) * kary(7) + 6
    +
    594  IF (kbz.GT.kend4) THEN
    +
    595  GO TO 5500
    +
    596  END IF
    +
    597 C NBINC IS NUMBER OF CHARS
    +
    598  nbinc = kary(7) / 8
    +
    599 C LOWEST = 0
    +
    600  CALL sbytes(kbufr,zeros,kary(3),8,0,nbinc)
    +
    601  kary(3) = kary(3) + kary(7)
    +
    602  CALL sbyte (kbufr,nbinc,kary(3),6)
    +
    603  kary(3) = kary(3) + 6
    +
    604 C HOW MANY FULL WORDS
    +
    605  nkpass = kary(7) / 32
    +
    606 C HOW MANY BYTES IN PARTIAL WORD
    +
    607  krem = mod(kary(7),32)
    +
    608 C KSKIP = KARY(7) - 32
    +
    609  DO 4080 nss = 1, isect3(1)
    +
    610 C POINT TO TEXT FOR THIS SUBSET
    +
    611  kary(2) = kary(11) + kary(18)
    +
    612  IF (nkpass.GE.1) THEN
    +
    613 C PROCESS TEXT IN A SUBSET
    +
    614  DO 4070 npp = 1, nkpass
    +
    615 C PROCESS FULL WORDS
    +
    616  IF (isect3(10).EQ.1) THEN
    +
    617  CALL w3ai38 (kdata(nss,kary(2)),4)
    +
    618  END IF
    +
    619  CALL sbyte (kbufr,kdata(nss,kary(2)),
    +
    620  * kary(3),32)
    +
    621  kary(3) = kary(3) + 32
    +
    622 C POINT TO NEXT DATA WORD FOR MORE TEXT
    +
    623  kary(2) = kary(2) + 1
    +
    624  4070 CONTINUE
    +
    625  END IF
    +
    626 C PROCESS PARTIALS - LESS THAN 4 BYTES
    +
    627  IF (krem.GT.0) THEN
    +
    628  IF (isect3(10).EQ.1) THEN
    +
    629  CALL w3ai38 (kdata(nss,kary(2)),4)
    +
    630  END IF
    +
    631  CALL sbyte (kbufr,kdata(nss,kary(2)),
    +
    632  * kary(3),krem)
    +
    633  kary(3) = kary(3) + krem
    +
    634  END IF
    +
    635  4080 CONTINUE
    +
    636 C ADJUST EXTRA WORD COUNT
    +
    637  IF (krem.GT.0) THEN
    +
    638  kary(18) = kary(18) + nkpass
    +
    639  ELSE
    +
    640  kary(18) = kary(18) + nkpass - 1
    +
    641  END IF
    +
    642 C -------------------------------------------------------------
    +
    643  GO TO 5000
    +
    644  ELSE
    +
    645  kary(2) = kary(11) + kary(18)
    +
    646  kary(7) = kwidth(l) + kary(26)
    +
    647 C
    +
    648 C NON TEXT/NUMERIC DATA
    +
    649 C
    +
    650 C PROCESS ASSOCIATED FIELD DATA
    +
    651  IF (kary(27).GT.0.AND.kdesc(1,kary(11)).NE.7957) THEN
    +
    652  dupflg = .true.
    +
    653  DO 4130 j = 2, isect3(1)
    +
    654  IF (kdata(j,kary(2)).NE.kdata(1,kary(2)))THEN
    +
    655  dupflg = .false.
    +
    656  GO TO 4131
    +
    657  END IF
    +
    658  4130 CONTINUE
    +
    659  4131 CONTINUE
    +
    660  IF (dupflg) THEN
    +
    661 C ALL VALUES ARE EQUAL
    +
    662  kbz = kary(3) + kary(7) + 6
    +
    663  IF (kbz.GT.kend4) THEN
    +
    664  GO TO 5500
    +
    665  END IF
    +
    666  nbinc = 0
    +
    667 C ENTER COMMON VALUE
    +
    668  IF (kdata(1,kary(2)).EQ.misg) THEN
    +
    669  CALL sbyte(kbufr,ibits(kary(7)),
    +
    670  * kary(3),kary(27))
    +
    671  ELSE
    +
    672  CALL sbyte(kbufr,kdata(1,kary(2)),
    +
    673  * kary(3),kary(27))
    +
    674  END IF
    +
    675  kary(3) = kary(3) + kary(27)
    +
    676 C ENTER NBINC
    +
    677  CALL sbyte (kbufr,nbinc,kary(3),6)
    +
    678  kary(3) = kary(3) + 6
    +
    679  ELSE
    +
    680 C MIX OF MISSING AND VALUES
    +
    681 C GET LARGEST DIFFERENCE VALUE
    +
    682  msgflg = .false.
    +
    683  DO 4132 j = 1, isect3(7)
    +
    684  IF (kdata(j,kary(2)).EQ.misg) THEN
    +
    685  msgflg = .true.
    +
    686  GO TO 4133
    +
    687  END IF
    +
    688  4132 CONTINUE
    +
    689  4133 CONTINUE
    +
    690  DO 4134 j = 1, isect3(7)
    +
    691  IF (kdata(j,kary(2)).LT.ibits(kary(27))
    +
    692  * .AND.kdata(j,kary(2)).GE.0.AND.
    +
    693  * kdata(j,kary(2)).NE.misg) THEN
    +
    694  lowest = kdata(j,kary(2))
    +
    695  maxval = kdata(j,kary(2))
    +
    696  jstart = j + 1
    +
    697  GO TO 4135
    +
    698  END IF
    +
    699  4134 CONTINUE
    +
    700  4135 CONTINUE
    +
    701  DO 4136 j = jstart, isect3(7)
    +
    702  IF (kdata(j,kary(2)).NE.misg) THEN
    +
    703  IF (kdata(j,kary(2)).LT.lowest) THEN
    +
    704  lowest = kdata(j,kary(2))
    +
    705  ELSE IF(kdata(j,kary(2)).GT.maxval)THEN
    +
    706  maxval = kdata(j,kary(2))
    +
    707  END IF
    +
    708  END IF
    +
    709  4136 CONTINUE
    +
    710  mxdiff = maxval - lowest
    +
    711 C FIND NBINC
    +
    712  mxbits = kary(27)
    +
    713  DO 4142 lj = 1, mxbits
    +
    714  nbinc = lj
    +
    715  IF (mxdiff.LT.ibits(lj)) THEN
    +
    716  GO TO 4143
    +
    717  END IF
    +
    718  4142 CONTINUE
    +
    719  4143 CONTINUE
    +
    720  kbz = kary(3) + mxbits + 6 + isect3(1) * nbinc
    +
    721  IF (kbz.GT.kend4) THEN
    +
    722  GO TO 5500
    +
    723  END IF
    +
    724  IF (nbinc.GT.mxbits) THEN
    +
    725  ierrtn = 3
    +
    726  RETURN
    +
    727  END IF
    +
    728 C ENTER LOWEST
    +
    729  CALL sbyte(kbufr,lowest,kary(3),mxbits)
    +
    730  kary(3) = kary(3) + mxbits
    +
    731  CALL sbyte(kbufr,nbinc,kary(3),6)
    +
    732  kary(3) = kary(3) + 6
    +
    733 C GET DIFFERENCE VALUES
    +
    734  IF (msgflg) THEN
    +
    735  DO 4144 m = 1, isect3(1)
    +
    736  IF (kdata(m,kary(2)).EQ.misg) THEN
    +
    737  kt(m) = ibits(nbinc)
    +
    738  ELSE
    +
    739  kt(m) = kdata(m,kary(2)) - lowest
    +
    740  END IF
    +
    741  4144 CONTINUE
    +
    742  ELSE
    +
    743  DO 4146 m = 1, isect3(1)
    +
    744  kt(m) = kdata(m,kary(2)) - lowest
    +
    745  4146 CONTINUE
    +
    746  END IF
    +
    747 C ENTER DATA VALUES
    +
    748  CALL sbytes(kbufr,kt,kary(3),nbinc,
    +
    749  * 0,isect3(1))
    +
    750  kary(3) = kary(3) + isect3(1) * nbinc
    +
    751  END IF
    +
    752  kary(18) = kary(18) + 1
    +
    753  END IF
    +
    754 C ---------------------------------------------------
    +
    755 C STANDARD DATA
    +
    756 C ---------------------------------------------------
    +
    757  kary(2) = kary(11) + kary(18)
    +
    758  mxbits = kary(7) + kary(26)
    +
    759  dupflg = .true.
    +
    760  DO 4030 j = 2, isect3(7)
    +
    761  IF (kdata(j,kary(2)).NE.kdata(1,kary(2))) THEN
    +
    762  dupflg = .false.
    +
    763  GO TO 4031
    +
    764  END IF
    +
    765  4030 CONTINUE
    +
    766  4031 CONTINUE
    +
    767  IF (dupflg) THEN
    +
    768 C ALL VALUES ARE EQUAL
    +
    769  kbz = kary(3) + kary(7) + 6
    +
    770  IF (kbz.GT.kend4) THEN
    +
    771  GO TO 5500
    +
    772  END IF
    +
    773  nbinc = 0
    +
    774 C ENTER COMMON VALUE
    +
    775  IF (kdata(1,kary(2)).EQ.misg) THEN
    +
    776  CALL sbyte(kbufr,ibits(mxbits),
    +
    777  * kary(3),mxbits)
    +
    778  ELSE
    +
    779  CALL sbyte(kbufr,kdata(1,kary(2)),
    +
    780  * kary(3),mxbits)
    +
    781  END IF
    +
    782  kary(3) = kary(3) + kary(7)
    +
    783 C ENTER NBINC
    +
    784  CALL sbyte (kbufr,nbinc,kary(3),6)
    +
    785  kary(3) = kary(3) + 6
    +
    786  ELSE
    +
    787 C MIX OF MISSING AND VALUES
    +
    788 C GET LARGEST DIFFERENCE VALUE
    +
    789  msgflg = .false.
    +
    790  DO 4032 j = 1, isect3(7)
    +
    791  IF (kdata(j,kary(2)).EQ.misg) THEN
    +
    792  msgflg = .true.
    +
    793  GO TO 4033
    +
    794  END IF
    +
    795  4032 CONTINUE
    +
    796  4033 CONTINUE
    +
    797  DO 4034 j = 1, isect3(7)
    +
    798  IF (kdata(j,kary(2)).NE.misg) THEN
    +
    799  lowest = kdata(j,kary(2))
    +
    800  maxval = kdata(j,kary(2))
    +
    801 C PRINT *,' '
    +
    802 C PRINT *,'START VALUES',LOWEST,MAXVAL,
    +
    803 C * 'J=',J,' KARY(2)=',KARY(2)
    +
    804  GO TO 4035
    +
    805  END IF
    +
    806  4034 CONTINUE
    +
    807  4035 CONTINUE
    +
    808  DO 4036 j = 1, isect3(1)
    +
    809  IF (kdata(j,kary(2)).NE.misg) THEN
    +
    810  IF (kdata(j,kary(2)).LT.lowest) THEN
    +
    811  lowest = kdata(j,kary(2))
    +
    812 C PRINT *,'NEW LOWEST=',LOWEST,J
    +
    813  ELSE IF (kdata(j,kary(2)).GT.maxval) THEN
    +
    814  maxval = kdata(j,kary(2))
    +
    815 C PRINT *,'NEW MAXVAL=',MAXVAL,J
    +
    816  END IF
    +
    817  END IF
    +
    818  4036 CONTINUE
    +
    819  mxdiff = maxval - lowest
    +
    820 C FIND NBINC
    +
    821  DO 4042 lj = 1, mxbits
    +
    822  nbinc = lj
    +
    823  IF (mxdiff.LT.ibits(lj)) GO TO 4043
    +
    824  IF (nbinc.EQ.mxbits) GO TO 4043
    +
    825  4042 CONTINUE
    +
    826  4043 CONTINUE
    +
    827  kbz = kary(3) + mxbits + 38 + isect3(1) * nbinc
    +
    828  IF (kbz.GT.kend4) THEN
    +
    829  GO TO 5500
    +
    830  END IF
    +
    831 C PRINT 4444,KARY(11),KDESC(1,KARY(11)),LOWEST,
    +
    832 C * MAXVAL,MXDIFF,KARY(7),NBINC,ISECT3(1),ISECT3(7)
    +
    833 C4444 FORMAT(9(1X,I8))
    +
    834 C ENTER LOWEST
    +
    835 C ADJUST WITH REFERENCE VALUE
    +
    836  IF (krfvsw(l).EQ.0) THEN
    +
    837  jrv = krfval(l)
    +
    838  ELSE
    +
    839  jrv = newrfv(l)
    +
    840  END IF
    +
    841  lval = lowest - jrv
    +
    842  CALL sbyte(kbufr,lval,kary(3),mxbits)
    +
    843  kary(3) = kary(3) + mxbits
    +
    844  IF (nbinc.GT.mxbits) THEN
    +
    845  ierrtn = 3
    +
    846  RETURN
    +
    847  END IF
    +
    848  CALL sbyte(kbufr,nbinc,kary(3),6)
    +
    849  kary(3) = kary(3) + 6
    +
    850 C GET DIFFERENCE VALUES
    +
    851  IF (msgflg) THEN
    +
    852  DO 4044 m = 1, isect3(1)
    +
    853  IF (kdata(m,kary(2)).EQ.misg) THEN
    +
    854  kt(m) = ibits(nbinc)
    +
    855  ELSE
    +
    856  kt(m) = kdata(m,kary(2)) - lowest
    +
    857  END IF
    +
    858  4044 CONTINUE
    +
    859  ELSE
    +
    860  DO 4046 m = 1, isect3(1)
    +
    861  kt(m) = kdata(m,kary(2)) - lowest
    +
    862  4046 CONTINUE
    +
    863  END IF
    +
    864 C ENTER DATA VALUES
    +
    865  CALL sbytes(kbufr,kt,kary(3),nbinc,
    +
    866  * 0,isect3(1))
    +
    867  kary(3) = kary(3) + isect3(1) * nbinc
    +
    868  END IF
    +
    869  GO TO 5000
    +
    870  END IF
    +
    871 C -------------------------------------------------------------
    +
    872  5000 CONTINUE
    +
    873  kary(11) = kary(11) + 1
    +
    874  GO TO 3000
    +
    875  ENDIF
    +
    876  5200 CONTINUE
    +
    877  END IF
    +
    878  isect3(6) = 0
    +
    879  GO TO 6000
    +
    880  5500 CONTINUE
    +
    881 C THE SEGMENT OF CODE BETWEEN STATEMENTS
    +
    882 C 5500-6000 ARE ACTIVATED IF AND WHEN THE
    +
    883 C MAXIMUM MESSAGE SIZE HAS BEEN EXCEEDED
    +
    884 C
    +
    885 C ARE WE REDUCING IF OVERSIZED ???
    +
    886  IF (isect3(4).NE.0) THEN
    +
    887 C INCREMENT REDUCTION COUNT
    +
    888  isect3(6) = isect3(6) + isect3(5)
    +
    889 C REDUCE NUMBER TO INCLUDE
    +
    890  isect3(7) = isect3(1) - isect3(5)
    +
    891  isect3(1) = isect3(7)
    +
    892  print *,'REDUCED BY ',isect3(5),' ON THIS PASS'
    +
    893  GO TO 5
    +
    894  ELSE
    +
    895  ierrtn = 1
    +
    896  RETURN
    +
    897  END IF
    +
    898  6000 CONTINUE
    +
    899 C ---------------------------------------------------------------
    +
    900 C FILL IN SECTION 4 OCTET COUNT
    +
    901  nbufr = mod((kary(3) - kary(5)),16)
    +
    902 C MAY BE NECESSARY TO ADJUST COUNT
    +
    903  IF (nbufr.NE.0) THEN
    +
    904  kary(3) = kary(3) + 16 - nbufr
    +
    905  END IF
    +
    906  kary(24) = (kary(3) - kary(5)) / 8
    +
    907  CALL sbyte (kbufr,kary(24),kary(5),24)
    +
    908 C PRINT *,'SECTION 4'
    +
    909 C =====================================
    +
    910 C ENDING KEY '7777' - SECTION 5
    +
    911 C =====================================
    +
    912  kary(25) = 4
    +
    913  nbufr = 926365495
    +
    914  CALL sbyte (kbufr,nbufr,kary(3),32)
    +
    915  kary(3) = kary(3) + 32
    +
    916 C CONSTRUCT TOTAL BYTE COUNT FOR SECTION 0
    +
    917  itotal = kary(3) / 8
    +
    918  CALL sbyte (kbufr,itotal,32,24)
    +
    919  kary(30) = itotal
    +
    920 C WRITE (6,8601) ITOTAL
    +
    921  8601 FORMAT (1x,22hthis message CONTAINS ,i10,6h bytes)
    +
    922 C =======================================
    +
    923 C KBUFR CONTAINS A COMPLETED MESSAGE
    +
    924  IF (isect3(4).NE.0.AND.isect3(5).NE.0) THEN
    +
    925 C ADJUST KDATA ARRAY
    +
    926  nr = mxrpts - isect3(1)
    +
    927  isect3(7) = isect3(7) + 1
    +
    928  DO 7500 i = 1, nr
    +
    929  DO 7000 j = 1, nrdesc
    +
    930  kdata(i,j) = kdata(isect3(7),j)
    +
    931  7000 CONTINUE
    +
    932  isect3(7) = isect3(7) + 1
    +
    933  7500 CONTINUE
    +
    934  kary(14) = nr
    +
    935  ELSE
    +
    936  isect3(7) = isect3(1)
    +
    937  END IF
    +
    938 C =======================================
    +
    939  ierrtn = 0
    +
    940  9000 CONTINUE
    +
    941  RETURN
    +
    942  END
    +
    943 C> @brief Perform replication of descriptors
    +
    944 C> @author Bill Cavanaugh @date 1993-12-03
    +
    945 
    +
    946 C> Have encountered a replication descriptor. It may include
    +
    947 C> delayed replication or not. That decision should have been
    +
    948 C> made prior to calling this routine.
    +
    949 C>
    +
    950 C> Program history log:
    +
    951 C> - Bill Cavanaugh 1993-12-03
    +
    952 C> - J. Hoppa 1994-03-25 Added line to initialize nxtptr to correct
    +
    953 C> an error in the standard replication.
    +
    954 C> - J. Hoppa 1994-03-28 Corrected an error in the standard replication
    +
    955 C> that was adding extra zeros to the bufr message after the replicated data.
    +
    956 C> - J. Hoppa 1994-03-31 Added the subset number to the parameter list.
    +
    957 C> corrected the equation for the number of replications with delayed replication.
    +
    958 C> (istart and k don't exist)
    +
    959 C> - J. Hoppa 1994-04-19 Switched the variables next and nxtprt
    +
    960 C> - J. Hoppa 1994-04-20 Added the kdata parameter counter to the parameter
    +
    961 C> list. In the assignment of nreps when have delayed replication, changed index
    +
    962 C> in kdata from n to k.
    +
    963 C> - J. Hoppa 1994-04-29 Removed n and k from the input list changed n to
    +
    964 C> kary(11) and k to kary(2)
    +
    965 C>
    +
    966 C> @param[in] ISTEP
    +
    967 C> @param[in] KCLASS
    +
    968 C> @param[in] KSEG
    +
    969 C> @param[in] IDATA
    +
    970 C> @param[in] RDATA
    +
    971 C> @param[in] KDATA
    +
    972 C> @param[in] NSUB Current subset
    +
    973 C> @param[inout] KDESC (modified [out]) List of descriptors
    +
    974 C> @param[inout] NRDESC Number of (new [out]) descriptors in kdesc
    +
    975 C> @param[out] IERRTN Error return value
    +
    976 C> @param KARY
    +
    977 C>
    +
    978 C> @author Bill Cavanaugh @date 1993-12-03
    +
    979  SUBROUTINE fi8501(KARY,ISTEP,KCLASS,KSEG,IDATA,RDATA,
    +
    980  * KDATA,NSUB,KDESC,NRDESC,IERRTN)
    +
    981 
    +
    982 C
    +
    983  REAL RDATA(*)
    +
    984 C
    +
    985  INTEGER IDATA(*),NREPS,KARY(*)
    +
    986  INTEGER KCLASS,KSEG
    +
    987  INTEGER KDESC(3,*),NRDESC,KDATA(500,*)
    +
    988  INTEGER IERRTN
    +
    989  INTEGER ITAIL(1600)
    +
    990  INTEGER IHOLD(1600),ISTEP
    +
    991 C
    +
    992  SAVE
    +
    993 C
    +
    994 C TEST KFUNC FOR DESCRIPTOR TYPE
    +
    995 C DO REPLICATION
    +
    996 C ****************************************************************
    +
    997  ierrtn = 0
    +
    998 C REPLICATION DESCRIPTOR
    +
    999 C STANDARD REPLICATION WILL SIMPLY
    +
    1000 C BE PROCESSED FROM ITS DESCRIPTOR
    +
    1001 C PARTS
    +
    1002 C
    +
    1003 C DELAYED REPLICATION DESCRIPTOR
    +
    1004 C MUST BE FOLLOWED BY ONE OF THE
    +
    1005 C DESCRIPTORS FOR A DELAYED
    +
    1006 C REPLICATION FACTOR
    +
    1007 C 0 31 001 (7937 DECIMAL)
    +
    1008 C 0 31 002 (7938 DECIMAL)
    +
    1009 C 0 31 011 (7947 DECIMAL)
    +
    1010 C 0 31 012 (7948 DECIMAL)
    +
    1011  IF (kseg.NE.0) THEN
    +
    1012 C HAVE NUMBER OF REPLICATIONS AS KSEG
    +
    1013  nreps = kseg
    +
    1014  iput = kary(11)
    +
    1015  next = iput + 1
    +
    1016  nxtptr = iput + 1 + kclass
    +
    1017  ELSE IF (kseg.EQ.0) THEN
    +
    1018  IF (kdesc(1,kary(11)+1).EQ.7937.OR.
    +
    1019  * kdesc(1,kary(11)+1).EQ.7938.OR.
    +
    1020  * kdesc(1,kary(11)+1).EQ.7947.OR.
    +
    1021  * kdesc(1,kary(11)+1).EQ.7948) THEN
    +
    1022 C PRINT *,'HAVE DELAYED REPLICATION'
    +
    1023  kary(4) = 1
    +
    1024 C MOVE REPLICATION DEFINITION
    +
    1025  kdesc(1,kary(11)) = kdesc(1,kary(11)+1)
    +
    1026 C MUST DETERMINE HOW MANY REPLICATIONS
    +
    1027  IF (istep.EQ.1) THEN
    +
    1028  nreps = idata(kary(11))
    +
    1029  ELSE IF (istep.EQ.2) THEN
    +
    1030  nreps = rdata(kary(11))
    +
    1031  ELSE
    +
    1032  nreps = kdata(nsub,kary(2))
    +
    1033  END IF
    +
    1034  iput = kary(11) + 1
    +
    1035  nxtptr = iput + kclass + 1
    +
    1036  next = iput + 1
    +
    1037 C POINT TO REPLICATION DESCRIPTOR
    +
    1038  END IF
    +
    1039  ELSE
    +
    1040  ierrtn = 10
    +
    1041  RETURN
    +
    1042  END IF
    +
    1043 C EXTRACT DESCRIPTORS TO BE REPLICATED
    +
    1044 C IF NREPS = 0, THIS LIST OF DESCRIPTORS IS NOT TO
    +
    1045 C BE USED IN DEFINING THE DATA,
    +
    1046 C OTHERWISE
    +
    1047 C IT WILL BE USED TO DEFINE THE DATA
    +
    1048  IF (nreps.NE.0) THEN
    +
    1049  DO 1000 ij = 1, kclass
    +
    1050  ihold(ij) = kdesc(1,next)
    +
    1051  next = next + 1
    +
    1052  1000 CONTINUE
    +
    1053 C SKIP THE NUMBER OF DESCRIPTORS DEFINED BY KCLASS
    +
    1054  END IF
    +
    1055 C SAVE OFF TAIL OF DESC STREAM
    +
    1056 C START AT FIRST POSITION OF TAIL
    +
    1057  igot = 0
    +
    1058  DO 1100 ij = nxtptr, nrdesc
    +
    1059  igot = igot + 1
    +
    1060  itail(igot) = kdesc(1,ij)
    +
    1061  1100 CONTINUE
    +
    1062 C INSERT ALL REPLICATED DESC'S
    +
    1063  IF (nreps.NE.0) THEN
    +
    1064  DO 1300 kr = 1, nreps
    +
    1065  DO 1200 kd = 1, kclass
    +
    1066  kdesc(1,iput) = ihold(kd)
    +
    1067  iput = iput + 1
    +
    1068  1200 CONTINUE
    +
    1069  1300 CONTINUE
    +
    1070  END IF
    +
    1071 C RESTORE TAIL
    +
    1072  DO 1400 itl = 1, igot
    +
    1073  kdesc(1,iput) = itail(itl)
    +
    1074  iput = iput + 1
    +
    1075  1400 CONTINUE
    +
    1076 C
    +
    1077 C RESET NUMBER OF DESCRIPTORS IN KDESC
    +
    1078  nrdesc = iput - 1
    +
    1079 C ****************************************************************
    +
    1080  RETURN
    +
    1081  END
    +
    1082 C> @brief Process an operator descriptor.
    +
    1083 C> @author Bill Cavanaugh @date 193-12-03
    +
    1084 
    +
    1085 C> Have encountered an operator descriptor.
    +
    1086 C>
    +
    1087 C> Program history log:
    +
    1088 C> - Bill Cavanaugh 1993-12-03
    +
    1089 C> - J. Hoppa 1994-04-15 Added kbufr to input parameter list.
    +
    1090 C> added block of data to correctly use sbyte when writing a 205yyy descriptor to the
    +
    1091 C> bufr message. The previous way didn't work because kdata was getting incremeted
    +
    1092 C> by the ksub value, not the param value.
    +
    1093 C> - J. Hoppa 1994-04-29 Changed k to kary(2) removed a line that became obsolete with
    +
    1094 C> above change
    +
    1095 C> - J. Hoppa 1994-05-18 Added a kary(2) increment
    +
    1096 C>
    +
    1097 C> @param[in] KCLASS
    +
    1098 C> @param[in] KSEG
    +
    1099 C> @param[inout] KDESC
    +
    1100 C> @param[inout] NRDESC
    +
    1101 C> @param[in] I
    +
    1102 C> @param[in] ISTEP
    +
    1103 C> @param[inout] KARY
    +
    1104 C> @param[out] IERRTN Error return value
    +
    1105 C> @param KBUFR
    +
    1106 C> @param KDATA
    +
    1107 C> @param ISECT3
    +
    1108 C> @param KRFVSW
    +
    1109 C> @param NEWRFV
    +
    1110 C> @param LDESC
    +
    1111 C> @param INDEXB
    +
    1112 C>
    +
    1113 C> @author Bill Cavanaugh @date 193-12-03
    +
    1114  SUBROUTINE fi8502(*,KBUFR,KCLASS,KSEG,KDESC,NRDESC,I,ISTEP,
    +
    1115  * KARY,KDATA,ISECT3,KRFVSW,NEWRFV,LDESC,IERRTN,INDEXB)
    +
    1116 
    +
    1117 C
    +
    1118  INTEGER KCLASS,KSEG,ZEROES(255)
    +
    1119  INTEGER KRFVSW(*),NEWRFV(*),LDESC(*)
    +
    1120  INTEGER I,KDESC(3,*),KDATA(500,*),ISECT3(*)
    +
    1121  INTEGER NRDESC
    +
    1122  INTEGER KARY(*)
    +
    1123  INTEGER IERRTN
    +
    1124  INTEGER NLEFT
    +
    1125 C
    +
    1126  SAVE
    +
    1127 C
    +
    1128  DATA zeroes/255*0/
    +
    1129 C
    +
    1130 C ****************************************************************
    +
    1131  ierrtn = 0
    +
    1132 C OPERATOR DESCRIPTOR
    +
    1133  IF (kclass.EQ.1) THEN
    +
    1134 C BITS ADDED TO DESCRIPTOR WIDTH
    +
    1135  IF (istep.EQ.3) THEN
    +
    1136  IF (kseg.NE.0) THEN
    +
    1137  kary(26) = kseg - 128
    +
    1138  ELSE
    +
    1139  kary(26) = 0
    +
    1140  END IF
    +
    1141  END IF
    +
    1142  ELSE IF (kclass.EQ.2) THEN
    +
    1143 C NEW SCALE VALUE
    +
    1144  IF (istep.EQ.3) THEN
    +
    1145  IF (kseg.EQ.0) THEN
    +
    1146  kary(9) = 0
    +
    1147  ELSE
    +
    1148  kary(9) = kseg - 128
    +
    1149  END IF
    +
    1150  END IF
    +
    1151  ELSE IF (kclass.EQ.3) THEN
    +
    1152 C CHANGE REFERENCE VALUE
    +
    1153 C MUST ACCEPT INTO OUTPUT THE
    +
    1154 C REFERENCE VALUE CHANGE AND ACTIVATE
    +
    1155 C THE CHANGE WHILE PROCESSING
    +
    1156  IF (istep.EQ.3) THEN
    +
    1157 C HAVE OPERATOR DESCRIPTOR FOR REFERENCE VALUES
    +
    1158  IF (kseg.EQ.0) THEN
    +
    1159  DO 100 iq = 1, isect3(8)
    +
    1160 C RESET ALL NEW REFERENCE VALUES
    +
    1161  krfvsw(iq) = 0
    +
    1162  100 CONTINUE
    +
    1163  END IF
    +
    1164  200 CONTINUE
    +
    1165 C GET NEXT DESCRIPTOR
    +
    1166  kary(11) = kary(11) + 1
    +
    1167  IF (kdesc(1,kary(11)).GT.16383) THEN
    +
    1168 C NOT AN ELEMENT DESCRIPTOR
    +
    1169  nfunc = kdesc(1,kary(11)) / 16384
    +
    1170  IF (nfunc.EQ.1.OR.nfunc.EQ.3) THEN
    +
    1171  ierrtn = 20
    +
    1172  print *,'INCORRECT ENTRY OF REPLICATION OR ',
    +
    1173  * 'SEQUENCE DESCRIPTOR IN LIST OF ',
    +
    1174  * 'REFERENCE VALUE CHANGES'
    +
    1175  RETURN
    +
    1176  END IF
    +
    1177  nclass = (kdesc(1,kary(11)) - nfunc*16384) / 256
    +
    1178  IF (nclass.EQ.3) THEN
    +
    1179  nseg = mod(kdesc(1,kary(11)),256)
    +
    1180  IF (nseg.EQ.255) THEN
    +
    1181  RETURN
    +
    1182  END IF
    +
    1183  END IF
    +
    1184  ierrtn = 21
    +
    1185  print *,'INCORRECT OPERATOR DESCRIPTOR ENTRY ',
    +
    1186  * 'IN LIST OF REFERENCE VALUE CHANGES'
    +
    1187  RETURN
    +
    1188  END IF
    +
    1189 C ELEMENT DESCRIPTOR W/NEW REFERENCE VALUE
    +
    1190 C FIND MATCH FOR CURRENT DESCRIPTOR
    +
    1191  iq = indexb(kdesc(1,kary(11)))
    +
    1192  IF (iq.LT.1) THEN
    +
    1193  ierrtn = 22
    +
    1194  print *,'ATTEMPTING TO ENTER NEW REFERENCE VALUE ',
    +
    1195  * 'INTO TABLE B, BUT DESCRIPTOR DOES NOT EXIST IN ',
    +
    1196  * 'CURRENT MODIFIED TABLE B'
    +
    1197  RETURN
    +
    1198  END IF
    +
    1199  END IF
    +
    1200  ELSE IF (kclass.EQ.4) THEN
    +
    1201 C SET/RESET ASSOCIATED FIELD WIDTH
    +
    1202  IF (istep.EQ.3) THEN
    +
    1203  kary(27) = kseg
    +
    1204  END IF
    +
    1205  ELSE IF (kclass.EQ.5) THEN
    +
    1206 C SET TO PROCESS TEXT/ASCII DATA
    +
    1207 C SET TO TEXT
    +
    1208 C PROCESS TEXT
    +
    1209 
    +
    1210  kary(2) = kary(11) + kary(18)
    +
    1211  IF (istep.EQ.3) THEN
    +
    1212 C KSEG TELLS HOW MANY BYTES EACH ITERATION
    +
    1213  IF (mod(kseg,4).NE.0) THEN
    +
    1214  iter = kseg / 4 + 1
    +
    1215  ELSE
    +
    1216  iter = kseg / 4
    +
    1217  END IF
    +
    1218 C POINT AT CORRECT KDATA WORD
    +
    1219  IF (isect3(3).NE.0) THEN
    +
    1220 C COMPRESSED
    +
    1221 C ---------------------------------------------------
    +
    1222  CALL sbytes(kbufr,zeroes,kary(3),32,0,iter)
    +
    1223  kary(3) = kary(3) + kseg * 8
    +
    1224 C
    +
    1225  CALL sbyte (kbufr,kseg*8,kary(3),6)
    +
    1226  kary(3) = kary(3) + 6
    +
    1227 C TEXT ENTRY BY SUBSET
    +
    1228  DO 2000 m = 1, isect3(1)
    +
    1229  jay = kary(3)
    +
    1230 C NUMBER OF SUBSETS
    +
    1231  DO 1950 kl = 1, iter
    +
    1232 C NUMBER OF WORDS
    +
    1233  kk = kary(2) + kl - 1
    +
    1234  IF (isect3(10).EQ.1) THEN
    +
    1235  CALL w3ai38(kdata(m,kk),4)
    +
    1236  END IF
    +
    1237  CALL sbyte (kbufr,kdata(m,kk),jay,32)
    +
    1238  jay = jay + 32
    +
    1239  1950 CONTINUE
    +
    1240  kary(3) = kary(3) + kseg * 8
    +
    1241  2000 CONTINUE
    +
    1242 C ---------------------------------------------------
    +
    1243  ELSE
    +
    1244 C NOT COMPRESSED
    +
    1245 
    +
    1246 C CALL SBYTE FOR EACH KDATA VALUE (4 CHARACTERS PER VALUE).
    +
    1247 C AN ADDITIONAL CALL IS DONE IF HAVE A VALUE WITH LESS THAN
    +
    1248 C 4 CHARACTERS.
    +
    1249  nbit = 32
    +
    1250  nleft = mod(kseg,4)
    +
    1251  DO 3000 j=kary(2),iter+kary(2)-1
    +
    1252  IF((j.EQ.(iter+kary(2)-1)).AND.(nleft.NE.0))THEN
    +
    1253  nbit = 8 * nleft
    +
    1254  ENDIF
    +
    1255  IF (isect3(10).NE.0) THEN
    +
    1256  CALL w3ai38 (kdata(i,j),4)
    +
    1257  END IF
    +
    1258  CALL sbyte(kbufr,kdata(i,j),kary(3),nbit)
    +
    1259  kary(3) = kary(3) + nbit
    +
    1260  3000 CONTINUE
    +
    1261 
    +
    1262 C ADJUST FOR EXTRA WORDS
    +
    1263  kary(18) = kary(18) + iter - 1
    +
    1264  END IF
    +
    1265  kary(2) = kary(2) + iter
    +
    1266  END IF
    +
    1267  ELSE IF (kclass.EQ.6) THEN
    +
    1268 C SET TO SKIP PROCESSING OF NEXT DESCRIPTOR
    +
    1269 C IF IT IS NOT IN BUFR TABLE B
    +
    1270 C DURING THE ENCODING PROCESS, THIS HAS NO MEANING
    +
    1271 C ELIMINATE IN PROCESSING
    +
    1272 C MOVE DESCRIPTOR LIST UP ONE POSITION AND RESTART
    +
    1273 C PROCESSING AT SAME LOCATION.
    +
    1274  km = i - 1
    +
    1275  DO 9000 kl = i+1, nrdesc
    +
    1276  km = km + 1
    +
    1277  kdesc(1,km) = kdesc(1,kl)
    +
    1278  9000 CONTINUE
    +
    1279  nrdesc = km
    +
    1280  RETURN 1
    +
    1281  END IF
    +
    1282 C ****************************************************************
    +
    1283  RETURN
    +
    1284  END
    +
    1285 C> @brief Expand sequence descriptor.
    +
    1286 C> @author Bill Cavanaugh @date 1993-12-03
    +
    1287 
    +
    1288 C> Have encountered a sequence descriptor. must perform proper replacment of
    +
    1289 C> descriptors in line.
    +
    1290 C>
    +
    1291 C> Program history log:
    +
    1292 C> - Bill Cavanaugh 1993-12-03
    +
    1293 C>
    +
    1294 C> @param[inout] I Current position in descriptor list
    +
    1295 C> @param[inout] KDESC List (modified [out]) of descriptors
    +
    1296 C> @param[inout] NRDESC Number (new [out]) of descriptors in kdesc
    +
    1297 C> @param[in] IUNITD
    +
    1298 C> @param[in] KSEQ
    +
    1299 C> @param[in] KNUM
    +
    1300 C> @param[in] KLIST
    +
    1301 C> @param[out] IERRTN Error return value
    +
    1302 C> @param ISECT3
    +
    1303 C>
    +
    1304 C> @author Bill Cavanaugh @date 1993-12-03
    +
    1305  SUBROUTINE fi8503(I,KDESC,NRDESC,
    +
    1306  * ISECT3,IUNITD,KSEQ,KNUM,KLIST,IERRTN)
    +
    1307 
    +
    1308 C
    +
    1309  INTEGER I
    +
    1310  INTEGER KDESC(3,*)
    +
    1311  INTEGER NRDESC
    +
    1312  INTEGER ISECT3(*)
    +
    1313  INTEGER IUNITD
    +
    1314  INTEGER KSEQ(*)
    +
    1315  INTEGER KNUM(*)
    +
    1316  INTEGER KLIST(300,*)
    +
    1317  INTEGER IERRTN
    +
    1318  INTEGER ITAIL(1600)
    +
    1319 C INTEGER IHOLD(200)
    +
    1320 C
    +
    1321  SAVE
    +
    1322 C
    +
    1323 C ****************************************************************
    +
    1324  ierrtn = 0
    +
    1325 C READ IN TABLE D IF NEEDED
    +
    1326  IF (isect3(9).EQ.0) THEN
    +
    1327  CALL fi8513 (iunitd,isect3,kseq,
    +
    1328  * knum,klist,ierrtn)
    +
    1329  IF (ierrtn.NE.0) THEN
    +
    1330 C PRINT *,'EXIT FI8503A'
    +
    1331  RETURN
    +
    1332  END IF
    +
    1333  END IF
    +
    1334 C HAVE TABLE D
    +
    1335 C
    +
    1336 C FIND MATCHING SEQUENCE DESCRIPTOR
    +
    1337  DO 100 l = 1, isect3(9)
    +
    1338  IF (kdesc(1,i).EQ.kseq(l)) THEN
    +
    1339 C JEN - DELETE NEXT PRINT LINE
    +
    1340 C PRINT *,'FOUND ',KDESC(1,I)
    +
    1341 C HAVE A MATCH
    +
    1342  GO TO 200
    +
    1343  END IF
    +
    1344  100 CONTINUE
    +
    1345  ierrtn = 12
    +
    1346  RETURN
    +
    1347  200 CONTINUE
    +
    1348 C REPLACE SEQUENCE DESCRIPTOR WITH IN LINE SEQUENCE
    +
    1349  iput = i
    +
    1350 C SAVE TAIL
    +
    1351  istart = i + 1
    +
    1352  kk = 0
    +
    1353  DO 400 ij = istart, nrdesc
    +
    1354  kk = kk + 1
    +
    1355  itail(kk) = kdesc(1,ij)
    +
    1356  400 CONTINUE
    +
    1357 C INSERT SEQUENCE OF DESCRIPTORS AT
    +
    1358 C CURRENT LOCATION
    +
    1359  kl = 0
    +
    1360  DO 600 kq = 1, knum(l)
    +
    1361  kdesc(1,iput) = klist(l,kq)
    +
    1362  iput = iput + 1
    +
    1363  600 CONTINUE
    +
    1364 
    +
    1365 C RESTORE TAIL
    +
    1366  DO 800 kl = 1, kk
    +
    1367  kdesc(1,iput) = itail(kl)
    +
    1368  iput = iput + 1
    +
    1369  800 CONTINUE
    +
    1370 C RESET NUMBER OF DESCRIPTORS IN KDESC
    +
    1371  nrdesc = iput - 1
    +
    1372 C JEN - DELETE NEXT PRINT LINE
    +
    1373 C PRINT *,' NRDESC IS ',NRDESC
    +
    1374 
    +
    1375 C RESET CURRENT POSITION & RETURN
    +
    1376  RETURN
    +
    1377  END
    +
    1378 C> @brief Convert descriptors fxy to decimal
    +
    1379 C> @author Bill Cavanaugh @date 1993-12-03
    +
    1380 
    +
    1381 C> Construct decimal descriptor values from f x and y segments
    +
    1382 C>
    +
    1383 C> Program history log:
    +
    1384 C> - Bill Cavanaugh 1993-12-03
    +
    1385 C>
    +
    1386 C> @param[in] MIF input flag
    +
    1387 C> @param[inout] MDESC list of descriptors in f x y (decimal [out]) form
    +
    1388 C> @param[in] NR number of descriptors in mdesc
    +
    1389 C> @param[out] IERRTN error return value
    +
    1390 C>
    +
    1391 C> @author Bill Cavanaugh @date 1993-12-03
    +
    1392  SUBROUTINE fi8505(MIF,MDESC,NR,IERRTN)
    +
    1393 
    +
    1394 C
    +
    1395  INTEGER MDESC(3,*), NR
    +
    1396 C
    +
    1397  SAVE
    +
    1398 C
    +
    1399  IF (nr.EQ.0) THEN
    +
    1400  ierrtn = 14
    +
    1401  RETURN
    +
    1402  END IF
    +
    1403 C
    +
    1404  DO 100 i = 1, nr
    +
    1405  mdesc(1,i) = mdesc(1,i) * 16384 + mdesc(2,i) * 256
    +
    1406  * + mdesc(3,i)
    +
    1407 C JEN - DELETE NEXT PRINT LINE
    +
    1408 C PRINT *,MDESC(2,I),MDESC(3,I),' BECOMES ',MDESC(1,I)
    +
    1409  100 CONTINUE
    +
    1410  mif = 1
    +
    1411  RETURN
    +
    1412  END
    +
    1413 C> @brief Process data in non-compressed format
    +
    1414 C> @author Bill Cavanaugh @date 1993-12-03
    +
    1415 
    +
    1416 C> Process data into non-compressed format for inclusion into
    +
    1417 C> section 4 of the bufr message
    +
    1418 C>
    +
    1419 C> Program history log:
    +
    1420 C> - Bill Cavanaugh 1993-12-03
    +
    1421 C> - J. Hoppa 1994-03-24 Changed the inner loop from a do loop to a
    +
    1422 C> goto loop so nrdesc isn't a set value.
    +
    1423 C> corrected a value in the call to fi8503().
    +
    1424 C> - J. Hoppa 1994-03-31 Corrected an error in sending the subset
    +
    1425 C> number rather than the descriptor number
    +
    1426 C> to subroutine fi8501(). Added the subset number to the fi8501() parameter list.
    +
    1427 C> - J. Hoppa 1994-04015 Added line to keep the parameter pointer
    +
    1428 C> kary(2) up to date. this variable is used
    +
    1429 C> in subroutine fi8502().
    +
    1430 C> added kbufr to the parameter list in the call
    +
    1431 C> to subroutine fi8502().
    +
    1432 C> corrected an infinite loop when have an
    +
    1433 C> operator descriptor that was caused by
    +
    1434 C> a correction made 94-03-24
    +
    1435 C> - J. Hoppa 1994-04-20 Added k to call to subroutine w3fi01
    +
    1436 C> - J. Hoppa 1994-04-29 Changed n to kary(11) and k to kary(2)
    +
    1437 C> removed k and n from the call to fi8501()
    +
    1438 C> - J. Hoppa 1994-05-03 Added an increment to kary(11) to prevent
    +
    1439 C> and infinite loop when have a missing value
    +
    1440 C> - J. Hoppa 1994-05-18 Changed so increments kary(2) after each
    +
    1441 C> call to sbyte and deleted
    +
    1442 C> kary(2) = kary(11) + kary(18)
    +
    1443 C>
    +
    1444 C> @param[in] ISTEP
    +
    1445 C> @param[in] ISECT3
    +
    1446 C> @param[in] KARY
    +
    1447 C> @param[in] JDESC
    +
    1448 C> @param[in] NEWNR
    +
    1449 C> @param[in] KDESC
    +
    1450 C> @param[in] NRDESC
    +
    1451 C> @param[in] LDESC
    +
    1452 C> @param[in] ANAME
    +
    1453 C> @param[in] AUNITS
    +
    1454 C> @param[in] KSCALE
    +
    1455 C> @param[in] KRFVAL
    +
    1456 C> @param[in] KWIDTH
    +
    1457 C> @param[in] KRFVSW
    +
    1458 C> @param[in] NEWRFV
    +
    1459 C> @param[in] KSEQ
    +
    1460 C> @param[in] KNUM
    +
    1461 C> @param[in] KLIST
    +
    1462 C> @param[out] KDATA
    +
    1463 C> @param[out] KBUFR
    +
    1464 C> @param[out] IERRTN
    +
    1465 C> @param IBFSIZ
    +
    1466 C> @param INDEXB
    +
    1467 C>
    +
    1468 C> @author Bill Cavanaugh @date 1993-12-03
    +
    1469  SUBROUTINE fi8506(ISTEP,ISECT3,KARY,JDESC,NEWNR,KDESC,NRDESC,
    +
    1470  * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,NEWRFV,
    +
    1471  * KSEQ,KNUM,KLIST,IBFSIZ,
    +
    1472  * KDATA,KBUFR,IERRTN,INDEXB)
    +
    1473 
    +
    1474 C
    +
    1475 C -------------------------------------------------------------
    +
    1476  INTEGER ISTEP,INDEXB(*)
    +
    1477  INTEGER KBUFR(*)
    +
    1478  INTEGER ISECT3(*)
    +
    1479  INTEGER KARY(*)
    +
    1480  INTEGER NRDESC,NEWNR,KDESC(3,*),JDESC(3,*)
    +
    1481  INTEGER KDATA(500,*)
    +
    1482  INTEGER KRFVSW(*),KSCALE(*),KRFVAL(*),KWIDTH(*),NEWRFV(*)
    +
    1483  INTEGER IERRTN
    +
    1484  INTEGER LDESC(*)
    +
    1485  INTEGER IBITS(32)
    +
    1486  INTEGER MISG
    +
    1487  INTEGER KSEQ(*),KNUM(*),KLIST(300,*)
    +
    1488  CHARACTER*40 ANAME(*)
    +
    1489  CHARACTER*25 AUNITS(*)
    +
    1490  CHARACTER*9 CCITT
    +
    1491  LOGICAL TEXT
    +
    1492 C
    +
    1493  SAVE
    +
    1494 C -------------------------------------------------------------
    +
    1495  DATA ibits / 1, 3, 7, 15,
    +
    1496  * 31, 63, 127, 255,
    +
    1497  * 511, 1023, 2047, 4095,
    +
    1498  * 8191, 16383, 32767, 65535,
    +
    1499  * z'0001FFFF',z'0003FFFF',z'0007FFFF',z'000FFFFF',
    +
    1500  * z'001FFFFF',z'003FFFFF',z'007FFFFF',z'00FFFFFF',
    +
    1501  * z'01FFFFFF',z'03FFFFFF',z'07FFFFFF',z'0FFFFFFF',
    +
    1502  * z'1FFFFFFF',z'3FFFFFFF',z'7FFFFFFF',z'FFFFFFFF'/
    +
    1503  DATA ccitt /'CCITT IA5'/
    +
    1504  DATA misg /99999/
    +
    1505 C -------------------------------------------------------------
    +
    1506  kend = ibfsiz * 8 - 32
    +
    1507 C **********************************************
    +
    1508 C * *
    +
    1509 C * PROCESS AS NON-COMPRESSED MESSAGE *
    +
    1510 C * *
    +
    1511 C * I POINTS TO SUBSET *
    +
    1512 C * N POINTS TO DESCRIPTOR *
    +
    1513 C * K ADJUSTS N TO CORRECT DATA ENTRY *
    +
    1514 C * *
    +
    1515 C **********************************************
    +
    1516  DO 4500 i = 1, isect3(1)
    +
    1517 C OUTER LOOP FOR EACH SUBSET
    +
    1518 C DO UNTIL ALL DESCRIPTORS HAVE
    +
    1519 C BEEN PROCESSED
    +
    1520 C SET ADDED BIT FOR WIDTH TO 0
    +
    1521  kary(26) = 0
    +
    1522 C SET ASSOCIATED FIELD WIDTH TO 0
    +
    1523  kary(27) = 0
    +
    1524  kary(18) = 0
    +
    1525 C IF MESSAGE CONTAINS DELAYED REPLICATION
    +
    1526 C WE NEED TO EXPAND THE ORIGINAL DESCRIPTOR LIST
    +
    1527 C TO MATCH THE INPUT DATA.
    +
    1528 C START WITH JDESC
    +
    1529  IF (kary(4).NE.0) THEN
    +
    1530  DO 100 m = 1, newnr
    +
    1531  kdesc(1,m) = jdesc(1,m)
    +
    1532  100 CONTINUE
    +
    1533  nrdesc = newnr
    +
    1534  END IF
    +
    1535  kary(11) = 1
    +
    1536  kary(2) = 1
    +
    1537  4300 CONTINUE
    +
    1538  IF(kary(11).GT.nrdesc) GOTO 4305
    +
    1539 C INNER LOOP FOR PARAMETER
    +
    1540  4200 CONTINUE
    +
    1541 C KARY(2) = KARY(11) + KARY(18)
    +
    1542 C PRINT *,'LOOKING AT DESCRIPTOR',KARY(11),
    +
    1543 C * KDESC(1,KARY(11)),
    +
    1544 C * KARY(2),KDATA(I,KARY(2))
    +
    1545 C
    +
    1546 C PROCESS ONE DESCRIPTOR AT A TIME
    +
    1547 C
    +
    1548 C ISOLATE TABLE
    +
    1549 C
    +
    1550  kfunc = kdesc(1,kary(11)) / 16384
    +
    1551 C ISOLATE CLASS
    +
    1552  kclass = mod(kdesc(1,kary(11)),16384) / 256
    +
    1553  kseg = mod(kdesc(1,kary(11)),256)
    +
    1554  IF (kfunc.EQ.1) THEN
    +
    1555 C REPLICATION DESCRIPTOR
    +
    1556  CALL fi8501(kary,istep,kclass,kseg,idata,rdata,
    +
    1557  * kdata,i,kdesc,nrdesc,ierrtn)
    +
    1558  IF (ierrtn.NE.0) THEN
    +
    1559  RETURN
    +
    1560  END IF
    +
    1561  GO TO 4200
    +
    1562  ELSE IF (kfunc.EQ.2) THEN
    +
    1563 C OPERATOR DESCRIPTOR
    +
    1564  CALL fi8502(*4200,kbufr,kclass,kseg,
    +
    1565  * kdesc,nrdesc,i,istep,
    +
    1566  * kary,kdata,isect3,krfvsw,newrfv,ldesc,ierrtn,indexb)
    +
    1567  IF (ierrtn.NE.0) THEN
    +
    1568  RETURN
    +
    1569  END IF
    +
    1570  kary(11) = kary(11) + 1
    +
    1571  GO TO 4300
    +
    1572  ELSE IF (kfunc.EQ.3) THEN
    +
    1573 C SEQUENCE DESCRIPTOR
    +
    1574  CALL fi8503(kary(11),kdesc,nrdesc,
    +
    1575  * isect3,iunitd,kseq,knum,klist,ierrtn)
    +
    1576  IF (ierrtn.NE.0) THEN
    +
    1577  RETURN
    +
    1578  END IF
    +
    1579  GO TO 4200
    +
    1580  END IF
    +
    1581 C FALL THRU WITH ELEMENT DESCRIPTOR
    +
    1582 C FIND MATCHING TABLE B ENTRY
    +
    1583  lk = indexb(kdesc(1,kary(11)))
    +
    1584  IF (lk.LT.1) THEN
    +
    1585 C FALL THRU WITH NO MATCHING B ENTRY
    +
    1586  print *,'FI8506 3800',kary(11),kdesc(1,kary(11)),
    +
    1587  * nrdesc,lk,ldesc(lk)
    +
    1588  ierrtn = 2
    +
    1589  RETURN
    +
    1590  END IF
    +
    1591 C
    +
    1592  IF (aunits(lk).EQ.ccitt) THEN
    +
    1593  text = .true.
    +
    1594  ELSE
    +
    1595  text = .false.
    +
    1596  END IF
    +
    1597 C
    +
    1598  IF (text) THEN
    +
    1599  jwide = kwidth(lk)
    +
    1600  3775 CONTINUE
    +
    1601  IF (jwide.GT.32) THEN
    +
    1602  IF(isect3(10).NE.0) THEN
    +
    1603  CALL w3ai38 (kdata(i,kary(2)),4)
    +
    1604  END IF
    +
    1605  IF ((kary(3)+32).GT.kend) THEN
    +
    1606  ierrtn = 1
    +
    1607  RETURN
    +
    1608  END IF
    +
    1609  CALL sbyte (kbufr,kdata(i,kary(2)),kary(3),32)
    +
    1610  kary(3) = kary(3) + 32
    +
    1611 C ADD A WORD HERE ONLY
    +
    1612  kary(18) = kary(18) + 1
    +
    1613 C KARY(2) = KARY(11) + KARY(18)
    +
    1614  kary(2) = kary(2) + 1
    +
    1615  jwide = jwide - 32
    +
    1616  GO TO 3775
    +
    1617  ELSE IF (jwide.EQ.32) THEN
    +
    1618  IF(isect3(10).NE.0) THEN
    +
    1619  CALL w3ai38 (kdata(i,kary(2)),4)
    +
    1620  END IF
    +
    1621  IF ((kary(3)+32).GT.kend) THEN
    +
    1622  ierrtn = 1
    +
    1623  RETURN
    +
    1624  END IF
    +
    1625  CALL sbyte (kbufr,kdata(i,kary(2)),kary(3),32)
    +
    1626  kary(3) = kary(3) + 32
    +
    1627  kary(2) = kary(2) + 1
    +
    1628  jwide = jwide - 32
    +
    1629  ELSE IF (jwide.GT.0) THEN
    +
    1630  IF(isect3(10).NE.0) THEN
    +
    1631  CALL w3ai38 (kdata(i,kary(2)),4)
    +
    1632  END IF
    +
    1633  IF ((kary(3)+jwide).GT.kend) THEN
    +
    1634  ierrtn = 1
    +
    1635  RETURN
    +
    1636  END IF
    +
    1637  CALL sbyte (kbufr,kdata(i,kary(2)),kary(3),jwide)
    +
    1638  kary(3) = kary(3) + jwide
    +
    1639  kary(2) = kary(2) + 1
    +
    1640  END IF
    +
    1641  ELSE
    +
    1642 C NOT TEXT
    +
    1643  IF (kary(27).NE.0.AND.kdesc(1,kary(11)).NE.7957) THEN
    +
    1644 C ENTER ASSOCIATED FIELD
    +
    1645  IF ((kary(3)+kary(27)).GT.kend) THEN
    +
    1646  ierrtn = 1
    +
    1647  RETURN
    +
    1648  END IF
    +
    1649  CALL sbyte (kbufr,kdata(i,kary(2)),kary(3),
    +
    1650  * kary(27))
    +
    1651  kary(3) = kary(3) + kary(27)
    +
    1652  kary(18) = kary(18) + 1
    +
    1653 C KARY(2) = KARY(11) + KARY(18)
    +
    1654  kary(2) = kary(2) + 1
    +
    1655  END IF
    +
    1656 C
    +
    1657  jwide = kwidth(lk) + kary(26)
    +
    1658  IF (kdata(i,kary(2)).EQ.misg) THEN
    +
    1659 C MISSING DATA, SET ALL BITS ON
    +
    1660  IF ((kary(3)+jwide).GT.kend) THEN
    +
    1661  ierrtn = 1
    +
    1662  RETURN
    +
    1663  END IF
    +
    1664  CALL sbyte (kbufr,ibits(jwide),kary(3),jwide)
    +
    1665  kary(3) = kary(3) + jwide
    +
    1666  kary(2) = kary(2) + 1
    +
    1667  kary(11) = kary(11) + 1
    +
    1668  GO TO 4300
    +
    1669  END IF
    +
    1670 C CAN DATA BE CONTAINED IN SPECIFIED
    +
    1671 C BIT WIDTH, IF NOT - ERROR
    +
    1672  IF (kdata(i,kary(2)).GT.ibits(jwide)) THEN
    +
    1673  ierrtn = 1
    +
    1674  RETURN
    +
    1675  END IF
    +
    1676 C ADJUST WITH REFERENCE VALUE
    +
    1677  IF (krfvsw(lk).EQ.0) THEN
    +
    1678  jrv = krfval(lk)
    +
    1679  ELSE
    +
    1680  jrv = newrfv(lk)
    +
    1681  END IF
    +
    1682 C
    +
    1683  kdata(i,kary(2)) = kdata(i,kary(2)) - jrv
    +
    1684 C IF NEW VALUE IS NEGATIVE - ERROR
    +
    1685  IF (kdata(i,kary(2)).LT.0) THEN
    +
    1686  ierrtn = 11
    +
    1687  RETURN
    +
    1688  END IF
    +
    1689 C PACK DATA INTO OUTPUT ARRAY
    +
    1690  IF ((kary(3)+jwide).GT.kend) THEN
    +
    1691  ierrtn = 1
    +
    1692  RETURN
    +
    1693  END IF
    +
    1694  CALL sbyte (kbufr,kdata(i,kary(2)),kary(3),jwide)
    +
    1695  kary(2) = kary(2) + 1
    +
    1696  kary(3) = kary(3) + jwide
    +
    1697  END IF
    +
    1698  kary(11) = kary(11) + 1
    +
    1699  GOTO 4300
    +
    1700  4305 CONTINUE
    +
    1701 C RESET ALL REFERENCE VALUES TO ORIGINAL
    +
    1702  DO 4310 lx = 1, isect3(8)
    +
    1703  krfvsw(lx) = 0
    +
    1704  4310 CONTINUE
    +
    1705  4500 CONTINUE
    +
    1706  RETURN
    +
    1707  END
    +
    1708 C> @brief Combine integer/text data
    +
    1709 C> @author Bill Cavanaugh @date 1993-12-03
    +
    1710 
    +
    1711 C> Construct integer subset from real and text data
    +
    1712 C>
    +
    1713 C> Program history log:
    +
    1714 C> - Bill Cavanaugh 1993-12-03
    +
    1715 C> - J. Hoppa 1994-03-31 added ksub to fi8501() parameter list.
    +
    1716 C> - J. Hoppa 1994-04-18 added dummy variable idum to fi8502() parameter list.
    +
    1717 C> - J. Hoppa 1994-04-20 added dummy variable ll to fi8501() parameter list.
    +
    1718 C> - J. Hoppa 1994-04-29 changed i to kary(11) added a kary(2) assignment so have something
    +
    1719 C> to pass to subroutines ** test this ** removed i and ll from call to fi8501()
    +
    1720 C> - J. Hoppa 1994-05-13 added code to calculate kwords when kfunc=2
    +
    1721 C> - J. Hoppa 1994-05-18 deleted kary(2) assignment
    +
    1722 C>
    +
    1723 C> @param[in] ISTEP
    +
    1724 C> @param[in] IUNITB Unit number of device containing table b
    +
    1725 C> @param[in] IDATA Integer working array
    +
    1726 C> @param[in] KDESC Expanded descriptor set
    +
    1727 C> @param[in] NRDESC Number of descriptors in kdesc
    +
    1728 C> @param[in] ATEXT Text data for ccitt ia5 and text operator fields
    +
    1729 C> @param[in] KSUB Subset number
    +
    1730 C> @param[in] KARY Working array
    +
    1731 C> @param[in] ISECT3
    +
    1732 C> @param[out] KDATA Array containing integer subsets
    +
    1733 C> @param[out] LDESC List of table b descriptors (decimal)
    +
    1734 C> @param[out] ANAME List of descriptor names
    +
    1735 C> @param[out] AUNITS Units for each descriptor
    +
    1736 C> @param[out] KSCALE Base 10 scale factor for each descriptor
    +
    1737 C> @param[out] KRFVAL Reference value for each descriptor
    +
    1738 C> @param[out] KRFVSW
    +
    1739 C> @param[out] KWIDTH Standard bit width to contain each value for specific descriptor
    +
    1740 C> @param[out] KASSOC
    +
    1741 C> @param[out] IERRTN Error return flag
    +
    1742 C> @param IUNITD
    +
    1743 C> @param KSEQ
    +
    1744 C> @param KNUM
    +
    1745 C> @param KLIST
    +
    1746 C> @param INDEXB
    +
    1747 C>
    +
    1748 C> @author Bill Cavanaugh @date 1993-12-03
    +
    1749  SUBROUTINE fi8508(ISTEP,IUNITB,IDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
    +
    1750  * KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
    +
    1751  * KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
    +
    1752 
    +
    1753 C TAKE EACH NON-TEXT ENTRY OF SECTION 2
    +
    1754 C ACCEPT IT
    +
    1755 C
    +
    1756 C TAKE EACH TEXT ENTRY
    +
    1757 C INSERT INTO INTEGER ARRAY,
    +
    1758 C ADDING FULL WORDS AS NECESSARY
    +
    1759 C MAKE SURE ANY LAST WORD HAS TEXT DATA
    +
    1760 C RIGHT JUSTIFIED
    +
    1761 C ---------------------------------------------------------------------
    +
    1762 C PASS BACK CONVERTED ENTRY TO LOCATION
    +
    1763 C SPECIFIED BY USER
    +
    1764 C
    +
    1765 C REFERENCE VALUE WILL BE APPLIED DURING
    +
    1766 C ENCODING OF MESSAGE
    +
    1767 C ---------------------------------------------------------------------
    +
    1768  INTEGER IUNITB,IUNITD,KSEQ(*),KNUM(*),KLIST(300,*)
    +
    1769  INTEGER KDESC(3,*),NRDESC,KASSOC(*)
    +
    1770  INTEGER IDATA(*),ISTEP
    +
    1771  INTEGER KDATA(500,*)
    +
    1772  INTEGER KARY(*),INDEXB(*)
    +
    1773  INTEGER KSUB,K
    +
    1774  INTEGER LDESC(*)
    +
    1775  INTEGER IBITS(32)
    +
    1776  INTEGER KSCALE(*)
    +
    1777  INTEGER KRFVAL(*)
    +
    1778  INTEGER KRFVSW(*)
    +
    1779  INTEGER KWIDTH(*)
    +
    1780  INTEGER MISG
    +
    1781  INTEGER MPTR,ISECT3(*)
    +
    1782  CHARACTER*1 ATEXT(*)
    +
    1783  CHARACTER*1 AHOLD1(256)
    +
    1784  INTEGER IHOLD4(64)
    +
    1785  CHARACTER*25 AUNITS(*)
    +
    1786  CHARACTER*25 CCITT
    +
    1787  CHARACTER*40 ANAME(*)
    +
    1788 C
    +
    1789  SAVE
    +
    1790 C
    +
    1791  equivalence(ahold1,ihold4)
    +
    1792 C
    +
    1793 C =====================================
    +
    1794  DATA ccitt /'CCITT IA5 '/
    +
    1795  DATA ibits / 1, 3, 7, 15,
    +
    1796  * 31, 63, 127, 255,
    +
    1797  * 511, 1023, 2047, 4095,
    +
    1798  * 8191, 16383, 32767, 65535,
    +
    1799  * z'0001FFFF',z'0003FFFF',z'0007FFFF',z'000FFFFF',
    +
    1800  * z'001FFFFF',z'003FFFFF',z'007FFFFF',z'00FFFFFF',
    +
    1801  * z'01FFFFFF',z'03FFFFFF',z'07FFFFFF',z'0FFFFFFF',
    +
    1802  * z'1FFFFFFF',z'3FFFFFFF',z'7FFFFFFF',z'FFFFFFFF'/
    +
    1803  DATA misg /99999/
    +
    1804 C
    +
    1805  IF (isect3(8).EQ.0) THEN
    +
    1806  CALL fi8512(iunitb,isect3,kdesc,nrdesc,kary,ierrtn,
    +
    1807  * ldesc,aname,aunits,kscale,krfval,kwidth,krfvsw,
    +
    1808  * iunitd,kseq,knum,klist,indexb)
    +
    1809  IF (ierrtn.NE.0) THEN
    +
    1810  RETURN
    +
    1811  END IF
    +
    1812  END IF
    +
    1813 C HAVE TABLE B AVAILABLE NOW
    +
    1814 C
    +
    1815 C LOOK AT EACH DATA ENTRY
    +
    1816 C CONVERT NON TEXT
    +
    1817 C MOVE TEXT
    +
    1818 C
    +
    1819  kpos = 0
    +
    1820  mptr = 0
    +
    1821  kary(11) = 0
    +
    1822  1000 CONTINUE
    +
    1823  kary(11) = kary(11) + 1
    +
    1824  IF (kary(11).GT.nrdesc) GO TO 1500
    +
    1825 C
    +
    1826 C RE-ENTRY POINT FOR REPLICATION AND SEQUENCE DESCR'S
    +
    1827 C
    +
    1828  500 CONTINUE
    +
    1829  kfunc = kdesc(1,kary(11)) / 16384
    +
    1830  kl = kdesc(1,kary(11)) - 16384 * kfunc
    +
    1831  kclass = kl / 256
    +
    1832  kseg = mod(kl,256)
    +
    1833 C KARY(2) = KARY(11) + KARY(18)
    +
    1834  IF (kfunc.EQ.1) THEN
    +
    1835 C REPLICATION DESCRIPTOR
    +
    1836  CALL fi8501(kary,istep,kclass,kseg,idata,rdata,
    +
    1837  * kdata,ksub,kdesc,nrdesc,ierrtn)
    +
    1838  IF (ierrtn.NE.0) THEN
    +
    1839  RETURN
    +
    1840  END IF
    +
    1841  GO TO 500
    +
    1842  ELSE IF (kfunc.EQ.2) THEN
    +
    1843  IF (kclass.EQ.5) THEN
    +
    1844 C HANDLE TEXT OPERATORS
    +
    1845 CC
    +
    1846  kavail = idata(kary(11))
    +
    1847 C UNUSED POSITIONS IN LAST WORD
    +
    1848  krem = mod(kavail,4)
    +
    1849  IF (krem.NE.0) THEN
    +
    1850  kwords = kavail / 4 + 1
    +
    1851  ELSE
    +
    1852  kwords = kavail / 4
    +
    1853  END IF
    +
    1854 CC
    +
    1855  jwide = kseg * 8
    +
    1856  GO TO 1200
    +
    1857  END IF
    +
    1858  ELSE IF (kfunc.EQ.3) THEN
    +
    1859 C SEQUENCE DESCRIPTOR - ERROR
    +
    1860  CALL fi8503(kary(11),kdesc,nrdesc,
    +
    1861  * isect3,iunitd,kseq,knum,klist,ierrtn)
    +
    1862  IF (ierrtn.NE.0) THEN
    +
    1863  RETURN
    +
    1864  END IF
    +
    1865  GO TO 500
    +
    1866  ELSE
    +
    1867 C
    +
    1868 C FIND MATCHING DESCRIPTOR
    +
    1869 C
    +
    1870  k = indexb(kdesc(1,kary(11)))
    +
    1871  IF (k.LT.1) THEN
    +
    1872  print *,'FI8508-NOT FOUND',kary(11),kdesc(1,kary(11)),
    +
    1873  * isect3(8),ldesc(k)
    +
    1874  ierrtn = 2
    +
    1875  RETURN
    +
    1876  END IF
    +
    1877 C HAVE MATCHING DESCRIPTOR
    +
    1878  200 CONTINUE
    +
    1879  IF (aunits(k)(1:9).NE.ccitt(1:9)) THEN
    +
    1880  IF (kary(27).NE.0) THEN
    +
    1881  IF (kdesc(1,kary(11)).LT.7937.OR.
    +
    1882  * kdesc(1,kary(11)).GT.8191) THEN
    +
    1883 C ASSOC FLD FOR ALL BUT CLASS 31
    +
    1884  kpos = kpos + 1
    +
    1885  IF (kassoc(kary(11)).EQ.ibits(kary(27))) THEN
    +
    1886  kdata(ksub,kpos) = misg
    +
    1887  ELSE
    +
    1888  kdata(ksub,kpos) = kassoc(kary(11))
    +
    1889  END IF
    +
    1890  END IF
    +
    1891  END IF
    +
    1892 C IF NOT MISSING DATA
    +
    1893  IF (idata(kary(11)).EQ.99999) THEN
    +
    1894  kpos = kpos + 1
    +
    1895  kdata(ksub,kpos) = misg
    +
    1896  ELSE
    +
    1897 C PROCESS INTEGER VALUES
    +
    1898  kpos = kpos + 1
    +
    1899  kdata(ksub,kpos) = idata(kary(11))
    +
    1900  END IF
    +
    1901  ELSE
    +
    1902 C PROCESS TEXT
    +
    1903 C NUMBER OF BYTES REQUIRED BY TABLE B
    +
    1904  kreq = kwidth(k) / 8
    +
    1905 C NUMBER BYTES AVAILABLE IN ATEXT
    +
    1906  kavail = idata(kary(11))
    +
    1907 C UNUSED POSITIONS IN LAST WORD
    +
    1908  krem = mod(kavail,4)
    +
    1909  IF (krem.NE.0) THEN
    +
    1910  kwords = kavail / 4 + 1
    +
    1911  ELSE
    +
    1912  kwords = kavail / 4
    +
    1913  END IF
    +
    1914 C MOVE TEXT CHARACTERS TO KDATA
    +
    1915  jwide = kwidth(k)
    +
    1916  GO TO 1200
    +
    1917  END IF
    +
    1918  END IF
    +
    1919  GO TO 1000
    +
    1920  1200 CONTINUE
    +
    1921  300 CONTINUE
    +
    1922  nptr = mptr
    +
    1923  DO 400 ij = 1, kwords
    +
    1924  kpos = kpos + 1
    +
    1925  CALL gbyte(atext,kdata(ksub,kpos),nptr,32)
    +
    1926  nptr = nptr + 32
    +
    1927  400 CONTINUE
    +
    1928  mptr = mptr + jwide
    +
    1929  GO TO 1000
    +
    1930  1500 CONTINUE
    +
    1931  RETURN
    +
    1932  END
    +
    1933 C> @brief Convert real/text input to integer
    +
    1934 C> @author Bill Cavanaugh @date 1993-12-03
    +
    1935 
    +
    1936 C> Construct integer subset from real and text data.
    +
    1937 C>
    +
    1938 C> Program history log:
    +
    1939 C> - Bill Cavanaugh 1993-12-03
    +
    1940 C> - J. Hoppa 1994-03-31 Added ksub to the fi8501 parameter list.
    +
    1941 C> - J. Hoppa 1994-04-18 Added dummy variable idum to fi8502 parameter list.
    +
    1942 C> - J. Hoppa 1994-04-20 Added dummy variable ll to fi8501 parameter list.
    +
    1943 C> - J. Hoppa 1994-04-29 Changed i to kary(11) added a kary(2) assignment so have something
    +
    1944 C> to pass to subroutines ** test this ** removed i and ll from call to fi8501
    +
    1945 C> - J. Hoppa 1994-05-18 Deleted kary(2) assignment
    +
    1946 C>
    +
    1947 C> @param[in] IUNITB unit number of device containing table b
    +
    1948 C> @param[in] RDATA real working array
    +
    1949 C> @param[in] KDESC expanded descriptor set
    +
    1950 C> @param[in] NRDESC number of descriptors in kdesc
    +
    1951 C> @param[in] ATEXT text data for ccitt ia5 and text operator fields
    +
    1952 C> @param[in] KSUB subset number
    +
    1953 C> @param[in] KARY working array
    +
    1954 C> @param[in] ISECT3
    +
    1955 C> @param[in] IUNITD
    +
    1956 C> @param[out] KDATA Array containing integer subsets
    +
    1957 C> @param[out] LDESC List of table b descriptors (decimal)
    +
    1958 C> @param[out] ANAME List of descriptor names
    +
    1959 C> @param[out] AUNITS Units for each descriptor
    +
    1960 C> @param[out] KSCALE Base 10 scale factor for each descriptor
    +
    1961 C> @param[out] KRFVAL Reference value for each descriptor
    +
    1962 C> @param[out] KRFVSW
    +
    1963 C> @param[out] KASSOC
    +
    1964 C> @param[out] KWIDTH Standard bit width to contain each value for specific descriptor
    +
    1965 C> @param[out] IERRTN Error return flag
    +
    1966 C> @param[out] KNUM
    +
    1967 C> @param[out] KLIST
    +
    1968 C> @param ISTEP
    +
    1969 C> @param KSEQ
    +
    1970 C> @param INDEXB
    +
    1971 C>
    +
    1972 C> @author Bill Cavanaugh @date 1993-12-03
    +
    1973  SUBROUTINE fi8509(ISTEP,IUNITB,RDATA,KDESC,NRDESC,ATEXT,KSUB,KARY,
    +
    1974  * KDATA,LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KRFVSW,ISECT3,
    +
    1975  * KWIDTH,KASSOC,IUNITD,KSEQ,KNUM,KLIST,IERRTN,INDEXB)
    +
    1976 
    +
    1977 C TAKE EACH NON-TEXT ENTRY OF SECTION 2
    +
    1978 C SCALE IT
    +
    1979 C ROUND IT
    +
    1980 C CONVERT TO INTEGER
    +
    1981 C
    +
    1982 C TAKE EACH TEXT ENTRY
    +
    1983 C INSERT INTO INTEGER ARRAY,
    +
    1984 C ADDING FULL WORDS AS NECESSARY
    +
    1985 C MAKE SURE ANY LAST WORD HAS TEXT DATA
    +
    1986 C RIGHT JUSTIFIED
    +
    1987 C PASS BACK CONVERTED ENTRY TO LOCATION
    +
    1988 C SPECIFIED BY USER
    +
    1989 C
    +
    1990 C REFERENCE VALUE WILL BE APPLIED DURING
    +
    1991 C ENCODING OF MESSAGE
    +
    1992 C ---------------------------------------------------------------------
    +
    1993  REAL RDATA(*)
    +
    1994  INTEGER IUNITB,IUNITD,KSEQ(*),KNUM(*),KLIST(300,*)
    +
    1995  INTEGER IBITS(32),INDEXB(*)
    +
    1996  INTEGER KDESC(3,*),ISTEP
    +
    1997  INTEGER KDATA(500,*)
    +
    1998  INTEGER KASSOC(*)
    +
    1999  INTEGER KARY(*)
    +
    2000  INTEGER KSUB,K
    +
    2001  INTEGER LDESC(*)
    +
    2002  INTEGER NRDESC
    +
    2003  INTEGER IERRTN
    +
    2004  INTEGER KSCALE(*)
    +
    2005  INTEGER KRFVAL(*)
    +
    2006  INTEGER KRFVSW(*)
    +
    2007  INTEGER KWIDTH(*)
    +
    2008  INTEGER MPTR,ISECT3(*)
    +
    2009  INTEGER MISG
    +
    2010  CHARACTER*1 AHOLD1(256)
    +
    2011  INTEGER IHOLD4(64)
    +
    2012  CHARACTER*1 ATEXT(*)
    +
    2013  CHARACTER*25 AUNITS(*)
    +
    2014  CHARACTER*25 CCITT
    +
    2015  CHARACTER*40 ANAME(*)
    +
    2016 C
    +
    2017  SAVE
    +
    2018 C =====================================
    +
    2019  equivalence(ahold1,ihold4)
    +
    2020 C
    +
    2021  DATA ibits/ 1, 3, 7, 15,
    +
    2022  * 31, 63, 127, 255,
    +
    2023  * 511, 1023, 2047, 4095,
    +
    2024  * 8191, 16383, 32767, 65535,
    +
    2025  * z'0001FFFF',z'0003FFFF',z'0007FFFF',z'000FFFFF',
    +
    2026  * z'001FFFFF',z'003FFFFF',z'007FFFFF',z'00FFFFFF',
    +
    2027  * z'01FFFFFF',z'03FFFFFF',z'07FFFFFF',z'0FFFFFFF',
    +
    2028  * z'1FFFFFFF',z'3FFFFFFF',z'7FFFFFFF',z'FFFFFFFF'/
    +
    2029 C
    +
    2030  DATA ccitt /'CCITT IA5 '/
    +
    2031  DATA misg /99999/
    +
    2032 C =====================================
    +
    2033 C
    +
    2034  IF (isect3(8).EQ.0) THEN
    +
    2035  CALL fi8512(iunitb,isect3,kdesc,nrdesc,kary,ierrtn,
    +
    2036  * ldesc,aname,aunits,kscale,krfval,kwidth,krfvsw,
    +
    2037  * iunitd,kseq,knum,klist,indexb)
    +
    2038  IF (ierrtn.NE.0) THEN
    +
    2039  RETURN
    +
    2040  END IF
    +
    2041  END IF
    +
    2042 C HAVE TABLE B AVAILABLE NOW
    +
    2043 C
    +
    2044 C LOOK AT EACH DATA ENTRY
    +
    2045 C CONVERT NON TEXT
    +
    2046 C MOVE TEXT
    +
    2047 C
    +
    2048  kpos = 0
    +
    2049  mptr = 0
    +
    2050  kary(11) = 0
    +
    2051  1000 CONTINUE
    +
    2052  kary(11) = kary(11) + 1
    +
    2053  IF (kary(11).GT.nrdesc) GO TO 1500
    +
    2054 C RE-ENRY POINT FOR REPLICATION AND
    +
    2055 C SEQUENCE DESCRIPTORS
    +
    2056  500 CONTINUE
    +
    2057  kfunc = kdesc(1,kary(11)) / 16384
    +
    2058  kl = kdesc(1,kary(11)) - 16384 * kfunc
    +
    2059  kclass = kl / 256
    +
    2060  kseg = mod(kl,256)
    +
    2061 C KARY(2) = KARY(11) + KARY(18)
    +
    2062  IF (kfunc.EQ.1) THEN
    +
    2063 C REPLICATION DESCRIPTOR
    +
    2064  CALL fi8501(kary,istep,kclass,kseg,idata,rdata,
    +
    2065  * kdata,ksub,kdesc,nrdesc,ierrtn)
    +
    2066  IF (ierrtn.NE.0) THEN
    +
    2067  RETURN
    +
    2068  END IF
    +
    2069  GO TO 500
    +
    2070  ELSE IF (kfunc.EQ.2) THEN
    +
    2071 C HANDLE OPERATORS
    +
    2072  IF (kclass.EQ.5) THEN
    +
    2073 C NUMBER BYTES AVAILABLE IN ATEXT
    +
    2074  kavail = rdata(kary(11))
    +
    2075 C UNUSED POSITIONS IN LAST WORD
    +
    2076  krem = mod(kavail,4)
    +
    2077  IF (krem.NE.0) THEN
    +
    2078  kwords = kavail / 4 + 1
    +
    2079  ELSE
    +
    2080  kwords = kavail / 4
    +
    2081  END IF
    +
    2082  jwide = kseg * 8
    +
    2083  GO TO 1200
    +
    2084  ELSE IF (kclass.EQ.2) THEN
    +
    2085  IF (kseg.EQ.0) THEN
    +
    2086  kary(9) = 0
    +
    2087  ELSE
    +
    2088  kary(9) = kseg - 128
    +
    2089  END IF
    +
    2090  GO TO 1200
    +
    2091  END IF
    +
    2092  ELSE IF (kfunc.EQ.3) THEN
    +
    2093 C SEQUENCE DESCRIPTOR - ERROR
    +
    2094  CALL fi8503(kary(11),kdesc,nrdesc,
    +
    2095  * isect3,iunitd,kseq,knum,klist,ierrtn)
    +
    2096  IF (ierrtn.NE.0) THEN
    +
    2097  RETURN
    +
    2098  END IF
    +
    2099  GO TO 500
    +
    2100  ELSE
    +
    2101 C
    +
    2102 C FIND MATCHING DESCRIPTOR
    +
    2103 C
    +
    2104  k = indexb(kdesc(1,kary(11)))
    +
    2105  IF (k.LT.1) THEN
    +
    2106  ierrtn = 2
    +
    2107 C PRINT *,'FI8509 - IERRTN = 2'
    +
    2108  RETURN
    +
    2109  END IF
    +
    2110 C HAVE MATCHING DESCRIPTOR
    +
    2111  200 CONTINUE
    +
    2112  IF (aunits(k)(1:9).NE.ccitt(1:9)) THEN
    +
    2113  IF (kary(27).NE.0) THEN
    +
    2114  IF (kdesc(1,kary(11)).LT.7937.OR.
    +
    2115  * kdesc(1,kary(11)).GT.8191) THEN
    +
    2116 C ASSOC FLD FOR ALL BUT CLASS 31
    +
    2117  kpos = kpos + 1
    +
    2118  IF (kassoc(kary(11)).EQ.ibits(kary(27))) THEN
    +
    2119  kdata(ksub,kpos) = misg
    +
    2120  ELSE
    +
    2121  kdata(ksub,kpos) = kassoc(kary(11))
    +
    2122  END IF
    +
    2123  END IF
    +
    2124  END IF
    +
    2125 C IF NOT MISSING DATA
    +
    2126  IF (rdata(kary(11)).EQ.99999.) THEN
    +
    2127  kpos = kpos + 1
    +
    2128  kdata(ksub,kpos) = misg
    +
    2129  ELSE
    +
    2130 C PROCESS REAL VALUES
    +
    2131  IF (kscale(k).NE.0) THEN
    +
    2132 C SCALING ALLOWING FOR CHANGE SCALE
    +
    2133  scale = 10. **(iabs(kscale(k)) + kary(9))
    +
    2134  IF (kscale(k).LT.0) THEN
    +
    2135  rdata(kary(11)) = rdata(kary(11)) / scale
    +
    2136  ELSE
    +
    2137  rdata(kary(11)) = rdata(kary(11)) * scale
    +
    2138  END IF
    +
    2139  END IF
    +
    2140 C PERFORM ROUNDING
    +
    2141  rdata(kary(11)) = rdata(kary(11)) +
    +
    2142  * sign(0.5,rdata(kary(11)))
    +
    2143 C CONVERT TO INTEGER
    +
    2144  kpos = kpos + 1
    +
    2145  kdata(ksub,kpos) = rdata(kary(11))
    +
    2146 C
    +
    2147  END IF
    +
    2148  ELSE
    +
    2149 C PROCESS TEXT
    +
    2150 C NUMBER OF BYTES REQUIRED BY TABLE B
    +
    2151  kreq = kwidth(k) / 8
    +
    2152 C NUMBER BYTES AVAILABLE IN ATEXT
    +
    2153  kavail = rdata(kary(11))
    +
    2154 C UNUSED POSITIONS IN LAST WORD
    +
    2155  krem = mod(kavail,4)
    +
    2156  IF (krem.NE.0) THEN
    +
    2157  kwords = kavail / 4 + 1
    +
    2158  ELSE
    +
    2159  kwords = kavail / 4
    +
    2160  END IF
    +
    2161 C MOVE TEXT CHARACTERS TO KDATA
    +
    2162  jwide = kwidth(k)
    +
    2163  GO TO 1200
    +
    2164  END IF
    +
    2165  END IF
    +
    2166  GO TO 1000
    +
    2167  1200 CONTINUE
    +
    2168  300 CONTINUE
    +
    2169  nptr = mptr
    +
    2170  DO 400 ij = 1, kwords
    +
    2171  kpos = kpos + 1
    +
    2172  CALL gbyte(atext,kdata(ksub,kpos),nptr,32)
    +
    2173  nptr = nptr + 32
    +
    2174  400 CONTINUE
    +
    2175  mptr = mptr + jwide
    +
    2176  GO TO 1000
    +
    2177  1500 CONTINUE
    +
    2178 C DO 2000 I = 1, KPOS
    +
    2179 C2000 CONTINUE
    +
    2180  RETURN
    +
    2181  END
    +
    2182 C> @brief Rebuild kdesc from jdesc
    +
    2183 C> @author Bill Cavanaugh @date 1993-12-03
    +
    2184 
    +
    2185 C> Construct working descriptor list from list of descriptors in section 3.
    +
    2186 C>
    +
    2187 C> Program history log:
    +
    2188 C> - Bill Cavanaugh 1993-12-03
    +
    2189 C>
    +
    2190 C> @param[in] ISECT3
    +
    2191 C> @param[in] KARY Utility - array see main routine
    +
    2192 C> @param[in] JIF Descriptor input form flag
    +
    2193 C> @param[in] JDESC List of descriptors for section 3
    +
    2194 C> @param[in] NEWNR Number of descriptors in jdesc
    +
    2195 C> @param[out] KIF Descriptor form
    +
    2196 C> @param[out] KDESC Working list of descriptors
    +
    2197 C> @param[out] NRDESC Number of descriptors in kdesc
    +
    2198 C> @param[out] IERRTN Error return
    +
    2199 C> - IERRTN = 0 Normal return
    +
    2200 C> - IERRTN = 5 Found delayed replication during expansion
    +
    2201 C>
    +
    2202 C> @author Bill Cavanaugh @date 1993-12-03
    +
    2203  SUBROUTINE fi8511(ISECT3,KARY,JIF,JDESC,NEWNR,
    +
    2204  * KIF,KDESC,NRDESC,IERRTN)
    +
    2205 
    +
    2206 C
    +
    2207  INTEGER JDESC(3,*), NEWNR, KDESC(3,*), NRDESC
    +
    2208  INTEGER KARY(*),IERRTN,KIF,JIF
    +
    2209  INTEGER ISECT3(*)
    +
    2210 C
    +
    2211  SAVE
    +
    2212 C
    +
    2213  IF (NEWNR.EQ.0) THEN
    +
    2214  IERRTN = 3
    +
    2215  return
    +
    2216  END IF
    +
    2217 C
    +
    2218  nrdesc = newnr
    +
    2219  IF (jif.EQ.0) THEN
    +
    2220  jif = 1
    +
    2221  DO 90 i = 1, newnr
    +
    2222  kdesc(1,i) = jdesc(1,i)*16384 + jdesc(2,i)*256 + jdesc(3,i)
    +
    2223  jdesc(1,i) = jdesc(1,i)*16384 + jdesc(2,i)*256 + jdesc(3,i)
    +
    2224  90 CONTINUE
    +
    2225  ELSE
    +
    2226  DO 100 i = 1, newnr
    +
    2227  kdesc(1,i) = jdesc(1,i)
    +
    2228  100 CONTINUE
    +
    2229  nrdesc = newnr
    +
    2230  END IF
    +
    2231  kif = 1
    +
    2232  9000 CONTINUE
    +
    2233  RETURN
    +
    2234  END
    +
    2235 C> @brief Read in table B
    +
    2236 C> @author Bill Cavanaugh @date 1993-12-03
    +
    2237 
    +
    2238 C> Read in tailored set of table B descriptors.
    +
    2239 C>
    +
    2240 C> Program history log:
    +
    2241 C> - Bill Cavanaugh 1993-12-03
    +
    2242 C> - J. Hoppa 1994-04-18 An error has been corrected to prevent later
    +
    2243 C> searching table b if there are only operator
    +
    2244 C> descriptors in the descriptor list.
    +
    2245 C> - J. Hoppa 1994-05-17 Changed the loop for expanding sequence
    +
    2246 C> descriptors from a do loop to a goto loop
    +
    2247 C>
    +
    2248 C> @param[in] IUNITB Unit where table b entries reside
    +
    2249 C> @param[in] KDESC Working descriptor list
    +
    2250 C> @param[in] NRDESC Number of descriptors in kdesc
    +
    2251 C> @param[in] IUNITD Unit where table d entries reside
    +
    2252 C> @param[out] KARY
    +
    2253 C> @param[out] IERRTN
    +
    2254 C> @param[out] LDESC Descriptors in table b (decimal values)
    +
    2255 C> @param[out] ANAME Array containing names of descriptors
    +
    2256 C> @param[out] AUNITS Array containing units of descriptors
    +
    2257 C> @param[out] KSCALE Scale values for each descriptor
    +
    2258 C> @param[out] KRFVAL Reference values for each descriptor
    +
    2259 C> @param[out] KWIDTH Bit width of each descriptor
    +
    2260 C> @param[out] KRFVSW New reference value switch
    +
    2261 C> @param[out] KSEQ Sequence descriptor
    +
    2262 C> @param[out] KNUM Number of descriptors in sequence
    +
    2263 C> @param[out] KLIST Sequence of descriptors
    +
    2264 C> @param ISECT3
    +
    2265 C> @param INDEXB
    +
    2266 C>
    +
    2267 C> @author Bill Cavanaugh @date 1993-12-03
    +
    2268  SUBROUTINE fi8512(IUNITB,ISECT3,KDESC,NRDESC,KARY,IERRTN,
    +
    2269  * LDESC,ANAME,AUNITS,KSCALE,KRFVAL,KWIDTH,KRFVSW,
    +
    2270  * IUNITD,KSEQ,KNUM,KLIST,INDEXB)
    +
    2271 
    +
    2272 C
    +
    2273  INTEGER KARY(*),LDESC(*),KSCALE(*),KRFVAL(*),KWIDTH(*)
    +
    2274  INTEGER KDESC(3,*), NRDESC, IUNITB, IERRTN, KRFVSW(*)
    +
    2275  INTEGER ISECT3(*),KEY(3,1600),INDEXB(*)
    +
    2276  INTEGER IUNITD,KSEQ(*),KNUM(*),KLIST(300,*)
    +
    2277  CHARACTER*40 ANAME(*)
    +
    2278  CHARACTER*25 AUNITS(*)
    +
    2279 C
    +
    2280  INTEGER MDESC(800),MR,I,J
    +
    2281 C
    +
    2282  SAVE
    +
    2283 C
    +
    2284 C ===================================================================
    +
    2285  ierrtn = 0
    +
    2286  DO 100 i = 1, 30
    +
    2287  kary(i) = 0
    +
    2288  100 CONTINUE
    +
    2289 C INITIALIZE DESCRIPTOR POINTERS TO MISSING
    +
    2290  DO 105 i = 1, 16383
    +
    2291  indexb(i) = -1
    +
    2292  105 CONTINUE
    +
    2293 C
    +
    2294 C ===================================================================
    +
    2295 C MAKE A COPY OF THE DESCRIPTOR LIST
    +
    2296 C ELIMINATING REPLICATION/OPERATORS
    +
    2297  j = 0
    +
    2298  DO 110 i = 1, nrdesc
    +
    2299  IF (kdesc(1,i).GE.49152.OR.kdesc(1,i).LT.16384) THEN
    +
    2300  j = j + 1
    +
    2301  key(1,j) = kdesc(1,i)
    +
    2302  END IF
    +
    2303  110 CONTINUE
    +
    2304  kcnt = j
    +
    2305 C ===================================================================
    +
    2306 C REPLACE ALL SEQUENCE DESCRIPTORS
    +
    2307 C JEN - FIXED NEXT BLOCK
    +
    2308 C DO 300 I = 1, KCNT
    +
    2309  i = 1
    +
    2310  300 IF(i.LE.kcnt)THEN
    +
    2311  200 CONTINUE
    +
    2312  IF (key(1,i).GE.49152) THEN
    +
    2313  CALL fi8503(i,key,kcnt,
    +
    2314  * isect3,iunitd,kseq,knum,klist,ierrtn)
    +
    2315  IF (ierrtn.NE.0) THEN
    +
    2316  RETURN
    +
    2317  END IF
    +
    2318  GO TO 200
    +
    2319  END IF
    +
    2320  i=i+1
    +
    2321  GOTO 300
    +
    2322  ENDIF
    +
    2323 C 300 CONTINUE
    +
    2324 C ===================================================================
    +
    2325 C ISOLATE SINGLE COPIES OF DESCRIPTORS
    +
    2326  mr = 1
    +
    2327 C THE FOLLOWING LINE IS TO PREVENT LATER SEARCHING TABLE B WHEN
    +
    2328 C HAVE ONLY OPERATOR DESCRIPTORS
    +
    2329  IF(kcnt.EQ.0) GOTO 9000
    +
    2330  mdesc(mr) = key(1,1)
    +
    2331  DO 500 i = 2, kcnt
    +
    2332  DO 400 j = 1, mr
    +
    2333  IF (key(1,i).EQ.mdesc(j)) THEN
    +
    2334  GO TO 500
    +
    2335  END IF
    +
    2336  400 CONTINUE
    +
    2337  mr = mr + 1
    +
    2338  mdesc(mr) = key(1,i)
    +
    2339  500 CONTINUE
    +
    2340 C ===================================================================
    +
    2341 C SORT INTO ASCENDING ORDER
    +
    2342 C READ IN MATCHING ENTRIES FROM TABLE B
    +
    2343  DO 700 kcur = 1, mr
    +
    2344  next = kcur + 1
    +
    2345  IF (next.LE.mr) THEN
    +
    2346  DO 600 lr = next, mr
    +
    2347  IF (mdesc(kcur).GT.mdesc(lr)) THEN
    +
    2348  ihold = mdesc(lr)
    +
    2349  mdesc(lr) = mdesc(kcur)
    +
    2350  mdesc(kcur) = ihold
    +
    2351  END IF
    +
    2352  600 CONTINUE
    +
    2353  END IF
    +
    2354  700 CONTINUE
    +
    2355 C ===================================================================
    +
    2356  rewind iunitb
    +
    2357 C
    +
    2358 C READ IN A MODIFIED TABLE B -
    +
    2359 C MODIFIED TABLE B CONTAINS ONLY
    +
    2360 C THOSE DESCRIPTORS ASSOCIATED WITH
    +
    2361 C CURRENT DATA.
    +
    2362 C
    +
    2363  ktry = 0
    +
    2364  DO 1500 nrtblb = 1, mr
    +
    2365  1000 CONTINUE
    +
    2366  1001 FORMAT (i1,i2,i3,a40,a25,i4,8x,i7,i5)
    +
    2367  READ (iunitb,1001,END=2000,ERR=8000)KF,KX,KY,ANAME(NRTBLB),
    +
    2368  * aunits(nrtblb),kscale(nrtblb),krfval(nrtblb),kwidth(nrtblb)
    +
    2369  krfvsw(nrtblb) = 0
    +
    2370  ldesc(nrtblb) = kx*256 + ky
    +
    2371 C
    +
    2372  IF (ldesc(nrtblb).EQ.mdesc(nrtblb)) THEN
    +
    2373 C PRINT *,'1001',NRTBLB,LDESC(NRTBLB)
    +
    2374 C PRINT *,LDESC(NRTBLB),ANAME(NRTBLB),KSCALE(NRTBLB),
    +
    2375 C * KRFVAL(NRTBLB),KWIDTH(NRTBLB)
    +
    2376  ktry = ktry + 1
    +
    2377  indexb(ldesc(nrtblb)) = ktry
    +
    2378 C PRINT *,'INDEX(',LDESC(NRTBLB),' = ',KTRY
    +
    2379  ELSE IF (ldesc(nrtblb).GT.mdesc(nrtblb)) THEN
    +
    2380 C PRINT *,'FI8512 - IERRTN=2'
    +
    2381  ierrtn = 2
    +
    2382  RETURN
    +
    2383  ELSE
    +
    2384  GO TO 1000
    +
    2385  END IF
    +
    2386  1500 CONTINUE
    +
    2387  IF (ktry.NE.mr) THEN
    +
    2388  print *,'DO NOT HAVE A COMPLETE SET OF TABLE B ENTRIES'
    +
    2389  ierrtn = 2
    +
    2390  RETURN
    +
    2391  END IF
    +
    2392 C DO 1998 I = 1, 16383, 30
    +
    2393 C WRITE (6,1999) (INDEXB(I+J),J=0,23)
    +
    2394 C1998 CONTINUE
    +
    2395 C1999 FORMAT(30(1X,I3))
    +
    2396 C
    +
    2397  2000 CONTINUE
    +
    2398  ierrtn = 0
    +
    2399  isect3(8) = mr
    +
    2400  GO TO 9000
    +
    2401  8000 CONTINUE
    +
    2402  ierrtn = 4
    +
    2403  9000 CONTINUE
    +
    2404  RETURN
    +
    2405  END
    +
    2406 C> @brief Read in table D
    +
    2407 C> @author Bill Cavanaugh @date 1993-12-03
    +
    2408 
    +
    2409 C> Read in table D
    +
    2410 C>
    +
    2411 C> Program history log:
    +
    2412 C> - Bill Cavanaugh 1993-12-03
    +
    2413 C>
    +
    2414 C> @param[in] IUNITD Unit number of input device
    +
    2415 C> @param[out] KSEQ Key for sequence descriptors
    +
    2416 C> @param[out] KNUM Number if descriptors in list
    +
    2417 C> @param[out] KLIST Descriptors list
    +
    2418 C> @param[out] IERRTN Error return flag
    +
    2419 C> @param ISECT3
    +
    2420 C>
    +
    2421 C> @author Bill Cavanaugh @date 1993-12-03
    +
    2422  SUBROUTINE fi8513 (IUNITD,ISECT3,KSEQ,KNUM,KLIST,IERRTN)
    +
    2423 
    +
    2424 C
    +
    2425  INTEGER IUNITD, ISECT3(*)
    +
    2426  INTEGER KSEQ(*),KNUM(*),KLIST(300,*)
    +
    2427  INTEGER KKF(10),KKX(10),KKY(10),KF,KX,KY
    +
    2428 C
    +
    2429  SAVE
    +
    2430 C
    +
    2431  REWIND IUNITD
    +
    2432  J = 0
    +
    2433  ierrtn = 0
    +
    2434  1000 CONTINUE
    +
    2435  READ (iunitd,1001,END=9000,ERR=8000)KF,KX,KY,
    +
    2436  * kkf(1),kkx(1),kky(1),
    +
    2437  * kkf(2),kkx(2),kky(2),
    +
    2438  * kkf(3),kkx(3),kky(3),
    +
    2439  * kkf(4),kkx(4),kky(4),
    +
    2440  * kkf(5),kkx(5),kky(5),
    +
    2441  * kkf(6),kkx(6),kky(6),
    +
    2442  * kkf(7),kkx(7),kky(7),
    +
    2443  * kkf(8),kkx(8),kky(8),
    +
    2444  * kkf(9),kkx(9),kky(9),
    +
    2445  * kkf(10),kkx(10),kky(10)
    +
    2446  1001 FORMAT (11(i1,i2,i3,1x),3x)
    +
    2447  j = j + 1
    +
    2448 C BUILD SEQUENCE KEY
    +
    2449  kseq(j) = 16384*kf + 256*kx + ky
    +
    2450  DO 2000 lm = 1, 10
    +
    2451 C BUILD KLIST
    +
    2452  klist(j,lm) = 16384*kkf(lm) + 256*kkx(lm) + kky(lm)
    +
    2453  IF(klist(j,lm).NE.0) THEN
    +
    2454  knum(j) = lm
    +
    2455  END IF
    +
    2456  2000 CONTINUE
    +
    2457  GO TO 1000
    +
    2458  8000 CONTINUE
    +
    2459  ierrtn = 6
    +
    2460  9000 CONTINUE
    +
    2461  isect3(9) = j
    +
    2462  RETURN
    +
    2463  END
    +
    +
    +
    fi8506
    subroutine fi8506(ISTEP, ISECT3, KARY, JDESC, NEWNR, KDESC, NRDESC, LDESC, ANAME, AUNITS, KSCALE, KRFVAL, KWIDTH, KRFVSW, NEWRFV, KSEQ, KNUM, KLIST, IBFSIZ, KDATA, KBUFR, IERRTN, INDEXB)
    Process data in non-compressed format.
    Definition: w3fi85.f:1473
    +
    fi8513
    subroutine fi8513(IUNITD, ISECT3, KSEQ, KNUM, KLIST, IERRTN)
    Read in table D.
    Definition: w3fi85.f:2423
    +
    fi8508
    subroutine fi8508(ISTEP, IUNITB, IDATA, KDESC, NRDESC, ATEXT, KSUB, KARY, KDATA, LDESC, ANAME, AUNITS, KSCALE, KRFVAL, KRFVSW, ISECT3, KWIDTH, KASSOC, IUNITD, KSEQ, KNUM, KLIST, IERRTN, INDEXB)
    Combine integer/text data.
    Definition: w3fi85.f:1752
    +
    w3ai38
    subroutine w3ai38(IE, NC)
    Convert EBCDIC to ASCII by character.
    Definition: w3ai38.f:37
    +
    fi8503
    subroutine fi8503(I, KDESC, NRDESC, ISECT3, IUNITD, KSEQ, KNUM, KLIST, IERRTN)
    Expand sequence descriptor.
    Definition: w3fi85.f:1307
    +
    fi8512
    subroutine fi8512(IUNITB, ISECT3, KDESC, NRDESC, KARY, IERRTN, LDESC, ANAME, AUNITS, KSCALE, KRFVAL, KWIDTH, KRFVSW, IUNITD, KSEQ, KNUM, KLIST, INDEXB)
    Read in table B.
    Definition: w3fi85.f:2271
    +
    sbyte
    subroutine sbyte(IOUT, IN, ISKIP, NBYTE)
    Definition: sbyte.f:12
    +
    w3fi85
    subroutine w3fi85(ISTEP, IUNITB, IUNITD, IBFSIZ, ISECT1, ISECT3, JIF, JDESC, NEWNR, IDATA, RDATA, ATEXT, KASSOC, KIF, KDESC, NRDESC, ISEC2D, ISEC2B, KDATA, KARY, KBUFR, IERRTN)
    Using information available in supplied arrays, generate a bufr message (wmo code fm94).
    Definition: w3fi85.f:214
    +
    fi8501
    subroutine fi8501(KARY, ISTEP, KCLASS, KSEG, IDATA, RDATA, KDATA, NSUB, KDESC, NRDESC, IERRTN)
    Perform replication of descriptors.
    Definition: w3fi85.f:981
    +
    fi8509
    subroutine fi8509(ISTEP, IUNITB, RDATA, KDESC, NRDESC, ATEXT, KSUB, KARY, KDATA, LDESC, ANAME, AUNITS, KSCALE, KRFVAL, KRFVSW, ISECT3, KWIDTH, KASSOC, IUNITD, KSEQ, KNUM, KLIST, IERRTN, INDEXB)
    Convert real/text input to integer.
    Definition: w3fi85.f:1976
    +
    gbyte
    subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
    This is the fortran version of gbyte.
    Definition: gbyte.f:27
    +
    fi8502
    subroutine fi8502(, KBUFR, KCLASS, KSEG, KDESC, NRDESC, I, ISTEP, KARY, KDATA, ISECT3, KRFVSW, NEWRFV, LDESC, IERRTN, INDEXB)
    Process an operator descriptor.
    Definition: w3fi85.f:1116
    +
    fi8511
    subroutine fi8511(ISECT3, KARY, JIF, JDESC, NEWNR, KIF, KDESC, NRDESC, IERRTN)
    Rebuild kdesc from jdesc.
    Definition: w3fi85.f:2205
    +
    fi8505
    subroutine fi8505(MIF, MDESC, NR, IERRTN)
    Convert descriptors fxy to decimal.
    Definition: w3fi85.f:1393
    + + + + diff --git a/ver-2.10.0/w3fi88_8f.html b/ver-2.10.0/w3fi88_8f.html new file mode 100644 index 00000000..c9dbc7d1 --- /dev/null +++ b/ver-2.10.0/w3fi88_8f.html @@ -0,0 +1,1955 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi88.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi88.f File Reference
    +
    +
    + +

    BUFR message decoder. +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

    +Functions/Subroutines

    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)
     Data extraction. More...
     
    subroutine fi8802 (IPTR, IDENT, MSGA, KDATA, KFXY1, LL, MSTACK, AUNIT1, IWIDE1, IRFVL1, ISCAL1, JDESC, IVALS, J, MAXR, MAXD, KPTRB)
     Process element descriptor. More...
     
    subroutine fi8803 (IPTR, IDENT, MSGA, KDATA, IVALS, MSTACK, IWIDE1, IRFVL1, ISCAL1, J, JDESC, MAXR, MAXD)
     Process compressed data. More...
     
    subroutine fi8804 (IPTR, MSGA, KDATA, IVALS, MSTACK, IWIDE1, IRFVL1, ISCAL1, J, LL, JDESC, MAXR, MAXD)
     Process serial data. More...
     
    subroutine fi8805 (IPTR, IDENT, MSGA, IWORK, LX, LY, KDATA, LL, KNR, MSTACK, MAXR, MAXD)
     Process a replication descriptor. More...
     
    subroutine fi8806 (IPTR, LX, LY, IDENT, MSGA, KDATA, IVALS, MSTACK, IWIDE1, IRFVL1, ISCAL1, J, LL, KFXY1, IWORK, JDESC, MAXR, MAXD, KPTRB)
     Process operator descriptors. More...
     
    subroutine fi8807 (IPTR, IWORK, ITBLD, ITBLD2, JDESC, KPTRD)
     Process queue descriptor. More...
     
    subroutine fi8808 (IPTR, IWORK, LF, LX, LY, JDESC)
     Program history log: More...
     
    subroutine fi8809 (IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
     Reformat profiler w hgt increments. More...
     
    subroutine fi8810 (IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
     Reformat profiler edition 2 data. More...
     
    subroutine fi8811 (IPTR, IDENT, MSTACK, KDATA, KNR, LDATA, LSTACK, MAXD, MAXR)
     Expand data/descriptor replication. More...
     
    +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)
     
    +subroutine fi8813 (IPTR, MAXR, MAXD, MSTACK, KDATA, IDENT, KPTRD, KPTRB, ITBLD, ANAME1, AUNIT1, KFXY1, ISCAL1, IRFVL1, IWIDE1, IUNITB)
     
    +subroutine fi8814 (ASCCHR, NPOS, NEWVAL, IERR, IPTR)
     
    +subroutine fi8815 (IPTR, IDENT, JDESC, KDATA, KFXY3, MAXR, MAXD, ANAME3, AUNIT3, ISCAL3, IRFVL3, IWIDE3, KEYSET, IBFLAG, IERR)
     
    +subroutine fi8818 (IPTR, KFXY1, ANAME1, AUNIT1, ISCAL1, IRFVL1, IWIDE1, KFXY2, ANAME2, AUNIT2, ISCAL2, IRFVL2, IWIDE2, KPTRB)
     
    +subroutine fi8819 (IPTR, ITBLD, ITBLD2, KPTRD)
     
    +subroutine fi8820 (ITBLD, IUNITD, IPTR, ITBLD2, KPTRD)
     
    subroutine w3fi88 (IPTR, IDENT, MSGA, ISTACK, MSTACK, KDATA, KNR, INDEX, LDATA, LSTACK, MAXR, MAXD, IUNITB, IUNITD)
     This set of routines will decode a bufr message and place information extracted from the bufr message into selected arrays for the user. More...
     
    +

    Detailed Description

    +

    BUFR message decoder.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-08-31
    + +

    Definition in file w3fi88.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ fi8801()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8801 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(*) ISTACK,
    integer, dimension(*) IWORK,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) IVALS,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(maxr) KNR,
    integer INDEX,
    integer MAXR,
    integer MAXD,
    integer, dimension(*) KFXY1,
    character*40, dimension(*) ANAME1,
    character*24, dimension(*) AUNIT1,
    integer, dimension(*) ISCAL1,
    integer, dimension(3,*) IRFVL1,
    integer, dimension(*) IWIDE1,
     IRF1SW,
     INEWVL,
    integer, dimension(*) KFXY2,
    character*64, dimension(*) ANAME2,
    character*24, dimension(*) AUNIT2,
    integer, dimension(*) ISCAL2,
    integer, dimension(*) IRFVL2,
    integer, dimension(*) IWIDE2,
    integer, dimension(200) KFXY3,
    character*64, dimension(200) ANAME3,
    character*24, dimension(200) AUNIT3,
    integer, dimension(200) ISCAL3,
    integer, dimension(200) IRFVL3,
    integer, dimension(200) IWIDE3,
     IUNITB,
     IUNITD,
    integer, dimension(20,*) ITBLD,
    integer, dimension(20,*) ITBLD2,
    integer, dimension(*) KPTRB,
    integer, dimension(*) KPTRD 
    )
    +
    + +

    Data extraction.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Control the extraction of data from section 4 based on data descriptors.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01\
      • +
    • Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed DATA.
      • +
    • Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with DELAYED REPLICATION.
      • +
    • Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
      • +
    • Dennis Keyser 1995-06-07 Corrected an error which required input argument "maxd" to be nearly twice as large as needed for decoding wind profiler reports (limit upper bound for "iwork" array was set to "maxd", now it is set to 15000)
      • +
    +
    Parameters
    + + + + + + + + + + + + + + +
    [in]IPTRSee w3fi88() routine docblock
    [in]IDENTSee w3fi88() routine docblock
    [in]MSGAArray containing bufr message
    [in,out]ISTACKOriginal array of descriptors extracted from source bufr message.
    [in]MSTACKWorking array of descriptors (expanded)and scaling factor
    [in,out]KFXY1+KFXY2+KFXY3Image of current descriptor
    [in]INDEX
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1700, but for most other data a value for maxd of 500 will suffice
    [in]IUNITBUnit number of data set holding table b
    [in]IUNITDUnit number of data set holding table d
    [out]IWORKWorking descriptor list
    [out]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd)
    +
    +
    +

    arrays containing data from table b

    Parameters
    + + + + + + + + + + + + + +
    [out]AUNIT1+AUNIT2+AUNIT3Units for descriptor
    [out]ANAME1+ANAME2+ANAME3Descriptor name
    [out]ISCAL1+ISCAL2+ISCAL3Scale for value of descriptor
    [out]IRFVL1+IRFVL2+IRFVL3Reference value for descriptor
    [out]IWIDE1+IWIDE2+IWIDE3Bit width for value of descriptor
    ITBLD+ITBLD2
    KPTRB
    KPTRD
    KNR
    IVALS
    IRF1SW
    INEWVLError return:
      +
    • IPTR(1)
        +
      • = 8 Error reading table b
        • +
      • = 9 Error reading table d
        • +
      • = 11 Error opening table b
        • +
      +
      • +
    +
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 973 of file w3fi88.f.

    + +
    +
    + +

    ◆ fi8802()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8802 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) KFXY1,
     LL,
    integer, dimension(2,maxd) MSTACK,
    character*24, dimension(*) AUNIT1,
    integer, dimension(*) IWIDE1,
    integer, dimension(3,*) IRFVL1,
    integer, dimension(*) ISCAL1,
    integer JDESC,
    integer, dimension(*) IVALS,
    integer J,
     MAXR,
     MAXD,
    integer, dimension(*) KPTRB 
    )
    +
    + +

    Process element descriptor.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Process an element descriptor (f = 0) and store data in output array.
    +

    Program history log: 88-09-01 91-04-04 Changed to pass width of text fields in bytes

    +
    Parameters
    + + + + + + + + + + + + + + + + + + +
    [in]IPTRSee w3fi88 routine docblock
    [in]IDENTSee w3fi88 routine docblock
    [in]MSGAArray containing bufr message
    [in,out]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd)
    [in,out]KFXY1Image of current descriptor
    [in]MSTACK
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1700, but for most other data a value for maxd of 500 will suffice arrays containing data from table b
    [out]AUNIT1Units for descriptor
    [out]ISCAL1Scale for value of descriptor
    [out]IRFVL1Reference value for descriptor
    [out]IWIDE1Bit width for value of descriptor
    LL
    JDESC
    IVALS
    J
    KPTRBError return: IPTR(1) = 3 - Message contains a descriptor with f=0 that does not exist in table b.
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1309 of file w3fi88.f.

    + +
    +
    + +

    ◆ fi8803()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8803 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) IVALS,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(*) IWIDE1,
    integer, dimension(3,*) IRFVL1,
    integer, dimension(*) ISCAL1,
    integer J,
    integer JDESC,
    integer MAXR,
    integer MAXD 
    )
    +
    + +

    Process compressed data.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Process compressed data and place individual elements into output array.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-04-04 Text handling portion of this routine modified to hanle width of fields in bytes.
      • +
    • Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed and uncompressed form gave different results. this has been corrected.
      • +
    • Bill Cavanaugh 1991-06-21 Processing of text data has been changed to provide exact reproduction of all characters.
      • +
    • Bill Cavanaugh 1994-04-11 Corrected processing of data when all values the same (nbinc = 0). corrected test of lowest value against proper bit mask.
      • +
    • Dennis Keyser 1995-06-07 Corrected an error which resulted in returned scale in "mstack(2, ..)" always being set to zero for compressed data. also, scale changes were not being recognized.
      • +
    +
    Parameters
    + + + + + + + + + + + + + + +
    [in]IPTRSee w3fi88 routine docblock
    [in]IDENTSee w3fi88 routine docblock
    [in]MSGAArray containing bufr message,mstack,
    [in]IVALSArray of single parameter values
    [in,out]J
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1700, but for most other data a value for maxd of 500 will suffice
    [out]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd) arrays containing data from table b
    [out]ISCAL1Scale for value of descriptor
    [out]IRFVL1Reference value for descriptor
    [out]IWIDE1Bit width for value of descriptor
    MSTACK
    JDESC
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1414 of file w3fi88.f.

    + +
    +
    + +

    ◆ fi8804()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8804 (integer, dimension(*) IPTR,
    integer, dimension(*) MSGA,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) IVALS,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(*) IWIDE1,
    integer, dimension(3,*) IRFVL1,
    integer, dimension(*) ISCAL1,
    integer J,
    integer LL,
    integer JDESC,
    integer MAXR,
    integer MAXD 
    )
    +
    + +

    Process serial data.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Process data that is not compressed
    +

    Program history log:

      +
    • Bill cavanaugh 1988-09-01
      • +
    • Bill cavanaugh 1991-01-18 Modified to properly handle non-compressed data.
      • +
    • Bill cavanaugh 1991-04-04 Text handling portion of this routine modified to handle field width in bytes.
      • +
    • Bill cavanaugh 1991-04-17 ests showed that the same data in compressed and uncompressed form gave different results. this has been corrected.
      • +
    +
    Parameters
    + + + + + + + + + + + + + + +
    [in]IPTRSee w3fi88() routine docblock
    [in]MSGAArray containing bufr message
    [in,out]IVALSArray of single parameter values
    [in,out]J
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1700, but for most other data a value for maxd of 500 will suffice
    [out]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd) Arrays containing data from table b
    [out]ISCAL1Scale for value of descriptor
    [out]IRFVL1Reference value for descriptor
    [out]IWIDE1Bit width for value of descriptorE
    MSTACK
    LL
    JDESCError return: IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1733 of file w3fi88.f.

    + +
    +
    + +

    ◆ fi8805()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8805 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(*) IWORK,
    integer LX,
    integer LY,
    integer, dimension(maxr,maxd) KDATA,
    integer LL,
    integer, dimension(maxr) KNR,
    integer, dimension(2,maxd) MSTACK,
     MAXR,
     MAXD 
    )
    +
    + +

    Process a replication descriptor.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Process a replication descriptor, must extract number of replications of n descriptors from the data stream.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    +
    Parameters
    + + + + + + + + + + + + + +
    [in]IWORKWorking descriptor list
    [in]IPTRSee w3fi88 routine docblock
    [in]IDENTSee w3fi88 routine docblock
    [in,out]LXX portion of current descriptor
    [in,out]LYY portion of current descriptor
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1700, but for most other data a value for maxd of 500 will suffice
    [out]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd)
    MSGA
    LL
    KNR
    MSTACKError return:
      +
    • IPTR(1)
        +
      • = 12 Data descriptor qualifier does not follow delayed replication descriptor
        • +
      • = 20 Exceeded count for delayed replication pass
        • +
      +
      • +
    +
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 1941 of file w3fi88.f.

    + +
    +
    + +

    ◆ fi8806()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8806 (integer, dimension(*) IPTR,
    integer LX,
    integer LY,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) IVALS,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(*) IWIDE1,
    integer, dimension(3,*) IRFVL1,
    integer, dimension(*) ISCAL1,
    integer J,
    integer LL,
    integer, dimension(*) KFXY1,
    integer, dimension(*) IWORK,
    integer JDESC,
     MAXR,
     MAXD,
    integer, dimension(*) KPTRB 
    )
    +
    + +

    Process operator descriptors.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Extract and save indicated change values for use until changes are rescinded, or extract text strings indicated through 2 05 yyy.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
      • +
    • Bill Cavanaugh 1991-05-10 Coding has been added to process properly table c descriptor 2 06 yyy.
      • +
    • Bill Cavanaugh 1991-11-21 Coding has been added to properly process table c descriptor 2 03 yyy, the change to new reference value for selected descriptors.
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + + + + + + +
    [in]IPTRSee w3fi88 routine docblock
    [in]LXX portion of current descriptor
    [in]LYY portion of current descriptor
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1700, but for most other data a value for maxd of 500 will suffice
    [out]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd) Arrays containing data from table b
    [out]ISCAL1Scale for value of descriptor
    [out]IRFVL1Reference value for descriptor
    [out]IWIDE1Bit width for value of descriptor
    IDENT
    MSGA
    IVALS
    MSTACK
    J
    LL
    KFXY1
    IWORK
    JDESC
    KPTRBError return: IPTR(1) = 5 - Erroneous x value in data descriptor operator
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 2149 of file w3fi88.f.

    + +
    +
    + +

    ◆ fi8807()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8807 (integer, dimension(*) IPTR,
    integer, dimension(*) IWORK,
    integer, dimension(20,*) ITBLD,
    integer, dimension(20,*) ITBLD2,
    integer JDESC,
    integer, dimension(*) KPTRD 
    )
    +
    + +

    Process queue descriptor.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 Substitute descriptor queue for queue descriptor.
    +

    Program history log:

      +
    • Bill Cavanaugh 1988-09-01
      • +
    • Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors
      • +
    • Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors based on tests with live data.
      • +
    +
    Parameters
    + + + + + + +
    [in]IWORKWorking descriptor list
    [in]IPTRSee w3fi88 routine docblock
    [in]ITBLD+ITBLD2Array containing descriptor queues
    [in]JDESCQueue descriptor to be expanded
    KPTRD
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 2372 of file w3fi88.f.

    + +
    +
    + +

    ◆ fi8808()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8808 (integer, dimension(*) IPTR,
    integer, dimension(*) IWORK,
    integer LF,
    integer LX,
    integer LY,
    integer JDESC 
    )
    +
    + +

    Program history log:

    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01 - Bill Cavanaugh 1988-09-01
    +
    Parameters
    + + + + + + + +
    [in,out]IPTRSee w3fi88 routine docblock
    [in]IWORKWorking descriptor list
    LF
    LX
    LY
    JDESC
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1988-09-01
    + +

    Definition at line 2459 of file w3fi88.f.

    + +
    +
    + +

    ◆ fi8809()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8809 (integer, dimension(*) IDENT,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) IPTR,
     MAXR,
     MAXD 
    )
    +
    + +

    Reformat profiler w hgt increments.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1990-02-14 Reformat decoded profiler data to show heights instead of height increments.
    +

    Program history log:

      +
    • Bill Cavanaugh 1990-02-14
      • +
    +
    Parameters
    + + + + + + + +
    [in]IDENTArray contains message information extracted from BUFR message
      +
    • IDENT(1) - Edition number (byte 4, section 1)
      • +
    • IDENT(2) - Originating center (bytes 5-6, section 1)
      • +
    • IDENT(3) - Update sequence (byte 7, section 1)
      • +
    • IDENT(4) - (byte 8, section 1)
      • +
    • IDENT(5) - Bufr message type (byte 9, section 1)
      • +
    • IDENT(6) - Bufr msg sub-type (byte 10, section 1)
      • +
    • IDENT(7) - (bytes 11-12, section 1)
      • +
    • IDENT(8) - Year of century (byte 13, section 1)
      • +
    • IDENT(9) - Month of year (byte 14, section 1)
      • +
    • IDENT(10) - Day of month (byte 15, section 1)
      • +
    • IDENT(11) - Hour of day (byte 16, section 1)
      • +
    • IDENT(12) - Minute of hour (byte 17, section 1)
      • +
    • IDENT(13) - Rsvd by adp centers (byte 18, section 1)
      • +
    • IDENT(14) - Nr of data subsets (byte 5-6, section 3)
      • +
    • IDENT(15) - Observed flag (byte 7, bit 1, section 3)
      • +
    • IDENT(16) - Compression flag (byte 7, bit 2, section 3)
      • +
    +
    [in]MSTACKWorking descriptor list and scaling factor
    [in]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd)
    [in]IPTRSee w3fi88
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1700, but for most other data a value for maxd of 500 will suffice
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1990-02-14
    + +

    Definition at line 2517 of file w3fi88.f.

    + +
    +
    + +

    ◆ fi8810()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8810 (integer, dimension(*) IDENT,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(*) IPTR,
     MAXR,
     MAXD 
    )
    +
    + +

    Reformat profiler edition 2 data.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-01-27 Reformat profiler data in edition 2
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-01-27
      • +
    • Dennis Keyser 1995-06-07 A correction was made to prevent unnecessary looping when all requested descriptors are missing.
      • +
    +
    Parameters
    + + + + + + + +
    [in]IDENT- ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM BUFR MESSAGE -
      +
    • IDENT(1) - Edition number (byte 4, section 1)
      • +
    • IDENT(2) - Originating center (bytes 5-6, section 1)
      • +
    • IDENT(3) - Update sequence (byte 7, section 1)
      • +
    • IDENT(4) - (byte 8, section 1)
      • +
    • IDENT(5) - Bufr message type (byte 9, section 1)
      • +
    • IDENT(6) - Bufr msg sub-type (byte 10, section 1)
      • +
    • IDENT(7) - (bytes 11-12, section 1)
      • +
    • IDENT(8) - Year of century (byte 13, section 1)
      • +
    • IDENT(9) - Month of year (byte 14, section 1)
      • +
    • IDENT(10) - Day of month (byte 15, section 1)
      • +
    • IDENT(11) - Hour of day (byte 16, section 1)
      • +
    • IDENT(12) - Minute of hour (byte 17, section 1)
      • +
    • IDENT(13) - Rsvd by adp centers(byte 18, section 1)
      • +
    • IDENT(14) - Nr of data subsets (byte 5-6, section 3)
      • +
    • IDENT(15) - Observed flag (byte 7, bit 1, section 3)
      • +
    • IDENT(16) - Compression flag (byte 7, bit 2, section 3)
      • +
    +
    [in]MSTACKWorking descriptor list and scaling factor
    [in]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd)
    [in]IPTRSee w3fi88
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1700, but for most other data a value for maxd of 500 will suffice
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-01-27
    + +

    Definition at line 2911 of file w3fi88.f.

    + +
    +
    + +

    ◆ fi8811()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine fi8811 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(maxr) KNR,
    integer, dimension(maxd) LDATA,
    integer, dimension(2,maxd) LSTACK,
     MAXD,
     MAXR 
    )
    +
    + +

    Expand data/descriptor replication.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-05-12 Expand data and descriptor strings
    +

    Program history log:

      +
    • Bill Cavanaugh 1993-05-12
      • +
    +
    Parameters
    + + + + + + + + + + +
    [in]IPTRSee w3fi88 routine docblock
    [in]IDENTSee w3fi88 routine docblock
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1700, but for most other data a value for maxd of 500 will suffice
    [in,out]KDATAArray containing decoded reports from bufr message. kdata(report number,parameter number) (report number limited to value of input argument maxr and parameter number limited to value of input argument maxd)
    [in,out]MSTACKList of descriptors and scale values
    KNR
    LDATA
    LSTACKError return:
      +
    • IPTR(1)
      • +
    +
    +
    +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1993-05-12
    + +

    Definition at line 3249 of file w3fi88.f.

    + +
    +
    + +

    ◆ w3fi88()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi88 (integer, dimension(*) IPTR,
    integer, dimension(*) IDENT,
    integer, dimension(*) MSGA,
    integer, dimension(*) ISTACK,
    integer, dimension(2,maxd) MSTACK,
    integer, dimension(maxr,maxd) KDATA,
    integer, dimension(maxr) KNR,
    integer INDEX,
    integer, dimension(maxd) LDATA,
    integer, dimension(2,maxd) LSTACK,
     MAXR,
     MAXD,
     IUNITB,
     IUNITD 
    )
    +
    + +

    This set of routines will decode a bufr message and place information extracted from the bufr message into selected arrays for the user.

    +

    the array kdata can now be sized by the user by indicating the maximum number of subsets and the maximum number of descriptors that are expected in the course of decoding selected input data. this allows for realistic sizing of kdata and the mstack arrays. this version also allows for the inclusion of the unit numbers for tables b and d into the argument list. this routine does not include ifod processing.

    +

    Program history log:

      +
    • Bill Cavanaugh 1988-08-31
      • +
    • Bill Cavanaugh 1990-12-07 Now Utilizing gbyte routines to gather and separate bit fields. this should improve (decrease) the time it takes to decode any bufr message. have entered coding that will permit processing bufr editions 1 and 2. improved and corrected the conversion into ifod format of decoded bufr messages.
      • +
    • Bill Cavanaugh 1991-01-18 Program/routines modified to properly handle serial profiler data.
      • +
    • Bill Cavanaugh 1991-04-04 Modified to handle text supplied thru descriptor 2 05 yyy.
      • +
    • Bill Cavanaugh 1991-04-17 Errors in extracting and scaling data corrected. improved handling of nested queue descriptors is added.
      • +
    • Bill Cavanaugh 1991-05-10 Array 'data' has been enlarged to real*8 to better contain very large numbers more accurately. the preious size real*4 could not contain sufficient significant digits. coding has been introduced to process new table c descriptor 2 06 yyy which permits in line processing of a local descriptor even if the descriptor is not contained in the users table b. a second routine to process ifod messages (ifod0) has been removed in favor of the improved processing of the one remaining (ifod1). new coding has been introduced to permit processing of bufr messages based on bufr edition up to and including edition 2. please note increased size requirements for arrays ident(20) and iptr(40).
      • +
    • Bill Cavanaugh 1991-07-26 Add Array mtime to calling sequence to permit inclusion of receipt/transfer times to ifod messages.
      • +
    • Bill Cavanaugh 1991-09-25 All processing of decoded bufr data into ifod (a local use reformat of bufr data) has been isolated from this set of routines. for those interested in the ifod form, see w3fl05 in the w3lib routines. processing of bufr messages containing delayed replication has been altered so that single subsets (reports) and and a matching descriptor list for that particular subset will be passed to the user will be passed to the user one at a time to assure that each subset can be fully defined with a minimum of reprocessing. processing of associated fields has been tested with messages containing non-compressed data. in order to facilitate user processing a matching list of scale factors are included with the expanded descriptor list (mstack).
      • +
    • Bill Cavanaugh 1991-11-21 Processing of descriptor 2 03 yyy has corrected to agree with fm94 standards.
      • +
    • Bill Cavanaugh 1991-12-19 Calls to fi8803 and fi8804 have been corrected to agree called program argument list. some additional entries have been included for communicating with data access routines. additional error exit provided for the case where table b is damaged.
      • +
    • Bill Cavanaugh 1992-01-24 Routines fi8801, fi8803 and fi8804 have been modified to handle associated fields all descriptors are set to echo to mstack(1,n)
      • +
    • Bill Cavanaugh 1992-05-21 Further expansion of information collected from within upper air soundings has produced the necessity to expand some of the processing and output arrays. (see remarks below) corrected descriptor denoting height of each wind level for profiler conversions.
      • +
    • Bill Cavanaugh 1992-07-23 Expansion of table b requires adjustment of arrays to contain table b values needed to assist in the decoding process. arrays containing data from table b
      • +
    • KFXY1 Descriptor
      • +
    • ANAME1 Descriptor name
      • +
    • AUNIT1 Units for descriptor
      • +
    • ISCAL1 Scale for value of descriptor
      • +
    • IRFVL1 Reference value for descriptor
      • +
    • IWIDE1 Bit width for value of descriptor
      • +
    • Bill Cavanaugh 1992-09-09 First encounter with operator descriptor 2 05 yyy showed error in decoding. that error is corrected with this implementation. further testing of upper air data has encountered the condition of large (many level) soundings arrays in the decoder have been expanded (again) to allow for this condition.
      • +
    • Bill Cavanaugh 1992-10-02 Modified routine to reformat profiler data (fi8809) to show descriptors, scale value and data in proper order. corrected an error that prevented user from assigning the second dimension of kdata(500,*).
      • +
    • Bill Cavanaugh 1992-10-20 Removed error that prevented full implementation of previous corrections and made corrections to table b to bring it up to date. changes include proper reformat of profiler data and user capability for assigning second dimension of kdata array.
      • +
    • Bill Cavanaugh 1992-12-09 Thanks to dennis keyser for the suggestions and coding, this implementation will allow the inclusion of unit numbers for tables b & d, and in addition allows for realistic sizing of kdata and mstack arrays by the user. as of this implementation, the upper size limit for a bufr message allows for a message size greater than 15000 bytes.
      • +
    • Bill Cavanaugh 1993-01-26 Routine fi8810 has been added to permit reformatting of profiler data in edition 2.
      • +
    • Bill Cavanaugh 1993-05-13 Routine fi8811 has been added to permit processing of run-line encoding. this provides for the handling of data for graphics products. please note the addition of two arguments in the calling sequence.
      • +
    • Bill Cavanaugh 1993-12-01 Routine fi8803 to correct handling of associated fields and arrays associated with table b entries enlarged to handle larger table b
      • +
    • Bill Cavanaugh 1994-05-25 Routines have been modified to construct a modified table b i.e., it is tailored to contain o those descriptors that will be used to decode data in current and subsequent bufr messages. table b and table d descriptors will be isolated and merged with the main tables for use with following bufr messages. the descriptors indicating the replication of descriptors and data are activated with this implementation.
      • +
    • Bill Cavanaugh 1994-08-30 Added statements that will allow use of these routines directly on the cray with no modification. handling od table d entries has been modified to prevent loss of ancillary entries. coding has been added to allow processing on either an 8 byte word or 4 byte word machine.
      • +
    +

    For those users of the bufr decoder that are processing sets of bufr messages that include type 11 messages, coding has been added to allow the recovery of the added or modified table b entries by writing them to a disk file available to the user. this is accomplished with no change to the calling sequence. table b entries will be designated as follows: IUNITB - Is the unit number for the master table b. IUNITB+1 - Will be the unit number for the table b entries that are to be used in the decoding of subsequent messages. this device will be formatted the same the disk file on iunitb.

    +
      +
    • Dennis Keyser 1995-06-07 Corrected an error which required input argument "maxd" to be nearly twice as large as needed for decoding wind profiler reports (limit upper bound for "iwork" array was set to "maxd", now it is set to 15000). also, a correction was made in the wind profiler processing to prevent unnecessary looping when all requested descriptors are missing. also corrected an error which resulted in returned scale in "mstack(2, ..)" always being set to zero for compressed data.
      • +
    • Bill Cavanaugh 1996-02-15 Modified identification of ascii/ebcdic machine. modified handling of table b to permit faster processing of multiple messages with changing data types and/or subtypes.
      • +
    • Bill Cavanaugh 1996-04-02 Deactivated extraneous write statement. enlarged arrays for table b entries to contain up to 1300 entries in preparation for new additions to table b.
      • +
    • Dennis Keyser 2001-02-01 The table b file will now be read whenever the input argument "iunitb" (table b unit number) changes from its value in the previous call to this routine (normally it is only read the first time this routine is called)
      • +
    • Boi Vuong 2002-10-15 Replaced function ichar with mova2i
      • +
    +
    Parameters
    + + + + + + + + + + + + + + + +
    [in]MSGAArray containing supposed bufr message size is determined by user, can be greater than 15000 bytes.
    [in]MAXRMaximum number of reports/subsets that may be contained in a bufr message
    [in]MAXDMaximum number of descriptor combinations that may be processed; upper air data and some satellite data require a value for maxd of 1700, but for most other data a value for maxd of 500 will suffice
    [in]IUNITBUnit number of data set holding table b, this is the number of a pair of data sets -IUNITB+Unit number for a dataset to contain table b entries from master table b and table b entries extracted from type 11 bufr messages that were used to decode current bufr messages.
    [in]IUNITDUnit number of data set holding tab
    [out]ISTACKOriginal array of descriptors extracted from source bufr message.
    [out]MSTACK(A,B)-LEVEL B Descriptor number (limited to value of input argument maxd)
      +
    • Level A:
        +
      • = 1 Descriptor
        • +
      • = 2 10**N scaling to return to original value
        • +
      +
      • +
    +
    [out]IPTRUtility array (should have at last 42 entries)
      +
    • IPTR(1)- Error return
      • +
    • IPTR(2)- Byte count section 1
      • +
    • IPTR(3)- Pointer to start of section 1
      • +
    • IPTR(4)- Byte count section 2
      • +
    • IPTR(5)- Pointer to start of section 2
      • +
    • IPTR(6)- Byte count section 3
      • +
    • IPTR(7)- Pointer to start of section 3
      • +
    • IPTR(8)- Byte count section 4
      • +
    • IPTR(9)- Pointer to start of section 4
      • +
    • IPTR(10)- Start of requested subset, reserved for dar
      • +
    • IPTR(11)- Current descriptor ptr in iwork
      • +
    • IPTR(12)- Last descriptor pos in iwork
      • +
    • IPTR(13)- Last descriptor pos in istack
      • +
    • IPTR(14)- Number of master table b entries
      • +
    • IPTR(15)- Requested subset pointer, reserved for dar
      • +
    • IPTR(16)- Indicator for existance of section 2
      • +
    • IPTR(17)- Number of reports processed
      • +
    • IPTR(18)- Ascii/text event
      • +
    • IPTR(19)- Pointer to start of bufr message
      • +
    • IPTR(20)- Number of entries from table d
      • +
    • IPTR(21)- Nr table b entries
      • +
    • IPTR(22)- Nr table b entries from current message
      • +
    • IPTR(23)- Code/flag table switch
      • +
    • IPTR(24)- Aditional words added by text info
      • +
    • IPTR(25)- Current bit number
      • +
    • IPTR(26)- Data width change - add to table b width
      • +
    • IPTR(27)- Data scale change - modifies table b scale
      • +
    • IPTR(28)- Data reference value change - ?????????
      • +
    • IPTR(29)- Add data associated field
      • +
    • IPTR(30)- Signify characters
      • +
    • IPTR(31)- Number of expanded descriptors in mstack
      • +
    • IPTR(32)- Current descriptor segment f
      • +
    • IPTR(33)- Current descriptor segment x
      • +
    • IPTR(34)- Current descriptor segment y
      • +
    • IPTR(35)- Data/descriptor replication in progress
        +
      • 0 = No
        • +
      • 1 = Yes
        • +
      +
      • +
    • IPTR(36)- Next descriptor may be undecipherable
      • +
    • IPTR(37)- Machine text type flag
        +
      • 0 = EBCIDIC
        • +
      • 1 = ASCII
        • +
      +
      • +
    • IPTR(38)- Data/descriptor replication flag
        +
      • 0 - Does not exist in current message
        • +
      • 1 - Exists in current message
        • +
      +
      • +
    • IPTR(39)- Delayed replication flag
        +
      • 0 - No delayed replication
        • +
      • 1 - Message contains delayed replication
        • +
      +
      • +
    • IPTR(40)- Number of characters in text for curr descriptor
      • +
    • IPTR(41)- Number of ancillary table b entries
      • +
    • IPTR(42)- Number of ancillary table d entries
      • +
    • IPTR(43)- Number of added table b entries encountered while processing a bufr message. these entries only exist durng processing of current bufr message IPTR(44)- Bits per word IPTR(45)- Bytes per word
      • +
    +
    [out]IDENTArray contains message information extracted from BUFR message:
      +
    • IDENT(1) - Edition number (byte 4, section 1)
      • +
    • IDENT(2) - Originating center (bytes 5-6, section 1)
      • +
    • IDENT(3) - Update sequence (byte 7, section 1)
      • +
    • IDENT(4) - Optional section (byte 8, section 1)
      • +
    • IDENT(5) - Bufr message type (byte 9, section 1)
        +
      • 0 = Surface data (land)
        • +
      • 1 = Surface data (ship)
        • +
      • 2 = Vertical soundings (other than satellite)
        • +
      • 3 = Vertical soundings (satellite)
        • +
      • 4 = Single lvl upper-air data(other than satellite)
        • +
      • 5 = Single level upper-air data (satellite)
        • +
      • 6 = Radar data
        • +
      • 7 = Synoptic features
        • +
      • 8 = Physical/chemical constituents
        • +
      • 9 = Dispersal and transport
        • +
      • 10 = Radiological data
        • +
      • 11 = Bufr tables (complete, replacement or update)
        • +
      • 12 = Surface data (satellite)
        • +
      • 21 = Radiances (satellite measured)
        • +
      • 31 = Oceanographic data
        • +
      +
      • +
    • IDENT(6) - Bufr msg sub-type (byte 10, section 1) + + + + +
      TYPE SBTYP
      2 7 = PROFILER
      +
      • +
    • IDENT(7) - (bytes 11-12, section 1)
      • +
    • IDENT(8) - Year of century (byte 13, section 1)
      • +
    • IDENT(9) - Month of year (byte 14, section 1)
      • +
    • IDENT(10) - Day of month (byte 15, section 1)
      • +
    • IDENT(11) - Hour of day (byte 16, section 1)
      • +
    • IDENT(12) - Minute of hour (byte 17, section 1)
      • +
    • IDENT(13) - Rsvd by adp centers(byte 18, section 1)
      • +
    • IDENT(14) - Nr of data subsets (byte 5-6, section 3)
      • +
    • IDENT(15) - Observed flag (byte 7, bit 1, section 3)
      • +
    • IDENT(16) - Compression flag (byte 7, bit 2, section 3)
      • +
    • IDENT(17) - Master table number(byte 4, section 1, ed 2 or gtr)
      • +
    +
    [out]KDATAArray containing decoded reports from bufr message. KDATA(Report number,parameter number) (Report number limited to value of input argument maxr and parameter number limited to value of input argument maxd)
    [out]INDEXPointer to available subset
    KNR
    LDATA
    LSTACK
    + Arrays containing data from table b new - base arrays containing data from table b
      +
    • KFXY1 - Decimal descriptor value of f x y values
      • +
    • ANAME1 - Descriptor name
      • +
    • AUNIT1 - Units for descriptor
      • +
    • ISCAL1 - Scale for value of descriptor
      • +
    • IRFVL1 - Reference value for descriptor
      • +
    +
    +
    +
    +

    +- IWIDE1 - Bit width for value of descriptor

    +

    New - ancillary arrays containing data from table b containing table b entries extracted from type 11 bufr messages

      +
    • KFXY2 - Decimal descriptor value of f x y values
      • +
    • ANAME2 - Descriptor name
      • +
    • AUNIT2 - Units for descriptor
      • +
    • ISCAL2 - Scale for value of descriptor
      • +
    • IRFVL2 - Reference value for descriptor
      • +
    +

    +- IWIDE2 - Bit width for value of descriptor

    +

    New - added arrays containing data from table b containing table b entries extracted from non-type 11 bufr messages these exist for the life of current bufr message

      +
    • KFXY3 - Decimal descriptor value of f x y values
      • +
    • ANAME3 - Descriptor name
      • +
    • AUNIT3 - Units for descriptor
      • +
    • ISCAL3 - Scale for value of descriptor
      • +
    • IRFVL3 - Reference value for descriptor
      • +
    +

    +- IWIDE3 - Bit width for value of descriptor

    +

    Error returns: IPTR(1)

      +
    • = 1 'BUFR' Not found in first 125 characters
      • +
    • = 2 '7777' Not found in location determined by by using counts found in each section. one or more sections have an erroneous byte count or characters '7777' are not in test message.
      • +
    • = 3 Message contains a descriptor with f=0 that does not exist in table b.
      • +
    • = 4 Message contains a descriptor with f=3 that does not exist in table d.
      • +
    • = 5 Message contains a descriptor with f=2 with the value of x outside the range 1-6.
      • +
    • = 6 Descriptor element indicated to have a flag value does not have an entry in the flag table. (to be activated)
      • +
    • = 7 Descriptor indicated to have a code value does not have an entry in the code table. (to be activated)
      • +
    • = 8 Error reading table d
      • +
    • = 9 Error reading table b
      • +
    • = 10 Error reading code/flag table
      • +
    • = 11 Descriptor 2 04 004 not followed by 0 31 021
      • +
    • = 12 Data descriptor operator qualifier does not follow delayed replication descriptor.
      • +
    • = 13 Bit width on ascii characters not a multiple of 8
      • +
    • = 14 Subsets = 0, no content bulletin
      • +
    • = 20 Exceeded count for delayed replication pass
      • +
    • = 21 Exceeded count for non-delayed replication pass
      • +
    • = 22 Exceeded combined bit width, bit width > 32
      • +
    • = 23 No element descriptors following 2 03 yyy
      • +
    • = 27 Non zero lowest on text data
      • +
    • = 28 Nbinc not nr of characters
      • +
    • = 29 Table b appears to be damaged
      • +
    • = 30 Table d entry with more than 18 in sequence being entered from type 11 message
      • +
    • = 99 No more subsets (reports) available in current bufr mesage
      • +
    • = 400 Number of subsets exceeds the value of input argument maxr; must increase maxr to value of ident(14) in calling program
      • +
    • = 401 Number of parameters (and associated fields) exceeds limits of this program.
      • +
    • = 500 Value for nbinc has been found that exceeds standard width plus any bit width change. check all bit widths up to point of error.
      • +
    • = 501 Corrected width for descriptor is 0 or less
      • +
    • = 888 Non-numeric character in conversion request
      • +
    • = 890 Class 0 element descriptor w/width of 0
      • +
    +

    On the initial call to w3fi88 with a bufr message the argument index must be set to zero (index = 0). on the return from w3fi88 'index' will be set to the next available subset/report. when there are no more subsets available a 99 err return will occur.

    +

    If the original bufr message does not contain delayed replication the bufr message will be completely decoded and 'index' will point to the first decoded subset. the users will then have the option of indexing through the subsets on their own or by recalling this routine (without resetting 'index') to have the routine do the indexing.

    +

    If the original bufr message does contain delayed replication one subset/report will be decoded at a time and passed back to the user. this is not an option.

    +
    +

    +To use this routine

    +

    the arrays to contain the output information are defined as follows: 

    KDATA(A,B)  is the a data entry  (integer value)
+            where a is the maximum number of reports/subsets
+            that may be contained in the bufr message (this
+            is now set to "maxr" which is passed as an input
+            argument to w3fi88), and where b is the maximum
+            number of descriptor combinations that may
+            be processed (this is now set to "maxd" which
+            is also passed as an input argument to w3fi88;
+            upper air data and some satellite data require
+            a value for maxd of 1700, but for most other
+            data a value for maxd of 500 will suffice)
+MSTACK(1,B) contains the descriptor that matches the
+            data entry (max. value for b is now "maxd"
+            which is passed as an input argument to w3fi88)
+MSTACK(2,B) is the scale (power of 10) to be applied to
+            the data (max. value for b is now "maxd"
+            which is passed as an input argument to w3fi88)
+
    +

    Definition at line 439 of file w3fi88.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi88_8f.js b/ver-2.10.0/w3fi88_8f.js new file mode 100644 index 00000000..9823edb1 --- /dev/null +++ b/ver-2.10.0/w3fi88_8f.js @@ -0,0 +1,22 @@ +var w3fi88_8f = +[ + [ "fi8801", "w3fi88_8f.html#ae5d0192919fea00763c2ea1490bff16a", null ], + [ "fi8802", "w3fi88_8f.html#a7829bc0e44ec367834a1a6d83377d428", null ], + [ "fi8803", "w3fi88_8f.html#a228b9ca88ab5e42aa00c6df379ecd470", null ], + [ "fi8804", "w3fi88_8f.html#a94b6d994b2df117c1395048caea2f86b", null ], + [ "fi8805", "w3fi88_8f.html#a45180c8723bc0f7b3eaff47b7fda7ed8", null ], + [ "fi8806", "w3fi88_8f.html#a119b554db1325ff6b2d3742797f107dd", null ], + [ "fi8807", "w3fi88_8f.html#aa56d7f5f943a7bf774c2e9ddc144595f", null ], + [ "fi8808", "w3fi88_8f.html#a2a7856fc62e88d8fa8670e58c4082293", null ], + [ "fi8809", "w3fi88_8f.html#a334e81d3c01ac71a02ef5425671e7bf0", null ], + [ "fi8810", "w3fi88_8f.html#adad8332e2168ab134f2c6f879f133a5f", null ], + [ "fi8811", "w3fi88_8f.html#a12b020b46772271cab997bb781bda9c1", null ], + [ "fi8812", "w3fi88_8f.html#a5d193ac75cc3a3a167b66c2fe484bcf5", null ], + [ "fi8813", "w3fi88_8f.html#adbabb10d7dd7f6a7de08d6d415d1e876", null ], + [ "fi8814", "w3fi88_8f.html#a4f8b235c2c2a9b5bb74da9207021384e", null ], + [ "fi8815", "w3fi88_8f.html#abb7e96e4b35aa7e920bc388cdc5b43f0", null ], + [ "fi8818", "w3fi88_8f.html#a4d95a6e5cfd0779cd61856302084ba4a", null ], + [ "fi8819", "w3fi88_8f.html#ab79c59537e969d0ca237e032cb41261b", null ], + [ "fi8820", "w3fi88_8f.html#a7bbb69a4b21fc8e813cdf6b0497b3d53", null ], + [ "w3fi88", "w3fi88_8f.html#aaa3b36f853bace0e172b8191ce3a4f17", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi88_8f_source.html b/ver-2.10.0/w3fi88_8f_source.html new file mode 100644 index 00000000..cbfe133e --- /dev/null +++ b/ver-2.10.0/w3fi88_8f_source.html @@ -0,0 +1,4701 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi88.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi88.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief BUFR message decoder
    +
    3 C> @author Bill Cavanaugh @date 1988-08-31
    +
    4 
    +
    5 C> This set of routines will decode a bufr message and
    +
    6 C> place information extracted from the bufr message into selected
    +
    7 C> arrays for the user. the array kdata can now be sized by the user
    +
    8 C> by indicating the maximum number of subsets and the maximum
    +
    9 C> number of descriptors that are expected in the course of decoding
    +
    10 C> selected input data. this allows for realistic sizing of kdata
    +
    11 C> and the mstack arrays. this version also allows for the inclusion
    +
    12 C> of the unit numbers for tables b and d into the
    +
    13 C> argument list. this routine does not include ifod processing.
    +
    14 C>
    +
    15 C> Program history log:
    +
    16 C> - Bill Cavanaugh 1988-08-31
    +
    17 C> - Bill Cavanaugh 1990-12-07 Now Utilizing gbyte routines to gather
    +
    18 C> and separate bit fields. this should improve
    +
    19 C> (decrease) the time it takes to decode any
    +
    20 C> bufr message. have entered coding that will
    +
    21 C> permit processing bufr editions 1 and 2.
    +
    22 C> improved and corrected the conversion into
    +
    23 C> ifod format of decoded bufr messages.
    +
    24 C> - Bill Cavanaugh 1991-01-18 Program/routines modified to properly handle
    +
    25 C> serial profiler data.
    +
    26 C> - Bill Cavanaugh 1991-04-04 Modified to handle text supplied thru
    +
    27 C> descriptor 2 05 yyy.
    +
    28 C> - Bill Cavanaugh 1991-04-17 Errors in extracting and scaling data
    +
    29 C> corrected. improved handling of nested
    +
    30 C> queue descriptors is added.
    +
    31 C> - Bill Cavanaugh 1991-05-10 Array 'data' has been enlarged to real*8
    +
    32 C> to better contain very large numbers more
    +
    33 C> accurately. the preious size real*4 could not
    +
    34 C> contain sufficient significant digits.
    +
    35 C> coding has been introduced to process new
    +
    36 C> table c descriptor 2 06 yyy which permits in
    +
    37 C> line processing of a local descriptor even if
    +
    38 C> the descriptor is not contained in the users
    +
    39 C> table b.
    +
    40 C> a second routine to process ifod messages
    +
    41 C> (ifod0) has been removed in favor of the
    +
    42 C> improved processing of the one
    +
    43 C> remaining (ifod1).
    +
    44 C> new coding has been introduced to permit
    +
    45 C> processing of bufr messages based on bufr
    +
    46 C> edition up to and including edition 2.
    +
    47 C> please note increased size requirements
    +
    48 C> for arrays ident(20) and iptr(40).
    +
    49 C> - Bill Cavanaugh 1991-07-26 Add Array mtime to calling sequence to
    +
    50 C> permit inclusion of receipt/transfer times
    +
    51 C> to ifod messages.
    +
    52 C> - Bill Cavanaugh 1991-09-25 All processing of decoded bufr data into
    +
    53 C> ifod (a local use reformat of bufr data)
    +
    54 C> has been isolated from this set of routines.
    +
    55 C> for those interested in the ifod form,
    +
    56 C> see w3fl05 in the w3lib routines.
    +
    57 C> processing of bufr messages containing
    +
    58 C> delayed replication has been altered so that
    +
    59 C> single subsets (reports) and and a matching
    +
    60 C> descriptor list for that particular subset
    +
    61 C> will be passed to the user will be passed to
    +
    62 C> the user one at a time to assure that each
    +
    63 C> subset can be fully defined with a minimum
    +
    64 C> of reprocessing.
    +
    65 C> processing of associated fields has been
    +
    66 C> tested with messages containing non-compressed
    +
    67 C> data.
    +
    68 C> in order to facilitate user processing
    +
    69 C> a matching list of scale factors are included
    +
    70 C> with the expanded descriptor list (mstack).
    +
    71 C> - Bill Cavanaugh 1991-11-21 Processing of descriptor 2 03 yyy
    +
    72 C> has corrected to agree with fm94 standards.
    +
    73 C> - Bill Cavanaugh 1991-12-19 Calls to fi8803 and fi8804 have been
    +
    74 C> corrected to agree called program argument
    +
    75 C> list. some additional entries have been
    +
    76 C> included for communicating with data access
    +
    77 C> routines. additional error exit provided for
    +
    78 C> the case where table b is damaged.
    +
    79 C> - Bill Cavanaugh 1992-01-24 Routines fi8801, fi8803 and fi8804
    +
    80 C> have been modified to handle associated fields
    +
    81 C> all descriptors are set to echo to mstack(1,n)
    +
    82 C> - Bill Cavanaugh 1992-05-21 Further expansion of information collected
    +
    83 C> from within upper air soundings has produced
    +
    84 C> the necessity to expand some of the processing
    +
    85 C> and output arrays. (see remarks below)
    +
    86 C> corrected descriptor denoting height of
    +
    87 C> each wind level for profiler conversions.
    +
    88 C> - Bill Cavanaugh 1992-07-23 Expansion of table b requires adjustment
    +
    89 C> of arrays to contain table b values needed to
    +
    90 C> assist in the decoding process.
    +
    91 C> arrays containing data from table b
    +
    92 C> - KFXY1 Descriptor
    +
    93 C> - ANAME1 Descriptor name
    +
    94 C> - AUNIT1 Units for descriptor
    +
    95 C> - ISCAL1 Scale for value of descriptor
    +
    96 C> - IRFVL1 Reference value for descriptor
    +
    97 C> - IWIDE1 Bit width for value of descriptor
    +
    98 C> - Bill Cavanaugh 1992-09-09 First encounter with operator descriptor
    +
    99 C> 2 05 yyy showed error in decoding. that error
    +
    100 C> is corrected with this implementation. further
    +
    101 C> testing of upper air data has encountered
    +
    102 C> the condition of large (many level) soundings
    +
    103 C> arrays in the decoder have been expanded (again)
    +
    104 C> to allow for this condition.
    +
    105 C> - Bill Cavanaugh 1992-10-02 Modified routine to reformat profiler data
    +
    106 C> (fi8809) to show descriptors, scale value and
    +
    107 C> data in proper order. corrected an error that
    +
    108 C> prevented user from assigning the second dimension
    +
    109 C> of kdata(500,*).
    +
    110 C> - Bill Cavanaugh 1992-10-20 Removed error that prevented full
    +
    111 C> implementation of previous corrections and
    +
    112 C> made corrections to table b to bring it up to
    +
    113 C> date. changes include proper reformat of profiler
    +
    114 C> data and user capability for assigning second
    +
    115 C> dimension of kdata array.
    +
    116 C> - Bill Cavanaugh 1992-12-09 Thanks to dennis keyser for the suggestions
    +
    117 C> and coding, this implementation will allow the
    +
    118 C> inclusion of unit numbers for tables b & d, and
    +
    119 C> in addition allows for realistic sizing of kdata
    +
    120 C> and mstack arrays by the user. as of this
    +
    121 C> implementation, the upper size limit for a bufr
    +
    122 C> message allows for a message size greater than
    +
    123 C> 15000 bytes.
    +
    124 C> - Bill Cavanaugh 1993-01-26 Routine fi8810 has been added to permit
    +
    125 C> reformatting of profiler data in edition 2.
    +
    126 C> - Bill Cavanaugh 1993-05-13 Routine fi8811 has been added to permit
    +
    127 C> processing of run-line encoding. this provides for
    +
    128 C> the handling of data for graphics products.
    +
    129 C> please note the addition of two arguments in the
    +
    130 C> calling sequence.
    +
    131 C> - Bill Cavanaugh 1993-12-01 Routine fi8803 to correct handling of
    +
    132 C> associated fields and arrays associated with
    +
    133 C> table b entries enlarged to handle larger table b
    +
    134 C> - Bill Cavanaugh 1994-05-25 Routines have been modified to construct a
    +
    135 C> modified table b i.e., it is tailored to contain o
    +
    136 C> those descriptors that will be used to decode
    +
    137 C> data in current and subsequent bufr messages.
    +
    138 C> table b and table d descriptors will be isolated
    +
    139 C> and merged with the main tables for use with
    +
    140 C> following bufr messages.
    +
    141 C> the descriptors indicating the replication of
    +
    142 C> descriptors and data are activated with this
    +
    143 C> implementation.
    +
    144 C> - Bill Cavanaugh 1994-08-30 Added statements that will allow use of
    +
    145 C> these routines directly on the cray with no
    +
    146 C> modification. handling od table d entries has been
    +
    147 C> modified to prevent loss of ancillary entries.
    +
    148 C> coding has been added to allow processing on
    +
    149 C> either an 8 byte word or 4 byte word machine.
    +
    150 C>
    +
    151 C> For those users of the bufr decoder that are
    +
    152 C> processing sets of bufr messages that include
    +
    153 C> type 11 messages, coding has been added to allow
    +
    154 C> the recovery of the added or modified table b
    +
    155 C> entries by writing them to a disk file available
    +
    156 C> to the user. this is accomplished with no change
    +
    157 C> to the calling sequence. table b entries will be
    +
    158 C> designated as follows:
    +
    159 C> IUNITB - Is the unit number for the master table b.
    +
    160 C> IUNITB+1 - Will be the unit number for the table b entries that are to be used
    +
    161 C> in the decoding of subsequent messages. this device will be formatted the same
    +
    162 C> the disk file on iunitb.
    +
    163 C>
    +
    164 C> - Dennis Keyser 1995-06-07 Corrected an error which required input
    +
    165 C> argument "maxd" to be nearly twice as large as
    +
    166 C> needed for decoding wind profiler reports (limit
    +
    167 C> upper bound for "iwork" array was set to "maxd",
    +
    168 C> now it is set to 15000). also, a correction was
    +
    169 C> made in the wind profiler processing to prevent
    +
    170 C> unnecessary looping when all requested
    +
    171 C> descriptors are missing. also corrected an
    +
    172 C> error which resulted in returned scale in
    +
    173 C> "mstack(2, ..)" always being set to zero for
    +
    174 C> compressed data.
    +
    175 C> - Bill Cavanaugh 1996-02-15 Modified identification of ascii/ebcdic
    +
    176 C> machine. modified handling of table b to permit
    +
    177 C> faster processing of multiple messages with
    +
    178 C> changing data types and/or subtypes.
    +
    179 C> - Bill Cavanaugh 1996-04-02 Deactivated extraneous write statement.
    +
    180 C> enlarged arrays for table b entries to contain
    +
    181 C> up to 1300 entries in preparation for new
    +
    182 C> additions to table b.
    +
    183 C> - Dennis Keyser 2001-02-01 The table b file will now be read whenever the
    +
    184 C> input argument "iunitb" (table b unit number)
    +
    185 C> changes from its value in the previous call to
    +
    186 C> this routine (normally it is only read the
    +
    187 C> first time this routine is called)
    +
    188 C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i
    +
    189 C>
    +
    190 C> @param[in] MSGA Array containing supposed bufr message
    +
    191 C> size is determined by user, can be greater
    +
    192 C> than 15000 bytes.
    +
    193 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    194 C> contained in a bufr message
    +
    195 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    196 C> may be processed; upper air data and some satellite
    +
    197 C> data require a value for maxd of 1700, but for most
    +
    198 C> other data a value for maxd of 500 will suffice
    +
    199 C> @param[in] IUNITB Unit number of data set holding table b, this is the
    +
    200 C> number of a pair of data sets
    +
    201 C> -IUNITB+Unit number for a dataset to contain table b entries
    +
    202 C> from master table b and table b entries extracted
    +
    203 C> from type 11 bufr messages that were used to decode
    +
    204 C> current bufr messages.
    +
    205 C> @param[in] IUNITD Unit number of data set holding tab
    +
    206 C> @param[out] ISTACK Original array of descriptors extracted from
    +
    207 C> source bufr message.
    +
    208 C> @param[out] MSTACK (A,B)-LEVEL B Descriptor number (limited to value of
    +
    209 C> input argument maxd)
    +
    210 C> - Level A:
    +
    211 C> - = 1 Descriptor
    +
    212 C> - = 2 10**N scaling to return to original value
    +
    213 C> @param[out] IPTR Utility array (should have at last 42 entries)
    +
    214 C> - IPTR(1)- Error return
    +
    215 C> - IPTR(2)- Byte count section 1
    +
    216 C> - IPTR(3)- Pointer to start of section 1
    +
    217 C> - IPTR(4)- Byte count section 2
    +
    218 C> - IPTR(5)- Pointer to start of section 2
    +
    219 C> - IPTR(6)- Byte count section 3
    +
    220 C> - IPTR(7)- Pointer to start of section 3
    +
    221 C> - IPTR(8)- Byte count section 4
    +
    222 C> - IPTR(9)- Pointer to start of section 4
    +
    223 C> - IPTR(10)- Start of requested subset, reserved for dar
    +
    224 C> - IPTR(11)- Current descriptor ptr in iwork
    +
    225 C> - IPTR(12)- Last descriptor pos in iwork
    +
    226 C> - IPTR(13)- Last descriptor pos in istack
    +
    227 C> - IPTR(14)- Number of master table b entries
    +
    228 C> - IPTR(15)- Requested subset pointer, reserved for dar
    +
    229 C> - IPTR(16)- Indicator for existance of section 2
    +
    230 C> - IPTR(17)- Number of reports processed
    +
    231 C> - IPTR(18)- Ascii/text event
    +
    232 C> - IPTR(19)- Pointer to start of bufr message
    +
    233 C> - IPTR(20)- Number of entries from table d
    +
    234 C> - IPTR(21)- Nr table b entries
    +
    235 C> - IPTR(22)- Nr table b entries from current message
    +
    236 C> - IPTR(23)- Code/flag table switch
    +
    237 C> - IPTR(24)- Aditional words added by text info
    +
    238 C> - IPTR(25)- Current bit number
    +
    239 C> - IPTR(26)- Data width change - add to table b width
    +
    240 C> - IPTR(27)- Data scale change - modifies table b scale
    +
    241 C> - IPTR(28)- Data reference value change - ?????????
    +
    242 C> - IPTR(29)- Add data associated field
    +
    243 C> - IPTR(30)- Signify characters
    +
    244 C> - IPTR(31)- Number of expanded descriptors in mstack
    +
    245 C> - IPTR(32)- Current descriptor segment f
    +
    246 C> - IPTR(33)- Current descriptor segment x
    +
    247 C> - IPTR(34)- Current descriptor segment y
    +
    248 C> - IPTR(35)- Data/descriptor replication in progress
    +
    249 C> - 0 = No
    +
    250 C> - 1 = Yes
    +
    251 C> - IPTR(36)- Next descriptor may be undecipherable
    +
    252 C> - IPTR(37)- Machine text type flag
    +
    253 C> - 0 = EBCIDIC
    +
    254 C> - 1 = ASCII
    +
    255 C> - IPTR(38)- Data/descriptor replication flag
    +
    256 C> - 0 - Does not exist in current message
    +
    257 C> - 1 - Exists in current message
    +
    258 C> - IPTR(39)- Delayed replication flag
    +
    259 C> - 0 - No delayed replication
    +
    260 C> - 1 - Message contains delayed replication
    +
    261 C> - IPTR(40)- Number of characters in text for curr descriptor
    +
    262 C> - IPTR(41)- Number of ancillary table b entries
    +
    263 C> - IPTR(42)- Number of ancillary table d entries
    +
    264 C> - IPTR(43)- Number of added table b entries encountered while
    +
    265 C> processing a bufr message. these entries only
    +
    266 C> exist durng processing of current bufr message
    +
    267 C> IPTR(44)- Bits per word
    +
    268 C> IPTR(45)- Bytes per word
    +
    269 C> @param[out] IDENT Array contains message information extracted from BUFR message:
    +
    270 C> - IDENT(1) - Edition number (byte 4, section 1)
    +
    271 C> - IDENT(2) - Originating center (bytes 5-6, section 1)
    +
    272 C> - IDENT(3) - Update sequence (byte 7, section 1)
    +
    273 C> - IDENT(4) - Optional section (byte 8, section 1)
    +
    274 C> - IDENT(5) - Bufr message type (byte 9, section 1)
    +
    275 C> - 0 = Surface data (land)
    +
    276 C> - 1 = Surface data (ship)
    +
    277 C> - 2 = Vertical soundings (other than satellite)
    +
    278 C> - 3 = Vertical soundings (satellite)
    +
    279 C> - 4 = Single lvl upper-air data(other than satellite)
    +
    280 C> - 5 = Single level upper-air data (satellite)
    +
    281 C> - 6 = Radar data
    +
    282 C> - 7 = Synoptic features
    +
    283 C> - 8 = Physical/chemical constituents
    +
    284 C> - 9 = Dispersal and transport
    +
    285 C> - 10 = Radiological data
    +
    286 C> - 11 = Bufr tables (complete, replacement or update)
    +
    287 C> - 12 = Surface data (satellite)
    +
    288 C> - 21 = Radiances (satellite measured)
    +
    289 C> - 31 = Oceanographic data
    +
    290 C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
    +
    291 C> | TYPE | SBTYP |
    +
    292 C> | :--- | :---- |
    +
    293 C> | 2 | 7 = PROFILER |
    +
    294 C> - IDENT(7) - (bytes 11-12, section 1)
    +
    295 C> - IDENT(8) - Year of century (byte 13, section 1)
    +
    296 C> - IDENT(9) - Month of year (byte 14, section 1)
    +
    297 C> - IDENT(10) - Day of month (byte 15, section 1)
    +
    298 C> - IDENT(11) - Hour of day (byte 16, section 1)
    +
    299 C> - IDENT(12) - Minute of hour (byte 17, section 1)
    +
    300 C> - IDENT(13) - Rsvd by adp centers(byte 18, section 1)
    +
    301 C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
    +
    302 C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
    +
    303 C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
    +
    304 C> - IDENT(17) - Master table number(byte 4, section 1, ed 2 or gtr)
    +
    305 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    306 C> KDATA(Report number,parameter number)
    +
    307 C> (Report number limited to value of input argument
    +
    308 C> maxr and parameter number limited to value of input
    +
    309 C> argument maxd)
    +
    310 C> @param[out] INDEX Pointer to available subset
    +
    311 C> @param KNR
    +
    312 C> @param LDATA
    +
    313 C> @param LSTACK
    +
    314 C>
    +
    315 C> ===========================================================
    +
    316 C> Arrays containing data from table b
    +
    317 C> new - base arrays containing data from table b
    +
    318 C> - KFXY1 - Decimal descriptor value of f x y values
    +
    319 C> - ANAME1 - Descriptor name
    +
    320 C> - AUNIT1 - Units for descriptor
    +
    321 C> - ISCAL1 - Scale for value of descriptor
    +
    322 C> - IRFVL1 - Reference value for descriptor
    +
    323 C> - IWIDE1 - Bit width for value of descriptor
    +
    324 C> ===========================================================
    +
    325 C> New - ancillary arrays containing data from table b
    +
    326 C> containing table b entries extracted
    +
    327 C> from type 11 bufr messages
    +
    328 C> - KFXY2 - Decimal descriptor value of f x y values
    +
    329 C> - ANAME2 - Descriptor name
    +
    330 C> - AUNIT2 - Units for descriptor
    +
    331 C> - ISCAL2 - Scale for value of descriptor
    +
    332 C> - IRFVL2 - Reference value for descriptor
    +
    333 C> - IWIDE2 - Bit width for value of descriptor
    +
    334 C> ===========================================================
    +
    335 C> New - added arrays containing data from table b
    +
    336 C> containing table b entries extracted
    +
    337 C> from non-type 11 bufr messages
    +
    338 C> these exist for the life of current bufr message
    +
    339 C> - KFXY3 - Decimal descriptor value of f x y values
    +
    340 C> - ANAME3 - Descriptor name
    +
    341 C> - AUNIT3 - Units for descriptor
    +
    342 C> - ISCAL3 - Scale for value of descriptor
    +
    343 C> - IRFVL3 - Reference value for descriptor
    +
    344 C> - IWIDE3 - Bit width for value of descriptor
    +
    345 C> ===========================================================
    +
    346 C>
    +
    347 C> Error returns:
    +
    348 C> IPTR(1)
    +
    349 C> - = 1 'BUFR' Not found in first 125 characters
    +
    350 C> - = 2 '7777' Not found in location determined by
    +
    351 C> by using counts found in each section. one or
    +
    352 C> more sections have an erroneous byte count or
    +
    353 C> characters '7777' are not in test message.
    +
    354 C> - = 3 Message contains a descriptor with f=0 that does
    +
    355 C> not exist in table b.
    +
    356 C> - = 4 Message contains a descriptor with f=3 that does
    +
    357 C> not exist in table d.
    +
    358 C> - = 5 Message contains a descriptor with f=2 with the
    +
    359 C> value of x outside the range 1-6.
    +
    360 C> - = 6 Descriptor element indicated to have a flag value
    +
    361 C> does not have an entry in the flag table.
    +
    362 C> (to be activated)
    +
    363 C> - = 7 Descriptor indicated to have a code value does
    +
    364 C> not have an entry in the code table.
    +
    365 C> (to be activated)
    +
    366 C> - = 8 Error reading table d
    +
    367 C> - = 9 Error reading table b
    +
    368 C> - = 10 Error reading code/flag table
    +
    369 C> - = 11 Descriptor 2 04 004 not followed by 0 31 021
    +
    370 C> - = 12 Data descriptor operator qualifier does not follow
    +
    371 C> delayed replication descriptor.
    +
    372 C> - = 13 Bit width on ascii characters not a multiple of 8
    +
    373 C> - = 14 Subsets = 0, no content bulletin
    +
    374 C> - = 20 Exceeded count for delayed replication pass
    +
    375 C> - = 21 Exceeded count for non-delayed replication pass
    +
    376 C> - = 22 Exceeded combined bit width, bit width > 32
    +
    377 C> - = 23 No element descriptors following 2 03 yyy
    +
    378 C> - = 27 Non zero lowest on text data
    +
    379 C> - = 28 Nbinc not nr of characters
    +
    380 C> - = 29 Table b appears to be damaged
    +
    381 C> - = 30 Table d entry with more than 18 in sequence
    +
    382 C> being entered from type 11 message
    +
    383 C> - = 99 No more subsets (reports) available in current
    +
    384 C> bufr mesage
    +
    385 C> - = 400 Number of subsets exceeds the value of input
    +
    386 C> argument maxr; must increase maxr to value of
    +
    387 C> ident(14) in calling program
    +
    388 C> - = 401 Number of parameters (and associated fields)
    +
    389 C> exceeds limits of this program.
    +
    390 C> - = 500 Value for nbinc has been found that exceeds
    +
    391 C> standard width plus any bit width change.
    +
    392 C> check all bit widths up to point of error.
    +
    393 C> - = 501 Corrected width for descriptor is 0 or less
    +
    394 C> - = 888 Non-numeric character in conversion request
    +
    395 C> - = 890 Class 0 element descriptor w/width of 0
    +
    396 C>
    +
    397 C> On the initial call to w3fi88 with a bufr message the argument
    +
    398 C> index must be set to zero (index = 0). on the return from w3fi88
    +
    399 C> 'index' will be set to the next available subset/report. when
    +
    400 C> there are no more subsets available a 99 err return will occur.
    +
    401 C>
    +
    402 C> If the original bufr message does not contain delayed replication
    +
    403 C> the bufr message will be completely decoded and 'index' will point
    +
    404 C> to the first decoded subset. the users will then have the option
    +
    405 C> of indexing through the subsets on their own or by recalling this
    +
    406 C> routine (without resetting 'index') to have the routine do the
    +
    407 C> indexing.
    +
    408 C>
    +
    409 C> If the original bufr message does contain delayed replication
    +
    410 C> one subset/report will be decoded at a time and passed back to
    +
    411 C> the user. this is not an option.
    +
    412 C>
    +
    413 C> =============================================
    +
    414 C> To use this routine
    +
    415 C> =============================================
    +
    416 C> the arrays to contain the output information are defined
    +
    417 C> as follows:
    +
    418 C>
    +
    419 C> KDATA(A,B) is the a data entry (integer value)
    +
    420 C> where a is the maximum number of reports/subsets
    +
    421 C> that may be contained in the bufr message (this
    +
    422 C> is now set to "maxr" which is passed as an input
    +
    423 C> argument to w3fi88), and where b is the maximum
    +
    424 C> number of descriptor combinations that may
    +
    425 C> be processed (this is now set to "maxd" which
    +
    426 C> is also passed as an input argument to w3fi88;
    +
    427 C> upper air data and some satellite data require
    +
    428 C> a value for maxd of 1700, but for most other
    +
    429 C> data a value for maxd of 500 will suffice)
    +
    430 C> MSTACK(1,B) contains the descriptor that matches the
    +
    431 C> data entry (max. value for b is now "maxd"
    +
    432 C> which is passed as an input argument to w3fi88)
    +
    433 C> MSTACK(2,B) is the scale (power of 10) to be applied to
    +
    434 C> the data (max. value for b is now "maxd"
    +
    435 C> which is passed as an input argument to w3fi88)
    +
    436 C>
    +
    437  SUBROUTINE w3fi88(IPTR,IDENT,MSGA,ISTACK,MSTACK,KDATA,KNR,INDEX,
    +
    438  * LDATA,LSTACK,MAXR,MAXD,IUNITB,IUNITD)
    +
    439 C
    +
    440 C
    +
    441 C
    +
    442 C THE MEMORY REQUIREMENTS FOR LSTACK AND LDATA ARE USED WITH
    +
    443 C RUN-LINE CODING PROVIDING FOR THE HANDLING OF DATA FOR
    +
    444 C GRAPHICS. I.E., RADAR DISPLAYS. IF THE DECODING PROCESS WILL
    +
    445 C NOT BE USED TO PROCESS THOSE TYPE OF MESSAGES, THEN THE
    +
    446 C VARIABLE SIZES FOR THE ARRAYS CAN BE MINIMIZED.
    +
    447 C IF THE DECODING PROCESS WILL BE USED TO DECODE THOSE MESSAGE
    +
    448 C TYPES, THEN MAXD MUST REFLECT THE MAXIMUM NUMBER OF
    +
    449 C DESCRIPTORS (FULLY EXPANDED LIST) TO BE EXPECTED IN THE
    +
    450 C MESSAGE.
    +
    451 C
    +
    452  INTEGER LDATA(MAXD)
    +
    453  INTEGER LSTACK(2,MAXD)
    +
    454 C
    +
    455  INTEGER MSGA(*)
    +
    456  INTEGER IPTR(*),KPTRB(16384),KPTRD(16384)
    +
    457  INTEGER KDATA(MAXR,MAXD)
    +
    458  INTEGER MSTACK(2,MAXD)
    +
    459 C
    +
    460  INTEGER IVALS(1000)
    +
    461  INTEGER KNR(MAXR)
    +
    462  INTEGER IDENT(*)
    +
    463  INTEGER ISTACK(*),IOLD11
    +
    464 cdak KEYSER fix 02/02/2001 VVVVV
    +
    465  INTEGER IOLDTB
    +
    466 cdak KEYSER fix 02/02/2001 AAAAA
    +
    467  INTEGER IWORK(15000)
    +
    468  INTEGER INDEX
    +
    469 C
    +
    470  INTEGER IIII
    +
    471  CHARACTER*1 BLANK
    +
    472  CHARACTER*4 DIRID(2)
    +
    473 C
    +
    474  LOGICAL SEC2
    +
    475 C ..................................................
    +
    476 C
    +
    477 C NEW BASE TABLE B
    +
    478 C MAY BE A COMBINATION OF MASTER TABLE B
    +
    479 C AND ANCILLARY TABLE B
    +
    480 C
    +
    481  INTEGER KFXY1(1300),ISCAL1(1300)
    +
    482  INTEGER IRFVL1(3,1300),IWIDE1(1300)
    +
    483  CHARACTER*40 ANAME1(1300)
    +
    484  CHARACTER*24 AUNIT1(1300)
    +
    485 C ..................................................
    +
    486 C
    +
    487 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
    +
    488 C
    +
    489  INTEGER KFXY2(200),ISCAL2(200),IRFVL2(200),IWIDE2(200)
    +
    490  CHARACTER*64 ANAME2(200)
    +
    491  CHARACTER*24 AUNIT2(200)
    +
    492 C ..................................................
    +
    493 C
    +
    494 C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE
    +
    495 C
    +
    496 C INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200)
    +
    497 C CHARACTER*64 ANAME3(200)
    +
    498 C CHARACTER*24 AUNIT3(200)
    +
    499 C ..................................................
    +
    500 C
    +
    501 C NEW BASE TABLE D
    +
    502 C
    +
    503  INTEGER ITBLD(20,400)
    +
    504 C ..................................................
    +
    505 C
    +
    506 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
    +
    507 C
    +
    508  INTEGER ITBLD2(20,50)
    +
    509 C ..................................................
    +
    510 C
    +
    511  SAVE
    +
    512 
    +
    513 cdak KEYSER fix 02/02/2001 VVVVV
    +
    514  DATA iold11/0/
    +
    515  DATA ioldtb/-99/
    +
    516 cdak KEYSER fix 02/02/2001 AAAAA
    +
    517 C
    +
    518  CALL w3fi01(lw)
    +
    519  iptr(45) = lw
    +
    520  iptr(44) = lw * 8
    +
    521 C
    +
    522  blank = ' '
    +
    523  IF (mova2i(blank).EQ.32) THEN
    +
    524  iptr(37) = 1
    +
    525 C PRINT *,'ASCII MACHINE'
    +
    526  ELSE
    +
    527  iptr(37) = 0
    +
    528 C PRINT *,'EBCDIC MACHINE'
    +
    529  END IF
    +
    530 C
    +
    531 C PRINT *,' W3FI88 DECODER'
    +
    532 C INITIALIZE ERROR RETURN
    +
    533  iptr(1) = 0
    +
    534  IF (index.GT.0) THEN
    +
    535 C HAVE RE-ENTRY
    +
    536  index = index + 1
    +
    537 C PRINT *,'RE-ENTRY LOOKING FOR SUBSET NR',INDEX
    +
    538  IF (index.GT.ident(14)) THEN
    +
    539 C ALL SUBSETS PROCESSED
    +
    540  iptr(1) = 99
    +
    541  iptr(38) = 0
    +
    542  iptr(39) = 0
    +
    543  ELSE IF (index.LE.ident(14)) THEN
    +
    544  IF (iptr(39).NE.0) THEN
    +
    545  DO 3000 j =1, iptr(13)
    +
    546  iwork(j) = istack(j)
    +
    547  3000 CONTINUE
    +
    548  iptr(12) = iptr(13)
    +
    549  CALL fi8801(iptr,ident,msga,istack,iwork,kdata,ivals,
    +
    550  * mstack,knr,index,maxr,maxd,
    +
    551  * kfxy1,aname1,aunit1,iscal1,irfvl1,iwide1,irf1sw,inewvl,
    +
    552  * kfxy2,aname2,aunit2,iscal2,irfvl2,iwide2,
    +
    553  * kfxy3,aname3,aunit3,iscal3,irfvl3,iwide3,
    +
    554  * iunitb,iunitd,itbld,itbld2,kptrb,kptrd)
    +
    555 C
    +
    556  END IF
    +
    557  END IF
    +
    558  RETURN
    +
    559  ELSE
    +
    560  index = 1
    +
    561 C PRINT *,'INITIAL ENTRY FOR THIS BUFR MESSAGE'
    +
    562  END IF
    +
    563  iptr(39) = 0
    +
    564 C FIND 'BUFR' IN FIRST 125 CHARACTERS
    +
    565  DO 1000 knofst = 0, 999, 8
    +
    566  inofst = knofst
    +
    567  CALL gbyte (msga,ivals,inofst,8)
    +
    568  IF (ivals(1).EQ.66) THEN
    +
    569  iptr(19) = inofst
    +
    570  inofst = inofst + 8
    +
    571  CALL gbyte (msga,ivals,inofst,24)
    +
    572  IF (ivals(1).EQ.5588562) THEN
    +
    573 C PRINT *,'FOUND BUFR AT',IPTR(19)
    +
    574  inofst = inofst + 24
    +
    575  GO TO 1500
    +
    576  END IF
    +
    577  END IF
    +
    578  1000 CONTINUE
    +
    579  print *,'BUFR - START OF BUFR MESSAGE NOT FOUND'
    +
    580  iptr(1) = 1
    +
    581  RETURN
    +
    582  1500 CONTINUE
    +
    583  ident(1) = 0
    +
    584 C TEST FOR EDITION NUMBER
    +
    585 C ======================
    +
    586  CALL gbyte (msga,ident(1),inofst+24,8)
    +
    587 C PRINT *,'THIS IS AN EDITION',IDENT(1),' BUFR MESSAGE'
    +
    588 C
    +
    589  IF (ident(1).GE.2) THEN
    +
    590 C GET TOTAL COUNT
    +
    591  CALL gbyte (msga,ivals,inofst,24)
    +
    592  itotal = ivals(1)
    +
    593  kender = itotal * 8 - 32 + iptr(19)
    +
    594  CALL gbyte (msga,ilast,kender,32)
    +
    595 C IF (ILAST.EQ.926365495) THEN
    +
    596 C PRINT *,'HAVE TOTAL COUNT FROM SEC 0',IVALS(1)
    +
    597 C END IF
    +
    598  inofst = inofst + 32
    +
    599 C GET SECTION 1 COUNT
    +
    600  iptr(3) = inofst
    +
    601  CALL gbyte (msga,ivals,inofst,24)
    +
    602 C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
    +
    603  inofst = inofst + 24
    +
    604  iptr( 2) = ivals(1)
    +
    605 C GET MASTER TABLE
    +
    606  CALL gbyte (msga,ivals,inofst,8)
    +
    607  inofst = inofst + 8
    +
    608  ident(17) = ivals(1)
    +
    609 C PRINT *,'BUFR MASTER TABLE NR',IDENT(17)
    +
    610  ELSE
    +
    611  iptr(3) = inofst
    +
    612 C GET SECTION 1 COUNT
    +
    613  CALL gbyte (msga,ivals,inofst,24)
    +
    614 C PRINT *,'SECTION 1 STARTS AT',INOFST,' SIZE',IVALS(1)
    +
    615  inofst = inofst + 32
    +
    616  iptr( 2) = ivals(1)
    +
    617  END IF
    +
    618 C ======================
    +
    619 C ORIGINATING CENTER
    +
    620  CALL gbyte (msga,ivals,inofst,16)
    +
    621  inofst = inofst + 16
    +
    622  ident(2) = ivals(1)
    +
    623 C UPDATE SEQUENCE
    +
    624  CALL gbyte (msga,ivals,inofst,8)
    +
    625  inofst = inofst + 8
    +
    626  ident(3) = ivals(1)
    +
    627 C OPTIONAL SECTION FLAG
    +
    628  CALL gbyte (msga,ivals,inofst,1)
    +
    629  ident(4) = ivals(1)
    +
    630  IF (ident(4).GT.0) THEN
    +
    631  sec2 = .true.
    +
    632  ELSE
    +
    633 C PRINT *,' NO OPTIONAL SECTION 2'
    +
    634  sec2 = .false.
    +
    635  END IF
    +
    636  inofst = inofst + 8
    +
    637 C MESSAGE TYPE
    +
    638  CALL gbyte (msga,ivals,inofst,8)
    +
    639  ident(5) = ivals(1)
    +
    640  inofst = inofst + 8
    +
    641 C MESSAGE SUBTYPE
    +
    642  CALL gbyte (msga,ivals,inofst,8)
    +
    643  ident(6) = ivals(1)
    +
    644  inofst = inofst + 8
    +
    645 cdak KEYSER fix 02/02/2001 VVVVV
    +
    646  IF (iunitb.NE.ioldtb) THEN
    +
    647 C IF HAVE A CHANGE IN TABLE B UNIT NUMBER , READ TABLE B
    +
    648  IF(ioldtb.NE.-99) print *, 'W3FI88 - NEW TABLE B UNIT NUMBER'
    +
    649  ioldtb = iunitb
    +
    650  iptr(14) = 0
    +
    651  iptr(21) = 0
    +
    652  END IF
    +
    653 cdak KEYSER fix 02/02/2001 AAAAA
    +
    654 C IF HAVE CHANGE IN DATA TYPE , RESET TABLE B
    +
    655  IF (iold11.EQ.11) THEN
    +
    656  iold11 = ident(5)
    +
    657  ioldsb = ident(6)
    +
    658 C JUST CONTINUE PROCESSING
    +
    659  ELSE IF (iold11.NE.11) THEN
    +
    660  IF (ident(5).EQ.11) THEN
    +
    661  iold11 = ident(5)
    +
    662  iptr(21) = 0
    +
    663  ELSE IF (ident(5).NE.iold11) THEN
    +
    664  iold11 = ident(5)
    +
    665  iptr(21) = 0
    +
    666  ELSE IF (ident(5).EQ.iold11) THEN
    +
    667 C IF HAVE A CHANGE IN SUBTYPE, RESET TABLE B
    +
    668  IF (ioldsb.NE.ident(6)) THEN
    +
    669  ioldsb = ident(6)
    +
    670  iptr(21) = 0
    +
    671 C ELSE IF
    +
    672  END IF
    +
    673  END IF
    +
    674  END IF
    +
    675 C IF BUFR EDITION 0 OR 1 THEN
    +
    676 C NEXT 2 BYTES ARE BUFR TABLE VERSION
    +
    677 C ELSE
    +
    678 C BYTE 11 IS VER NR OF MASTER TABLE
    +
    679 C BYTE 12 IS VER NR OF LOCAL TABLE
    +
    680  IF (ident(1).LT.2) THEN
    +
    681  CALL gbyte (msga,ivals,inofst,16)
    +
    682  ident(7) = ivals(1)
    +
    683  inofst = inofst + 16
    +
    684  ELSE
    +
    685 C BYTE 11 IS VER NR OF MASTER TABLE
    +
    686  CALL gbyte (msga,ivals,inofst,8)
    +
    687  ident(18) = ivals(1)
    +
    688  inofst = inofst + 8
    +
    689 C BYTE 12 IS VER NR OF LOCAL TABLE
    +
    690  CALL gbyte (msga,ivals,inofst,8)
    +
    691  ident(19) = ivals(1)
    +
    692  inofst = inofst + 8
    +
    693 
    +
    694  END IF
    +
    695 C YEAR OF CENTURY
    +
    696  CALL gbyte (msga,ivals,inofst,8)
    +
    697  ident(8) = ivals(1)
    +
    698  inofst = inofst + 8
    +
    699 C MONTH
    +
    700  CALL gbyte (msga,ivals,inofst,8)
    +
    701  ident(9) = ivals(1)
    +
    702  inofst = inofst + 8
    +
    703 C DAY
    +
    704 C PRINT *,'DAY AT ',INOFST
    +
    705  CALL gbyte (msga,ivals,inofst,8)
    +
    706  ident(10) = ivals(1)
    +
    707  inofst = inofst + 8
    +
    708 C HOUR
    +
    709  CALL gbyte (msga,ivals,inofst,8)
    +
    710  ident(11) = ivals(1)
    +
    711  inofst = inofst + 8
    +
    712 C MINUTE
    +
    713  CALL gbyte (msga,ivals,inofst,8)
    +
    714  ident(12) = ivals(1)
    +
    715 C RESET POINTER (INOFST) TO START OF
    +
    716 C NEXT SECTION
    +
    717 C (SECTION 2 OR SECTION 3)
    +
    718  inofst = iptr(3) + iptr(2) * 8
    +
    719  iptr(4) = 0
    +
    720  iptr(5) = inofst
    +
    721  IF (sec2) THEN
    +
    722 C SECTION 2 COUNT
    +
    723  CALL gbyte (msga,iptr(4),inofst,24)
    +
    724  inofst = inofst + 32
    +
    725 C PRINT *,'SECTION 2 STARTS AT',INOFST,' BYTES=',IPTR(4)
    +
    726  kentry = (iptr(4) - 4) / 14
    +
    727 C PRINT *,'SHOULD BE A MAX OF',KENTRY,' REPORTS'
    +
    728  IF (ident(2).EQ.7) THEN
    +
    729  DO 2000 i = 1, kentry
    +
    730  CALL gbyte (msga,kdspl ,inofst,16)
    +
    731  inofst = inofst + 16
    +
    732  CALL gbyte (msga,lat ,inofst,16)
    +
    733  inofst = inofst + 16
    +
    734  CALL gbyte (msga,lon ,inofst,16)
    +
    735  inofst = inofst + 16
    +
    736  CALL gbyte (msga,kdahr ,inofst,16)
    +
    737  inofst = inofst + 16
    +
    738  CALL gbyte (msga,dirid(1),inofst,32)
    +
    739  inofst = inofst + 32
    +
    740  CALL gbyte (msga,dirid(2),inofst,16)
    +
    741  inofst = inofst + 16
    +
    742 C PRINT *,KDSPL,LAT,LON,KDAHR,DIRID(1),DIRID(2)
    +
    743  2000 CONTINUE
    +
    744  END IF
    +
    745 C RESET POINTER (INOFST) TO START OF
    +
    746 C SECTION 3
    +
    747  inofst = iptr(5) + iptr(4) * 8
    +
    748  END IF
    +
    749 C BIT OFFSET TO START OF SECTION 3
    +
    750  iptr( 7) = inofst
    +
    751 C SECTION 3 COUNT
    +
    752  CALL gbyte (msga,iptr(6),inofst,24)
    +
    753 C PRINT *,'SECTION 3 STARTS AT',INOFST,' BYTES=',IPTR(6)
    +
    754  inofst = inofst + 24
    +
    755 C SKIP RESERVED BYTE
    +
    756  inofst = inofst + 8
    +
    757 C NUMBER OF DATA SUBSETS
    +
    758  CALL gbyte (msga,ident(14),inofst,16)
    +
    759 C
    +
    760  IF (ident(14).GT.maxr) THEN
    +
    761  print *,'THE NUMBER OF SUBSETS EXCEEDS THE MAXIMUM OF',maxr
    +
    762  print *,'PASSED INTO W3FI88; MAXR MUST BE INCREASED IN '
    +
    763  print *,'THE CALLING PROGRAM TO AT LEAST THE VALUE OF'
    +
    764  print *,ident(14),'TO BE ABLE TO PROCESS THIS DATA'
    +
    765 C
    +
    766  iptr(1) = 400
    +
    767  RETURN
    +
    768  END IF
    +
    769  inofst = inofst + 16
    +
    770 C OBSERVED DATA FLAG
    +
    771  CALL gbyte (msga,ivals,inofst,1)
    +
    772  ident(15) = ivals(1)
    +
    773  inofst = inofst + 1
    +
    774 C COMPRESSED DATA FLAG
    +
    775  CALL gbyte (msga,ivals,inofst,1)
    +
    776  ident(16) = ivals(1)
    +
    777  inofst = inofst + 7
    +
    778 C CALCULATE NUMBER OF DESCRIPTORS
    +
    779  nrdesc = (iptr( 6) - 8) / 2
    +
    780  iptr(12) = nrdesc
    +
    781  iptr(13) = nrdesc
    +
    782 C EXTRACT DESCRIPTORS
    +
    783  CALL gbytes (msga,istack,inofst,16,0,nrdesc)
    +
    784 C PRINT *,'INITIAL DESCRIPTOR LIST OF',NRDESC,' DESCRIPTORS'
    +
    785  DO 10 l = 1, nrdesc
    +
    786  iwork(l) = istack(l)
    +
    787 C PRINT *,L,ISTACK(L)
    +
    788  10 CONTINUE
    +
    789  iptr(13) = nrdesc
    +
    790 C ===============================================================
    +
    791 C
    +
    792 C CONSTRUCT A TABLE B TO MATCH THE
    +
    793 C LIST OF DESCRIPTORS FOR THIS MESSAGE
    +
    794 C
    +
    795  IF (iptr(21).EQ.0) THEN
    +
    796  print *,'W3FI88- TABLE B NOT YET ENTERED'
    +
    797  CALL fi8812(iptr,iunitb,iunitd,istack,nrdesc,kptrb,kptrd,
    +
    798  * irf1sw,newref,itbld,itbld2,
    +
    799  * kfxy1,aname1,aunit1,iscal1,irfvl1,iwide1,
    +
    800  * kfxy2,aname2,aunit2,iscal2,irfvl2,iwide2)
    +
    801  ELSE
    +
    802 C PRINT *,'W3FI88- TABLE B ALL READY IN PLACE'
    +
    803  IF (iptr(41).NE.0) THEN
    +
    804 C PRINT *,'MERGE',IPTR(41),' ENTRIES INTO TABLE B'
    +
    805 C CALL FI8818(IPTR,KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
    +
    806 C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB)
    +
    807  END IF
    +
    808  END IF
    +
    809  IF (iptr(1).NE.0) RETURN
    +
    810 C ================================================================
    +
    811 C RESET POINTER TO START OF SECTION 4
    +
    812  inofst = iptr(7) + iptr(6) * 8
    +
    813 C BIT OFFSET TO START OF SECTION 4
    +
    814  iptr( 9) = inofst
    +
    815 C SECTION 4 COUNT
    +
    816  CALL gbyte (msga,ivals,inofst,24)
    +
    817 C PRINT *,'SECTION 4 STARTS AT',INOFST,' VALUE',IVALS(1)
    +
    818  iptr( 8) = ivals(1)
    +
    819  inofst = inofst + 32
    +
    820 C SET FOR STARTING BIT OF DATA
    +
    821  iptr(25) = inofst
    +
    822 C FIND OUT IF '7777' TERMINATOR IS THERE
    +
    823  inofst = iptr(9) + iptr(8) * 8
    +
    824  CALL gbyte (msga,ivals,inofst,32)
    +
    825 C PRINT *,'SECTION 5 STARTS AT',INOFST,' VALUE',IVALS(1)
    +
    826  IF (ivals(1).NE.926365495) THEN
    +
    827  print *,'BAD SECTION COUNT'
    +
    828  iptr(1) = 2
    +
    829  RETURN
    +
    830  ELSE
    +
    831  iptr(1) = 0
    +
    832  END IF
    +
    833 C
    +
    834  CALL fi8801(iptr,ident,msga,istack,iwork,kdata,ivals,
    +
    835  * mstack,knr,index,maxr,maxd,
    +
    836  * kfxy1,aname1,aunit1,iscal1,irfvl1,iwide1,irf1sw,inewvl,
    +
    837  * kfxy2,aname2,aunit2,iscal2,irfvl2,iwide2,
    +
    838  * kfxy3,aname3,aunit3,iscal3,irfvl3,iwide3,
    +
    839  * iunitb,iunitd,itbld,itbld2,kptrb,kptrd)
    +
    840 C
    +
    841 C PRINT *,'HAVE RETURNED FROM FI8801'
    +
    842  IF (iptr(1).NE.0) THEN
    +
    843  RETURN
    +
    844  END IF
    +
    845 C FURTHER PROCESSING REQUIRED FOR PROFILER DATA
    +
    846  IF (ident(5).EQ.2) THEN
    +
    847  IF (ident(6).EQ.7) THEN
    +
    848 C PRINT *,'REFORMAT PROFILER DATA'
    +
    849 C
    +
    850 C DO 7151 I = 1, 40
    +
    851 C IF (I.LE.20) THEN
    +
    852 C PRINT *,'IPTR(',I,')=',IPTR(I),
    +
    853 C * ' IDENT(',I,')= ',IDENT(I)
    +
    854 C ELSE
    +
    855 C PRINT *,'IPTR(',I,')=',IPTR(I)
    +
    856 C END IF
    +
    857 C7151 CONTINUE
    +
    858 C DO 152 I = 1, IPTR(31)
    +
    859 C PRINT *,MSTACK(1,I),MSTACK(2,I),(KDATA(J,I),J=1,5)
    +
    860 C 152 CONTINUE
    +
    861  IF (ident(1).LT.2) THEN
    +
    862  CALL fi8809(ident,mstack,kdata,iptr,maxr,maxd)
    +
    863  ELSE
    +
    864  CALL fi8810(ident,mstack,kdata,iptr,maxr,maxd)
    +
    865  END IF
    +
    866 C DO 151 I = 1, 40
    +
    867 C IF (I.LE.20) THEN
    +
    868 C PRINT *,'IPTR(',I,')=',IPTR(I),
    +
    869 C * ' IDENT(',I,')= ',IDENT(I)
    +
    870 C ELSE
    +
    871 C PRINT *,'IPTR(',I,')=',IPTR(I)
    +
    872 C END IF
    +
    873 C 151 CONTINUE
    +
    874  IF (iptr(1).NE.0) THEN
    +
    875  RETURN
    +
    876  END IF
    +
    877 C
    +
    878 C DO 154 I = 1, IPTR(31)
    +
    879 C PRINT *,I,MSTACK(1,I),MSTACK(2,I),KDATA(1,I),KDATA(2,I)
    +
    880 C 154 CONTINUE
    +
    881  END IF
    +
    882  END IF
    +
    883 C IF DATA/DESCRIPTOR REPLICATION FLAG IS ON,
    +
    884 C MUST COMPLETE EXPANSION OF DATA AND
    +
    885 C DESCRIPTORS.
    +
    886  IF (iptr(38).EQ.1) THEN
    +
    887  CALL fi8811(iptr,ident,mstack,kdata,knr,
    +
    888  * ldata,lstack,maxd,maxr)
    +
    889  END IF
    +
    890 C
    +
    891 C IF HAVE A LIST OF TABLE ENTRIES FROM
    +
    892 C A BUFR MESSAGE TYPE 11
    +
    893 C PRINT OUT THE ENTRIES
    +
    894 C
    +
    895  IF (ident(5).EQ.11) THEN
    +
    896 C DO 100 I = 1, IPTR(31)+IPTR(24)
    +
    897 C PRINT *,I,MSTACK(1,I),(KDATA(J,I),J=1,4)
    +
    898 C 100 CONTINUE
    +
    899  CALL fi8813 (iptr,maxr,maxd,mstack,kdata,ident,kptrd,kptrb,
    +
    900  * itbld,aname1,aunit1,kfxy1,iscal1,irfvl1,iwide1,iunitb)
    +
    901  END IF
    +
    902  RETURN
    +
    903  END
    +
    904 C> @brief Data extraction
    +
    905 C> @author Bill Cavanaugh @date 1988-09-01
    +
    906 
    +
    907 C> Control the extraction of data from section 4 based on data descriptors.
    +
    908 C>
    +
    909 C> Program history log:
    +
    910 C> - Bill Cavanaugh 1988-09-01\
    +
    911 C> - Bill Cavanaugh 1991-01-18 Corrections to properly handle non-compressed
    +
    912 C> DATA.
    +
    913 C> - Bill Cavanaugh 1991-09-23 Coding added to handle single subsets with
    +
    914 C> DELAYED REPLICATION.
    +
    915 C> - Bill Cavanaugh 1992-01-24 Modified to echo descriptors to mstack(1,n)
    +
    916 C> - Dennis Keyser 1995-06-07 Corrected an error which required input
    +
    917 C> argument "maxd" to be nearly twice as large
    +
    918 C> as needed for decoding wind profiler reports
    +
    919 C> (limit upper bound for "iwork" array was set
    +
    920 C> to "maxd", now it is set to 15000)
    +
    921 C>
    +
    922 C> @param[in] IPTR See w3fi88() routine docblock
    +
    923 C> @param[in] IDENT See w3fi88() routine docblock
    +
    924 C> @param[in] MSGA Array containing bufr message
    +
    925 C> @param[inout] ISTACK Original array of descriptors extracted from
    +
    926 C> source bufr message.
    +
    927 C> @param[in] MSTACK Working array of descriptors (expanded)and scaling
    +
    928 C> factor
    +
    929 C> @param[inout] KFXY1+KFXY2+KFXY3 Image of current descriptor
    +
    930 C> @param[in] INDEX
    +
    931 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    932 C> contained in a bufr message
    +
    933 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    934 C> may be processed; upper air data and some satellite
    +
    935 C> data require a value for maxd of 1700, but for most
    +
    936 C> other data a value for maxd of 500 will suffice
    +
    937 C> @param[in] IUNITB Unit number of data set holding table b
    +
    938 C> @param[in] IUNITD Unit number of data set holding table d
    +
    939 C> @param[out] IWORK Working descriptor list
    +
    940 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    941 C> KDATA(Report number,parameter number)
    +
    942 C> (report number limited to value of input argument
    +
    943 C> maxr and parameter number limited to value of input
    +
    944 C> argument maxd)
    +
    945 C>
    +
    946 C> arrays containing data from table b
    +
    947 C> @param[out] AUNIT1+AUNIT2+AUNIT3 Units for descriptor
    +
    948 C> @param[out] ANAME1+ANAME2+ANAME3 Descriptor name
    +
    949 C> @param[out] ISCAL1+ISCAL2+ISCAL3 Scale for value of descriptor
    +
    950 C> @param[out] IRFVL1+IRFVL2+IRFVL3 Reference value for descriptor
    +
    951 C> @param[out] IWIDE1+IWIDE2+IWIDE3 Bit width for value of descriptor
    +
    952 C> @param ITBLD+ITBLD2
    +
    953 C> @param KPTRB
    +
    954 C> @param KPTRD
    +
    955 C> @param KNR
    +
    956 C> @param IVALS
    +
    957 C> @param IRF1SW
    +
    958 C> @param INEWVL
    +
    959 C>
    +
    960 C> Error return:
    +
    961 C> - IPTR(1)
    +
    962 C> - = 8 Error reading table b
    +
    963 C> - = 9 Error reading table d
    +
    964 C> - = 11 Error opening table b
    +
    965 C>
    +
    966 C> @author Bill Cavanaugh @date 1988-09-01
    +
    967  SUBROUTINE fi8801(IPTR,IDENT,MSGA,ISTACK,IWORK,KDATA,IVALS,
    +
    968  * MSTACK,KNR,INDEX,MAXR,MAXD,
    +
    969  * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,IRF1SW,INEWVL,
    +
    970  * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
    +
    971  * KFXY3,ANAME3,AUNIT3,ISCAL3,IRFVL3,IWIDE3,
    +
    972  * IUNITB,IUNITD,ITBLD,ITBLD2,KPTRB,KPTRD)
    +
    973 C
    +
    974 
    +
    975 C ..................................................
    +
    976 C
    +
    977 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
    +
    978 C
    +
    979  INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
    +
    980  CHARACTER*64 ANAME2(*)
    +
    981  CHARACTER*24 AUNIT2(*)
    +
    982 C ..................................................
    +
    983 C
    +
    984 C NEW ADDED TABLE B FROM NON-TYPE 11 BUFR MESSAGE
    +
    985 C
    +
    986  INTEGER KFXY3(200),ISCAL3(200),IRFVL3(200),IWIDE3(200)
    +
    987  CHARACTER*64 ANAME3(200)
    +
    988  CHARACTER*24 AUNIT3(200)
    +
    989 C ..................................................
    +
    990 C
    +
    991 C NEW BASE TABLE B
    +
    992 C MAY BE A COMBINATION OF MASTER TABLE B
    +
    993 C AND ANCILLARY TABLE B
    +
    994 C
    +
    995  INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
    +
    996  CHARACTER*40 ANAME1(*)
    +
    997  CHARACTER*24 AUNIT1(*)
    +
    998 C ..................................................
    +
    999 C
    +
    1000 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
    +
    1001 C
    +
    1002  INTEGER ITBLD2(20,*)
    +
    1003 C ..................................................
    +
    1004 C
    +
    1005 C NEW BASE TABLE D
    +
    1006 C
    +
    1007  INTEGER ITBLD(20,*)
    +
    1008 C ..................................................
    +
    1009 C
    +
    1010 C
    +
    1011  INTEGER MAXD, MAXR
    +
    1012 C
    +
    1013  INTEGER MSGA(*),KDATA(MAXR,MAXD),IVALS(*)
    +
    1014 C
    +
    1015  INTEGER KNR(MAXR)
    +
    1016  INTEGER LX,LY,LL,J
    +
    1017 C INTEGER IHOLD(33)
    +
    1018  INTEGER IPTR(*),KPTRB(*),KPTRD(*)
    +
    1019  INTEGER IDENT(*)
    +
    1020  INTEGER ISTACK(*),IWORK(*)
    +
    1021 C
    +
    1022  INTEGER MSTACK(2,MAXD)
    +
    1023 C
    +
    1024  INTEGER JDESC
    +
    1025  INTEGER INDEX
    +
    1026 C
    +
    1027  SAVE
    +
    1028 C
    +
    1029 C PRINT *,' DECOLL FI8801'
    +
    1030  IF (index.GT.1) THEN
    +
    1031  GO TO 1000
    +
    1032  END IF
    +
    1033 C --------- DECOLL ---------------
    +
    1034  iptr(23) = 0
    +
    1035  iptr(26) = 0
    +
    1036  iptr(27) = 0
    +
    1037  iptr(28) = 0
    +
    1038  iptr(29) = 0
    +
    1039  iptr(30) = 0
    +
    1040  iptr(36) = 0
    +
    1041 C INITIALIZE OUTPUT AREA
    +
    1042 C SET POINTER TO BEGINNING OF DATA
    +
    1043 C SET BIT
    +
    1044  iptr(17) = 1
    +
    1045  1000 CONTINUE
    +
    1046 C IPTR(12) = IPTR(13)
    +
    1047  ll = 0
    +
    1048  iptr(11) = 1
    +
    1049  IF (iptr(10).EQ.0) THEN
    +
    1050 C RE-ENTRY POINT FOR MULTIPLE
    +
    1051 C NON-COMPRESSED REPORTS
    +
    1052  ELSE
    +
    1053  index = iptr(15)
    +
    1054  iptr(17) = index
    +
    1055  iptr(25) = iptr(10)
    +
    1056  iptr(10) = 0
    +
    1057  iptr(15) = 0
    +
    1058  END IF
    +
    1059 C PRINT *,'FI8801 - RPT',IPTR(17),' STARTS AT',IPTR(25)
    +
    1060  iptr(24) = 0
    +
    1061  iptr(31) = 0
    +
    1062 C POINTING AT NEXT AVAILABLE DESCRIPTOR
    +
    1063  mm = 0
    +
    1064  IF (iptr(21).EQ.0) THEN
    +
    1065  nrdesc = iptr(13)
    +
    1066  CALL fi8812(iptr,iunitb,iunitd,istack,nrdesc,kptrb,kptrd,
    +
    1067  * irf1sw,newref,itbld,itbld2,
    +
    1068  * kfxy1,aname1,aunit1,iscal1,irfvl1,iwide1,
    +
    1069  * kfxy2,aname2,aunit2,iscal2,irfvl2,iwide2)
    +
    1070  END IF
    +
    1071  10 CONTINUE
    +
    1072 C PROCESS THRU THE FOLLOWING
    +
    1073 C DEPENDING UPON THE VALUE OF 'F' (LF)
    +
    1074  mm = mm + 1
    +
    1075  12 CONTINUE
    +
    1076  IF (mm.GT.maxd) THEN
    +
    1077  GO TO 200
    +
    1078  END IF
    +
    1079 C END OF CYCLE TEST (SERIAL/SEQUENTIAL)
    +
    1080  IF (iptr(11).GT.iptr(12)) THEN
    +
    1081 C PRINT *,' HAVE COMPLETED REPORT SEQUENCE'
    +
    1082  IF (ident(16).NE.0) THEN
    +
    1083 C PRINT *,' PROCESSING COMPRESSED REPORTS'
    +
    1084 C REFORMAT DATA FROM DESCRIPTOR
    +
    1085 C FORM TO USER FORM
    +
    1086  RETURN
    +
    1087  ELSE
    +
    1088 C WRITE (6,1)
    +
    1089 C 1 FORMAT (1H1)
    +
    1090 C PRINT *,' PROCESSED SERIAL REPORT',IPTR(17),IPTR(25)
    +
    1091  iptr(17) = iptr(17) + 1
    +
    1092  IF (iptr(17).GT.ident(14)) THEN
    +
    1093  iptr(17) = iptr(17) - 1
    +
    1094  GO TO 200
    +
    1095  END IF
    +
    1096  DO 300 i = 1, iptr(13)
    +
    1097  iwork(i) = istack(i)
    +
    1098  300 CONTINUE
    +
    1099 C RESET POINTERS
    +
    1100  ll = 0
    +
    1101  iptr(1) = 0
    +
    1102  iptr(11) = 1
    +
    1103  iptr(12) = iptr(13)
    +
    1104 C IS THIS LAST REPORT ?
    +
    1105 C PRINT *,'READY',IPTR(39),INDEX
    +
    1106  IF (iptr(39).GT.0) THEN
    +
    1107  IF (index.GT.0) THEN
    +
    1108 C PRINT *,'HERE IS SUBSET NR',INDEX
    +
    1109  RETURN
    +
    1110  END IF
    +
    1111  END IF
    +
    1112  GO TO 1000
    +
    1113  END IF
    +
    1114  END IF
    +
    1115  14 CONTINUE
    +
    1116 C GET NEXT DESCRIPTOR
    +
    1117  CALL fi8808 (iptr,iwork,lf,lx,ly,jdesc)
    +
    1118 C PRINT *,IPTR(11)-1,'JDESC= ',JDESC,' AND NEXT ',
    +
    1119 C * IPTR(11),IWORK(IPTR(11)),IPTR(31)
    +
    1120 C PRINT *,IPTR(11)-1,'DESCRIPTOR',JDESC,LF,LX,LY,
    +
    1121 C * ' FOR LOC',IPTR(17),IPTR(25)
    +
    1122 CVVVVVCHANGE#2 FIX BY KEYSER -- 12/06/1994
    +
    1123 C NOTE: THIS FIX NEEDED BECAUSE IWORK ARRAY DOES NOT HAVE TO BE
    +
    1124 C LIMITED TO SIZE OF "MAXD" -- WASTES SPACE BECAUSE "MAXD"
    +
    1125 C MUST BECOME OVER TWICE AS LARGE AS NEEDED FOR PROFILERS
    +
    1126 C IN ORDER TO AVOID SATISFYING THIS BELOW IF TEST
    +
    1127 CDAK IF (IPTR(11).GT.MAXD) THEN
    +
    1128  IF (iptr(11).GT.15000) THEN
    +
    1129 CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994
    +
    1130  iptr(1) = 401
    +
    1131  RETURN
    +
    1132  END IF
    +
    1133 C
    +
    1134  kprm = iptr(31) + iptr(24)
    +
    1135  IF (kprm.GT.maxd) THEN
    +
    1136  IF (kprm.GT.kold) THEN
    +
    1137  print *,'EXCEEDED ARRAY SIZE',kprm,iptr(31),
    +
    1138  * iptr(24)
    +
    1139  kold = kprm
    +
    1140  END IF
    +
    1141  END IF
    +
    1142 C REPLICATION PROCESSING
    +
    1143  IF (lf.EQ.1) THEN
    +
    1144 C ---------- F1 ---------
    +
    1145  iptr(31) = iptr(31) + 1
    +
    1146  kprm = iptr(31) + iptr(24)
    +
    1147  mstack(1,kprm) = jdesc
    +
    1148  mstack(2,kprm) = 0
    +
    1149  kdata(iptr(17),kprm) = 0
    +
    1150 C PRINT *,'FI8801-1',KPRM,MSTACK(1,KPRM),
    +
    1151 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1152  CALL fi8805(iptr,ident,msga,iwork,lx,ly,
    +
    1153  * kdata,ll,knr,mstack,maxr,maxd)
    +
    1154 C * KDATA,LL,KNR,MSTACK,MAXR,MAXD)
    +
    1155  IF (iptr(1).NE.0) THEN
    +
    1156  RETURN
    +
    1157  ELSE
    +
    1158  GO TO 12
    +
    1159  END IF
    +
    1160 C
    +
    1161 C DATA DESCRIPTION OPERATORS
    +
    1162  ELSE IF (lf.EQ.2)THEN
    +
    1163  IF (lx.EQ.4) THEN
    +
    1164  iptr(31) = iptr(31) + 1
    +
    1165  kprm = iptr(31) + iptr(24)
    +
    1166  mstack(1,kprm) = jdesc
    +
    1167  mstack(2,kprm) = 0
    +
    1168  kdata(iptr(17),kprm) = 0
    +
    1169 C PRINT *,'FI8801-2',KPRM,MSTACK(1,KPRM),
    +
    1170 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1171  END IF
    +
    1172  CALL fi8806 (iptr,lx,ly,ident,msga,kdata,ivals,mstack,
    +
    1173  * iwide1,irfvl1,iscal1,j,ll,kfxy1,iwork,jdesc,maxr,maxd,
    +
    1174  * kptrb)
    +
    1175  IF (iptr(1).NE.0) THEN
    +
    1176  RETURN
    +
    1177  END IF
    +
    1178  GO TO 12
    +
    1179 C DESCRIPTOR SEQUENCE STRINGS
    +
    1180  ELSE IF (lf.EQ.3) THEN
    +
    1181 C PRINT *,'F3 SEQUENCE DESCRIPTOR'
    +
    1182 C READ IN TABLE D, BUT JUST ONCE
    +
    1183  IF (iptr(20).EQ.0) THEN
    +
    1184  CALL fi8820 (itbld,iunitd,iptr,itbld2,kptrd)
    +
    1185  IF (iptr(1).GT.0) THEN
    +
    1186  RETURN
    +
    1187  END IF
    +
    1188 C ELSE
    +
    1189 C IF (IPTR(42).NE.0) THEN
    +
    1190 C PRINT *,'MERGE',IPTR(42),' ENTRIES INTO TABLE D'
    +
    1191 C CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD)
    +
    1192 C END IF
    +
    1193  END IF
    +
    1194  CALL fi8807(iptr,iwork,itbld,itbld2,jdesc,kptrd)
    +
    1195  IF (iptr(1).GT.0) THEN
    +
    1196  RETURN
    +
    1197  END IF
    +
    1198  GO TO 14
    +
    1199 C
    +
    1200 C ELEMENT DESCRIPTOR PROCESSING
    +
    1201 C
    +
    1202  ELSE
    +
    1203  kprm = iptr(31) + iptr(24)
    +
    1204  CALL fi8802(iptr,ident,msga,kdata,kfxy1,ll,mstack,
    +
    1205  * aunit1,iwide1,irfvl1,iscal1,jdesc,ivals,j,maxr,maxd,
    +
    1206  * kptrb)
    +
    1207 C TURN OFF SKIP FLAG AFTER STD DESCRIPTOR
    +
    1208  iptr(36) = 0
    +
    1209  IF (iptr(1).GT.0) THEN
    +
    1210  RETURN
    +
    1211  ELSE
    +
    1212 C
    +
    1213 C IF ENCOUNTER CLASS 0 DESCRIPTOR
    +
    1214 C NOT CONTAINED WITHIN A BUFR
    +
    1215 C MESSAGE OF TYPE 11, THEN COLLECT
    +
    1216 C ALL TABLE B ENTRIES FOR USE ON
    +
    1217 C CURRENT BUFR MESSAGE
    +
    1218 C
    +
    1219  IF (jdesc.LE.20.AND.jdesc.GE.10) THEN
    +
    1220  IF (ident(5).NE.11) THEN
    +
    1221 C COLLECT TABLE B ENTRIES
    +
    1222  CALL fi8815(iptr,ident,jdesc,kdata,
    +
    1223  * kfxy3,maxr,maxd,aname3,aunit3,
    +
    1224  * iscal3,irfvl3,iwide3,
    +
    1225  * keyset,ibflag,ierr)
    +
    1226  IF (ierr.NE.0) THEN
    +
    1227  END IF
    +
    1228  IF (iand(ibflag,16).NE.0) THEN
    +
    1229  IF (iand(ibflag,8).NE.0) THEN
    +
    1230  IF (iand(ibflag,4).NE.0) THEN
    +
    1231  IF (iand(ibflag,2).NE.0) THEN
    +
    1232  IF (iand(ibflag,1).NE.0) THEN
    +
    1233 C HAVE A COMPLETE TABLE B ENTRY
    +
    1234  iptr(43) = iptr(43) + ident(14)
    +
    1235  keyset = 0
    +
    1236  ibflag = 0
    +
    1237  GO TO 1000
    +
    1238  END IF
    +
    1239  END IF
    +
    1240  END IF
    +
    1241  END IF
    +
    1242  END IF
    +
    1243  END IF
    +
    1244  END IF
    +
    1245  IF (ident(16).EQ.0) THEN
    +
    1246  knr(iptr(17)) = iptr(31)
    +
    1247  ELSE
    +
    1248  DO 310 kj = 1, maxr
    +
    1249  knr(kj) = iptr(31)
    +
    1250  310 CONTINUE
    +
    1251  END IF
    +
    1252  GO TO 10
    +
    1253  END IF
    +
    1254  END IF
    +
    1255 C END IF
    +
    1256 C END DO WHILE
    +
    1257  200 CONTINUE
    +
    1258 C IF (IDENT(16).NE.0) THEN
    +
    1259 C PRINT *,'RETURN WITH',IDENT(14),' COMPRESSED REPORTS'
    +
    1260 C ELSE
    +
    1261 C PRINT *,'RETURN WITH',IPTR(17),' NON-COMPRESSED REPORTS'
    +
    1262 C END IF
    +
    1263  RETURN
    +
    1264  END
    +
    1265 C> @brief Process element descriptor.
    +
    1266 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1267 
    +
    1268 C> Process an element descriptor (f = 0) and store data
    +
    1269 C> in output array.
    +
    1270 C>
    +
    1271 C> Program history log:
    +
    1272 C> 88-09-01
    +
    1273 C> 91-04-04 Changed to pass width of text fields in bytes
    +
    1274 C>
    +
    1275 C> @param[in] IPTR See w3fi88 routine docblock
    +
    1276 C> @param[in] IDENT See w3fi88 routine docblock
    +
    1277 C> @param[in] MSGA Array containing bufr message
    +
    1278 C> @param[inout] KDATA Array containing decoded reports from bufr message.
    +
    1279 C> KDATA(Report number,parameter number)
    +
    1280 C> (report number limited to value of input argument
    +
    1281 C> maxr and parameter number limited to value of input
    +
    1282 C> argument maxd)
    +
    1283 C> @param[inout] KFXY1 Image of current descriptor
    +
    1284 C> @param[in] MSTACK
    +
    1285 C> @param[in] MAXR Maximum number of reports/subsets that may be contained in
    +
    1286 C> a bufr message
    +
    1287 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    1288 C> may be processed; upper air data and some satellite
    +
    1289 C> data require a value for maxd of 1700, but for most
    +
    1290 C> other data a value for maxd of 500 will suffice
    +
    1291 C> arrays containing data from table b
    +
    1292 C> @param[out] AUNIT1 Units for descriptor
    +
    1293 C> @param[out] ISCAL1 Scale for value of descriptor
    +
    1294 C> @param[out] IRFVL1 Reference value for descriptor
    +
    1295 C> @param[out] IWIDE1 Bit width for value of descriptor
    +
    1296 C> @param LL
    +
    1297 C> @param JDESC
    +
    1298 C> @param IVALS
    +
    1299 C> @param J
    +
    1300 C> @param KPTRB
    +
    1301 C>
    +
    1302 C> Error return:
    +
    1303 C> IPTR(1) = 3 - Message contains a descriptor with f=0 that does not exist
    +
    1304 C> in table b.
    +
    1305 C>
    +
    1306 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1307  SUBROUTINE fi8802(IPTR,IDENT,MSGA,KDATA,KFXY1,LL,MSTACK,AUNIT1,
    +
    1308  * IWIDE1,IRFVL1,ISCAL1,JDESC,IVALS,J,MAXR,MAXD,KPTRB)
    +
    1309 
    +
    1310 C TABLE B ENTRY
    +
    1311  CHARACTER*24 ASKEY
    +
    1312  INTEGER MSGA(*)
    +
    1313  INTEGER IPTR(*)
    +
    1314  INTEGER KPTRB(*)
    +
    1315  INTEGER IDENT(*)
    +
    1316  INTEGER J
    +
    1317  INTEGER JDESC
    +
    1318  INTEGER MSTACK(2,MAXD)
    +
    1319  INTEGER KDATA(MAXR,MAXD),IVALS(*)
    +
    1320 C ..................................................
    +
    1321 C
    +
    1322 C NEW BASE TABLE B
    +
    1323 C MAY BE A COMBINATION OF MASTER TABLE B
    +
    1324 C AND ANCILLARY TABLE B
    +
    1325 C
    +
    1326  INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
    +
    1327 C CHARACTER*40 ANAME1(*)
    +
    1328  CHARACTER*24 AUNIT1(*)
    +
    1329 C ..................................................
    +
    1330  SAVE
    +
    1331 C
    +
    1332  DATA ASKEY /'CCITT IA5 '/
    +
    1333 C
    +
    1334 C PRINT *,' FI8802 - ELEMENT DESCRIPTOR ',JDESC,KPTRB(JDESC)
    +
    1335 C FIND TABLE B ENTRY
    +
    1336  j = kptrb(jdesc)
    +
    1337 C HAVE A MATCH
    +
    1338 C SET FLAG IF TEXT EVENT
    +
    1339 C PRINT *,'ASKEY=',ASKEY,'AUNIT1(',J,')=',AUNIT1(J),JDESC
    +
    1340  IF (askey(1:9).EQ.aunit1(j)(1:9)) THEN
    +
    1341  iptr(18) = 1
    +
    1342  iptr(40) = iwide1(j) / 8
    +
    1343  ELSE
    +
    1344  iptr(18) = 0
    +
    1345  END IF
    +
    1346 C PRINT *,'FI8802 - BIT WIDTH =',IWIDE1(J),IPTR(18),' FOR',JDESC
    +
    1347  IF (ident(16).NE.0) THEN
    +
    1348 C COMPRESSED
    +
    1349  CALL fi8803(iptr,ident,msga,kdata,ivals,mstack,
    +
    1350  * iwide1,irfvl1,iscal1,j,jdesc,maxr,maxd)
    +
    1351 C IF (IPTR(1).NE.0) THEN
    +
    1352 C RETURN
    +
    1353 C END IF
    +
    1354  ELSE
    +
    1355 C NOT COMPRESSED
    +
    1356 C PRINT *,' FROM FI8802',J
    +
    1357  CALL fi8804(iptr,msga,kdata,ivals,mstack,
    +
    1358  * iwide1,irfvl1,iscal1,j,ll,jdesc,maxr,maxd)
    +
    1359 C IF (IPTR(1).NE.0) THEN
    +
    1360 C RETURN
    +
    1361 C END IF
    +
    1362  END IF
    +
    1363  RETURN
    +
    1364  END
    +
    1365 C> @brief Process compressed data
    +
    1366 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1367 
    +
    1368 C> Process compressed data and place individual elements
    +
    1369 C> into output array.
    +
    1370 C>
    +
    1371 C> Program history log:
    +
    1372 C> - Bill Cavanaugh 1988-09-01
    +
    1373 C> - Bill Cavanaugh 1991-04-04 Text handling portion of this routine
    +
    1374 C> modified to hanle width of fields in bytes.
    +
    1375 C> - Bill Cavanaugh 1991-04-17 Tests showed that the same data in compressed
    +
    1376 C> and uncompressed form gave different results.
    +
    1377 C> this has been corrected.
    +
    1378 C> - Bill Cavanaugh 1991-06-21 Processing of text data has been changed to
    +
    1379 C> provide exact reproduction of all characters.
    +
    1380 C> - Bill Cavanaugh 1994-04-11 Corrected processing of data when all values
    +
    1381 C> the same (nbinc = 0). corrected test of lowest
    +
    1382 C> value against proper bit mask.
    +
    1383 C> - Dennis Keyser 1995-06-07 Corrected an error which resulted in
    +
    1384 C> returned scale in "mstack(2, ..)" always
    +
    1385 C> being set to zero for compressed data. also,
    +
    1386 C> scale changes were not being recognized.
    +
    1387 C>
    +
    1388 C> @param[in] IPTR See w3fi88 routine docblock
    +
    1389 C> @param[in] IDENT See w3fi88 routine docblock
    +
    1390 C> @param[in] MSGA Array containing bufr message,mstack,
    +
    1391 C> @param[in] IVALS Array of single parameter values
    +
    1392 C> @param[inout] J
    +
    1393 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    1394 C> contained in a bufr message
    +
    1395 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    1396 C> may be processed; upper air data and some satellite
    +
    1397 C> data require a value for maxd of 1700, but for most
    +
    1398 C> other data a value for maxd of 500 will suffice
    +
    1399 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1400 C> KDATA(Report number,parameter number)
    +
    1401 C> (report number limited to value of input argument
    +
    1402 C> maxr and parameter number limited to value of input
    +
    1403 C> argument maxd)
    +
    1404 C> arrays containing data from table b
    +
    1405 C> @param[out] ISCAL1 Scale for value of descriptor
    +
    1406 C> @param[out] IRFVL1 Reference value for descriptor
    +
    1407 C> @param[out] IWIDE1 Bit width for value of descriptor
    +
    1408 C> @param MSTACK
    +
    1409 C> @param JDESC
    +
    1410 C>
    +
    1411 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1412  SUBROUTINE fi8803(IPTR,IDENT,MSGA,KDATA,IVALS,MSTACK,
    +
    1413  * IWIDE1,IRFVL1,ISCAL1,J,JDESC,MAXR,MAXD)
    +
    1414 
    +
    1415 C
    +
    1416 C ..................................................
    +
    1417 C
    +
    1418 C NEW BASE TABLE B
    +
    1419 C MAY BE A COMBINATION OF MASTER TABLE B
    +
    1420 C AND ANCILLARY TABLE B
    +
    1421 C
    +
    1422 C INTEGER KFXY1(*)
    +
    1423  INTEGER ISCAL1(*)
    +
    1424  INTEGER IRFVL1(3,*)
    +
    1425  INTEGER IWIDE1(*)
    +
    1426 C CHARACTER*40 ANAME1(*)
    +
    1427 C CHARACTER*24 AUNIT1(*)
    +
    1428 C ..................................................
    +
    1429  INTEGER MAXD,MAXR
    +
    1430  INTEGER MSGA(*),JDESC,MSTACK(2,MAXD)
    +
    1431  INTEGER IPTR(*),IVALS(*),KDATA(MAXR,MAXD)
    +
    1432  INTEGER NRVALS,JWIDE,IDATA
    +
    1433  INTEGER IDENT(*)
    +
    1434  INTEGER J
    +
    1435  INTEGER KLOW(256)
    +
    1436 C
    +
    1437  LOGICAL TEXT
    +
    1438 C
    +
    1439  INTEGER MSK(32)
    +
    1440 C
    +
    1441  SAVE
    +
    1442 C
    +
    1443  DATA msk /1, 3, 7, 15, 31, 63, 127,
    +
    1444 C 1 2 3 4 5 6 7
    +
    1445  * 255, 511, 1023, 2047, 4095,
    +
    1446 C 8 9 10 11 12
    +
    1447  * 8191, 16383, 32767, 65535,
    +
    1448 C 13 14 15 16
    +
    1449  * 131071, 262143, 524287,
    +
    1450 C 17 18 19
    +
    1451  * 1048575, 2097151, 4194303,
    +
    1452 C 20 21 22
    +
    1453  * 8388607, 16777215, 33554431,
    +
    1454 C 23 24 25
    +
    1455  * 67108863, 134217727, 268435455,
    +
    1456 C 26 27 28
    +
    1457  * 536870911, 1073741823, 2147483647,-1 /
    +
    1458 C 29 30 31 32
    +
    1459  CALL w3fi01(lw)
    +
    1460  mwdbit = iptr(44)
    +
    1461  IF (iptr(45).EQ.8) THEN
    +
    1462  i = 2147483647
    +
    1463  msk(32) = i + i + 1
    +
    1464  END IF
    +
    1465 C
    +
    1466 C PRINT *,' FI8803 COMPR J=',J,' IWIDE1(J) =',IWIDE1(J),
    +
    1467 C * ' EXTRA BITS =',IPTR(26),' START AT',IPTR(25)
    +
    1468  IF (iptr(18).EQ.0) THEN
    +
    1469  text = .false.
    +
    1470  ELSE
    +
    1471  text = .true.
    +
    1472  END IF
    +
    1473 C PRINT *,'DESCRIPTOR',KPRM,JDESC
    +
    1474  IF (.NOT.text) THEN
    +
    1475  IF (iptr(29).GT.0.AND.jdesc.NE.7957) THEN
    +
    1476 C PRINT *,'ASSOCIATED FIELD AT',IPTR(25)
    +
    1477 C WORKING WITH ASSOCIATED FIELDS HERE
    +
    1478  iptr(31) = iptr(31) + 1
    +
    1479  kprm = iptr(31) + iptr(24)
    +
    1480 C GET LOWEST
    +
    1481  CALL gbyte (msga,lowest,iptr(25),iptr(29))
    +
    1482  iptr(25) = iptr(25) + iptr(29)
    +
    1483 C GET NBINC
    +
    1484  CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1485  iptr(25) = iptr(25) + 6
    +
    1486 C PRINT *,'LOWEST=',LOWEST,' NBINC=',NBINC
    +
    1487  IF (nbinc.GT.32) THEN
    +
    1488  iptr(1) = 22
    +
    1489  RETURN
    +
    1490  END IF
    +
    1491 C EXTRACT DATA FOR ASSOCIATED FIELD
    +
    1492  IF (nbinc.GT.0) THEN
    +
    1493  CALL gbytes (msga,ivals,iptr(25),nbinc,0,iptr(21))
    +
    1494  iptr(25) = iptr(25) + nbinc * iptr(21)
    +
    1495  DO 50 i = 1, ident(14)
    +
    1496  kdata(i,kprm) = ivals(i) + lowest
    +
    1497  IF (nbinc.EQ.32) THEN
    +
    1498  IF (kdata(i,kprm).EQ.msk(nbinc)) THEN
    +
    1499  kdata(i,kprm) = 999999
    +
    1500  END IF
    +
    1501  ELSE IF (kdata(i,kprm).GE.msk(nbinc)) THEN
    +
    1502  kdata(i,kprm) = 999999
    +
    1503  END IF
    +
    1504  50 CONTINUE
    +
    1505  ELSE
    +
    1506  DO 51 i = 1, ident(14)
    +
    1507  kdata(i,kprm) = lowest
    +
    1508  IF (nbinc.EQ.32) THEN
    +
    1509  IF (lowest.EQ.msk(32)) THEN
    +
    1510  kdata(i,kprm) = 999999
    +
    1511  END IF
    +
    1512  ELSE IF(lowest.GE.msk(nbinc)) THEN
    +
    1513  kdata(i,kprm) = 999999
    +
    1514  END IF
    +
    1515  51 CONTINUE
    +
    1516  END IF
    +
    1517  END IF
    +
    1518 C SET PARAMETER
    +
    1519 C ISOLATE COMBINED BIT WIDTH
    +
    1520  jwide = iwide1(j) + iptr(26)
    +
    1521 C
    +
    1522  IF (jwide.GT.32) THEN
    +
    1523 C TOO MANY BITS IN COMBINED
    +
    1524 C BIT WIDTH
    +
    1525  print *,'ERR 22 - HAVE EXCEEDED COMBINED BIT WIDTH'
    +
    1526  iptr(1) = 22
    +
    1527  RETURN
    +
    1528  END IF
    +
    1529 C SINGLE VALUE FOR LOWEST
    +
    1530  nrvals = 1
    +
    1531 C LOWEST
    +
    1532 C PRINT *,'PARAM',KPRM
    +
    1533  CALL gbyte (msga,lowest,iptr(25),jwide)
    +
    1534 C PRINT *,' LOWEST=',LOWEST,' AT BIT LOC ',IPTR(25)
    +
    1535  iptr(25) = iptr(25) + jwide
    +
    1536 C ISOLATE COMPRESSED BIT WIDTH
    +
    1537  CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1538 C PRINT *,' NBINC=',NBINC,' AT BIT LOC',IPTR(25)
    +
    1539  IF (nbinc.GT.32) THEN
    +
    1540 C NBINC TOO LARGE
    +
    1541  iptr(1) = 22
    +
    1542  RETURN
    +
    1543  END IF
    +
    1544  IF (iptr(32).EQ.2.AND.iptr(33).EQ.5) THEN
    +
    1545  ELSE
    +
    1546  IF (nbinc.GT.jwide) THEN
    +
    1547 C PRINT *,'FOR DESCRIPTOR',JDESC
    +
    1548 C PRINT *,J,'NBINC=',NBINC,' LOWEST=',LOWEST,' IWIDE1(J)=',
    +
    1549 C * IWIDE1(J),' IPTR(26)=',IPTR(26),' AT BIT LOC',IPTR(25)
    +
    1550 C DO 110 I = 1, KPRM
    +
    1551 C WRITE (6,111)I,(KDATA(J,I),J=1,6)
    +
    1552 C 110 CONTINUE
    +
    1553 C 111 FORMAT (1X,5HDATA ,I3,6(2X,I10))
    +
    1554  iptr(1) = 500
    +
    1555  print *,'NBINC CALLS FOR LARGER BIT WIDTH THAN TABLE',
    +
    1556  * ' B PLUS WIDTH CHANGES'
    +
    1557  END IF
    +
    1558  END IF
    +
    1559  iptr(25) = iptr(25) + 6
    +
    1560 C PRINT *,'LOWEST',LOWEST,' NBINC=',NBINC
    +
    1561 C IF TEXT EVENT, PROCESS TEXT
    +
    1562 C GET COMPRESSED VALUES
    +
    1563 C PRINT *,'COMPRESSED VALUES - NONTEXT'
    +
    1564  nrvals = ident(14)
    +
    1565  iptr(31) = iptr(31) + 1
    +
    1566  kprm = iptr(31) + iptr(24)
    +
    1567  IF (nbinc.NE.0) THEN
    +
    1568  CALL gbytes (msga,ivals,iptr(25),nbinc,0,nrvals)
    +
    1569  iptr(25) = iptr(25) + nbinc * nrvals
    +
    1570 C RECALCULATE TO ORIGINAL VALUES
    +
    1571  DO 100 i = 1, nrvals
    +
    1572 C PRINT *,IVALS(I),MSK(NBINC),NBINC
    +
    1573  IF (ivals(i).GE.msk(nbinc)) THEN
    +
    1574  kdata(i,kprm) = 999999
    +
    1575  ELSE
    +
    1576  IF (irfvl1(2,j).EQ.0) THEN
    +
    1577  jrv = irfvl1(1,j)
    +
    1578  ELSE
    +
    1579  jrv = irfvl1(3,j)
    +
    1580  END IF
    +
    1581  kdata(i,kprm) = ivals(i) + lowest + jrv
    +
    1582  END IF
    +
    1583  100 CONTINUE
    +
    1584 C PRINT *,I,JDESC,LOWEST,IRFVL1(1,J),IRFVL1(3,J)
    +
    1585  ELSE
    +
    1586  IF (lowest.EQ.msk(jwide)) THEN
    +
    1587  DO 105 i = 1, nrvals
    +
    1588  kdata(i,kprm) = 999999
    +
    1589  105 CONTINUE
    +
    1590  ELSE
    +
    1591  IF (irfvl1(2,j).EQ.0) THEN
    +
    1592  jrv = irfvl1(1,j)
    +
    1593  ELSE
    +
    1594  jrv = irfvl1(3,j)
    +
    1595  END IF
    +
    1596  icomb = lowest + jrv
    +
    1597  DO 106 i = 1, nrvals
    +
    1598  kdata(i,kprm) = icomb
    +
    1599  106 CONTINUE
    +
    1600  END IF
    +
    1601  END IF
    +
    1602 C PRINT *,'KPRM=',KPRM,' IPTR(25)=',IPTR(25)
    +
    1603  mstack(1,kprm) = jdesc
    +
    1604 C WRITE (6,80) (KDATA(I,KPRM),I=1,10)
    +
    1605  80 FORMAT(2x,10(f10.2,1x))
    +
    1606 CVVVVVCHANGE#3 FIX BY KEYSER -- 12/06/1994
    +
    1607 C NOTE: THIS FIX NEEDED BECAUSE THE RETURNED SCALE IN MSTACK(2,..)
    +
    1608 C WAS ALWAYS '0' FOR COMPRESSED DATA, INCL. CHANGED SCALES)
    +
    1609  mstack(2,kprm) = iscal1(j) + iptr(27)
    +
    1610 CAAAAACHANGE#3 FIX BY KEYSER -- 12/06/1994
    +
    1611  ELSE IF (text) THEN
    +
    1612 C PRINT *,' FOUND TEXT MODE IN COMPRESSED DATA',IPTR(40)
    +
    1613 C GET LOWEST
    +
    1614 C PRINT *,' PICKED UP LOWEST',(KLOW(K),K=1,IPTR(40))
    +
    1615  DO 1906 k = 1, iptr(40)
    +
    1616  CALL gbyte (msga,klow,iptr(25),8)
    +
    1617  iptr(25) = iptr(25) + 8
    +
    1618  IF (klow(k).NE.0) THEN
    +
    1619  iptr(1) = 27
    +
    1620  print *,'NON-ZERO LOWEST ON TEXT DATA'
    +
    1621  RETURN
    +
    1622  END IF
    +
    1623  1906 CONTINUE
    +
    1624 C PRINT *,'TEXT - LOWEST = 0'
    +
    1625 C GET NBINC
    +
    1626  CALL gbyte (msga,nbinc,iptr(25),6)
    +
    1627  iptr(25) = iptr(25) + 6
    +
    1628  IF (nbinc.NE.iptr(40)) THEN
    +
    1629  iptr(1) = 28
    +
    1630  print *,'NBINC IS NOT THE NUMBER OF CHARACTERS',nbinc
    +
    1631  RETURN
    +
    1632  END IF
    +
    1633 C PRINT *,'TEXT NBINC =',NBINC
    +
    1634 C FOR NUMBER OF OBSERVATIONS
    +
    1635  iptr(31) = iptr(31) + 1
    +
    1636  kprm = iptr(31) + iptr(24)
    +
    1637  istart = kprm
    +
    1638  i24 = iptr(24)
    +
    1639  DO 1900 n = 1, ident(14)
    +
    1640  kprm = istart
    +
    1641  iptr(24) = i24
    +
    1642  nbits = iptr(40) * 8
    +
    1643  1700 CONTINUE
    +
    1644 C PRINT *,N,IDENT(14),'KPRM-B=',KPRM,IPTR(24),NBITS
    +
    1645  IF (nbits.GT.mwdbit) THEN
    +
    1646  CALL gbyte (msga,idata,iptr(25),mwdbit)
    +
    1647  iptr(25) = iptr(25) + mwdbit
    +
    1648  nbits = nbits - mwdbit
    +
    1649  IF (iptr(37).EQ.0) THEN
    +
    1650 C CONVERTS ASCII TO EBCIDIC
    +
    1651  CALL w3ai39 (idata,lw)
    +
    1652  END IF
    +
    1653  mstack(1,kprm) = jdesc
    +
    1654  mstack(2,kprm) = 0
    +
    1655  kdata(n,kprm) = idata
    +
    1656 C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
    +
    1657 C SET FOR NEXT PART
    +
    1658  kprm = kprm + 1
    +
    1659  iptr(24) = iptr(24) + 1
    +
    1660 C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
    +
    1661 C1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,I12)
    +
    1662  GO TO 1700
    +
    1663  ELSE IF (nbits.GT.0) THEN
    +
    1664  CALL gbyte (msga,idata,iptr(25),nbits)
    +
    1665  iptr(25) = iptr(25) + nbits
    +
    1666  ibuf = (iptr(44) - nbits) / 8
    +
    1667  IF (ibuf.GT.0) THEN
    +
    1668  DO 1750 mp = 1, ibuf
    +
    1669  idata = idata * 256 + 32
    +
    1670  1750 CONTINUE
    +
    1671  END IF
    +
    1672 C CONVERTS ASCII TO EBCIDIC
    +
    1673  IF (iptr(37).EQ.0) THEN
    +
    1674  CALL w3ai39 (idata,lw)
    +
    1675  END IF
    +
    1676  mstack(1,kprm) = jdesc
    +
    1677  mstack(2,kprm) = 0
    +
    1678  kdata(n,kprm) = idata
    +
    1679 C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
    +
    1680 C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
    +
    1681  nbits = 0
    +
    1682  END IF
    +
    1683 C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
    +
    1684 C1800 FORMAT (2X,I4,2X,3A4)
    +
    1685  1900 CONTINUE
    +
    1686  END IF
    +
    1687  RETURN
    +
    1688  END
    +
    1689 C> @brief Process serial data
    +
    1690 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1691 
    +
    1692 C> Process data that is not compressed
    +
    1693 C>
    +
    1694 C> Program history log:
    +
    1695 C> - Bill cavanaugh 1988-09-01
    +
    1696 C> - Bill cavanaugh 1991-01-18 Modified to properly handle non-compressed
    +
    1697 C> data.
    +
    1698 C> - Bill cavanaugh 1991-04-04 Text handling portion of this routine
    +
    1699 C> modified to handle field width in bytes.
    +
    1700 C> - Bill cavanaugh 1991-04-17 ests showed that the same data in compressed
    +
    1701 C> and uncompressed form gave different results.
    +
    1702 C> this has been corrected.
    +
    1703 C>
    +
    1704 C> @param[in] IPTR See w3fi88() routine docblock
    +
    1705 C> @param[in] MSGA Array containing bufr message
    +
    1706 C> @param[inout] IVALS Array of single parameter values
    +
    1707 C> @param[inout] J
    +
    1708 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    1709 C> contained in a bufr message
    +
    1710 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    1711 C> may be processed; upper air data and some satellite
    +
    1712 C> data require a value for maxd of 1700, but for most
    +
    1713 C> other data a value for maxd of 500 will suffice
    +
    1714 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1715 C> KDATA(Report number,parameter number)
    +
    1716 C> (report number limited to value of input argument
    +
    1717 C> maxr and parameter number limited to value of input
    +
    1718 C> argument maxd)
    +
    1719 C> Arrays containing data from table b
    +
    1720 C> @param[out] ISCAL1 Scale for value of descriptor
    +
    1721 C> @param[out] IRFVL1 Reference value for descriptor
    +
    1722 C> @param[out] IWIDE1 Bit width for value of descriptorE
    +
    1723 C> @param MSTACK
    +
    1724 C> @param LL
    +
    1725 C> @param JDESC
    +
    1726 C>
    +
    1727 C> Error return:
    +
    1728 C> IPTR(1) = 13 - Bit width on ascii chars not a multiple of 8
    +
    1729 C>
    +
    1730 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1731  SUBROUTINE fi8804(IPTR,MSGA,KDATA,IVALS,MSTACK,
    +
    1732  * IWIDE1,IRFVL1,ISCAL1,J,LL,JDESC,MAXR,MAXD)
    +
    1733 
    +
    1734 C ..................................................
    +
    1735 C
    +
    1736 C NEW BASE TABLE B
    +
    1737 C MAY BE A COMBINATION OF MASTER TABLE B
    +
    1738 C AND ANCILLARY TABLE B
    +
    1739 C
    +
    1740 C INTEGER KFXY1(*)
    +
    1741  INTEGER ISCAL1(*)
    +
    1742  INTEGER IRFVL1(3,*)
    +
    1743  INTEGER IWIDE1(*)
    +
    1744 C CHARACTER*40 ANAME1(*)
    +
    1745 C CHARACTER*24 AUNIT1(*)
    +
    1746 C ..................................................
    +
    1747 C
    +
    1748  INTEGER MSGA(*),MAXD,MAXR
    +
    1749  INTEGER IPTR(*)
    +
    1750  INTEGER JDESC
    +
    1751  INTEGER IVALS(*)
    +
    1752 C INTEGER LSTBLK(3)
    +
    1753  INTEGER KDATA(MAXR,MAXD),MSTACK(2,MAXD)
    +
    1754  INTEGER J,LL
    +
    1755 C LOGICAL LKEY
    +
    1756 C
    +
    1757 C
    +
    1758  INTEGER ITEST(32)
    +
    1759 C
    +
    1760  SAVE
    +
    1761 C
    +
    1762  DATA itest /1,3,7,15,31,63,127,255,
    +
    1763  * 511,1023,2047,4095,8191,16383,
    +
    1764  * 32767, 65535,131071,262143,524287,
    +
    1765  * 1048575,2097151,4194303,8388607,
    +
    1766  * 16777215,33554431,67108863,134217727,
    +
    1767  * 268435455,536870911,1073741823,
    +
    1768  * 2147483647,-1/
    +
    1769 C
    +
    1770  mwdbit = iptr(44)
    +
    1771  IF (iptr(45).NE.4) THEN
    +
    1772  i = 2147483647
    +
    1773  itest(32) = i + i + 1
    +
    1774  END IF
    +
    1775 C
    +
    1776 C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25)
    +
    1777 C -------- NOCMP --------
    +
    1778 C IF NOT TEXT EVENT, PROCESS
    +
    1779  IF (iptr(18).EQ.0) THEN
    +
    1780 C PRINT *,' NOT TEXT'
    +
    1781  IF ((iptr(26)+iwide1(j)).LT.1) THEN
    +
    1782 C PRINT *,' FI8804 NOCMP',J,JDESC,IWIDE1(J),IPTR(26),IPTR(25)
    +
    1783  iptr(1) = 501
    +
    1784  RETURN
    +
    1785  END IF
    +
    1786 C ISOLATE BIT WIDTH
    +
    1787  jwide = iwide1(j) + iptr(26)
    +
    1788 C IF ASSOCIATED FIELD SW ON
    +
    1789  IF (iptr(29).GT.0) THEN
    +
    1790  IF (jdesc.NE.7957.AND.jdesc.NE.7937) THEN
    +
    1791  iptr(31) = iptr(31) + 1
    +
    1792  kprm = iptr(31) + iptr(24)
    +
    1793  mstack(1,kprm) = 33792 + iptr(29)
    +
    1794  mstack(2,kprm) = 0
    +
    1795  CALL gbyte (msga,ivals,iptr(25),iptr(29))
    +
    1796  iptr(25) = iptr(25) + iptr(29)
    +
    1797  kdata(iptr(17),kprm) = ivals(1)
    +
    1798 C PRINT *,'FI8804-A',KPRM,MSTACK(1,KPRM),
    +
    1799 C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
    +
    1800  END IF
    +
    1801  END IF
    +
    1802  iptr(31) = iptr(31) + 1
    +
    1803  kprm = iptr(31) + iptr(24)
    +
    1804  mstack(1,kprm) = jdesc
    +
    1805 C IF (IPTR(27).NE.0) THEN
    +
    1806 C MSTACK(2,KPRM) = IPTR(27)
    +
    1807 C ELSE
    +
    1808  mstack(2,kprm) = iscal1(j) + iptr(27)
    +
    1809 C END IF
    +
    1810 C GET VALUES
    +
    1811 C CALL TO GET DATA OF GIVEN BIT WIDTH
    +
    1812  CALL gbyte (msga,ivals,iptr(25),jwide)
    +
    1813 C PRINT *,'DATA TO',IPTR(17),KPRM,IVALS(1),JWIDE,IPTR(25)
    +
    1814  iptr(25) = iptr(25) + jwide
    +
    1815 C RETURN WITH SINGLE VALUE
    +
    1816  IF (irfvl1(2,j).EQ.0) THEN
    +
    1817  jrv = irfvl1(1,j)
    +
    1818  ELSE
    +
    1819  jrv = irfvl1(3,j)
    +
    1820  END IF
    +
    1821  IF (jwide.EQ.32) THEN
    +
    1822  IF (ivals(1).EQ.itest(jwide)) THEN
    +
    1823  kdata(iptr(17),kprm) = 999999
    +
    1824  ELSE
    +
    1825  kdata(iptr(17),kprm) = ivals(1) + jrv
    +
    1826  END IF
    +
    1827  ELSE IF (ivals(1).GE.itest(jwide)) THEN
    +
    1828  kdata(iptr(17),kprm) = 999999
    +
    1829  ELSE
    +
    1830  kdata(iptr(17),kprm) = ivals(1) + jrv
    +
    1831  END IF
    +
    1832 C PRINT *,'FI8804-B',KPRM,MSTACK(1,KPRM),
    +
    1833 C * MSTACK(2,KPRM),IPTR(17),KDATA(IPTR(17),KPRM)
    +
    1834 C IF(JDESC.EQ.2049) THEN
    +
    1835 C PRINT *,'VERT SIG =',KDATA(IPTR(17),KPRM)
    +
    1836 C END IF
    +
    1837 C PRINT *,'FI8804 ',KPRM,MSTACK(1,KPRM),
    +
    1838 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1839  ELSE
    +
    1840 C PRINT *,' TEXT'
    +
    1841 C PRINT *,' FOUND TEXT MODE ****** NOT COMPRESSED *********'
    +
    1842  jwide = iptr(40) * 8
    +
    1843 C PRINT *,' WIDTH =',JWIDE,IPTR(40)
    +
    1844  nrchrs = iptr(40)
    +
    1845  nrbits = jwide
    +
    1846 C PRINT *,' CHARS =',NRCHRS,' BITS =',NRBITS
    +
    1847  iptr(31) = iptr(31) + 1
    +
    1848  kany = 0
    +
    1849  1800 CONTINUE
    +
    1850  kany = kany + 1
    +
    1851 C PRINT *,' NR BITS THIS PASS',NRBITS
    +
    1852  IF (nrbits.GT.mwdbit) THEN
    +
    1853  CALL gbyte (msga,idata,iptr(25),mwdbit)
    +
    1854 C PRINT 1801,KANY,IDATA,IPTR(17),KPRM,NRBITS
    +
    1855  1801 FORMAT (1x,i2,4x,z8,2(4x,i4))
    +
    1856 C CONVERTS ASCII TO EBCIDIC
    +
    1857 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1858  IF (iptr(37).EQ.0) THEN
    +
    1859  CALL w3ai39 (idata,iptr(45))
    +
    1860  END IF
    +
    1861  kprm = iptr(31) + iptr(24)
    +
    1862  kdata(iptr(17),kprm) = idata
    +
    1863  mstack(1,kprm) = jdesc
    +
    1864  mstack(2,kprm) = 0
    +
    1865 C PRINT *,'BODY ',KPRM,MSTACK(1,KPRM),MSTACK(2,KPRM),
    +
    1866 C * KDATA(IPTR(17),KPRM)
    +
    1867  iptr(25) = iptr(25) + mwdbit
    +
    1868  nrbits = nrbits - mwdbit
    +
    1869  iptr(24) = iptr(24) + 1
    +
    1870  GO TO 1800
    +
    1871  ELSE IF (nrbits.GT.0) THEN
    +
    1872  CALL gbyte (msga,idata,iptr(25),nrbits)
    +
    1873  iptr(25) = iptr(25) + nrbits
    +
    1874 C CONVERTS ASCII TO EBCIDIC
    +
    1875 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    1876  IF (iptr(37).EQ.0) THEN
    +
    1877  CALL w3ai39 (idata,iptr(45))
    +
    1878  END IF
    +
    1879  kprm = iptr(31) + iptr(24)
    +
    1880  kshft = mwdbit - nrbits
    +
    1881  IF (kshft.GT.0) THEN
    +
    1882  ktry = kshft / 8
    +
    1883  DO 1722 lak = 1, ktry
    +
    1884  IF (iptr(37).EQ.0) THEN
    +
    1885  idata = idata * 256 + 64
    +
    1886  ELSE
    +
    1887  idata = idata * 256 + 32
    +
    1888  END IF
    +
    1889 C PRINT 1723,IDATA
    +
    1890 C1723 FORMAT (12X,Z8)
    +
    1891  1722 CONTINUE
    +
    1892  END IF
    +
    1893  kdata(iptr(17),kprm) = idata
    +
    1894 C PRINT 1801,KANY,IDATA,KDATA(IPTR(17),KPRM),KPRM
    +
    1895  mstack(1,kprm) = jdesc
    +
    1896  mstack(2,kprm) = 0
    +
    1897 C PRINT *,'TAIL ',KPRM,MSTACK(1,KPRM),
    +
    1898 C * KDATA(IPTR(17),KPRM)
    +
    1899  END IF
    +
    1900  END IF
    +
    1901  RETURN
    +
    1902  END
    +
    1903 C> @brief Process a replication descriptor
    +
    1904 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1905 
    +
    1906 C> Process a replication descriptor, must extract number
    +
    1907 C> of replications of n descriptors from the data stream.
    +
    1908 C>
    +
    1909 C> Program history log:
    +
    1910 C> - Bill Cavanaugh 1988-09-01
    +
    1911 C>
    +
    1912 C> @param[in] IWORK Working descriptor list
    +
    1913 C> @param[in] IPTR See w3fi88 routine docblock
    +
    1914 C> @param[in] IDENT See w3fi88 routine docblock
    +
    1915 C> @param[inout] LX X portion of current descriptor
    +
    1916 C> @param[inout] LY Y portion of current descriptor
    +
    1917 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    1918 C> contained in a bufr message
    +
    1919 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    1920 C> may be processed; upper air data and some satellite
    +
    1921 C> data require a value for maxd of 1700, but for most
    +
    1922 C> other data a value for maxd of 500 will suffice
    +
    1923 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    1924 C> KDATA(Report number,parameter number)
    +
    1925 C> (report number limited to value of input argument
    +
    1926 C> maxr and parameter number limited to value of input
    +
    1927 C> argument maxd)
    +
    1928 C> @param MSGA
    +
    1929 C> @param LL
    +
    1930 C> @param KNR
    +
    1931 C> @param MSTACK
    +
    1932 C>
    +
    1933 C> Error return:
    +
    1934 C> - IPTR(1)
    +
    1935 C> - = 12 Data descriptor qualifier does not follow delayed replication descriptor
    +
    1936 C> - = 20 Exceeded count for delayed replication pass
    +
    1937 C>
    +
    1938 C> @author Bill Cavanaugh @date 1988-09-01
    +
    1939  SUBROUTINE fi8805(IPTR,IDENT,MSGA,IWORK,LX,LY,
    +
    1940  * KDATA,LL,KNR,MSTACK,MAXR,MAXD)
    +
    1941 
    +
    1942 C
    +
    1943  INTEGER IPTR(*)
    +
    1944  INTEGER KNR(MAXR)
    +
    1945  INTEGER ITEMP(2000)
    +
    1946  INTEGER LL
    +
    1947  INTEGER KTEMP(2000)
    +
    1948  INTEGER KDATA(MAXR,MAXD)
    +
    1949  INTEGER LX,MSTACK(2,MAXD)
    +
    1950  INTEGER LY
    +
    1951  INTEGER MSGA(*)
    +
    1952  INTEGER KVALS(1300)
    +
    1953 CVVVVVCHANGE#2 FIX BY KEYSER -- 12/06/1994
    +
    1954 C NOTE: THIS FIX JUST CLEANS UP CODE SINCE IWORK ARRAY IS EARLIER
    +
    1955 C DEFINED AS 15000 WORDS
    +
    1956  INTEGER IWORK(*)
    +
    1957 CDAK INTEGER IWORK(MAXD)
    +
    1958 CAAAAACHANGE#2 FIX BY KEYSER -- 12/06/1994
    +
    1959  INTEGER IDENT(*)
    +
    1960 C
    +
    1961  SAVE
    +
    1962 C
    +
    1963 C PRINT *,' REPLICATION FI8805'
    +
    1964 C DO 7100 I = 1, IPTR(13)
    +
    1965 C PRINT *,I,IWORK(I)
    +
    1966 C7100 CONTINUE
    +
    1967 C NUMBER OF DESCRIPTORS
    +
    1968  nrset = lx
    +
    1969 C NUMBER OF REPLICATIONS
    +
    1970  nrreps = ly
    +
    1971  icurr = iptr(11) - 1
    +
    1972  ipick = iptr(11) - 1
    +
    1973 C
    +
    1974  IF (nrreps.EQ.0) THEN
    +
    1975  iptr(39) = 1
    +
    1976 C SAVE PRIMARY DELAYED REPLICATION DESCRIPTOR
    +
    1977 C IPTR(31) = IPTR(31) + 1
    +
    1978 C KPRM = IPTR(31) + IPTR(24)
    +
    1979 C MSTACK(1,KPRM) = JDESC
    +
    1980 C MSTACK(2,KPRM) = 0
    +
    1981 C KDATA(IPTR(17),KPRM) = 0
    +
    1982 C PRINT *,'FI8805-1',KPRM,MSTACK(1,KPRM),
    +
    1983 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    1984 C DELAYED REPLICATION - MUST GET NUMBER OF
    +
    1985 C REPLICATIONS FROM DATA.
    +
    1986 C GET NEXT DESCRIPTOR
    +
    1987  CALL fi8808(iptr,iwork,lf,lx,ly,jdesc)
    +
    1988 C PRINT *,' DELAYED REPLICATION',LF,LX,LY,JDESC
    +
    1989 C MUST BE DATA DESCRIPTION
    +
    1990 C OPERATION QUALIFIER
    +
    1991  IF (jdesc.EQ.7937.OR.jdesc.EQ.7947) THEN
    +
    1992  jwide = 8
    +
    1993  ELSE IF (jdesc.EQ.7938.OR.jdesc.EQ.7948) THEN
    +
    1994  jwide = 16
    +
    1995  ELSE IF (jdesc.EQ.7936) THEN
    +
    1996  jwide = 1
    +
    1997  ELSE
    +
    1998  iptr(1) = 12
    +
    1999  RETURN
    +
    2000  END IF
    +
    2001 C THIS IF BLOCK IS SET TO HANDLE
    +
    2002 C DATA/DESCRIPTOR REPLICATION
    +
    2003  IF (jdesc.EQ.7947.OR.jdesc.EQ.7948) THEN
    +
    2004 C SET DATA/DESCRIPTOR REPLICATION FLAG = ON
    +
    2005  iptr(38) = 1
    +
    2006 C SAVE AS NEXT ENTRY IN KDATA, MSTACK
    +
    2007  iptr(31) = iptr(31) + 1
    +
    2008  kprm = iptr(31) + iptr(24)
    +
    2009  mstack(1,kprm) = jdesc
    +
    2010  mstack(2,kprm) = 0
    +
    2011  CALL gbyte (msga,kvals,iptr(25),jwide)
    +
    2012  iptr(25) = iptr(25) + jwide
    +
    2013  kdata(iptr(17),kprm) = kvals(1)
    +
    2014  RETURN
    +
    2015  END IF
    +
    2016 
    +
    2017 C SET SINGLE VALUE FOR SEQUENTIAL,
    +
    2018 C MULTIPLE VALUES FOR COMPRESSED
    +
    2019  IF (ident(16).EQ.0) THEN
    +
    2020 
    +
    2021 C NON COMPRESSED
    +
    2022  CALL gbyte (msga,kvals,iptr(25),jwide)
    +
    2023 C PRINT *,LF,LX,LY,JDESC,' NR OF REPLICATIONS',KVALS(1)
    +
    2024  iptr(25) = iptr(25) + jwide
    +
    2025  iptr(31) = iptr(31) + 1
    +
    2026  kprm = iptr(31) + iptr(24)
    +
    2027  mstack(1,kprm) = jdesc
    +
    2028  mstack(2,kprm) = 0
    +
    2029  kdata(iptr(17),kprm) = kvals(1)
    +
    2030  nrreps = kvals(1)
    +
    2031 C PRINT *,'FI8805-2',KPRM,MSTACK(1,KPRM),
    +
    2032 C * MSTACK(2,KPRM),KDATA(IPTR(17),KPRM)
    +
    2033  ELSE
    +
    2034  nrvals = ident(14)
    +
    2035  CALL gbytes (msga,kvals,iptr(25),jwide,0,nrvals)
    +
    2036  iptr(25) = iptr(25) + jwide * nrvals
    +
    2037  iptr(31) = iptr(31) + 1
    +
    2038  kprm = iptr(31) + iptr(24)
    +
    2039  mstack(1,kprm) = jdesc
    +
    2040  mstack(2,kprm) = 0
    +
    2041  kdata(iptr(17),kprm) = kvals(1)
    +
    2042  DO 100 i = 1, nrvals
    +
    2043  kdata(i,kprm) = kvals(i)
    +
    2044  100 CONTINUE
    +
    2045  nrreps = kvals(1)
    +
    2046  END IF
    +
    2047  ELSE
    +
    2048 C PRINT *,'NOT DELAYED REPLICATION'
    +
    2049  END IF
    +
    2050 C RESTRUCTURE WORKING STACK W/REPLICATIONS
    +
    2051  IF (nrreps.EQ.0) THEN
    +
    2052 C PRINT *,'RESTRUCTURING - NO REPLICATION'
    +
    2053  iptr(11) = ipick + nrset + 2
    +
    2054  GO TO 9999
    +
    2055  END IF
    +
    2056 C PRINT *,' SAVE OFF',NRSET,' DESCRIPTORS'
    +
    2057 C PICK UP DESCRIPTORS TO BE REPLICATED
    +
    2058  DO 1000 i = 1, nrset
    +
    2059  CALL fi8808(iptr,iwork,lf,lx,ly,jdesc)
    +
    2060  itemp(i) = jdesc
    +
    2061 C PRINT *,'REPLICATION ',I,ITEMP(I)
    +
    2062  1000 CONTINUE
    +
    2063 C MOVE TRAILING DESCRIPTORS TO HOLD AREA
    +
    2064  lax = iptr(12) - iptr(11) + 1
    +
    2065 C PRINT *,LAX,' TRAILING DESCRIPTORS TO HOLD AREA',IPTR(11),IPTR(12)
    +
    2066  DO 2000 i = 1, lax
    +
    2067  CALL fi8808(iptr,iwork,lf,lx,ly,jdesc)
    +
    2068  ktemp(i) = jdesc
    +
    2069 C PRINT *,' ',I,KTEMP(I)
    +
    2070  2000 CONTINUE
    +
    2071 C REPLICATIONS INTO ISTACK
    +
    2072 C PRINT *,' MUST REPLICATE ',KX,' DESCRIPTORS',KY,' TIMES'
    +
    2073 C PRINT *,'REPLICATIONS INTO STACK. LOC',ICURR
    +
    2074  DO 4000 i = 1, nrreps
    +
    2075  DO 3000 j = 1, nrset
    +
    2076  iwork(icurr) = itemp(j)
    +
    2077 C PRINT *,'FI8805 A',ICURR,IWORK(ICURR)
    +
    2078  icurr = icurr + 1
    +
    2079  3000 CONTINUE
    +
    2080  4000 CONTINUE
    +
    2081 C PRINT *,' TO LOC',ICURR-1
    +
    2082 C RESTORE TRAILING DESCRIPTORS
    +
    2083 C PRINT *,'TRAILING DESCRIPTORS INTO STACK. LOC',ICURR
    +
    2084  DO 5000 i = 1, lax
    +
    2085  iwork(icurr) = ktemp(i)
    +
    2086 C PRINT *,'FI8805 B',ICURR,IWORK(ICURR)
    +
    2087  icurr = icurr + 1
    +
    2088  5000 CONTINUE
    +
    2089  iptr(12) = icurr - 1
    +
    2090  iptr(11) = ipick
    +
    2091  9999 CONTINUE
    +
    2092 C DO 5500 I = 1, IPTR(12)
    +
    2093 C PRINT *,'FI8805 B',I,IWORK(I),IPTR(11)
    +
    2094 C5500 CONTINUE
    +
    2095  RETURN
    +
    2096  END
    +
    2097 C> @brief Process operator descriptors
    +
    2098 C> @author Bill Cavanaugh @date 1988-09-01
    +
    2099 
    +
    2100 C> Extract and save indicated change values for use
    +
    2101 C> until changes are rescinded, or extract text strings indicated
    +
    2102 C> through 2 05 yyy.
    +
    2103 C>
    +
    2104 C> Program history log:
    +
    2105 C> - Bill Cavanaugh 1988-09-01
    +
    2106 C> - Bill Cavanaugh 1991-04-04 Modified to handle descriptor 2 05 yyy
    +
    2107 C> - Bill Cavanaugh 1991-05-10 Coding has been added to process properly
    +
    2108 C> table c descriptor 2 06 yyy.
    +
    2109 C> - Bill Cavanaugh 1991-11-21 Coding has been added to properly process
    +
    2110 C> table c descriptor 2 03 yyy, the change
    +
    2111 C> to new reference value for selected
    +
    2112 C> descriptors.
    +
    2113 C>
    +
    2114 C> @param[in] IPTR See w3fi88 routine docblock
    +
    2115 C> @param[in] LX X portion of current descriptor
    +
    2116 C> @param[in] LY Y portion of current descriptor
    +
    2117 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    2118 C> contained in a bufr message
    +
    2119 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    2120 C> may be processed; upper air data and some satellite
    +
    2121 C> data require a value for maxd of 1700, but for most
    +
    2122 C> other data a value for maxd of 500 will suffice
    +
    2123 C> @param[out] KDATA Array containing decoded reports from bufr message.
    +
    2124 C> KDATA(Report number,parameter number)
    +
    2125 C> (report number limited to value of input argument
    +
    2126 C> maxr and parameter number limited to value of input
    +
    2127 C> argument maxd)
    +
    2128 C> Arrays containing data from table b
    +
    2129 C> @param[out] ISCAL1 Scale for value of descriptor
    +
    2130 C> @param[out] IRFVL1 Reference value for descriptor
    +
    2131 C> @param[out] IWIDE1 Bit width for value of descriptor
    +
    2132 C> @param IDENT
    +
    2133 C> @param MSGA
    +
    2134 C> @param IVALS
    +
    2135 C> @param MSTACK
    +
    2136 C> @param J
    +
    2137 C> @param LL
    +
    2138 C> @param KFXY1
    +
    2139 C> @param IWORK
    +
    2140 C> @param JDESC
    +
    2141 C> @param KPTRB
    +
    2142 C>
    +
    2143 C> Error return:
    +
    2144 C> IPTR(1) = 5 - Erroneous x value in data descriptor operator
    +
    2145 C>
    +
    2146 C> @author Bill Cavanaugh @date 1988-09-01
    +
    2147  SUBROUTINE fi8806 (IPTR,LX,LY,IDENT,MSGA,KDATA,IVALS,MSTACK,
    +
    2148  * IWIDE1,IRFVL1,ISCAL1,J,LL,KFXY1,IWORK,JDESC,MAXR,MAXD,KPTRB)
    +
    2149 
    +
    2150 C ..................................................
    +
    2151 C
    +
    2152 C NEW BASE TABLE B
    +
    2153 C MAY BE A COMBINATION OF MASTER TABLE B
    +
    2154 C AND ANCILLARY TABLE B
    +
    2155 C
    +
    2156  INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
    +
    2157 C CHARACTER*40 ANAME1(*)
    +
    2158 C CHARACTER*24 AUNIT1(*)
    +
    2159 C ..................................................
    +
    2160  INTEGER IPTR(*),KDATA(MAXR,MAXD),IVALS(*)
    +
    2161  INTEGER IDENT(*),IWORK(*),KPTRB(*)
    +
    2162  INTEGER MSGA(*),MSTACK(2,MAXD)
    +
    2163  INTEGER J,JDESC
    +
    2164  INTEGER LL
    +
    2165  INTEGER LX
    +
    2166  INTEGER LY
    +
    2167 C
    +
    2168  SAVE
    +
    2169 C
    +
    2170 C PRINT *,' F2 - DATA DESCRIPTOR OPERATOR'
    +
    2171  IF (lx.EQ.1) THEN
    +
    2172 C CHANGE BIT WIDTH
    +
    2173  IF (ly.EQ.0) THEN
    +
    2174 C PRINT *,' RETURN TO NORMAL WIDTH'
    +
    2175  iptr(26) = 0
    +
    2176  ELSE
    +
    2177 C PRINT *,' EXPAND WIDTH BY',LY-128,' BITS'
    +
    2178  iptr(26) = ly - 128
    +
    2179  END IF
    +
    2180  ELSE IF (lx.EQ.2) THEN
    +
    2181 C CHANGE SCALE
    +
    2182  IF (ly.EQ.0) THEN
    +
    2183 C RESET TO STANDARD SCALE
    +
    2184  iptr(27) = 0
    +
    2185  ELSE
    +
    2186 C SET NEW SCALE
    +
    2187  iptr(27) = ly - 128
    +
    2188  END IF
    +
    2189  ELSE IF (lx.EQ.3) THEN
    +
    2190 C CHANGE REFERENCE VALUE
    +
    2191 C FOR EACH OF THOSE DESCRIPTORS BETWEEN
    +
    2192 C 2 03 YYY WHERE Y LT 255 AND
    +
    2193 C 2 03 255, EXTRACT THE NEW REFERENCE
    +
    2194 C VALUE (BIT WIDTH YYY) AND PLACE
    +
    2195 C IN TERTIARY TABLE B REF VAL POSITION,
    +
    2196 C SET FLAG IN SECONDARY REFVAL POSITION
    +
    2197 C THOSE DESCRIPTORS DO NOT HAVE DATA
    +
    2198 C ASSOCIATED WITH THEM, BUT ONLY
    +
    2199 C IDENTIFY THE TABLE B ENTRIES THAT
    +
    2200 C ARE GETTING NEW REFERENCE VALUES.
    +
    2201  kyyy = ly
    +
    2202  IF (kyyy.GT.0.AND.kyyy.LT.255) THEN
    +
    2203 C START CYCLING THRU DESCRIPTORS UNTIL
    +
    2204 C TERMINATE NEW REF VALS IS FOUND
    +
    2205  300 CONTINUE
    +
    2206  CALL fi8808 (iptr,iwork,lf,lx,ly,jdesc)
    +
    2207  IF (jdesc.EQ.33791) THEN
    +
    2208 C IF 2 03 255 THEN RETURN
    +
    2209  RETURN
    +
    2210  END IF
    +
    2211 C FIND MATCHING TABLE B ENTRY
    +
    2212  lj = kptrb(jdesc)
    +
    2213  IF (lj.LT.1) THEN
    +
    2214 C MATCHING DESCRIPTOR NOT FOUND, ERROR ERROR
    +
    2215  print *,'2 03 YYY - MATCHING DESCRIPTOR NOT FOUND'
    +
    2216  iptr(1) = 23
    +
    2217  RETURN
    +
    2218  END IF
    +
    2219 C TURN ON SWITCH
    +
    2220  irfvl1(2,lj) = 1
    +
    2221 C INSERT NEW REFERENCE VALUE
    +
    2222  CALL gbyte (msga,irfvl1(3,lj),iptr(25),kyyy)
    +
    2223  GO TO 300
    +
    2224  ELSE IF (kyyy.EQ.0) THEN
    +
    2225 C MUST TURN OFF ALL NEW
    +
    2226 C REFERENCE VALUES
    +
    2227  DO 400 i = 1, iptr(21)
    +
    2228  irfvl1(2,i) = 0
    +
    2229  400 CONTINUE
    +
    2230  END IF
    +
    2231 C LX = 3
    +
    2232 C MUST BE CONCLUDED WITH Y=255
    +
    2233  ELSE IF (lx.EQ.4) THEN
    +
    2234 C ASSOCIATED VALUES
    +
    2235  IF (ly.EQ.0) THEN
    +
    2236  iptr(29) = 0
    +
    2237 C PRINT *,'RESET ASSOCIATED VALUES',IPTR(29)
    +
    2238  ELSE
    +
    2239  iptr(29) = ly
    +
    2240  IF (iwork(iptr(11)).NE.7957) THEN
    +
    2241  print *,'2 04 YYY NOT FOLLOWED BY 0 31 021'
    +
    2242  iptr(1) = 11
    +
    2243  END IF
    +
    2244 C PRINT *,'SET ASSOCIATED VALUES',IPTR(29)
    +
    2245  END IF
    +
    2246  ELSE IF (lx.EQ.5) THEN
    +
    2247  mwdbit = iptr(44)
    +
    2248 C PROCESS TEXT DATA
    +
    2249  iptr(40) = ly
    +
    2250  iptr(18) = 1
    +
    2251  j = kptrb(jdesc)
    +
    2252  IF (ident(16).EQ.0) THEN
    +
    2253 C PRINT *,'FROM FI8806 - 2 05 YYY - NONCOMPRESSED TEXT',J
    +
    2254  CALL fi8804(iptr,msga,kdata,ivals,mstack,
    +
    2255  * iwide1,irfvl1,iscal1,j,ll,jdesc,maxr,maxd)
    +
    2256  ELSE
    +
    2257 C PRINT *,'2 05 YYY - TEXT - COMPRESSED MODE YYY=',LY
    +
    2258 C PRINT *,'TEXT - LOWEST = 0'
    +
    2259  iptr(25) = iptr(25) + iptr(40) * 8
    +
    2260 C GET NBINC
    +
    2261 C CALL GBYTE (MSGA,NBINC,IPTR(25),6)
    +
    2262  iptr(25) = iptr(25) + 6
    +
    2263  nbinc = iptr(40)
    +
    2264 C PRINT *,'TEXT NBINC =',NBINC,IPTR(40)
    +
    2265 C FOR NUMBER OF OBSERVATIONS
    +
    2266  iptr(31) = iptr(31) + 1
    +
    2267  kprm = iptr(31) + iptr(24)
    +
    2268  istart = kprm
    +
    2269  DO 1900 n = 1, ident(14)
    +
    2270  kprm = istart
    +
    2271  nbits = iptr(40) * 8
    +
    2272  1700 CONTINUE
    +
    2273 C PRINT *,'1700',KDATA(N,KPRM),N,KPRM,NBITS
    +
    2274  IF (nbits.GT.mwdbit) THEN
    +
    2275  CALL gbyte (msga,idata,iptr(25),mwdbit)
    +
    2276  iptr(25) = iptr(25) + mwdbit
    +
    2277  nbits = nbits - mwdbit
    +
    2278 C CONVERTS ASCII TO EBCIDIC
    +
    2279 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    2280  IF (iptr(37).EQ.0) THEN
    +
    2281  CALL w3ai39 (idata,iptr(45))
    +
    2282  END IF
    +
    2283  mstack(1,kprm) = jdesc
    +
    2284  mstack(2,kprm) = 0
    +
    2285  kdata(n,kprm) = idata
    +
    2286 C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
    +
    2287 C SET FOR NEXT PART
    +
    2288  kprm = kprm + 1
    +
    2289 C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
    +
    2290 C1701 FORMAT (1X,I1,1X,6HKDATA=,A4,2X,I5,2X,I5,2X,I5,2X,
    +
    2291 C * I10)
    +
    2292  GO TO 1700
    +
    2293  ELSE IF (nbits.EQ.mwdbit) THEN
    +
    2294  CALL gbyte (msga,idata,iptr(25),mwdbit)
    +
    2295  iptr(25) = iptr(25) + mwdbit
    +
    2296  nbits = nbits - mwdbit
    +
    2297 C CONVERTS ASCII TO EBCIDIC
    +
    2298 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    2299  IF (iptr(37).EQ.0) THEN
    +
    2300  CALL w3ai39 (idata,iptr(45))
    +
    2301  END IF
    +
    2302  mstack(1,kprm) = jdesc
    +
    2303  mstack(2,kprm) = 0
    +
    2304  kdata(n,kprm) = idata
    +
    2305 C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
    +
    2306 C SET FOR NEXT PART
    +
    2307  kprm = kprm + 1
    +
    2308 C PRINT 1701,1,KDATA(N,KPRM),N,KPRM,NBITS,IDATA
    +
    2309  ELSE IF (nbits.GT.0) THEN
    +
    2310  CALL gbyte (msga,idata,iptr(25),nbits)
    +
    2311  iptr(25) = iptr(25) + nbits
    +
    2312  ibuf = (mwdbit - nbits) / 8
    +
    2313  IF (ibuf.GT.0) THEN
    +
    2314  DO 1750 mp = 1, ibuf
    +
    2315  idata = idata * 256 + 32
    +
    2316  1750 CONTINUE
    +
    2317  END IF
    +
    2318 C CONVERTS ASCII TO EBCIDIC
    +
    2319 C COMMENT OUT IF NOT IBM370 COMPUTER
    +
    2320  IF (iptr(37).EQ.0) THEN
    +
    2321  CALL w3ai39 (idata,iptr(45))
    +
    2322  END IF
    +
    2323  mstack(1,kprm) = jdesc
    +
    2324  mstack(2,kprm) = 0
    +
    2325  kdata(n,kprm) = idata
    +
    2326 C PRINT *,'TEXT ',N,KPRM,KDATA(N,KPRM)
    +
    2327 C PRINT 1701,2,KDATA(N,KPRM),N,KPRM,NBITS
    +
    2328  END IF
    +
    2329 C WRITE (6,1800)N,(KDATA(N,I),I=KPRS,KPRM)
    +
    2330 C1800 FORMAT (2X,I4,2X,3A4)
    +
    2331  1900 CONTINUE
    +
    2332 
    +
    2333  iptr(24) = iptr(24) + iptr(40) / 4 - 1
    +
    2334  IF (mod(iptr(40),4).NE.0) iptr(24) = iptr(24) + 1
    +
    2335  END IF
    +
    2336  iptr(18) = 0
    +
    2337 C ---------------------------
    +
    2338  ELSE IF (lx.EQ.6) THEN
    +
    2339 C SKIP NEXT DESCRIPTOR
    +
    2340 C SET TO PASS OVER DESCRIPTOR AND DATA
    +
    2341 C IF DESCRIPTOR NOT IN TABLE B
    +
    2342  iptr(36) = ly
    +
    2343 C PRINT *,'SET TO SKIP',LY,' BIT FIELD'
    +
    2344  iptr(31) = iptr(31) + 1
    +
    2345  kprm = iptr(31) + iptr(24)
    +
    2346  mstack(1,kprm) = 34304 + ly
    +
    2347  mstack(2,kprm) = 0
    +
    2348  ELSE
    +
    2349  iptr(1) = 5
    +
    2350  ENDIF
    +
    2351  RETURN
    +
    2352  END
    +
    2353 C> @brief Process queue descriptor.
    +
    2354 C> @author Bill Cavanaugh @date 1988-09-01
    +
    2355 
    +
    2356 C> Substitute descriptor queue for queue descriptor.
    +
    2357 C>
    +
    2358 C> Program history log:
    +
    2359 C> - Bill Cavanaugh 1988-09-01
    +
    2360 C> - Bill Cavanaugh 1991-04-17 Improved handling of nested queue descriptors
    +
    2361 C> - Bill Cavanaugh 1991-05-28 Improved handling of nested queue descriptors
    +
    2362 C> based on tests with live data.
    +
    2363 C>
    +
    2364 C> @param[in] IWORK Working descriptor list
    +
    2365 C> @param[in] IPTR See w3fi88 routine docblock
    +
    2366 C> @param[in] ITBLD+ITBLD2 Array containing descriptor queues
    +
    2367 C> @param[in] JDESC Queue descriptor to be expanded
    +
    2368 C> @param KPTRD
    +
    2369 C>
    +
    2370 C> @author Bill Cavanaugh @date 1988-09-01
    +
    2371  SUBROUTINE fi8807(IPTR,IWORK,ITBLD,ITBLD2,JDESC,KPTRD)
    +
    2372 
    +
    2373 C ..................................................
    +
    2374 C
    +
    2375 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
    +
    2376 C
    +
    2377  INTEGER ITBLD2(20,*)
    +
    2378 C ..................................................
    +
    2379 C
    +
    2380 C NEW BASE TABLE D
    +
    2381 C
    +
    2382  INTEGER ITBLD(20,*)
    +
    2383 C ..................................................
    +
    2384 C
    +
    2385  INTEGER IPTR(*),JDESC,KPTRD(*)
    +
    2386  INTEGER IWORK(*),IHOLD(15000)
    +
    2387 C
    +
    2388  SAVE
    +
    2389 C PRINT *,' FI8807 F3 ENTRY',IPTR(11),IPTR(12)
    +
    2390 C SET FOR BINARY SEARCH IN TABLE D
    +
    2391  jlo = 1
    +
    2392  jhi = iptr(20)
    +
    2393 C PRINT *,'LOOKING FOR QUEUE DESCRIPTOR',JDESC,IPTR(11),IPTR(12)
    +
    2394 C
    +
    2395  jmid = kptrd(mod(jdesc,16384))
    +
    2396  IF (jmid.LT.0) THEN
    +
    2397  iptr(1) = 4
    +
    2398  RETURN
    +
    2399  END IF
    +
    2400 C HAVE TABLE D MATCH
    +
    2401 C PRINT *,'D ',(ITBLD(LL,JMID),LL=1,20)
    +
    2402 C PRINT *,'TABLE D TO IHOLD'
    +
    2403  ik = 0
    +
    2404  jk = 0
    +
    2405  DO 200 ki = 2, 20
    +
    2406  IF (itbld(ki,jmid).NE.0) THEN
    +
    2407  ik = ik + 1
    +
    2408  ihold(ik) = itbld(ki,jmid)
    +
    2409 C PRINT *,IK,IHOLD(IK)
    +
    2410  ELSE
    +
    2411  GO TO 300
    +
    2412  END IF
    +
    2413  200 CONTINUE
    +
    2414  300 CONTINUE
    +
    2415  kk = iptr(11)
    +
    2416  IF (kk.GT.iptr(12)) THEN
    +
    2417 C NOTHING MORE TO APPEND
    +
    2418 C PRINT *,'NOTHING MORE TO APPEND'
    +
    2419  ELSE
    +
    2420 C APPEND TRAILING IWORK TO IHOLD
    +
    2421 C PRINT *,'APPEND FROM ',KK,' TO',IPTR(12)
    +
    2422  DO 500 i = kk, iptr(12)
    +
    2423  ik = ik + 1
    +
    2424  ihold(ik) = iwork(i)
    +
    2425  500 CONTINUE
    +
    2426  END IF
    +
    2427 C RESET IHOLD TO IWORK
    +
    2428 C PRINT *,' RESET IWORK STACK'
    +
    2429  kk = iptr(11) - 2
    +
    2430  DO 1000 i = 1, ik
    +
    2431  kk = kk + 1
    +
    2432  iwork(kk) = ihold(i)
    +
    2433  1000 CONTINUE
    +
    2434  iptr(12) = kk
    +
    2435 C PRINT *,' FI8807 F3 EXIT ',IPTR(11),IPTR(12)
    +
    2436 C DO 2000 I = 1, IPTR(12)
    +
    2437 C PRINT *,'EXIT IWORK',I,IWORK(I)
    +
    2438 C2000 CONTINUE
    +
    2439 C RESET POINTERS
    +
    2440  iptr(11) = iptr(11) - 1
    +
    2441  RETURN
    +
    2442  END
    +
    2443 C> @brief
    +
    2444 C> @author Bill Cavanaugh @date 1988-09-01
    +
    2445 
    +
    2446 C>
    +
    2447 C> Program history log:
    +
    2448 C> - Bill Cavanaugh 1988-09-01
    +
    2449 C>
    +
    2450 C> @param[inout] IPTR See w3fi88 routine docblock
    +
    2451 C> @param[in] IWORK Working descriptor list
    +
    2452 C> @param LF
    +
    2453 C> @param LX
    +
    2454 C> @param LY
    +
    2455 C> @param JDESC
    +
    2456 C>
    +
    2457 C> @author Bill Cavanaugh @date 1988-09-01
    +
    2458  SUBROUTINE fi8808(IPTR,IWORK,LF,LX,LY,JDESC)
    +
    2459 
    +
    2460  INTEGER IPTR(*),IWORK(*),LF,LX,LY,JDESC
    +
    2461  SAVE
    +
    2462 C
    +
    2463 C PRINT *,' FI8808 NEW DESCRIPTOR PICKUP'
    +
    2464  JDESC = iwork(iptr(11))
    +
    2465  ly = mod(jdesc,256)
    +
    2466  iptr(34) = ly
    +
    2467  lx = mod((jdesc/256),64)
    +
    2468  iptr(33) = lx
    +
    2469  lf = jdesc / 16384
    +
    2470  iptr(32) = lf
    +
    2471 C PRINT *,' TEST DESCRIPTOR',LF,LX,LY,' AT',IPTR(11)
    +
    2472  iptr(11) = iptr(11) + 1
    +
    2473  RETURN
    +
    2474  END
    +
    2475 C> @brief Reformat profiler w hgt increments
    +
    2476 C> @author Bill Cavanaugh @date 1990-02-14
    +
    2477 
    +
    2478 C> Reformat decoded profiler data to show heights instead of
    +
    2479 C> height increments.
    +
    2480 C>
    +
    2481 C> Program history log:
    +
    2482 C> - Bill Cavanaugh 1990-02-14
    +
    2483 C>
    +
    2484 C> @param[in] IDENT Array contains message information extracted from BUFR message
    +
    2485 C> - IDENT(1) - Edition number (byte 4, section 1)
    +
    2486 C> - IDENT(2) - Originating center (bytes 5-6, section 1)
    +
    2487 C> - IDENT(3) - Update sequence (byte 7, section 1)
    +
    2488 C> - IDENT(4) - (byte 8, section 1)
    +
    2489 C> - IDENT(5) - Bufr message type (byte 9, section 1)
    +
    2490 C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
    +
    2491 C> - IDENT(7) - (bytes 11-12, section 1)
    +
    2492 C> - IDENT(8) - Year of century (byte 13, section 1)
    +
    2493 C> - IDENT(9) - Month of year (byte 14, section 1)
    +
    2494 C> - IDENT(10) - Day of month (byte 15, section 1)
    +
    2495 C> - IDENT(11) - Hour of day (byte 16, section 1)
    +
    2496 C> - IDENT(12) - Minute of hour (byte 17, section 1)
    +
    2497 C> - IDENT(13) - Rsvd by adp centers (byte 18, section 1)
    +
    2498 C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
    +
    2499 C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
    +
    2500 C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
    +
    2501 C> @param[in] MSTACK Working descriptor list and scaling factor
    +
    2502 C> @param[in] KDATA Array containing decoded reports from bufr message.
    +
    2503 C> KDATA(Report number,parameter number)
    +
    2504 C> (report number limited to value of input argument
    +
    2505 C> maxr and parameter number limited to value of input
    +
    2506 C> argument maxd)
    +
    2507 C> @param[in] IPTR See w3fi88
    +
    2508 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    2509 C> contained in a bufr message
    +
    2510 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    2511 C> may be processed; upper air data and some satellite
    +
    2512 C> data require a value for maxd of 1700, but for most
    +
    2513 C> other data a value for maxd of 500 will suffice
    +
    2514 C>
    +
    2515 C> @author Bill Cavanaugh @date 1990-02-14
    +
    2516  SUBROUTINE fi8809(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
    +
    2517 
    +
    2518 C ----------------------------------------------------------------
    +
    2519 C
    +
    2520  INTEGER ISW
    +
    2521  INTEGER IDENT(*),KDATA(MAXR,MAXD)
    +
    2522  INTEGER MSTACK(2,MAXD),IPTR(*)
    +
    2523  INTEGER KPROFL(1700)
    +
    2524  INTEGER KPROF2(1700)
    +
    2525  INTEGER KSET2(1700)
    +
    2526 C
    +
    2527 C ----------------------------------------------------------
    +
    2528  SAVE
    +
    2529 C PRINT *,'FI8809'
    +
    2530 C LOOP FOR NUMBER OF SUBSETS/REPORTS
    +
    2531  DO 3000 i = 1, ident(14)
    +
    2532 C INIT FOR DATA INPUT ARRAY
    +
    2533  mk = 1
    +
    2534 C INIT FOR DESC OUTPUT ARRAY
    +
    2535  jk = 0
    +
    2536 C LOCATION
    +
    2537  isw = 0
    +
    2538  DO 200 j = 1, 3
    +
    2539 C LATITUDE
    +
    2540  IF (mstack(1,mk).EQ.1282) THEN
    +
    2541  isw = isw + 1
    +
    2542  GO TO 100
    +
    2543 C LONGITUDE
    +
    2544  ELSE IF (mstack(1,mk).EQ.1538) THEN
    +
    2545  isw = isw + 2
    +
    2546  GO TO 100
    +
    2547 C HEIGHT ABOVE SEA LEVEL
    +
    2548  ELSE IF (mstack(1,mk).EQ.1793) THEN
    +
    2549  ihgt = kdata(i,mk)
    +
    2550  isw = isw + 4
    +
    2551  GO TO 100
    +
    2552  END IF
    +
    2553  GO TO 200
    +
    2554  100 CONTINUE
    +
    2555  jk = jk + 1
    +
    2556 C SAVE DESCRIPTOR
    +
    2557  kprofl(jk) = mstack(1,mk)
    +
    2558 C SAVE SCALE
    +
    2559  kprof2(jk) = mstack(2,mk)
    +
    2560 C SAVE DATA
    +
    2561  kset2(jk) = kdata(i,mk)
    +
    2562  mk = mk + 1
    +
    2563  200 CONTINUE
    +
    2564  IF (isw.NE.7) THEN
    +
    2565  print *,'LOCATION ERROR PROCESSING PROFILER'
    +
    2566  iptr(1) = 200
    +
    2567  RETURN
    +
    2568  END IF
    +
    2569 C TIME
    +
    2570  isw = 0
    +
    2571  DO 400 j = 1, 7
    +
    2572 C YEAR
    +
    2573  IF (mstack(1,mk).EQ.1025) THEN
    +
    2574  isw = isw + 1
    +
    2575  GO TO 300
    +
    2576 C MONTH
    +
    2577  ELSE IF (mstack(1,mk).EQ.1026) THEN
    +
    2578  isw = isw + 2
    +
    2579  GO TO 300
    +
    2580 C DAY
    +
    2581  ELSE IF (mstack(1,mk).EQ.1027) THEN
    +
    2582  isw = isw + 4
    +
    2583  GO TO 300
    +
    2584 C HOUR
    +
    2585  ELSE IF (mstack(1,mk).EQ.1028) THEN
    +
    2586  isw = isw + 8
    +
    2587  GO TO 300
    +
    2588 C MINUTE
    +
    2589  ELSE IF (mstack(1,mk).EQ.1029) THEN
    +
    2590  isw = isw + 16
    +
    2591  GO TO 300
    +
    2592 C TIME SIGNIFICANCE
    +
    2593  ELSE IF (mstack(1,mk).EQ.2069) THEN
    +
    2594  isw = isw + 32
    +
    2595  GO TO 300
    +
    2596  ELSE IF (mstack(1,mk).EQ.1049) THEN
    +
    2597  isw = isw + 64
    +
    2598  GO TO 300
    +
    2599  END IF
    +
    2600  GO TO 400
    +
    2601  300 CONTINUE
    +
    2602  jk = jk + 1
    +
    2603 C SAVE DESCRIPTOR
    +
    2604  kprofl(jk) = mstack(1,mk)
    +
    2605 C SAVE SCALE
    +
    2606  kprof2(jk) = mstack(2,mk)
    +
    2607 C SAVE DATA
    +
    2608  kset2(jk) = kdata(i,mk)
    +
    2609  mk = mk + 1
    +
    2610  400 CONTINUE
    +
    2611  IF (isw.NE.127) THEN
    +
    2612  print *,'TIME ERROR PROCESSING PROFILER',isw
    +
    2613  iptr(1) = 201
    +
    2614  RETURN
    +
    2615  END IF
    +
    2616 C SURFACE DATA
    +
    2617  krg = 0
    +
    2618  isw = 0
    +
    2619  DO 600 j = 1, 10
    +
    2620 C WIND SPEED
    +
    2621  IF (mstack(1,mk).EQ.2818) THEN
    +
    2622  isw = isw + 1
    +
    2623  GO TO 500
    +
    2624 C WIND DIRECTION
    +
    2625  ELSE IF (mstack(1,mk).EQ.2817) THEN
    +
    2626  isw = isw + 2
    +
    2627  GO TO 500
    +
    2628 C PRESS REDUCED TO MSL
    +
    2629  ELSE IF (mstack(1,mk).EQ.2611) THEN
    +
    2630  isw = isw + 4
    +
    2631  GO TO 500
    +
    2632 C TEMPERATURE
    +
    2633  ELSE IF (mstack(1,mk).EQ.3073) THEN
    +
    2634  isw = isw + 8
    +
    2635  GO TO 500
    +
    2636 C RAINFALL RATE
    +
    2637  ELSE IF (mstack(1,mk).EQ.3342) THEN
    +
    2638  isw = isw + 16
    +
    2639  GO TO 500
    +
    2640 C RELATIVE HUMIDITY
    +
    2641  ELSE IF (mstack(1,mk).EQ.3331) THEN
    +
    2642  isw = isw + 32
    +
    2643  GO TO 500
    +
    2644 C 1ST RANGE GATE OFFSET
    +
    2645  ELSE IF (mstack(1,mk).EQ.1982.OR.
    +
    2646  * mstack(1,mk).EQ.1983) THEN
    +
    2647 C CANNOT USE NORMAL PROCESSING FOR FIRST RANGE GATE, MUST SAVE
    +
    2648 C VALUE FOR LATER USE
    +
    2649  IF (mstack(1,mk).EQ.1983) THEN
    +
    2650  ihgt = kdata(i,mk)
    +
    2651  mk = mk + 1
    +
    2652  krg = 1
    +
    2653  ELSE
    +
    2654  IF (krg.EQ.0) THEN
    +
    2655  incrht = kdata(i,mk)
    +
    2656  mk = mk + 1
    +
    2657  krg = 1
    +
    2658 C PRINT *,'INITIAL INCR =',INCRHT
    +
    2659  ELSE
    +
    2660  lhgt = 500 + ihgt - kdata(i,mk)
    +
    2661  isw = isw + 64
    +
    2662 C PRINT *,'BASE HEIGHT=',LHGT,' INCR=',INCRHT
    +
    2663  END IF
    +
    2664  END IF
    +
    2665 C MODE #1
    +
    2666  ELSE IF (mstack(1,mk).EQ.8128) THEN
    +
    2667  isw = isw + 128
    +
    2668  GO TO 500
    +
    2669 C MODE #2
    +
    2670  ELSE IF (mstack(1,mk).EQ.8129) THEN
    +
    2671  isw = isw + 256
    +
    2672  GO TO 500
    +
    2673  END IF
    +
    2674  GO TO 600
    +
    2675  500 CONTINUE
    +
    2676 C SAVE DESCRIPTOR
    +
    2677  jk = jk + 1
    +
    2678  kprofl(jk) = mstack(1,mk)
    +
    2679 C SAVE SCALE
    +
    2680  kprof2(jk) = mstack(2,mk)
    +
    2681 C SAVE DATA
    +
    2682  kset2(jk) = kdata(i,mk)
    +
    2683 C IF (I.EQ.1) THEN
    +
    2684 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
    +
    2685 C END IF
    +
    2686  mk = mk + 1
    +
    2687  600 CONTINUE
    +
    2688  IF (isw.NE.511) THEN
    +
    2689  print *,'SURFACE ERROR PROCESSING PROFILER',isw
    +
    2690  iptr(1) = 202
    +
    2691  RETURN
    +
    2692  END IF
    +
    2693 C 43 LEVELS
    +
    2694  DO 2000 l = 1, 43
    +
    2695  2020 CONTINUE
    +
    2696  isw = 0
    +
    2697 C HEIGHT INCREMENT
    +
    2698  IF (mstack(1,mk).EQ.1982) THEN
    +
    2699 C PRINT *,'NEW HEIGHT INCREMENT',KDATA(I,MK)
    +
    2700  incrht = kdata(i,mk)
    +
    2701  mk = mk + 1
    +
    2702  IF (lhgt.LT.(9250+ihgt)) THEN
    +
    2703  lhgt = ihgt + 500 - incrht
    +
    2704  ELSE
    +
    2705  lhgt = ihgt + 9250 - incrht
    +
    2706  END IF
    +
    2707  END IF
    +
    2708 C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DATA
    +
    2709 C AT THIS POINT - HEIGHT + INCREMENT + BASE VALUE
    +
    2710  lhgt = lhgt + incrht
    +
    2711 C PRINT *,'LEVEL ',L,LHGT
    +
    2712  IF (l.EQ.37) THEN
    +
    2713  lhgt = lhgt + incrht
    +
    2714  END IF
    +
    2715  jk = jk + 1
    +
    2716 C SAVE DESCRIPTOR
    +
    2717  kprofl(jk) = 1798
    +
    2718 C SAVE SCALE
    +
    2719  kprof2(jk) = 0
    +
    2720 C SAVE DATA
    +
    2721  kset2(jk) = lhgt
    +
    2722 C IF (I.EQ.10) THEN
    +
    2723 C PRINT *,' '
    +
    2724 C PRINT *,'HGT',JK,KPROFL(JK),KSET2(JK)
    +
    2725 C END IF
    +
    2726  isw = 0
    +
    2727  DO 800 j = 1, 9
    +
    2728  750 CONTINUE
    +
    2729  IF (mstack(1,mk).EQ.1982) THEN
    +
    2730  GO TO 2020
    +
    2731 C U VECTOR VALUE
    +
    2732  ELSE IF (mstack(1,mk).EQ.3008) THEN
    +
    2733  isw = isw + 1
    +
    2734  IF (kdata(i,mk).GE.2047) THEN
    +
    2735  vectu = 32767
    +
    2736  ELSE
    +
    2737  vectu = kdata(i,mk)
    +
    2738  END IF
    +
    2739  mk = mk + 1
    +
    2740  GO TO 800
    +
    2741 C V VECTOR VALUE
    +
    2742  ELSE IF (mstack(1,mk).EQ.3009) THEN
    +
    2743  isw = isw + 2
    +
    2744  IF (kdata(i,mk).GE.2047) THEN
    +
    2745  vectv = 32767
    +
    2746  ELSE
    +
    2747  vectv = kdata(i,mk)
    +
    2748  END IF
    +
    2749  mk = mk + 1
    +
    2750 C IF U VALUE IS ALSO AVAILABLE THEN GENERATE DDFFF
    +
    2751 C DESCRIPTORS AND DATA
    +
    2752  IF (iand(isw,1).NE.0) THEN
    +
    2753  IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
    +
    2754 C SAVE DD DESCRIPTOR
    +
    2755  jk = jk + 1
    +
    2756  kprofl(jk) = 2817
    +
    2757 C SAVE SCALE
    +
    2758  kprof2(jk) = 0
    +
    2759 C SAVE DD DATA
    +
    2760  kset2(jk) = 32767
    +
    2761 C SAVE FFF DESCRIPTOR
    +
    2762  jk = jk + 1
    +
    2763  kprofl(jk) = 2818
    +
    2764 C SAVE SCALE
    +
    2765  kprof2(jk) = 1
    +
    2766 C SAVE FFF DATA
    +
    2767  kset2(jk) = 32767
    +
    2768  ELSE
    +
    2769 C GENERATE DDFFF
    +
    2770  CALL w3fc05 (vectu,vectv,dir,spd)
    +
    2771  ndir = dir
    +
    2772  spd = spd
    +
    2773  nspd = spd
    +
    2774 C PRINT *,' ',NDIR,NSPD
    +
    2775 C SAVE DD DESCRIPTOR
    +
    2776  jk = jk + 1
    +
    2777  kprofl(jk) = 2817
    +
    2778 C SAVE SCALE
    +
    2779  kprof2(jk) = 0
    +
    2780 C SAVE DD DATA
    +
    2781  kset2(jk) = dir
    +
    2782 C IF (I.EQ.1) THEN
    +
    2783 C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
    +
    2784 C END IF
    +
    2785 C SAVE FFF DESCRIPTOR
    +
    2786  jk = jk + 1
    +
    2787  kprofl(jk) = 2818
    +
    2788 C SAVE SCALE
    +
    2789  kprof2(jk) = 1
    +
    2790 C SAVE FFF DATA
    +
    2791  kset2(jk) = spd
    +
    2792 C IF (I.EQ.1) THEN
    +
    2793 C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
    +
    2794 C END IF
    +
    2795  END IF
    +
    2796  END IF
    +
    2797  GO TO 800
    +
    2798 C W VECTOR VALUE
    +
    2799  ELSE IF (mstack(1,mk).EQ.3010) THEN
    +
    2800  isw = isw + 4
    +
    2801  GO TO 700
    +
    2802 C Q/C TEST RESULTS
    +
    2803  ELSE IF (mstack(1,mk).EQ.8130) THEN
    +
    2804  isw = isw + 8
    +
    2805  GO TO 700
    +
    2806 C U,V QUALITY IND
    +
    2807  ELSE IF(iand(isw,16).EQ.0.AND.mstack(1,mk).EQ.2070) THEN
    +
    2808  isw = isw + 16
    +
    2809  GO TO 700
    +
    2810 C W QUALITY IND
    +
    2811  ELSE IF(iand(isw,32).EQ.0.AND.mstack(1,mk).EQ.2070) THEN
    +
    2812  isw = isw + 32
    +
    2813  GO TO 700
    +
    2814 C SPECTRAL PEAK POWER
    +
    2815  ELSE IF (mstack(1,mk).EQ.5568) THEN
    +
    2816  isw = isw + 64
    +
    2817  GO TO 700
    +
    2818 C U,V VARIABILITY
    +
    2819  ELSE IF (mstack(1,mk).EQ.3011) THEN
    +
    2820  isw = isw + 128
    +
    2821  GO TO 700
    +
    2822 C W VARIABILITY
    +
    2823  ELSE IF (mstack(1,mk).EQ.3013) THEN
    +
    2824  isw = isw + 256
    +
    2825  GO TO 700
    +
    2826  ELSE IF ((mstack(1,mk)/16384).NE.0) THEN
    +
    2827  mk = mk + 1
    +
    2828  GO TO 750
    +
    2829  END IF
    +
    2830  GO TO 800
    +
    2831  700 CONTINUE
    +
    2832  jk = jk + 1
    +
    2833 C SAVE DESCRIPTOR
    +
    2834  kprofl(jk) = mstack(1,mk)
    +
    2835 C SAVE SCALE
    +
    2836  kprof2(jk) = mstack(2,mk)
    +
    2837 C SAVE DATA
    +
    2838  kset2(jk) = kdata(i,mk)
    +
    2839  mk = mk + 1
    +
    2840 C IF (I.EQ.1) THEN
    +
    2841 C PRINT *,' ',JK,KPROFL(JK),KSET2(JK)
    +
    2842 C END IF
    +
    2843  800 CONTINUE
    +
    2844  IF (isw.NE.511) THEN
    +
    2845  print *,'LEVEL ERROR PROCESSING PROFILER',isw
    +
    2846  iptr(1) = 203
    +
    2847  RETURN
    +
    2848  END IF
    +
    2849  2000 CONTINUE
    +
    2850 C MOVE DATA BACK INTO KDATA ARRAY
    +
    2851  DO 4000 ll = 1, jk
    +
    2852  kdata(i,ll) = kset2(ll)
    +
    2853  4000 CONTINUE
    +
    2854  3000 CONTINUE
    +
    2855 C PRINT *,'REBUILT ARRAY'
    +
    2856  DO 5000 ll = 1, jk
    +
    2857 C DESCRIPTOR
    +
    2858  mstack(1,ll) = kprofl(ll)
    +
    2859 C SCALE
    +
    2860  mstack(2,ll) = kprof2(ll)
    +
    2861 C PRINT *,LL,MSTACK(1,LL),(KDATA(I,LL),I=1,7)
    +
    2862  5000 CONTINUE
    +
    2863 C MOVE REFORMATTED DESCRIPTORS TO MSTACK ARRAY
    +
    2864  iptr(31) = jk
    +
    2865  RETURN
    +
    2866  END
    +
    2867 C> @brief Reformat profiler edition 2 data
    +
    2868 C> @author Bill Cavanaugh @date 1993-01-27
    +
    2869 
    +
    2870 C> Reformat profiler data in edition 2
    +
    2871 C>
    +
    2872 C> Program history log:
    +
    2873 C> - Bill Cavanaugh 1993-01-27
    +
    2874 C> - Dennis Keyser 1995-06-07 A correction was made to prevent
    +
    2875 C> unnecessary looping when all requested
    +
    2876 C> descriptors are missing.
    +
    2877 C>
    +
    2878 C> @param[in] IDENT - ARRAY CONTAINS MESSAGE INFORMATION EXTRACTED FROM BUFR MESSAGE -
    +
    2879 C> - IDENT(1) - Edition number (byte 4, section 1)
    +
    2880 C> - IDENT(2) - Originating center (bytes 5-6, section 1)
    +
    2881 C> - IDENT(3) - Update sequence (byte 7, section 1)
    +
    2882 C> - IDENT(4) - (byte 8, section 1)
    +
    2883 C> - IDENT(5) - Bufr message type (byte 9, section 1)
    +
    2884 C> - IDENT(6) - Bufr msg sub-type (byte 10, section 1)
    +
    2885 C> - IDENT(7) - (bytes 11-12, section 1)
    +
    2886 C> - IDENT(8) - Year of century (byte 13, section 1)
    +
    2887 C> - IDENT(9) - Month of year (byte 14, section 1)
    +
    2888 C> - IDENT(10) - Day of month (byte 15, section 1)
    +
    2889 C> - IDENT(11) - Hour of day (byte 16, section 1)
    +
    2890 C> - IDENT(12) - Minute of hour (byte 17, section 1)
    +
    2891 C> - IDENT(13) - Rsvd by adp centers(byte 18, section 1)
    +
    2892 C> - IDENT(14) - Nr of data subsets (byte 5-6, section 3)
    +
    2893 C> - IDENT(15) - Observed flag (byte 7, bit 1, section 3)
    +
    2894 C> - IDENT(16) - Compression flag (byte 7, bit 2, section 3)
    +
    2895 C> @param[in] MSTACK Working descriptor list and scaling factor
    +
    2896 C> @param[in] KDATA Array containing decoded reports from bufr message.
    +
    2897 C> KDATA(Report number,parameter number)
    +
    2898 C> (report number limited to value of input argument
    +
    2899 C> maxr and parameter number limited to value of input
    +
    2900 C> argument maxd)
    +
    2901 C> @param[in] IPTR See w3fi88
    +
    2902 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    2903 C> contained in a bufr message
    +
    2904 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    2905 C> may be processed; upper air data and some satellite
    +
    2906 C> data require a value for maxd of 1700, but for most
    +
    2907 C> other data a value for maxd of 500 will suffice
    +
    2908 C>
    +
    2909 C> @author Bill Cavanaugh @date 1993-01-27
    +
    2910  SUBROUTINE fi8810(IDENT,MSTACK,KDATA,IPTR,MAXR,MAXD)
    +
    2911 
    +
    2912  INTEGER ISW
    +
    2913  INTEGER IDENT(*),KDATA(MAXR,MAXD)
    +
    2914  INTEGER MSTACK(2,MAXD),IPTR(*)
    +
    2915  INTEGER KPROFL(1700)
    +
    2916  INTEGER KPROF2(1700)
    +
    2917  INTEGER KSET2(1700)
    +
    2918 C
    +
    2919  SAVE
    +
    2920 C LOOP FOR NUMBER OF SUBSETS
    +
    2921  DO 3000 i = 1, ident(14)
    +
    2922  mk = 1
    +
    2923  jk = 0
    +
    2924  isw = 0
    +
    2925 C PRINT *,'IDENTIFICATION'
    +
    2926  DO 200 j = 1, 5
    +
    2927  IF (mstack(1,mk).EQ.257) THEN
    +
    2928 C BLOCK NUMBER
    +
    2929  isw = isw + 1
    +
    2930  ELSE IF (mstack(1,mk).EQ.258) THEN
    +
    2931 C STATION NUMBER
    +
    2932  isw = isw + 2
    +
    2933  ELSE IF (mstack(1,mk).EQ.1282) THEN
    +
    2934 C LATITUDE
    +
    2935  isw = isw + 4
    +
    2936  ELSE IF (mstack(1,mk).EQ.1538) THEN
    +
    2937 C LONGITUDE
    +
    2938  isw = isw + 8
    +
    2939  ELSE IF (mstack(1,mk).EQ.1793) THEN
    +
    2940 C HEIGHT OF STATION
    +
    2941  isw = isw + 16
    +
    2942  ihgt = kdata(i,mk)
    +
    2943  ELSE
    +
    2944  mk = mk + 1
    +
    2945  GO TO 200
    +
    2946  END IF
    +
    2947  jk = jk + 1
    +
    2948  kprofl(jk) = mstack(1,mk)
    +
    2949  kprof2(jk) = mstack(2,mk)
    +
    2950  kset2(jk) = kdata(i,mk)
    +
    2951 C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2952  mk = mk + 1
    +
    2953  200 CONTINUE
    +
    2954 C PRINT *,'LOCATION ',ISW
    +
    2955  IF (isw.NE.31) THEN
    +
    2956  print *,'LOCATION ERROR PROCESSING PROFILER'
    +
    2957  iptr(10) = 200
    +
    2958  RETURN
    +
    2959  END IF
    +
    2960 C PROCESS TIME ELEMENTS
    +
    2961  isw = 0
    +
    2962  DO 400 j = 1, 7
    +
    2963  IF (mstack(1,mk).EQ.1025) THEN
    +
    2964 C YEAR
    +
    2965  isw = isw + 1
    +
    2966  ELSE IF (mstack(1,mk).EQ.1026) THEN
    +
    2967 C MONTH
    +
    2968  isw = isw + 2
    +
    2969  ELSE IF (mstack(1,mk).EQ.1027) THEN
    +
    2970 C DAY
    +
    2971  isw = isw + 4
    +
    2972  ELSE IF (mstack(1,mk).EQ.1028) THEN
    +
    2973 C HOUR
    +
    2974  isw = isw + 8
    +
    2975  ELSE IF (mstack(1,mk).EQ.1029) THEN
    +
    2976 C MINUTE
    +
    2977  isw = isw + 16
    +
    2978  ELSE IF (mstack(1,mk).EQ.2069) THEN
    +
    2979 C TIME SIGNIFICANCE
    +
    2980  isw = isw + 32
    +
    2981  ELSE IF (mstack(1,mk).EQ.1049) THEN
    +
    2982 C TIME DISPLACEMENT
    +
    2983  isw = isw + 64
    +
    2984  ELSE
    +
    2985  mk = mk + 1
    +
    2986  GO TO 400
    +
    2987  END IF
    +
    2988  jk = jk + 1
    +
    2989  kprofl(jk) = mstack(1,mk)
    +
    2990  kprof2(jk) = mstack(2,mk)
    +
    2991  kset2(jk) = kdata(i,mk)
    +
    2992 C PRINT *,JK,KPROFL(JK),KSET2(JK)
    +
    2993  mk = mk + 1
    +
    2994  400 CONTINUE
    +
    2995 C PRINT *,'TIME ',ISW
    +
    2996  IF (isw.NE.127) THEN
    +
    2997  print *,'TIME ERROR PROCESSING PROFILER'
    +
    2998  iptr(1) = 201
    +
    2999  RETURN
    +
    3000  END IF
    +
    3001 C SURFACE DATA
    +
    3002  isw = 0
    +
    3003 C PRINT *,'SURFACE'
    +
    3004  DO 600 k = 1, 8
    +
    3005 C PRINT *,MK,MSTACK(1,MK),JK,ISW
    +
    3006  IF (mstack(1,mk).EQ.2817) THEN
    +
    3007  isw = isw + 1
    +
    3008  ELSE IF (mstack(1,mk).EQ.2818) THEN
    +
    3009  isw = isw + 2
    +
    3010  ELSE IF (mstack(1,mk).EQ.2611) THEN
    +
    3011  isw = isw + 4
    +
    3012  ELSE IF (mstack(1,mk).EQ.3073) THEN
    +
    3013  isw = isw + 8
    +
    3014  ELSE IF (mstack(1,mk).EQ.3342) THEN
    +
    3015  isw = isw + 16
    +
    3016  ELSE IF (mstack(1,mk).EQ.3331) THEN
    +
    3017  isw = isw + 32
    +
    3018  ELSE IF (mstack(1,mk).EQ.1797) THEN
    +
    3019  incrht = kdata(i,mk)
    +
    3020  isw = isw + 64
    +
    3021 C PRINT *,'INITIAL INCREMENT = ',INCRHT
    +
    3022  mk = mk + 1
    +
    3023 C PRINT *,JK,KPROFL(JK),KSET2(JK),' ISW=',ISW
    +
    3024  GO TO 600
    +
    3025  ELSE IF (mstack(1,mk).EQ.6433) THEN
    +
    3026  isw = isw + 128
    +
    3027  END IF
    +
    3028  jk = jk + 1
    +
    3029  kprofl(jk) = mstack(1,mk)
    +
    3030  kprof2(jk) = mstack(2,mk)
    +
    3031  kset2(jk) = kdata(i,mk)
    +
    3032 C PRINT *,JK,KPROFL(JK),KSET2(JK),'ISW=',ISW
    +
    3033  mk = mk + 1
    +
    3034  600 CONTINUE
    +
    3035  IF (isw.NE.255) THEN
    +
    3036  print *,'ERROR PROCESSING PROFILER',isw
    +
    3037  iptr(1) = 204
    +
    3038  RETURN
    +
    3039  END IF
    +
    3040  IF (mstack(1,mk).NE.1797) THEN
    +
    3041  print *,'ERROR PROCESSING HEIGHT INCREMENT IN PROFILER'
    +
    3042  iptr(1) = 205
    +
    3043  RETURN
    +
    3044  END IF
    +
    3045 C MUST SAVE THIS HEIGHT VALUE
    +
    3046  lhgt = 500 + ihgt - kdata(i,mk)
    +
    3047 C PRINT *,'BASE HEIGHT = ',LHGT,' INCR = ',INCRHT
    +
    3048  mk = mk + 1
    +
    3049  IF (mstack(1,mk).GE.16384) THEN
    +
    3050  mk = mk + 1
    +
    3051  END IF
    +
    3052 C PROCESS LEVEL DATA
    +
    3053 C PRINT *,'LEVEL DATA'
    +
    3054  DO 2000 l = 1, 43
    +
    3055  2020 CONTINUE
    +
    3056 C PRINT *,'DESC',MK,MSTACK(1,MK),JK
    +
    3057  isw = 0
    +
    3058 C HEIGHT INCREMENT
    +
    3059  IF (mstack(1,mk).EQ.1797) THEN
    +
    3060  incrht = kdata(i,mk)
    +
    3061 C PRINT *,'NEW HEIGHT INCREMENT = ',INCRHT
    +
    3062  mk = mk + 1
    +
    3063 C IF (LHGT.LT.(9250+IHGT)) THEN
    +
    3064 C LHGT = IHGT + 500 - INCRHT
    +
    3065 C ELSE
    +
    3066 C LHGT = IHGT + 9250 -INCRHT
    +
    3067 C END IF
    +
    3068  END IF
    +
    3069 C MUST ENTER HEIGHT OF THIS LEVEL - DESCRIPTOR AND DA
    +
    3070 C AT THIS POINT
    +
    3071  lhgt = lhgt + incrht
    +
    3072 C PRINT *,'LEVEL ',L,LHGT
    +
    3073 C IF (L.EQ.37) THEN
    +
    3074 C LHGT = LHGT + INCRHT
    +
    3075 C END IF
    +
    3076  jk = jk + 1
    +
    3077 C SAVE DESCRIPTOR
    +
    3078  kprofl(jk) = 1798
    +
    3079 C SAVE SCALE
    +
    3080  kprof2(jk) = 0
    +
    3081 C SAVE DATA
    +
    3082  kset2(jk) = lhgt
    +
    3083 C PRINT *,KPROFL(JK),KSET2(JK),JK
    +
    3084  isw = 0
    +
    3085  icon = 1
    +
    3086  DO 800 j = 1, 10
    +
    3087 750 CONTINUE
    +
    3088  IF (mstack(1,mk).EQ.1797) THEN
    +
    3089  GO TO 2020
    +
    3090  ELSE IF (mstack(1,mk).EQ.6432) THEN
    +
    3091 C HI/LO MODE
    +
    3092  isw = isw + 1
    +
    3093  ELSE IF (mstack(1,mk).EQ.6434) THEN
    +
    3094 C Q/C TEST
    +
    3095  isw = isw + 2
    +
    3096  ELSE IF (mstack(1,mk).EQ.2070) THEN
    +
    3097  IF (icon.EQ.1) THEN
    +
    3098 C FIRST PASS - U,V CONSENSUS
    +
    3099  isw = isw + 4
    +
    3100  icon = icon + 1
    +
    3101  ELSE
    +
    3102 C SECOND PASS - W CONSENSUS
    +
    3103  isw = isw + 64
    +
    3104  END IF
    +
    3105  ELSE IF (mstack(1,mk).EQ.2819) THEN
    +
    3106 C U VECTOR VALUE
    +
    3107  isw = isw + 8
    +
    3108  IF (kdata(i,mk).GE.2047) THEN
    +
    3109  vectu = 32767
    +
    3110  ELSE
    +
    3111  vectu = kdata(i,mk)
    +
    3112  END IF
    +
    3113  mk = mk + 1
    +
    3114  GO TO 800
    +
    3115  ELSE IF (mstack(1,mk).EQ.2820) THEN
    +
    3116 C V VECTOR VALUE
    +
    3117  isw = isw + 16
    +
    3118  IF (kdata(i,mk).GE.2047) THEN
    +
    3119  vectv = 32767
    +
    3120  ELSE
    +
    3121  vectv = kdata(i,mk)
    +
    3122  END IF
    +
    3123  IF (iand(isw,1).NE.0) THEN
    +
    3124  IF (vectu.EQ.32767.OR.vectv.EQ.32767) THEN
    +
    3125 C SAVE DD DESCRIPTOR
    +
    3126  jk = jk + 1
    +
    3127  kprofl(jk) = 2817
    +
    3128  kprof2(jk) = 0
    +
    3129  kset2(jk) = 32767
    +
    3130 C SAVE FFF DESCRIPTOR
    +
    3131  jk = jk + 1
    +
    3132  kprofl(jk) = 2818
    +
    3133  kprof2(jk) = 1
    +
    3134  kset2(jk) = 32767
    +
    3135  ELSE
    +
    3136  CALL w3fc05 (vectu,vectv,dir,spd)
    +
    3137  ndir = dir
    +
    3138  spd = spd
    +
    3139  nspd = spd
    +
    3140 C PRINT *,' ',NDIR,NSPD
    +
    3141 C SAVE DD DESCRIPTOR
    +
    3142  jk = jk + 1
    +
    3143  kprofl(jk) = 2817
    +
    3144  kprof2(jk) = 0
    +
    3145  kset2(jk) = ndir
    +
    3146 C IF (I.EQ.1) THEN
    +
    3147 C PRINT *,'DD ',JK,KPROFL(JK),KSET2(JK)
    +
    3148 C ENDIF
    +
    3149 C SAVE FFF DESCRIPTOR
    +
    3150  jk = jk + 1
    +
    3151  kprofl(jk) = 2818
    +
    3152  kprof2(jk) = 1
    +
    3153  kset2(jk) = nspd
    +
    3154 C IF (I.EQ.1) THEN
    +
    3155 C PRINT *,'FFF',JK,KPROFL(JK),KSET2(JK)
    +
    3156 C ENDIF
    +
    3157  END IF
    +
    3158  mk = mk + 1
    +
    3159  GO TO 800
    +
    3160  END IF
    +
    3161  ELSE IF (mstack(1,mk).EQ.2866) THEN
    +
    3162 C SPEED STD DEVIATION
    +
    3163  isw = isw + 32
    +
    3164 C -- A CHANGE BY KEYSER : POWER DESCR. BACK TO 5568
    +
    3165  ELSE IF (mstack(1,mk).EQ.5568) THEN
    +
    3166 C SIGNAL POWER
    +
    3167  isw = isw + 128
    +
    3168  ELSE IF (mstack(1,mk).EQ.2822) THEN
    +
    3169 C W COMPONENT
    +
    3170  isw = isw + 256
    +
    3171  ELSE IF (mstack(1,mk).EQ.2867) THEN
    +
    3172 C VERT STD DEVIATION
    +
    3173  isw = isw + 512
    +
    3174 CVVVVVCHANGE#1 FIX BY KEYSER -- 12/06/1994
    +
    3175 C NOTE: THIS FIX PREVENTS UNNECESSARY LOOPING WHEN ALL REQ. DESCR.
    +
    3176 C ARE MISSING. WOULD GO INTO INFINITE LOOP EXCEPT EVENTUALLY
    +
    3177 C MSTACK ARRAY SIZE IS EXCEEDED AND GET FORTRAN ERROR INTERRUPT
    +
    3178 CDAK ELSE
    +
    3179  ELSE IF ((mstack(1,mk)/16384).NE.0) THEN
    +
    3180 CAAAAACHANGE#1 FIX BY KEYSER -- 12/06/1994
    +
    3181  mk = mk + 1
    +
    3182  GO TO 750
    +
    3183  END IF
    +
    3184  jk = jk + 1
    +
    3185 C SAVE DESCRIPTOR
    +
    3186  kprofl(jk) = mstack(1,mk)
    +
    3187 C SAVE SCALE
    +
    3188  kprof2(jk) = mstack(2,mk)
    +
    3189 C SAVE DATA
    +
    3190  kset2(jk) = kdata(i,mk)
    +
    3191  mk = mk + 1
    +
    3192 C PRINT *,L,'TEST ',JK,KPROFL(JK),KSET2(JK)
    +
    3193  800 CONTINUE
    +
    3194  IF (isw.NE.1023) THEN
    +
    3195  print *,'LEVEL ERROR PROCESSING PROFILER',isw
    +
    3196  iptr(1) = 202
    +
    3197  RETURN
    +
    3198  END IF
    +
    3199  2000 CONTINUE
    +
    3200 C MOVE DATA BACK INTO KDATA ARRAY
    +
    3201  DO 5000 ll = 1, jk
    +
    3202 C DATA
    +
    3203  kdata(i,ll) = kset2(ll)
    +
    3204  5000 CONTINUE
    +
    3205  3000 CONTINUE
    +
    3206  DO 5005 ll = 1, jk
    +
    3207 C DESCRIPTOR
    +
    3208  mstack(1,ll) = kprofl(ll)
    +
    3209 C SCALE
    +
    3210  mstack(2,ll) = kprof2(ll)
    +
    3211 C -- A CHANGE BY KEYSER : PRINT STATEMNT SHOULD BE HERE NOT IN 5000 LOOP
    +
    3212 C PRINT *,LL,MSTACK(1,LL),MSTACK(2,LL),(KDATA(I,LL),I=1,4)
    +
    3213  5005 CONTINUE
    +
    3214  iptr(31) = jk
    +
    3215  RETURN
    +
    3216  END
    +
    3217 C> @brief Expand data/descriptor replication
    +
    3218 C> @author Bill Cavanaugh @date 1993-05-12
    +
    3219 
    +
    3220 C> Expand data and descriptor strings
    +
    3221 C>
    +
    3222 C> Program history log:
    +
    3223 C> - Bill Cavanaugh 1993-05-12
    +
    3224 C>
    +
    3225 C> @param[in] IPTR See w3fi88 routine docblock
    +
    3226 C> @param[in] IDENT See w3fi88 routine docblock
    +
    3227 C> @param[in] MAXR Maximum number of reports/subsets that may be
    +
    3228 C> contained in a bufr message
    +
    3229 C> @param[in] MAXD Maximum number of descriptor combinations that
    +
    3230 C> may be processed; upper air data and some satellite
    +
    3231 C> data require a value for maxd of 1700, but for most
    +
    3232 C> other data a value for maxd of 500 will suffice
    +
    3233 C> @param[inout] KDATA Array containing decoded reports from bufr message.
    +
    3234 C> kdata(report number,parameter number)
    +
    3235 C> (report number limited to value of input argument
    +
    3236 C> maxr and parameter number limited to value of input
    +
    3237 C> argument maxd)
    +
    3238 C> @param[inout] MSTACK List of descriptors and scale values
    +
    3239 C> @param KNR
    +
    3240 C> @param LDATA
    +
    3241 C> @param LSTACK
    +
    3242 C>
    +
    3243 C> Error return:
    +
    3244 C> - IPTR(1)
    +
    3245 C>
    +
    3246 C> @author Bill Cavanaugh @date 1993-05-12
    +
    3247  SUBROUTINE fi8811(IPTR,IDENT,MSTACK,KDATA,KNR,
    +
    3248  * LDATA,LSTACK,MAXD,MAXR)
    +
    3249 
    +
    3250  INTEGER IPTR(*)
    +
    3251  INTEGER KNR(MAXR)
    +
    3252  INTEGER KDATA(MAXR,MAXD),LDATA(MAXD)
    +
    3253  INTEGER MSTACK(2,MAXD),LSTACK(2,MAXD)
    +
    3254  INTEGER IDENT(*)
    +
    3255 C
    +
    3256  SAVE
    +
    3257 C
    +
    3258 C PRINT *,' DATA/DESCRIPTOR REPLICATION '
    +
    3259  DO 1000 i = 1, knr(1)
    +
    3260 C IF NOT REPLICATION DESCRIPTOR
    +
    3261  IF ((mstack(1,i)/16384).NE.1) THEN
    +
    3262  GO TO 1000
    +
    3263  END IF
    +
    3264 C IF DELAYED REPLICATION DESCRIPTOR
    +
    3265  IF (mod(mstack(1,i),256).EQ.0) THEN
    +
    3266 C SAVE KX VALUE (NR DESC'S TO REPLICATE)
    +
    3267  kx = mod((mstack(1,i)/256),64)
    +
    3268 C IF NEXT DESC IS NOT 7947 OR 7948
    +
    3269 C (I.E., 0 31 011 OR 0 31 012)
    +
    3270  IF (mstack(1,i+1).NE.7947.AND.mstack(1,i+1).NE.7948) THEN
    +
    3271 C SKIP IT
    +
    3272  GO TO 1000
    +
    3273  END IF
    +
    3274 C GET NR REPS FROM KDATA
    +
    3275  nrreps = kdata(1,i+1)
    +
    3276  last = i + 1 + kx
    +
    3277 C SAVE OFF TRAILING DESCS AND DATA
    +
    3278  ktrail = knr(1) - i - 1 - kx
    +
    3279  DO 100 l = 1, ktrail
    +
    3280  nx = i + l + kx + 1
    +
    3281  ldata(l) = kdata(1,nx)
    +
    3282  lstack(1,l) = mstack(1,nx)
    +
    3283  lstack(2,l) = mstack(2,nx)
    +
    3284  100 CONTINUE
    +
    3285 C INSERT FX DESCS/DATA NR REPS TIMES
    +
    3286  last = i + 1
    +
    3287  DO 400 j = 1, nrreps
    +
    3288  nx = i + 2
    +
    3289  DO 300 k = 1, kx
    +
    3290  last = last + 1
    +
    3291  kdata(1,last) = kdata(1,nx)
    +
    3292  mstack(1,last) = mstack(1,nx)
    +
    3293  mstack(2,last) = mstack(2,nx)
    +
    3294  nx = nx + 1
    +
    3295  300 CONTINUE
    +
    3296 
    +
    3297  400 CONTINUE
    +
    3298 C RESTORE TRAILING DATA/DESCS
    +
    3299  DO 500 l = 1, ktrail
    +
    3300  last = last + 1
    +
    3301  kdata(1,last) = ldata(l)
    +
    3302  mstack(1,last) = lstack(1,l)
    +
    3303  mstack(2,last) = lstack(2,l)
    +
    3304  500 CONTINUE
    +
    3305 C RESET KNR(1)
    +
    3306  knr(1) = last
    +
    3307  END IF
    +
    3308  1000 CONTINUE
    +
    3309  RETURN
    +
    3310  END
    +
    3311  SUBROUTINE fi8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
    +
    3312  * IRF1SW,NEWREF,ITBLD,ITBLD2,
    +
    3313  * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
    +
    3314  * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
    +
    3315 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
    +
    3316 C . . . .
    +
    3317 C SUBPROGRAM: FI8812 BUILD TABLE B SUBSET BASED ON BUFR SEC 3
    +
    3318 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-12-23
    +
    3319 C
    +
    3320 C ABSTRACT: BUILD A SUBSET OF TABLE B ENTRIES THAT CORRESPOND TO
    +
    3321 C THE DESCRIPTORS NEEDED FOR THIS MESSAGE
    +
    3322 C
    +
    3323 C PROGRAM HISTORY LOG:
    +
    3324 C 93-05-12 CAVANAUGH
    +
    3325 C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE
    +
    3326 C
    +
    3327 C USAGE: CALL FI8812(IPTR,IUNITB,IUNITD,ISTACK,NRDESC,KPTRB,KPTRD,
    +
    3328 C * IRF1SW,NEWREF,ITBLD,ITBLD2,
    +
    3329 C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
    +
    3330 C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2)
    +
    3331 C INPUT ARGUMENT LIST:
    +
    3332 C IPTR - SEE W3FI88 ROUTINE DOCBLOCK
    +
    3333 C IDENT - SEE W3FI88 ROUTINE DOCBLOCK
    +
    3334 C ISTACK - LIST OF DESCRIPTORS AND SCALE VALUES
    +
    3335 C IUNITB -
    +
    3336 C IUNITD -
    +
    3337 C ISTACK -
    +
    3338 C NRDESC -
    +
    3339 C KFXY2 -
    +
    3340 C ANAME2 -
    +
    3341 C AUNIT2 -
    +
    3342 C ISCAL2 -
    +
    3343 C IRFVL2 -
    +
    3344 C IWIDE2 -
    +
    3345 C IRF1SW -
    +
    3346 C NEWREF -
    +
    3347 C ITBLD2 -
    +
    3348 C
    +
    3349 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
    +
    3350 C KDATA - ARRAY CONTAINING DECODED REPORTS FROM BUFR MESSAGE.
    +
    3351 C KDATA(REPORT NUMBER,PARAMETER NUMBER)
    +
    3352 C (REPORT NUMBER LIMITED TO VALUE OF INPUT ARGUMENT
    +
    3353 C MAXR AND PARAMETER NUMBER LIMITED TO VALUE OF INPUT
    +
    3354 C ARGUMENT MAXD)
    +
    3355 C MSTACK - LIST OF DESCRIPTORS AND SCALE VALUES
    +
    3356 C KFXY1 -
    +
    3357 C ANAME1 -
    +
    3358 C AUNIT1 -
    +
    3359 C ISCAL1 -
    +
    3360 C IRFVL1 -
    +
    3361 C IWIDE1 -
    +
    3362 C ITBLD -
    +
    3363 C
    +
    3364 C SUBPROGRAMS CALLED:
    +
    3365 C LIBRARY:
    +
    3366 C W3LIB -
    +
    3367 C
    +
    3368 C REMARKS: ERROR RETURN:
    +
    3369 C IPTR(1) =
    +
    3370 C
    +
    3371 C ATTRIBUTES:
    +
    3372 C LANGUAGE: FORTRAN 77
    +
    3373 C MACHINE: NAS
    +
    3374 C
    +
    3375 C$$$
    +
    3376 C ..................................................
    +
    3377 C
    +
    3378 C NEW BASE TABLE B
    +
    3379 C MAY BE A COMBINATION OF MASTER TABLE B
    +
    3380 C AND ANCILLARY TABLE B
    +
    3381 C
    +
    3382  INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
    +
    3383  CHARACTER*40 ANAME1(*)
    +
    3384  CHARACTER*24 AUNIT1(*)
    +
    3385 C ..................................................
    +
    3386 C
    +
    3387 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
    +
    3388 C
    +
    3389  INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
    +
    3390  CHARACTER*64 ANAME2(*)
    +
    3391  CHARACTER*24 AUNIT2(*)
    +
    3392 C ..................................................
    +
    3393 C
    +
    3394 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
    +
    3395 C
    +
    3396  INTEGER ITBLD2(20,*)
    +
    3397 C ..................................................
    +
    3398 C
    +
    3399 C NEW BASE TABLE D
    +
    3400 C
    +
    3401  INTEGER ITBLD(20,*)
    +
    3402 C ..................................................
    +
    3403  INTEGER IPTR(*),ISTACK(*),NRDESC,NWLIST(200)
    +
    3404  INTEGER NEWREF(*),KPTRB(*),KPTRD(*)
    +
    3405  INTEGER IUNITB,IUNITD,ICOPY(20000),NRCOPY,IELEM,IPOS
    +
    3406  CHARACTER*64 AHLD64
    +
    3407  CHARACTER*24 AHLD24
    +
    3408 C
    +
    3409  SAVE
    +
    3410 C
    +
    3411 C SCAN AND DISCARD REPLICATION AND OPERATOR DESCRIPTORS
    +
    3412 C REPLACING SEQUENCE DESCRIPTORS WITH THEIR CORRESPONDING
    +
    3413 C SET OF DESCRIPTORS ALSO ELIMINATING DUPLICATES.
    +
    3414 C
    +
    3415 C-----------------------------------------------------------
    +
    3416 C PRINT *,'ENTER FI8812'
    +
    3417 C
    +
    3418  DO 10 i = 1, 16384
    +
    3419  kptrb(i) = -1
    +
    3420  10 CONTINUE
    +
    3421 C
    +
    3422 C
    +
    3423 C
    +
    3424  IF (iptr(14).NE.0) THEN
    +
    3425  DO i = 1, iptr(14)
    +
    3426  kptrb(kfxy1(i)) = i
    +
    3427  ENDDO
    +
    3428  GO TO 9000
    +
    3429  END IF
    +
    3430 C
    +
    3431 C READ IN TABLE B
    +
    3432  print *,'FI8812 - READING TABLE B'
    +
    3433  rewind iunitb
    +
    3434  i = 1
    +
    3435  4000 CONTINUE
    +
    3436 C
    +
    3437  READ(unit=iunitb,fmt=20,err=9999,END=9000)MF,
    +
    3438  * mx,my,
    +
    3439  * (aname1(i)(k:k),k=1,40),
    +
    3440  * (aunit1(i)(k:k),k=1,24),
    +
    3441  * iscal1(i),irfvl1(1,i),iwide1(i)
    +
    3442  20 FORMAT(i1,i2,i3,40a1,24a1,i5,i15,1x,i4)
    +
    3443  kfxy1(i) = mf*16384 + mx*256 + my
    +
    3444 C PRINT *,MF,MX,MY,KFXY1(I)
    +
    3445  5000 CONTINUE
    +
    3446  kptrb(kfxy1(i)) = i
    +
    3447  iptr(14) = i
    +
    3448 C PRINT *,I
    +
    3449 C WRITE(6,21) MF,MX,MY,KFXY1(I),
    +
    3450 C * (ANAME1(I)(K:K),K=1,40),
    +
    3451 C * (AUNIT1(I)(K:K),K=1,24),
    +
    3452 C * ISCAL1(I),IRFVL1(1,I),IWIDE1(I)
    +
    3453  21 FORMAT(1x,i1,i2,i3,1x,i6,1x,40a1,
    +
    3454  * 2x,24a1,2x,i5,2x,i15,1x,i4)
    +
    3455  i = i + 1
    +
    3456  GO TO 4000
    +
    3457 C ======================================================
    +
    3458  9999 CONTINUE
    +
    3459 C ERROR READING TABLE B
    +
    3460  print *,'FI8812 - ERROR READING TABLE B - RECORD ',i
    +
    3461  iptr(1) = 9
    +
    3462  9000 CONTINUE
    +
    3463  iptr(21) = iptr(14)
    +
    3464 C PRINT *,'EXIT FI8812 - IPTR(21) =',IPTR(21),' IPTR(1) =',IPTR(1)
    +
    3465  RETURN
    +
    3466  END
    +
    3467  SUBROUTINE fi8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,KPTRB,
    +
    3468  * ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB)
    +
    3469 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
    +
    3470 C . . . .
    +
    3471 C SUBPROGRAM: FI8813 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES
    +
    3472 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04
    +
    3473 C
    +
    3474 C ABSTRACT: EXTRACT TABLE A, TABLE B, TABLE D ENTRIES FROM A
    +
    3475 C DECODED BUFR MESSAGE.
    +
    3476 C
    +
    3477 C PROGRAM HISTORY LOG:
    +
    3478 C 94-03-04 CAVANAUGH
    +
    3479 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
    +
    3480 C
    +
    3481 C USAGE: CALL FI8813 (IPTR,MAXR,MAXD,MSTACK,KDATA,IDENT,KPTRD,
    +
    3482 C * KPTRB,ITBLD,ANAME1,AUNIT1,KFXY1,ISCAL1,IRFVL1,IWIDE1,IUNITB)
    +
    3483 C INPUT ARGUMENT LIST:
    +
    3484 C IPTR
    +
    3485 C MAXR
    +
    3486 C MAXD
    +
    3487 C MSTACK
    +
    3488 C KDATA
    +
    3489 C IDENT
    +
    3490 C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
    +
    3491 C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
    +
    3492 C
    +
    3493 C OUTPUT ARGUMENT LIST:
    +
    3494 C IUNITB
    +
    3495 C ITBLD1
    +
    3496 C ANAME1
    +
    3497 C AUNIT1
    +
    3498 C KFXY1
    +
    3499 C ISCAL1
    +
    3500 C IRFVL1
    +
    3501 C IWIDE1
    +
    3502 C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
    +
    3503 C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
    +
    3504 C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
    +
    3505 C
    +
    3506 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
    +
    3507 C
    +
    3508 C ATTRIBUTES:
    +
    3509 C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
    +
    3510 C MACHINE: NAS, CYBER, WHATEVER
    +
    3511 C
    +
    3512 C$$$
    +
    3513 C ..................................................
    +
    3514 C
    +
    3515 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
    +
    3516 C
    +
    3517  INTEGER KFXY1(*),ISCAL1(*),IRFVL1(*),IWIDE1(*)
    +
    3518  CHARACTER*40 ANAME1(*)
    +
    3519  CHARACTER*24 AUNIT1(*)
    +
    3520 C ..................................................
    +
    3521 C
    +
    3522 C TABLE D
    +
    3523 C
    +
    3524  INTEGER ITBLD(20,*)
    +
    3525 C ..................................................
    +
    3526  CHARACTER*32 SPACES
    +
    3527  CHARACTER*8 ASCCHR
    +
    3528  CHARACTER*32 AAAA
    +
    3529 C
    +
    3530  INTEGER I1(20),I2(20),I3(20),KPTRB(*)
    +
    3531  INTEGER IPTR(*),MAXR,MAXD,MSTACK(2,MAXD)
    +
    3532  INTEGER IXA, IXB, IXD, KDATA(MAXR,MAXD)
    +
    3533  INTEGER IEXTRA,KPTRD(*)
    +
    3534  INTEGER KEYSET,ISCSGN(200),IRFSGN(200)
    +
    3535  INTEGER IDENT(*),IHOLD,JHOLD(8),IUNITB
    +
    3536  EQUIVALENCE (IHOLD,ASCCHR),(JHOLD,AAAA)
    +
    3537  SAVE
    +
    3538  DATA SPACES/' '/
    +
    3539  DATA IEXTRA/0/
    +
    3540  DATA keyset/0/
    +
    3541 
    +
    3542 C ==============================================================
    +
    3543 C PRINT *,'FI8813',IPTR(41),IPTR(42),IPTR(31),IPTR(21)
    +
    3544 C BUILD SPACE CONSTANT
    +
    3545 C INITIALIZE ENTRY COUNTS
    +
    3546  ixa = 0
    +
    3547 C NUMBER IN TABLE B
    +
    3548  ixb = iptr(21)
    +
    3549 C
    +
    3550 C
    +
    3551 C SET FOR COMPRESSED OR NON COMPRESSED
    +
    3552 C PROCESSING
    +
    3553 C
    +
    3554 C PRINT *,'FI8813 - 2',IDENT(16),IDENT(14)
    +
    3555  IF (ident(16).EQ.0) THEN
    +
    3556  jk = 1
    +
    3557  ELSE
    +
    3558  jk = ident(14)
    +
    3559  END IF
    +
    3560 C PRINT *,'FI8813 - 3, JK=',JK
    +
    3561 C
    +
    3562 C
    +
    3563 C START PROCESSING ENTRIES
    +
    3564 C PRINT *,'START PROCESSING ENTRIES'
    +
    3565 C
    +
    3566 C DO 995 I = 1, IPTR(31)
    +
    3567 C IF (IPTR(45).EQ.4) THEN
    +
    3568 C PRINT 9958,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I)
    +
    3569 C9958 FORMAT (1X,I5,2X,I5,2X,Z8,2X,A4)
    +
    3570 C ELSE
    +
    3571 C PRINT 9959,I,MSTACK(1,I),KDATA(1,I),KDATA(1,I)
    +
    3572 C9959 FORMAT (1X,I5,2X,I5,2X,Z16,2X,A8)
    +
    3573 C END IF
    +
    3574 C 995 CONTINUE
    +
    3575 C PRINT *,' '
    +
    3576  i = 0
    +
    3577  iextra = 0
    +
    3578  1000 CONTINUE
    +
    3579 C
    +
    3580 C SET POINTER TO CORRECT DATA POSITION
    +
    3581 C I IS THE NUMBER OF DESCRIPTORS
    +
    3582 C IEXTRA IS THE NUMBER OF WORDS ADDED
    +
    3583 C FOR TEXT DATA
    +
    3584 C
    +
    3585  i = i + 1
    +
    3586  IF (i.GT.iptr(31)) THEN
    +
    3587 C RETURN IF COMPLETED SEARCH
    +
    3588  GO TO 9000
    +
    3589  END IF
    +
    3590  klk = i + iextra
    +
    3591 C PRINT *,'ENTRY',KLK,I,IPTR(31),IEXTRA,MSTACK(1,KLK)
    +
    3592 C
    +
    3593 C IF TABLE A ENTRY OR EDITION NUMBER
    +
    3594 C OR IF DESCRIPTOR IS NOT IN CLASS 0
    +
    3595 C SKIP OVER
    +
    3596 C
    +
    3597  IF (mstack(1,klk).EQ.1) THEN
    +
    3598 C PRINT *,'A ENTRY'
    +
    3599  GO TO 1000
    +
    3600  ELSE IF (mstack(1,klk).EQ.2) THEN
    +
    3601 C PRINT *,'A ENTRY LINE 1'
    +
    3602  iextra = iextra + 32 / iptr(45) - 1
    +
    3603  GO TO 1000
    +
    3604  ELSE IF (mstack(1,klk).EQ.3) THEN
    +
    3605 C PRINT *,'A ENTRY LINE 2'
    +
    3606  iextra = iextra + 32 / iptr(45) - 1
    +
    3607  GO TO 1000
    +
    3608  ELSE IF (mstack(1,klk).GE.34048.AND.mstack(1,klk).LE.34303) THEN
    +
    3609  ly = mod(mstack(1,klk),256)
    +
    3610 C PRINT *,'CLASS C - HAVE',LY,' BYTES OF TEXT'
    +
    3611  IF (mod(ly,iptr(45)).EQ.0) THEN
    +
    3612  iwds = ly / iptr(45)
    +
    3613  ELSE
    +
    3614  iwds = ly / iptr(45) + 1
    +
    3615  END IF
    +
    3616  iextra = iextra + iwds - 1
    +
    3617  GO TO 1000
    +
    3618  ELSE IF (mstack(1,klk).LT.10.OR.mstack(1,klk).GT.255) THEN
    +
    3619 C PRINT *,MSTACK(1,KLK),' NOT CLASS 0'
    +
    3620  GO TO 1000
    +
    3621  END IF
    +
    3622 C
    +
    3623 C MUST FIND F X Y KEY FOR TABLE B
    +
    3624 C OR TABLE D ENTRY
    +
    3625 C
    +
    3626  iz = 1
    +
    3627  keyset = 0
    +
    3628  10 CONTINUE
    +
    3629  IF (i.GT.iptr(31)) THEN
    +
    3630  GO TO 9000
    +
    3631  END IF
    +
    3632  klk = i + iextra
    +
    3633  IF (mstack(1,klk).GE.34048.AND.mstack(1,klk).LE.34303) THEN
    +
    3634  ly = mod(mstack(1,klk),256)
    +
    3635 C PRINT *,'TABLE C - HAVE',LY,' TEXT BYTES'
    +
    3636  IF (mod(ly,4).EQ.0) THEN
    +
    3637  iwds = ly / iptr(45)
    +
    3638  ELSE
    +
    3639  iwds = ly / iptr(45) + 1
    +
    3640  END IF
    +
    3641  iextra = iextra + iwds - 1
    +
    3642  i = i + 1
    +
    3643  GO TO 10
    +
    3644  ELSE IF (mstack(1,klk)/16384.NE.0) THEN
    +
    3645  IF (mod(mstack(1,klk),256).EQ.0) THEN
    +
    3646  i = i + 1
    +
    3647  END IF
    +
    3648  i = i + 1
    +
    3649  GO TO 10
    +
    3650  END IF
    +
    3651  IF (mstack(1,klk).GE.10.AND.mstack(1,klk).LE.12) THEN
    +
    3652 C PRINT *,'FIND KEY'
    +
    3653 C
    +
    3654 C MUST INCLUDE PROCESSING FOR COMPRESSED DATA
    +
    3655 C
    +
    3656 C BUILD DESCRIPTOR SEGMENT
    +
    3657 C
    +
    3658  IF (mstack(1,klk).EQ.10) THEN
    +
    3659  CALL fi8814 (kdata(iz,klk),1,mf,ierr,iptr)
    +
    3660 C PRINT *,'F =',MF,KDATA(IZ,KLK),IPTR(31),I,IEXTRA
    +
    3661  keyset = ior(keyset,4)
    +
    3662  ELSE IF (mstack(1,klk).EQ.11) THEN
    +
    3663  CALL fi8814 (kdata(iz,klk),2,mx,ierr,iptr)
    +
    3664 C PRINT *,'X =',MX,KDATA(IZ1,KLK)
    +
    3665  keyset = ior(keyset,2)
    +
    3666  ELSE IF (mstack(1,klk).EQ.12) THEN
    +
    3667  CALL fi8814 (kdata(iz,klk),3,my,ierr,iptr)
    +
    3668 C PRINT *,'Y =',MY,KDATA(IZ,KLK)
    +
    3669  keyset = ior(keyset,1)
    +
    3670  END IF
    +
    3671 C PRINT *,' KEYSET =',KEYSET
    +
    3672  i = i + 1
    +
    3673  GO TO 10
    +
    3674  END IF
    +
    3675  IF (keyset.EQ.7) THEN
    +
    3676 C PRINT *,'HAVE KEY DESCRIPTOR',MF,MX,MY
    +
    3677 C
    +
    3678 C TEST NEXT DESCRIPTOR FOR TABLE B
    +
    3679 C OR TABLE D ENTRY, PROCESS ACCORDINGLY
    +
    3680 C
    +
    3681  klk = i + iextra
    +
    3682 C PRINT *,'DESC ',MSTACK(1,KLK),KLK,I,IEXTRA,KDATA(1,KLK)
    +
    3683  IF (mstack(1,klk).EQ.30) THEN
    +
    3684  ixd = iptr(20) + 1
    +
    3685  itbld(1,ixd) =16384 * mf + 256 * mx + my
    +
    3686 C PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD)
    +
    3687  GO TO 300
    +
    3688  ELSE IF (mstack(1,klk).GE.13.AND.mstack(1,klk).LE.20) THEN
    +
    3689  kfxy1(ixb+iz) = 16384 * mf + 256 * mx + my
    +
    3690 C PRINT *,'ELEMENT DESCRIPTOR',MF,MX,MY,KFXY1(IXB+IZ),IXB+IZ
    +
    3691  kptrb(kfxy1(ixb+iz)) = ixb+iz
    +
    3692  GO TO 200
    +
    3693  ELSE
    +
    3694  END IF
    +
    3695 C I = I + 1
    +
    3696 C IF (I.GT.IPTR(31)) THEN
    +
    3697 C GO TO 9000
    +
    3698 C END IF
    +
    3699 C GO TO 10
    +
    3700  END IF
    +
    3701  GO TO 1000
    +
    3702 C ==================================================================
    +
    3703  200 CONTINUE
    +
    3704  ibflag = 1
    +
    3705  20 CONTINUE
    +
    3706  klk = i + iextra
    +
    3707 C PRINT *,'ZZZ',KLK,I,IEXTRA,MSTACK(1,KLK),KDATA(IZ,KLK)
    +
    3708  IF (mstack(1,klk).LT.13.OR.mstack(1,klk).GT.20) THEN
    +
    3709  print *,'IMPROPER SEQUENCE OF DESCRIPTORS IN LIST'
    +
    3710 C ===============================================================
    +
    3711  ELSE IF (mstack(1,klk).EQ.13) THEN
    +
    3712 C PRINT *,'13 NAME',KLK
    +
    3713 C
    +
    3714 C ELEMENT NAME PART 1 - 32 BYTES
    +
    3715 C FOR THIS PARAMETER
    +
    3716  jj = iextra
    +
    3717  DO 21 ll = 1, 32, iptr(45)
    +
    3718  lll = ll + iptr(45) - 1
    +
    3719  kqk = i + jj
    +
    3720  ihold = kdata(iz,kqk)
    +
    3721  IF (iptr(37).EQ.0) THEN
    +
    3722 C CALL W3AI39 (IDATA,IPTR(45))
    +
    3723  END IF
    +
    3724  aname1(ixb+iz)(ll:lll) = ascchr
    +
    3725  jj = jj + 1
    +
    3726  21 CONTINUE
    +
    3727  iextra = iextra + (32 / iptr(45)) - 1
    +
    3728  ibflag = ior(ibflag,64)
    +
    3729 C ===============================================================
    +
    3730  ELSE IF (mstack(1,klk).EQ.14) THEN
    +
    3731 C PRINT *,'14 NAME2',KLK
    +
    3732 C
    +
    3733 C ELEMENT NAME PART 2 - 32 BYTES
    +
    3734 C
    +
    3735 C FOR THIS PARAMETER
    +
    3736  jj = iextra
    +
    3737  DO 22 ll = 33, 64, iptr(45)
    +
    3738  lll = ll + iptr(45) - 1
    +
    3739  kqk = i + jj
    +
    3740  ihold = kdata(iz,kqk)
    +
    3741  IF (iptr(37).EQ.0) THEN
    +
    3742 C CALL W3AI39 (ASCCHR,IPTR(45))
    +
    3743  END IF
    +
    3744  aname1(ixb+iz)(ll:lll) = ascchr
    +
    3745  jj = jj + 1
    +
    3746  22 CONTINUE
    +
    3747  iextra = iextra + (32 / iptr(45)) - 1
    +
    3748  ibflag = ior(ibflag,32)
    +
    3749 C ===============================================================
    +
    3750  ELSE IF (mstack(1,klk).EQ.15) THEN
    +
    3751 C PRINT *,'15 UNITS',KLK
    +
    3752 C
    +
    3753 C UNITS NAME - 24 BYTES
    +
    3754 C
    +
    3755 C FOR THIS PARAMETER
    +
    3756  jj = iextra
    +
    3757  DO 23 ll = 1, 24, iptr(45)
    +
    3758  lll = ll + iptr(45) - 1
    +
    3759  kqk = i + jj
    +
    3760  ihold = kdata(iz,kqk)
    +
    3761  IF (iptr(37).EQ.0) THEN
    +
    3762 C CALL W3AI39 (ASCCHR,IPTR(45))
    +
    3763  END IF
    +
    3764  aunit1(ixb+iz)(ll:lll) = ascchr
    +
    3765  jj = jj + 1
    +
    3766  23 CONTINUE
    +
    3767  iextra = iextra + (24 / iptr(45)) - 1
    +
    3768  ibflag = ior(ibflag,16)
    +
    3769 C ===============================================================
    +
    3770  ELSE IF (mstack(1,klk).EQ.16) THEN
    +
    3771 C PRINT *,'16 SCALE SIGN'
    +
    3772 C
    +
    3773 C SCALE SIGN - 1 BYTE
    +
    3774 C 0 = POS, 1 = NEG
    +
    3775  ihold = kdata(iz,klk)
    +
    3776  klk = i + iextra
    +
    3777  IF (index(ascchr,'-').EQ.0) THEN
    +
    3778  iscsgn(iz) = 1
    +
    3779  ELSE
    +
    3780  iscsgn(iz) = -1
    +
    3781  END IF
    +
    3782 C ===============================================================
    +
    3783  ELSE IF (mstack(1,klk).EQ.17) THEN
    +
    3784 C PRINT *,'17 SCALE',KLK
    +
    3785 C
    +
    3786 C SCALE - 3 BYTES
    +
    3787 C
    +
    3788  klk = i + iextra
    +
    3789  CALL fi8814(kdata(iz,klk),3,iscal1(ixb+iz),ierr,iptr)
    +
    3790  IF (ierr.NE.0) THEN
    +
    3791  print *,'NON-NUMERIC CHAR - CANNOT CONVERT'
    +
    3792  iptr(1) = 888
    +
    3793  GO TO 9000
    +
    3794  END IF
    +
    3795  iscal1(ixb+iz) = iscal1(ixb+iz) * iscsgn(iz)
    +
    3796  ibflag = ior(ibflag,8)
    +
    3797 C ===============================================================
    +
    3798  ELSE IF (mstack(1,klk).EQ.18) THEN
    +
    3799 C PRINT *,'18 REFERENCE SCALE',KLK
    +
    3800 C
    +
    3801 C REFERENCE SIGN - 1 BYTE
    +
    3802 C 0 = POS, 1 = NEG
    +
    3803 C
    +
    3804  klk = i + iextra
    +
    3805  ihold = kdata(iz,klk)
    +
    3806  IF (index(ascchr,'-').EQ.0) THEN
    +
    3807  irfsgn(iz) = 1
    +
    3808  ELSE
    +
    3809  irfsgn(iz) = -1
    +
    3810  END IF
    +
    3811 C ===============================================================
    +
    3812  ELSE IF (mstack(1,klk).EQ.19) THEN
    +
    3813 C PRINT *,'19 REFERENCE VALUE',KLK
    +
    3814 C
    +
    3815 C REFERENCE VALUE - 10 BYTES/ 3 WDS
    +
    3816 C
    +
    3817  jj = iextra
    +
    3818  kqk = i + jj
    +
    3819  km = 0
    +
    3820  DO 26 ll = 1, 12, iptr(45)
    +
    3821  kqk = i + jj
    +
    3822  km = km + 1
    +
    3823  jhold(km) = kdata(iz,kqk)
    +
    3824  jj = jj + 1
    +
    3825  26 CONTINUE
    +
    3826  CALL fi8814(aaaa,10,irfvl1(ixb+iz),ierr,iptr)
    +
    3827  IF (ierr.NE.0) THEN
    +
    3828  print *,'NON-NUMERIC CHARACTER-CANNOT CONVERT'
    +
    3829  iptr(1) = 888
    +
    3830  GO TO 9000
    +
    3831  END IF
    +
    3832  irfvl1(ixb+iz) = irfvl1(ixb+iz) * irfsgn(iz)
    +
    3833  iextra = iextra + 10 / iptr(45)
    +
    3834 C DO 261 IZ = 1, JK
    +
    3835 C PRINT *,'RFVAL',IXB+IZ,JK,IRFVL1(IXB+IZ)
    +
    3836 C 261 CONTINUE
    +
    3837  ibflag = ior(ibflag,4)
    +
    3838 C ===============================================================
    +
    3839  ELSE
    +
    3840 C PRINT *,'20 WIDTH',KLK
    +
    3841 C
    +
    3842 C ELEMENT DATA WIDTH - 3 BYTES
    +
    3843 C
    +
    3844 C DO 27 LL = 1, 24, IPTR(45)
    +
    3845  klk = i + iextra
    +
    3846 C DO 270 IZ = 1, JK
    +
    3847  CALL fi8814(kdata(iz,klk),3,iwide1(ixb+iz),ierr,iptr)
    +
    3848  IF (ierr.NE.0) THEN
    +
    3849  print *,'NON-NUMERIC CHAR - CANNOT CONVERT'
    +
    3850  iptr(1) = 888
    +
    3851  GO TO 9000
    +
    3852  END IF
    +
    3853  IF (iwide1(ixb+iz).LT.1) THEN
    +
    3854  iptr(1) = 890
    +
    3855 C PRINT *,'CLASS 0 DESCRIPTOR, WIDTH=0',KFXY1(IXB+IZ)
    +
    3856  GO TO 9000
    +
    3857  END IF
    +
    3858 C 270 CONTINUE
    +
    3859 C 27 CONTINUE
    +
    3860  ibflag = ior(ibflag,2)
    +
    3861  END IF
    +
    3862 C NO, IT ISN'T
    +
    3863 C
    +
    3864 C IF THERE ARE ENOUGH OF THE ELEMENTS
    +
    3865 C NECESSARY TO ACCEPT A TABLE B ENTRY
    +
    3866 C
    +
    3867 C PRINT *,' IBFLAG =',IBFLAG
    +
    3868  IF (ibflag.EQ.127) THEN
    +
    3869 C PRINT *,'COMPLETE TABLE B ENTRY'
    +
    3870 C HAVE A COMPLETE TABLE B ENTRY
    +
    3871  ixb = ixb + 1
    +
    3872 C PRINT *,'B',IXB,JK,KFXY1(IXB),ANAME1(IXB)
    +
    3873 C PRINT *,' ',AUNIT1(IXB),ISCAL1(IXB),
    +
    3874 C * IRFVL1(IXB),IWIDE1(IXB)
    +
    3875  iptr(21) = ixb
    +
    3876  GO TO 1000
    +
    3877  END IF
    +
    3878  i = i + 1
    +
    3879 C
    +
    3880 C CHECK NEXT DESCRIPTOR
    +
    3881 C
    +
    3882  IF (i.GT.iptr(31)) THEN
    +
    3883 C RETURN IF COMPLETED SEARCH
    +
    3884  GO TO 9000
    +
    3885  END IF
    +
    3886  GO TO 20
    +
    3887 C ==================================================================
    +
    3888  300 CONTINUE
    +
    3889  iseq = 0
    +
    3890  ijk = iptr(20) + 1
    +
    3891 C PRINT *,'SEQUENCE DESCRIPTOR',MF,MX,MY,ITBLD(1,IXD),' FOR',IJK
    +
    3892  30 CONTINUE
    +
    3893  klk = i + iextra
    +
    3894 C PRINT *,'HAVE A SEQUENCE DESCRIPTOR',KLK,KDATA(IZ,KLK)
    +
    3895  IF (mstack(1,klk).EQ.30) THEN
    +
    3896 C FROM TEXT FIELD (6 BYTES/2 WDS)
    +
    3897 C STRIP OUT NEXT DESCRIPTOR IN SEQUENCE
    +
    3898 C
    +
    3899 C F - EXTRACT AND CONVERT TO DECIMAL
    +
    3900  jj = iextra
    +
    3901  kk = 0
    +
    3902  DO 351 ll = 1, 6, iptr(45)
    +
    3903  kqk = i + jj
    +
    3904  kk = kk + 1
    +
    3905  jhold(kk) = kdata(1,kqk)
    +
    3906  jj = jj + 1
    +
    3907  IF (ll.GT.1) iextra = iextra + 1
    +
    3908  351 CONTINUE
    +
    3909 C PRINT 349,KDATA(1,KQK)
    +
    3910  349 FORMAT (6x,z24)
    +
    3911 C CONVERT TO INTEGER
    +
    3912  CALL fi8814(aaaa,6,ihold,ierr,iptr)
    +
    3913 C PRINT *,' ',IHOLD
    +
    3914  IF (ierr.NE.0) THEN
    +
    3915  print *,'NON NUMERIC CHARACTER FOUND IN F X Y'
    +
    3916  iptr(1) = 888
    +
    3917  GO TO 9000
    +
    3918  END IF
    +
    3919 C CONSTRUCT SEQUENCE DESCRIPTOR
    +
    3920  iff = ihold / 100000
    +
    3921  ixx = mod((ihold/1300),100)
    +
    3922  iyy = mod(ihold,1300)
    +
    3923 C INSERT IN PROPER SEQUENCE
    +
    3924  itbld(iseq+2,ijk) = 16384 * iff + 256 * ixx + iyy
    +
    3925 C PRINT *,' SEQUENCE',IZ,AAAA,IHOLD,ITBLD(ISEQ+2,IJK),
    +
    3926 C * IFF,IXX,IYY
    +
    3927  iseq = iseq + 1
    +
    3928  IF (iseq.GT.18) THEN
    +
    3929  iptr(1) = 30
    +
    3930  RETURN
    +
    3931  END IF
    +
    3932 C SET TO LOOK AT NEXT DESCRIPTOR
    +
    3933  i = i + 1
    +
    3934 C IF (IPTR(45).LT.6) THEN
    +
    3935 C IEXTRA = IEXTRA + 1
    +
    3936 C END IF
    +
    3937  GO TO 30
    +
    3938  ELSE
    +
    3939 C NEXT DESCRIPTOR IS NOT A SEQUENCE DESCRIPTOR
    +
    3940  IF (iseq.GE.1) THEN
    +
    3941 C HAVE COMPLETE TABLE D ENTRY
    +
    3942  iptr(20) = iptr(20) + 1
    +
    3943 C PRINT *,' INTO LOCATION ',IPTR(20)
    +
    3944  lz = itbld(1,ijk)
    +
    3945  mz = mod(lz,16384)
    +
    3946  kptrd(mz) = ijk
    +
    3947  i = i - 1
    +
    3948  END IF
    +
    3949  END IF
    +
    3950 C GO TEST NEXT DESCRIPTOR
    +
    3951  GO TO 1000
    +
    3952 C ==================================================================
    +
    3953  9000 CONTINUE
    +
    3954 C PRINT *,IPTR(21),' ENTRIES IN ANCILLARY TABLE B'
    +
    3955 C PRINT *,IPTR(20),' ENTRIES IN ANCILLARY TABLE D'
    +
    3956 C DO 9050 L = 1, 16384
    +
    3957 C IF (KPTRD(L).GT.0) PRINT *,' D',L+32768, KPTRD(L)
    +
    3958 C9050 CONTINUE
    +
    3959 C IF (I.GE.IPTR(31)) THEN
    +
    3960 C
    +
    3961 C FILE FOR MODIFIED TABLE B OUTPUT
    +
    3962  numnut = iunitb + 1
    +
    3963  rewind numnut
    +
    3964 C
    +
    3965 C PRINT *,' HERE IS THE NEW TABLE B',IPTR(21)
    +
    3966  DO 2000 kb = 1, iptr(21)
    +
    3967  jf = kfxy1(kb) / 16384
    +
    3968  jx = mod((kfxy1(kb) / 256),64)
    +
    3969  jy = mod(kfxy1(kb),256)
    +
    3970 C WRITE (6,2001)JF,JX,JY,ANAME1(KB),
    +
    3971 C * AUNIT1(KB),ISCAL1(KB),IRFVL1(KB),IWIDE1(KB)
    +
    3972  WRITE (numnut,5000)jf,jx,jy,aname1(kb)(1:40),
    +
    3973  * aunit1(kb)(1:24),iscal1(kb),irfvl1(kb),iwide1(kb)
    +
    3974  5000 FORMAT(i1,i2,i3,a40,a24,i5,i15,i5)
    +
    3975  2000 CONTINUE
    +
    3976  2001 FORMAT (1x,i1,1x,i2,1x,i3,2x,a40,3x,a24,2x,i5,2x,i12,
    +
    3977  * 2x,i4)
    +
    3978 C
    +
    3979  endfile numnut
    +
    3980 C
    +
    3981  IF (iptr(20).NE.0) THEN
    +
    3982 C PRINT OUT TABLE
    +
    3983 C PRINT *,' HERE IS THE UPGRADED TABLE D'
    +
    3984 C DO 3000 KB = 1, IPTR(20)
    +
    3985 C PRINT 3001,KB,(ITBLD(K,KB),K=1,15)
    +
    3986 C3000 CONTINUE
    +
    3987 C3001 FORMAT (16(1X,I5))
    +
    3988  END IF
    +
    3989 C EXIT ROUTINE, ALL DONE WITH PASS
    +
    3990 C END IF
    +
    3991  RETURN
    +
    3992  END
    +
    3993  SUBROUTINE fi8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR)
    +
    3994 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
    +
    3995 C . . . .
    +
    3996 C SUBPROGRAM: FI8814 CONVERT TEXT TO INTEGER
    +
    3997 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04
    +
    3998 C
    +
    3999 C ABSTRACT: CONVERT TEXT CHARACTERS TO INTEGER VALUE
    +
    4000 C
    +
    4001 C PROGRAM HISTORY LOG:
    +
    4002 C 94-03-04 CAVANAUGH
    +
    4003 C YY-MM-DD MODIFIER2 DESCRIPTION OF CHANGE
    +
    4004 C
    +
    4005 C USAGE: CALL FI8814 (ASCCHR,NPOS,NEWVAL,IERR,IPTR)
    +
    4006 C INPUT ARGUMENT LIST:
    +
    4007 C ASCCHR -
    +
    4008 C NPOS -
    +
    4009 C NEWVAL -
    +
    4010 C IERR -
    +
    4011 C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
    +
    4012 C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
    +
    4013 C
    +
    4014 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
    +
    4015 C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
    +
    4016 C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
    +
    4017 C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
    +
    4018 C
    +
    4019 C INPUT FILES: (DELETE IF NO INPUT FILES IN SUBPROGRAM)
    +
    4020 C DDNAME1 - GENERIC NAME & CONTENT
    +
    4021 C
    +
    4022 C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM)
    +
    4023 C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE
    +
    4024 C FT06F001 - INCLUDE IF ANY PRINTOUT
    +
    4025 C
    +
    4026 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
    +
    4027 C
    +
    4028 C ATTRIBUTES:
    +
    4029 C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
    +
    4030 C MACHINE: NAS, CYBER, WHATEVER
    +
    4031 C
    +
    4032 C$$$
    +
    4033  INTEGER IERR, IHOLD, IPTR(*)
    +
    4034  CHARACTER*8 AHOLD
    +
    4035  CHARACTER*64 ASCCHR
    +
    4036  EQUIVALENCE (IHOLD,AHOLD)
    +
    4037 
    +
    4038  SAVE
    +
    4039 C ----------------------------------------------------------
    +
    4040  IERR = 0
    +
    4041  newval = 0
    +
    4042  iflag = 0
    +
    4043 C
    +
    4044  DO 1000 i = 1, npos
    +
    4045  ihold = 0
    +
    4046  ahold(iptr(45):iptr(45)) = ascchr(i:i)
    +
    4047  IF (iptr(37).EQ.1) THEN
    +
    4048  IF (ihold.EQ.32) THEN
    +
    4049  IF (iflag.EQ.0) GO TO 1000
    +
    4050  GO TO 2000
    +
    4051  ELSE IF (ihold.LT.48.OR.ihold.GT.57) THEN
    +
    4052 C PRINT*,' ASCII IHOLD =',IHOLD
    +
    4053  ierr = 1
    +
    4054  RETURN
    +
    4055  ELSE
    +
    4056  iflag = 1
    +
    4057  newval = newval * 10 + ihold - 48
    +
    4058  END IF
    +
    4059  ELSE
    +
    4060  IF (ihold.EQ.64) THEN
    +
    4061  IF (iflag.EQ.0) GO TO 1000
    +
    4062  GO TO 2000
    +
    4063  ELSE IF (ihold.LT.240.OR.ihold.GT.249) THEN
    +
    4064 C PRINT*,' EBCIDIC IHOLD =',IHOLD
    +
    4065  ierr = 1
    +
    4066  RETURN
    +
    4067  ELSE
    +
    4068  iflag = 1
    +
    4069  newval = newval * 10 + ihold - 240
    +
    4070  END IF
    +
    4071  END IF
    +
    4072  1000 CONTINUE
    +
    4073  2000 CONTINUE
    +
    4074  RETURN
    +
    4075  END
    +
    4076  SUBROUTINE fi8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD,
    +
    4077  * ANAME3,AUNIT3,
    +
    4078  * ISCAL3,IRFVL3,IWIDE3,
    +
    4079  * KEYSET,IBFLAG,IERR)
    +
    4080 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
    +
    4081 C . . . .
    +
    4082 C SUBPROGRAM: FI8815 EXTRACT TABLE A, TABLE B, TABLE D ENTRIES
    +
    4083 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-03-04
    +
    4084 C
    +
    4085 C ABSTRACT: EXTRACT TABLE A, TABLE B, ENTRIES FROM ACTIVE BUFR MESSAGE
    +
    4086 C TO BE RETAINED FOR USE DURING THE DECODING OF ACTIVE BUFR MESSAGE.
    +
    4087 C THESE WILL BE DISCARDED WHEN DECODING OF CURRENT MESSAGE IS COMPLETE
    +
    4088 C
    +
    4089 C PROGRAM HISTORY LOG:
    +
    4090 C 94-03-04 CAVANAUGH
    +
    4091 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
    +
    4092 C
    +
    4093 C USAGE: CALL FI8815(IPTR,IDENT,JDESC,KDATA,KFXY3,MAXR,MAXD,
    +
    4094 C * ANAME3,AUNIT3,
    +
    4095 C * ISCAL3,IRFVL3,IWIDE3,
    +
    4096 C * KEYSET,IBFLAG,IERR)
    +
    4097 C INPUT ARGUMENT LIST:
    +
    4098 C IPTR -
    +
    4099 C MAXR -
    +
    4100 C MAXD -
    +
    4101 C MSTACK -
    +
    4102 C KDATA -
    +
    4103 C IDENT -
    +
    4104 C INARG1 - GENERIC DESCRIPTION, INCLUDING CONTENT, UNITS,
    +
    4105 C INARG2 - TYPE. EXPLAIN FUNCTION IF CONTROL VARIABLE.
    +
    4106 C
    +
    4107 C OUTPUT ARGUMENT LIST:
    +
    4108 C ANAME3 -
    +
    4109 C AUNIT3 -
    +
    4110 C KFXY3 -
    +
    4111 C ISCAL3 -
    +
    4112 C IRFVL3 -
    +
    4113 C IWIDE3 -
    +
    4114 C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE.
    +
    4115 C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN
    +
    4116 C ERRFLAG - EVEN IF MANY LINES ARE NEEDED
    +
    4117 C
    +
    4118 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
    +
    4119 C
    +
    4120 C ATTRIBUTES:
    +
    4121 C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
    +
    4122 C MACHINE: NAS, CYBER
    +
    4123 C
    +
    4124 C$$$
    +
    4125  CHARACTER*64 ANAME3(*),SPACES
    +
    4126  CHARACTER*24 AUNIT3(*)
    +
    4127 C
    +
    4128  INTEGER IPTR(*),MAXR,MAXD,JDESC
    +
    4129  INTEGER IXA, IXB, IXD, KDATA(MAXR,MAXD)
    +
    4130  INTEGER IEXTRA
    +
    4131  INTEGER KEYSET
    +
    4132  INTEGER KFXY3(*),IDENT(*)
    +
    4133  INTEGER ISCAL3(*),ISCSGN(150)
    +
    4134  INTEGER IRFVL3(*),IRFSGN(150)
    +
    4135  INTEGER IWIDE3(*)
    +
    4136 
    +
    4137  SAVE
    +
    4138 C ==============================================================
    +
    4139 C PRINT *,'FI8815'
    +
    4140  IEXTRA = 0
    +
    4141 C BUILD SPACE CONSTANT
    +
    4142  do 1 i = 1, 64
    +
    4143  spaces(i:i) = ' '
    +
    4144  1 CONTINUE
    +
    4145 C INITIALIZE ENTRY COUNTS
    +
    4146  ixa = 0
    +
    4147  ixb = 0
    +
    4148  ixd = 0
    +
    4149 C
    +
    4150 C SET FOR COMPRESSED OR NON COMPRESSED
    +
    4151 C PROCESSING
    +
    4152 C
    +
    4153  IF (ident(16).EQ.0) THEN
    +
    4154  jk = 1
    +
    4155  ELSE
    +
    4156  jk = ident(14)
    +
    4157  END IF
    +
    4158 C
    +
    4159 C CLEAR NECESSARY ENTRIES
    +
    4160 C
    +
    4161  DO 2 iy = 1, jk
    +
    4162 C
    +
    4163 C CLEAR NEXT TABLE B ENTRY
    +
    4164 C
    +
    4165  kfxy3(ixb+iy) = 0
    +
    4166  aname3(ixb+iy)(1:64) = spaces(1:64)
    +
    4167  aunit3(ixb+iy)(1:24) = spaces(1:24)
    +
    4168  iscal3(ixb+iy) = 0
    +
    4169  irfvl3(ixb+iy) = 0
    +
    4170  iwide3(ixb+iy) = 0
    +
    4171  iscsgn(iy) = 1
    +
    4172  irfsgn(iy) = 1
    +
    4173  2 CONTINUE
    +
    4174 C
    +
    4175 C START PROCESSING ENTRIES
    +
    4176 C
    +
    4177  i = 0
    +
    4178  1000 CONTINUE
    +
    4179 C
    +
    4180 C SET POINTER TO CORRECT DATA POSITION
    +
    4181 C
    +
    4182  k = i + iextra
    +
    4183 C
    +
    4184 C MUST FIND F X Y KEY FOR TABLE B
    +
    4185 C OR TABLE D ENTRY
    +
    4186 C
    +
    4187  IF (jdesc.GE.10.AND.jdesc.LE.12) THEN
    +
    4188  10 CONTINUE
    +
    4189 C
    +
    4190 C BUILD DESCRIPTOR SEGMENT
    +
    4191 C
    +
    4192  DO 20 ly = 1,jk
    +
    4193  IF (jdesc.EQ.10) THEN
    +
    4194  kfxy3(ixb+ly) = kdata(k,1) * 16384 + kfxy3(ixb+ly)
    +
    4195  keyset = ior(keyset,4)
    +
    4196  i = i + 1
    +
    4197  GO TO 10
    +
    4198  ELSE IF (jdesc.EQ.11) THEN
    +
    4199  kfxy3(ixb+ly) = kdata(k,1) * 256 + kfxy3(ixb+ly)
    +
    4200  keyset = ior(keyset,2)
    +
    4201  i = i + 1
    +
    4202  GO TO 10
    +
    4203  ELSE IF (jdesc.EQ.12) THEN
    +
    4204  kfxy3(ixb+ly) = kdata(k,1) + kfxy3(ixb+ly)
    +
    4205  keyset = ior(keyset,1)
    +
    4206  END IF
    +
    4207  20 CONTINUE
    +
    4208 C ==================================================================
    +
    4209  ELSE IF (jdesc.GE.13.AND.jdesc.LE.20) THEN
    +
    4210  DO 250 iz = 1, jk
    +
    4211  IF (jdesc.EQ.13) THEN
    +
    4212 C
    +
    4213 C ELEMENT NAME PART 1 - 32 BYTES/8 WDS
    +
    4214 C
    +
    4215  CALL gbytes (aname3(ixb+iz),kdata(k,iz),0,32,0,8)
    +
    4216  ibflag = ior(ibflag,16)
    +
    4217  ELSE IF (jdesc.EQ.14) THEN
    +
    4218 C
    +
    4219 C ELEMENT NAME PART 2 - 32 BYTES/8 WDS
    +
    4220 C
    +
    4221  CALL gbytes(aname3(ixb+iz)(33:33),kdata(k,iz),0,32,0,8)
    +
    4222  ELSE IF (jdesc.EQ.15) THEN
    +
    4223 C
    +
    4224 C UNITS NAME - 24 BYTES/6 WDS
    +
    4225 C
    +
    4226  CALL gbytes (aunit3(ixb+iz)(1:1),kdata(k,iz),0,32,0,6)
    +
    4227  ibflag = ior(ibflag,8)
    +
    4228  ELSE IF (jdesc.EQ.16) THEN
    +
    4229 C
    +
    4230 C UNITS SCALE SIGN - 1 BYTE/ 1 WD
    +
    4231 C 0 = POS, 1 = NEG
    +
    4232  IF (kdata(k,1).NE.48) THEN
    +
    4233  iscsgn(iz) = -1
    +
    4234  ELSE
    +
    4235  iscsgn(iz) = 1
    +
    4236  END IF
    +
    4237  ELSE IF (jdesc.EQ.17) THEN
    +
    4238 C
    +
    4239 C UNITS SCALE - 3 BYTES/ 1 WD
    +
    4240 C
    +
    4241  CALL fi8814(kdata(k,iz),3,iscal3(ixb+iz),ierr,iptr)
    +
    4242  IF (ierr.NE.0) THEN
    +
    4243  print *,'NON-NUMERIC CHARACTER - CANNOT CONVERT'
    +
    4244  iptr(1) = 888
    +
    4245  RETURN
    +
    4246  END IF
    +
    4247  ibflag = ior(ibflag,4)
    +
    4248  ELSE IF (jdesc.EQ.18) THEN
    +
    4249 C
    +
    4250 C UNITS REFERENCE SIGN - 1 BYTE/ 1 WD
    +
    4251 C 0 = POS, 1 = NEG
    +
    4252 C
    +
    4253  IF (kdata(k,1).EQ.48) THEN
    +
    4254  irfsgn(iz) = 1
    +
    4255  ELSE
    +
    4256  irfsgn(iz) = -1
    +
    4257  END IF
    +
    4258  ELSE IF (jdesc.EQ.19) THEN
    +
    4259 C
    +
    4260 C UNITS REFERENCE VALUE - 10 BYTES/ 3 WDS
    +
    4261 C
    +
    4262  CALL fi8814(kdata(k,iz),10,irfvl3(ixb+iz),ierr,iptr)
    +
    4263  IF (ierr.NE.0) THEN
    +
    4264  print *,'NON-NUMERIC CHARACTER-CANNOT CONVERT'
    +
    4265  iptr(1) = 888
    +
    4266  RETURN
    +
    4267  END IF
    +
    4268  ibflag = ior(ibflag,2)
    +
    4269  ELSE
    +
    4270 C
    +
    4271 C ELEMENT DATA WIDTH - 3 BYTES/ 1 WD
    +
    4272 C
    +
    4273  CALL fi8814(kdata(k,1),3,iwide3(ixb+1),ierr,iptr)
    +
    4274  IF (ierr.NE.0) THEN
    +
    4275  print *,'NON-NUMERIC CHARACTER-CANNOT CONVERT'
    +
    4276  iptr(1) = 888
    +
    4277  RETURN
    +
    4278  END IF
    +
    4279  ibflag = ior(ibflag,1)
    +
    4280  END IF
    +
    4281  250 CONTINUE
    +
    4282  END IF
    +
    4283 C ==================================================================
    +
    4284  9000 RETURN
    +
    4285  END
    +
    4286  SUBROUTINE fi8818(IPTR,
    +
    4287  * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
    +
    4288  * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,
    +
    4289  * KPTRB)
    +
    4290 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
    +
    4291 C . . . .
    +
    4292 C SUBPROGRAM: FI8818 MERGE ANCILLARY & STANDARD B ENTRIES
    +
    4293 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD
    +
    4294 C
    +
    4295 C ABSTRACT: START ABSTRACT HERE AND INDENT TO COLUMN 5 ON THE
    +
    4296 C FOLLOWING LINES. SEE NMC HANDBOOK SECTION 3.1.1. FOR DETAILS
    +
    4297 C
    +
    4298 C PROGRAM HISTORY LOG:
    +
    4299 C YY-MM-DD CAVANAUGH
    +
    4300 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
    +
    4301 C
    +
    4302 C USAGE: CALL FI8818(IPTR,
    +
    4303 C * KFXY1,ANAME1,AUNIT1,ISCAL1,IRFVL1,IWIDE1,
    +
    4304 C * KFXY2,ANAME2,AUNIT2,ISCAL2,IRFVL2,IWIDE2,KPTRB)
    +
    4305 C INPUT ARGUMENT LIST:
    +
    4306 C IPTR -
    +
    4307 C KFXY1 -
    +
    4308 C ANAME1 -
    +
    4309 C AUNIT1 -
    +
    4310 C ISCAL1 -
    +
    4311 C IRFVL1 -
    +
    4312 C IWIDE1 -
    +
    4313 C KFXY2 -
    +
    4314 C ANAME2 -
    +
    4315 C AUNIT2 -
    +
    4316 C ISCAL2 -
    +
    4317 C IRFVL2 -
    +
    4318 C IWIDE2 -
    +
    4319 C
    +
    4320 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
    +
    4321 C IPTR -
    +
    4322 C KFXY1 -
    +
    4323 C ANAME1 -
    +
    4324 C AUNIT1 -
    +
    4325 C ISCAL1 -
    +
    4326 C IRFVL1 -
    +
    4327 C IWIDE1 -
    +
    4328 C
    +
    4329 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
    +
    4330 C
    +
    4331 C ATTRIBUTES:
    +
    4332 C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS
    +
    4333 C MACHINE: NAS, CYBER, WHATEVER
    +
    4334 C
    +
    4335 C$$$
    +
    4336 C ..................................................
    +
    4337 C
    +
    4338 C NEW BASE TABLE B
    +
    4339 C MAY BE A COMBINATION OF MASTER TABLE B
    +
    4340 C AND ANCILLARY TABLE B
    +
    4341 C
    +
    4342  INTEGER KFXY1(*),ISCAL1(*),IRFVL1(3,*),IWIDE1(*)
    +
    4343  CHARACTER*40 ANAME1(*)
    +
    4344  CHARACTER*24 AUNIT1(*)
    +
    4345 C ..................................................
    +
    4346 C
    +
    4347 C NEW ANCILLARY TABLE B FROM TYPE 11 BUFR MESSAGE
    +
    4348 C
    +
    4349  INTEGER KFXY2(*),ISCAL2(*),IRFVL2(*),IWIDE2(*)
    +
    4350  CHARACTER*64 ANAME2(*)
    +
    4351  CHARACTER*24 AUNIT2(*)
    +
    4352 C ..................................................
    +
    4353  INTEGER IPTR(*),KPTRB(*)
    +
    4354 
    +
    4355  SAVE
    +
    4356 C
    +
    4357 C SET UP POINTERS
    +
    4358 C PRINT *,'FI8818-A',IPTR(21),IPTR(41)
    +
    4359  KAB = 1
    +
    4360  kb = 1
    +
    4361  1000 CONTINUE
    +
    4362 C PRINT *,KB,KAB,KFXY1(KB),KFXY2(KAB),IPTR(21)
    +
    4363  IF (kb.GT.iptr(21)) THEN
    +
    4364 C NO MORE MASTER ENTRIES
    +
    4365 C PRINT *,'NO MORE MASTER ENTRIES'
    +
    4366  IF (kab.GT.iptr(41)) THEN
    +
    4367  GO TO 5000
    +
    4368  END IF
    +
    4369 C APPEND ANCILLARY ENTRY
    +
    4370  GO TO 2000
    +
    4371  ELSE IF (kb.LE.iptr(21)) THEN
    +
    4372 C HAVE MORE MASTER ENTRIES
    +
    4373  IF (kab.GT.iptr(41)) THEN
    +
    4374 C NO MORE ANCILLARY ENTRIES
    +
    4375  GO TO 5000
    +
    4376  END IF
    +
    4377  IF (kfxy2(kab).EQ.kfxy1(kb)) THEN
    +
    4378 C REPLACE MASTER ENTRY
    +
    4379  GO TO 3000
    +
    4380  ELSE IF (kfxy2(kab).LT.kfxy1(kb)) THEN
    +
    4381 C INSERT ANCILLARY ENTRY
    +
    4382  GO TO 2000
    +
    4383  ELSE IF (kfxy2(kab).GT.kfxy1(kb)) THEN
    +
    4384 C SKIP MASTER ENTRY
    +
    4385  kb = kb + 1
    +
    4386  END IF
    +
    4387  END IF
    +
    4388  GO TO 1000
    +
    4389  2000 CONTINUE
    +
    4390  iptr(21) = iptr(21) + 1
    +
    4391  kptrb(kfxy2(kab)) = iptr(21)
    +
    4392 C APPEND ANCILLARY ENTRY
    +
    4393  kfxy1(iptr(21)) = kfxy2(kab)
    +
    4394  aname1(iptr(21))(1:40) = aname2(kab)(1:40)
    +
    4395  aunit1(iptr(21)) = aunit2(kab)
    +
    4396  iscal1(iptr(21)) = iscal2(kab)
    +
    4397  irfvl1(1,iptr(21)) = irfvl2(kab)
    +
    4398  iwide1(iptr(21)) = iwide2(kab)
    +
    4399 C PRINT *,IPTR(21),KFXY1(IPTR(21)),' APPENDED'
    +
    4400  kab = kab + 1
    +
    4401  GO TO 1000
    +
    4402  3000 CONTINUE
    +
    4403 C REPLACE MASTER ENTRY
    +
    4404  kfxy1(kb) = kfxy2(kab)
    +
    4405  aname1(kb) = aname2(kab)(1:40)
    +
    4406  aunit1(kb) = aunit2(kab)
    +
    4407  iscal1(kb) = iscal2(kab)
    +
    4408  irfvl1(1,kb) = irfvl2(kab)
    +
    4409  iwide1(kb) = iwide2(kab)
    +
    4410 C PRINT *,KB,KFXY1(KB),'REPLACED',IWIDE1(KB)
    +
    4411  kab = kab + 1
    +
    4412  kb = kb + 1
    +
    4413  GO TO 1000
    +
    4414  5000 CONTINUE
    +
    4415  iptr(41) = 0
    +
    4416 C PROCESSING COMPLETE
    +
    4417 C PRINT *,'FI8818-B',IPTR(21),IPTR(41)
    +
    4418 C DO 6000 I = 1, IPTR(21)
    +
    4419 C PRINT *,'FI8818-C',I,KFXY1(I),IWIDE1(I)
    +
    4420 C6000 CONTINUE
    +
    4421  RETURN
    +
    4422  END
    +
    4423  SUBROUTINE fi8819(IPTR,ITBLD,ITBLD2,KPTRD)
    +
    4424 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
    +
    4425 C . . . .
    +
    4426 C SUBPROGRAM: FI8819 MERGE ANCILLARY & MASTER TABLE D
    +
    4427 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: YY-MM-DD
    +
    4428 C
    +
    4429 C ABSTRACT: MERGE TABLE D ENTRIES WITH THE ENTRIES FROM THE STANDARD
    +
    4430 C TABLE D. ASSURE THAT ENTRIES ARE SEQUENTIAL.
    +
    4431 C
    +
    4432 C PROGRAM HISTORY LOG:
    +
    4433 C YY-MM-DD CAVANAUGH
    +
    4434 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
    +
    4435 C
    +
    4436 C USAGE: CALL FI8819(IPTR,ITBLD,ITBLD2,KPTRD)
    +
    4437 C INPUT ARGUMENT LIST:
    +
    4438 C IPTR -
    +
    4439 C ITBLD -
    +
    4440 C ITBLD2 -
    +
    4441 C
    +
    4442 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
    +
    4443 C IPTR -
    +
    4444 C ITBLD -
    +
    4445 C
    +
    4446 C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION
    +
    4447 C
    +
    4448 C ATTRIBUTES:
    +
    4449 C LANGUAGE: FORTRAN 77
    +
    4450 C MACHINE: NAS, CYBER
    +
    4451 C
    +
    4452 C$$$
    +
    4453 C ..................................................
    +
    4454 C
    +
    4455 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
    +
    4456 C
    +
    4457  INTEGER ITBLD2(20,*)
    +
    4458 C ..................................................
    +
    4459 C
    +
    4460 C NEW BASE TABLE D
    +
    4461 C
    +
    4462  INTEGER ITBLD(20,*)
    +
    4463 C ..................................................
    +
    4464  INTEGER IPTR(*),KPTRD(*)
    +
    4465 
    +
    4466  SAVE
    +
    4467 C PRINT *,'FI8819-A',IPTR(20),IPTR(42)
    +
    4468 C SET UP POINTERS
    +
    4469  DO 1000 I = 1, iptr(42)
    +
    4470  iptr(20) = iptr(20) + 1
    +
    4471  DO 500 j = 1, 20
    +
    4472  itbld(j,iptr(20)) = itbld2(j,i)
    +
    4473  mptrd = mod(itbld(j,iptr(20)),16384)
    +
    4474  kptrd(mptrd) = iptr(20)
    +
    4475  500 CONTINUE
    +
    4476  1000 CONTINUE
    +
    4477 C =======================================================
    +
    4478  iptr(42) = 0
    +
    4479 C PRINT *,'MERGED TABLE D -- FI8819-B',IPTR(20),IPTR(42)
    +
    4480 C DO 6000 I = 1, IPTR(20)
    +
    4481 C WRITE (6,6001)I,(ITBLD(J,I),J=1,20)
    +
    4482 C6001 FORMAT(15(1X,I5))
    +
    4483 C6000 CONTINUE
    +
    4484  RETURN
    +
    4485  END
    +
    4486  SUBROUTINE fi8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD)
    +
    4487 C$$$ SUBPROGRAM DOCUMENTATION BLOCK
    +
    4488 C . . . .
    +
    4489 C SUBPROGRAM: FI8820 READ IN BUFR TABLE D
    +
    4490 C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-05-06
    +
    4491 C
    +
    4492 C ABSTRACT: READ IN BUFR TABLE D
    +
    4493 C
    +
    4494 C PROGRAM HISTORY LOG:
    +
    4495 C 93-05-06 CAVANAUGH
    +
    4496 C YY-MM-DD MODIFIER1 DESCRIPTION OF CHANGE
    +
    4497 C
    +
    4498 C USAGE: CALL FI8820 (ITBLD,IUNITD,IPTR,ITBLD2,KPTRD)
    +
    4499 C INPUT ARGUMENT LIST:
    +
    4500 C IUNITD - UNIT NUMBER FOR TABLE D INPUT
    +
    4501 C IPTR - ARRAY OF WORKING VALUES
    +
    4502 C
    +
    4503 C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
    +
    4504 C ITBLD - ARRAY TO CONTAIN TABLE D
    +
    4505 C
    +
    4506 C REMARKS:
    +
    4507 C
    +
    4508 C ATTRIBUTES:
    +
    4509 C LANGUAGE: FORTRAN 77
    +
    4510 C MACHINE: NAS
    +
    4511 C
    +
    4512 C$$$
    +
    4513 C ..................................................
    +
    4514 C
    +
    4515 C ANCILLARY TABLE D FROM TYPE 11 BUFR MESSAGE
    +
    4516 C
    +
    4517  INTEGER ITBLD2(20,*)
    +
    4518 C ..................................................
    +
    4519 C
    +
    4520 C NEW BASE TABLE D
    +
    4521 C
    +
    4522  INTEGER ITBLD(20,*)
    +
    4523 C ..................................................
    +
    4524 C
    +
    4525  INTEGER IHOLD(33),IPTR(*),KPTRD(*)
    +
    4526  LOGICAL MORE
    +
    4527 
    +
    4528  SAVE
    +
    4529 C
    +
    4530  MORE = .true.
    +
    4531  i = 0
    +
    4532 C
    +
    4533 C READ IN TABLE D, BUT JUST ONCE
    +
    4534 C PRINT *,'TABLE D SWITCH=',IPTR(20),' ANCILLARY D SW=',IPTR(42)
    +
    4535  IF (iptr(20).EQ.0) THEN
    +
    4536  DO 1000 mm = 1, 16384
    +
    4537  kptrd(mm) = -1
    +
    4538  1000 CONTINUE
    +
    4539  ierr = 0
    +
    4540  print *,'FI8820 - READING TABLE D'
    +
    4541  key = 0
    +
    4542  100 CONTINUE
    +
    4543 C READ NEXT TABLE D ENTRY
    +
    4544  READ(iunitd,15,err=9998,END=9000)(IHOLD(M),M=1,33)
    +
    4545  15 FORMAT(11(i1,i2,i3,1x),3x)
    +
    4546 C BUILD KEY FROM MASTER D ENTRY
    +
    4547 C INSERT NEW MASTER INTO TABLE B
    +
    4548  i = i + 1
    +
    4549  iptr(20) = iptr(20) + 1
    +
    4550  DO 25 jj = 1, 41, 3
    +
    4551  kk = (jj/3) + 1
    +
    4552  IF (jj.LE.31) THEN
    +
    4553  itbld(kk,i) = ihold(jj)*16384 +
    +
    4554  * ihold(jj+1)*256 + ihold(jj+2)
    +
    4555  IF (itbld(kk,i).LT.1.OR.itbld(kk,i).GT.65535) THEN
    +
    4556  itbld(kk,i) = 0
    +
    4557  GO TO 25
    +
    4558  END IF
    +
    4559  ELSE
    +
    4560  itbld(kk,i) = 0
    +
    4561  END IF
    +
    4562  25 CONTINUE
    +
    4563  mptrd = mod(itbld(1,i),16384)
    +
    4564  kptrd(mptrd) = i
    +
    4565  50 CONTINUE
    +
    4566 C WRITE (6,51)I,(ITBLD(L,I),L=1,15)
    +
    4567  51 FORMAT (7h tabled,16(1x,i5))
    +
    4568  GO TO 100
    +
    4569  ELSE
    +
    4570 C PRINT *,'TABLE D IS IN PLACE'
    +
    4571  END IF
    +
    4572  GO TO 9999
    +
    4573  9000 CONTINUE
    +
    4574  CLOSE(unit=iunitd,status='KEEP')
    +
    4575  GO TO 9999
    +
    4576  9998 CONTINUE
    +
    4577  iptr(1) = 8
    +
    4578 C
    +
    4579  9999 CONTINUE
    +
    4580 C PRINT *,'THERE ARE',IPTR(20),' ENTRIES IN TABLE D'
    +
    4581  RETURN
    +
    4582  END
    +
    +
    +
    gbytes
    subroutine gbytes(IPACKD, IUNPKD, NOFF, NBITS, ISKIP, ITER)
    Program history log:
    Definition: gbytes.f:26
    +
    fi8801
    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)
    Data extraction.
    Definition: w3fi88.f:973
    +
    fi8802
    subroutine fi8802(IPTR, IDENT, MSGA, KDATA, KFXY1, LL, MSTACK, AUNIT1, IWIDE1, IRFVL1, ISCAL1, JDESC, IVALS, J, MAXR, MAXD, KPTRB)
    Process element descriptor.
    Definition: w3fi88.f:1309
    +
    fi8804
    subroutine fi8804(IPTR, MSGA, KDATA, IVALS, MSTACK, IWIDE1, IRFVL1, ISCAL1, J, LL, JDESC, MAXR, MAXD)
    Process serial data.
    Definition: w3fi88.f:1733
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    w3ai39
    subroutine w3ai39(NFLD, N)
    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
    Definition: w3ai39.f:26
    +
    fi8809
    subroutine fi8809(IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
    Reformat profiler w hgt increments.
    Definition: w3fi88.f:2517
    +
    w3fc05
    subroutine w3fc05(U, V, DIR, SPD)
    Given the true (Earth oriented) wind components compute the wind direction and speed.
    Definition: w3fc05.f:29
    +
    fi8805
    subroutine fi8805(IPTR, IDENT, MSGA, IWORK, LX, LY, KDATA, LL, KNR, MSTACK, MAXR, MAXD)
    Process a replication descriptor.
    Definition: w3fi88.f:1941
    +
    fi8810
    subroutine fi8810(IDENT, MSTACK, KDATA, IPTR, MAXR, MAXD)
    Reformat profiler edition 2 data.
    Definition: w3fi88.f:2911
    +
    fi8803
    subroutine fi8803(IPTR, IDENT, MSGA, KDATA, IVALS, MSTACK, IWIDE1, IRFVL1, ISCAL1, J, JDESC, MAXR, MAXD)
    Process compressed data.
    Definition: w3fi88.f:1414
    +
    fi8807
    subroutine fi8807(IPTR, IWORK, ITBLD, ITBLD2, JDESC, KPTRD)
    Process queue descriptor.
    Definition: w3fi88.f:2372
    +
    fi8808
    subroutine fi8808(IPTR, IWORK, LF, LX, LY, JDESC)
    Program history log:
    Definition: w3fi88.f:2459
    +
    gbyte
    subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
    This is the fortran version of gbyte.
    Definition: gbyte.f:27
    +
    fi8806
    subroutine fi8806(IPTR, LX, LY, IDENT, MSGA, KDATA, IVALS, MSTACK, IWIDE1, IRFVL1, ISCAL1, J, LL, KFXY1, IWORK, JDESC, MAXR, MAXD, KPTRB)
    Process operator descriptors.
    Definition: w3fi88.f:2149
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    +
    fi8811
    subroutine fi8811(IPTR, IDENT, MSTACK, KDATA, KNR, LDATA, LSTACK, MAXD, MAXR)
    Expand data/descriptor replication.
    Definition: w3fi88.f:3249
    +
    w3fi88
    subroutine w3fi88(IPTR, IDENT, MSGA, ISTACK, MSTACK, KDATA, KNR, INDEX, LDATA, LSTACK, MAXR, MAXD, IUNITB, IUNITD)
    This set of routines will decode a bufr message and place information extracted from the bufr message...
    Definition: w3fi88.f:439
    + + + + diff --git a/ver-2.10.0/w3fi92_8f.html b/ver-2.10.0/w3fi92_8f.html new file mode 100644 index 00000000..14b940e9 --- /dev/null +++ b/ver-2.10.0/w3fi92_8f.html @@ -0,0 +1,210 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi92.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fi92.f File Reference
    +
    +
    + +

    Build 80-char on 295 grib queue descriptor. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fi92 (LOC, TTAAII, KARY, KWBX, IERR)
     Build 80 character queue descriptor using information supplied by user, placing the completed queue descriptor in the location specified by the user. More...
     
    +

    Detailed Description

    +

    Build 80-char on 295 grib queue descriptor.

    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-06-21
    + +

    Definition in file w3fi92.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fi92()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fi92 (character*80 LOC,
    character*6 TTAAII,
    integer, dimension(7) KARY,
    character*4 KWBX,
    integer IERR 
    )
    +
    + +

    Build 80 character queue descriptor using information supplied by user, placing the completed queue descriptor in the location specified by the user.

    +

    (based on office note 295).

    +
    Note
    This is a modified version of w3fi62() which adds the 'KWBX' parameter. This value will now be added to bytes 35-38 for all grib products. Queue desciptors for non-grib products will continue to be generated by w3fi62().
    +

    Program history log:

      +
    • Bill Cavanaugh 1991-06-21
      • +
    • Bill Cavanaugh 1994-03-08 Modified to allow for bulletin sizes that exceed 20000 bytes
      • +
    • Ralph Jones 1994-04-28 Change for cray 64 bit word size and for ASCII character set computers
      • +
    • J. Smith 1995-10-16 Modified version of w3fi62() to add 'KWBX' to bytes 35-38 of queue descriptor.
      • +
    • Ralph Jones 1996-01-29 Preset ierr to zero.
      • +
    • Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
      • +
    +
    Parameters
    + + + + + + +
    [in]TTAAIIFirst 6 characters of wmo header
    [in,out]KARYInteger array containing user information
      +
    • 1 = Day of month
      • +
    • 2 = Hour of day
      • +
    • 3 = Hour * 100 + minute
      • +
    • 4 = Catalog number
      • +
    • 5 = Number of 80 byte increments
      • +
    • 6 = Number of bytes in last increment
      • +
    • 7 = Total size of message WMO header + body of message in bytes (not including queue descriptor)
      • +
    +
    [in]KWBX4 characters, representing the fcst model that the bulletin was derived from.
    [out]LOCLocation to receive queue descriptor.
    [out]IERRError return.
    +
    +
    +
    Note
    If total size is entered (kary(7)) then kary(5) and kary(6) will be calculated. If kary(5) and kary(6) are provided then kary(7) will be ignored.
    +
    +Equivalence array loc to integer array so it starts on a word boundary for sbyte subroutine.
    +

    Error returns:

      +
    • IERR = 1 Total byte count and/or 80 byte increment count is missing. One or the other is required to complete the queue descriptor.
      • +
    • IERR = 2 Total size too small
      • +
    +
    Author
    Bill Cavanaugh
    +
    Date
    1991-06-21
    + +

    Definition at line 54 of file w3fi92.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fi92_8f.js b/ver-2.10.0/w3fi92_8f.js new file mode 100644 index 00000000..a6e47b41 --- /dev/null +++ b/ver-2.10.0/w3fi92_8f.js @@ -0,0 +1,4 @@ +var w3fi92_8f = +[ + [ "w3fi92", "w3fi92_8f.html#a2e8b8ef3dcf66d40422987430e28545a", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fi92_8f_source.html b/ver-2.10.0/w3fi92_8f_source.html new file mode 100644 index 00000000..7ce3093b --- /dev/null +++ b/ver-2.10.0/w3fi92_8f_source.html @@ -0,0 +1,306 @@ + + + + + + + +NCEPLIBS-w3emc: w3fi92.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fi92.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Build 80-char on 295 grib queue descriptor.
    +
    3 C> @author Bill Cavanaugh @date 1991-06-21
    +
    4 
    +
    5 C> Build 80 character queue descriptor using information
    +
    6 C> supplied by user, placing the completed queue descriptor in the
    +
    7 C> location specified by the user. (based on office note 295).
    +
    8 C>
    +
    9 C> @note This is a modified version of w3fi62() which adds the 'KWBX'
    +
    10 C> parameter. This value will now be added to bytes 35-38 for all grib
    +
    11 C> products. Queue desciptors for non-grib products will continue to be
    +
    12 C> generated by w3fi62().
    +
    13 C>
    +
    14 C> Program history log:
    +
    15 C> - Bill Cavanaugh 1991-06-21
    +
    16 C> - Bill Cavanaugh 1994-03-08 Modified to allow for bulletin sizes that
    +
    17 C> exceed 20000 bytes
    +
    18 C> - Ralph Jones 1994-04-28 Change for cray 64 bit word size and for ASCII
    +
    19 C> character set computers
    +
    20 C> - J. Smith 1995-10-16 Modified version of w3fi62() to add 'KWBX' to bytes
    +
    21 C> 35-38 of queue descriptor.
    +
    22 C> - Ralph Jones 1996-01-29 Preset ierr to zero.
    +
    23 C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
    +
    24 C>
    +
    25 C> @param[in] TTAAII First 6 characters of wmo header
    +
    26 C> @param[inout] KARY Integer array containing user information
    +
    27 C> - 1 = Day of month
    +
    28 C> - 2 = Hour of day
    +
    29 C> - 3 = Hour * 100 + minute
    +
    30 C> - 4 = Catalog number
    +
    31 C> - 5 = Number of 80 byte increments
    +
    32 C> - 6 = Number of bytes in last increment
    +
    33 C> - 7 = Total size of message WMO header + body of message in bytes (not
    +
    34 C> including queue descriptor)
    +
    35 C> @param[in] KWBX 4 characters, representing the fcst model that the bulletin
    +
    36 C> was derived from.
    +
    37 C> @param[out] LOC Location to receive queue descriptor.
    +
    38 C> @param[out] IERR Error return.
    +
    39 C>
    +
    40 C>
    +
    41 C> @note If total size is entered (kary(7)) then kary(5) and kary(6) will be calculated.
    +
    42 C> If kary(5) and kary(6) are provided then kary(7) will be ignored.
    +
    43 C>
    +
    44 C> @note Equivalence array loc to integer array so it starts on a word
    +
    45 C> boundary for sbyte subroutine.
    +
    46 C>
    +
    47 C> Error returns:
    +
    48 C> - IERR = 1 Total byte count and/or 80 byte increment count is missing. One
    +
    49 C> or the other is required to complete the queue descriptor.
    +
    50 C> - IERR = 2 Total size too small
    +
    51 C>
    +
    52 C> @author Bill Cavanaugh @date 1991-06-21
    +
    53  SUBROUTINE w3fi92 (LOC,TTAAII,KARY,KWBX,IERR)
    +
    54 C
    +
    55  INTEGER IHOLD(2)
    +
    56  INTEGER KARY(7),IERR
    +
    57 C
    +
    58  LOGICAL IBM370
    +
    59 C
    +
    60  CHARACTER*6 TTAAII,AHOLD
    +
    61  CHARACTER*80 LOC
    +
    62  CHARACTER*1 BLANK
    +
    63  CHARACTER*4 KWBX
    +
    64 C
    +
    65  equivalence(ahold,ihold)
    +
    66 C
    +
    67  SAVE
    +
    68 C
    +
    69 C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE
    +
    70 C COMPUTER, THIS IS THE EBCDIC CHARACTER SET.
    +
    71 C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE
    +
    72 C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER
    +
    73 C SETS TO FIND IBM370 TYPE COMPUTER.
    +
    74 C
    +
    75  DATA blank /' '/
    +
    76 C ----------------------------------------------------------------
    +
    77 C
    +
    78 C TEST FOR CRAY 64 BIT COMPUTER, LW = 8
    +
    79 C
    +
    80  CALL w3fi01(lw)
    +
    81 C
    +
    82 C TEST FOR EBCDIC CHARACTER SET
    +
    83 C
    +
    84  ibm370 = .false.
    +
    85  IF (mova2i(blank).EQ.64) THEN
    +
    86  ibm370 = .true.
    +
    87  END IF
    +
    88 C
    +
    89  inofst = 0
    +
    90 C BYTES 1-16 'QUEUE DESCRIPTOR'
    +
    91  CALL sbyte (loc,-656095772,inofst,32)
    +
    92  inofst = inofst + 32
    +
    93  CALL sbyte (loc,-985611067,inofst,32)
    +
    94  inofst = inofst + 32
    +
    95  CALL sbyte (loc,-490481207,inofst,32)
    +
    96  inofst = inofst + 32
    +
    97  CALL sbyte (loc,-672934183,inofst,32)
    +
    98  inofst = inofst + 32
    +
    99 C BYTES 17-20 INTEGER ZEROES
    +
    100  CALL sbyte (loc,0,inofst,32)
    +
    101  inofst = inofst + 32
    +
    102 C IF TOTAL COUNT IS INCLUDED
    +
    103 C THEN WILL DETERMINE THE NUMBER OF
    +
    104 C 80 BYTE INCREMENTS AND WILL DETERMINE
    +
    105 C THE NUMBER OF BYTES IN THE LAST INCREMENT
    +
    106  ierr = 0
    +
    107  IF (kary(7).NE.0) THEN
    +
    108  IF (kary(7).LT.35) THEN
    +
    109 C PRINT *,'LESS THAN MINIMUM SIZE'
    +
    110  ierr = 2
    +
    111  RETURN
    +
    112  END IF
    +
    113  kary(5) = kary(7) / 80
    +
    114  kary(6) = mod(kary(7),80)
    +
    115  IF (kary(6).EQ.0) THEN
    +
    116  kary(6) = 80
    +
    117  ELSE
    +
    118  kary(5) = kary(5) + 1
    +
    119  END IF
    +
    120  ELSE
    +
    121  IF (kary(5).LT.1) THEN
    +
    122  ierr = 1
    +
    123  RETURN
    +
    124  END IF
    +
    125  END IF
    +
    126 C BYTE 21-22 NR OF 80 BYTE INCREMENTS
    +
    127  CALL sbyte (loc,kary(5),inofst,16)
    +
    128  inofst = inofst + 16
    +
    129 C BYTE 23 NR OF BYTES IN LAST INCREMENT
    +
    130  CALL sbyte (loc,kary(6),inofst,8)
    +
    131  inofst = inofst + 8
    +
    132 C BYTES 24-28 INTEGER ZEROES
    +
    133  CALL sbyte (loc,0,inofst,32)
    +
    134  inofst = inofst + 32
    +
    135  CALL sbyte (loc,0,inofst,8)
    +
    136  inofst = inofst + 8
    +
    137 C BYTES 29-34 6 CHAR BULLETIN NAME TTAAII
    +
    138  loc(29:34) = ttaaii(1:6)
    +
    139 C
    +
    140 C IF ON ASCII COMPUTER, CONVERT LAST 6 CHARACTERS TO EBCDIC
    +
    141 C
    +
    142  IF (.NOT.ibm370) CALL w3ai39(loc(29:29),6)
    +
    143 C
    +
    144  inofst = inofst + 48
    +
    145 C BYTES 35-38 KWBX
    +
    146 C
    +
    147  loc(35:38) = kwbx(1:4)
    +
    148 C
    +
    149 C IF ON ASCII COMPUTER, CONVERT LAST 4 CHARACTERS TO EBCDIC
    +
    150 C
    +
    151  IF (.NOT.ibm370) CALL w3ai39(loc(35:35),4)
    +
    152  inofst = inofst + 32
    +
    153 C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION
    +
    154 C TWO BYTES AS 4 BIT BCD
    +
    155  ka = kary(3) / 1000
    +
    156  kb = mod(kary(3),1000) / 100
    +
    157  kc = mod(kary(3),100) / 10
    +
    158  kd = mod(kary(3),10)
    +
    159  CALL sbyte (loc,ka,inofst,4)
    +
    160  inofst = inofst + 4
    +
    161  CALL sbyte (loc,kb,inofst,4)
    +
    162  inofst = inofst + 4
    +
    163  CALL sbyte (loc,kc,inofst,4)
    +
    164  inofst = inofst + 4
    +
    165  CALL sbyte (loc,kd,inofst,4)
    +
    166  inofst = inofst + 4
    +
    167 C BYTES 41-45 CATALOG NUMBER ELSE (SET TO 55555)
    +
    168  IF (kary(4).GE.1.AND.kary(4).LE.99999) THEN
    +
    169  CALL w3ai15 (kary(4),ihold,1,8,'-')
    +
    170  IF (lw.EQ.4) THEN
    +
    171  CALL sbyte (loc,ihold(1),inofst,8)
    +
    172  inofst = inofst + 8
    +
    173  CALL sbyte (loc,ihold(2),inofst,32)
    +
    174  inofst = inofst + 32
    +
    175 C
    +
    176 C ON CRAY 64 BIT COMPUTER
    +
    177 C
    +
    178  ELSE
    +
    179  CALL sbyte (loc,ihold,inofst,40)
    +
    180  inofst = inofst + 40
    +
    181  END IF
    +
    182 C
    +
    183 C IF ON ASCII COMPUTER, CONVERT LAST 5 CHARACTERS TO EBCDIC
    +
    184 C
    +
    185  IF (.NOT.ibm370) CALL w3ai39(loc(41:41),5)
    +
    186  ELSE
    +
    187  CALL sbyte (loc,-168430091,inofst,32)
    +
    188  inofst = inofst + 32
    +
    189  CALL sbyte (loc,245,inofst,8)
    +
    190  inofst = inofst + 8
    +
    191  END IF
    +
    192 C BYTES 46-80 INTEGER ZEROES
    +
    193  DO 4676 i = 1, 8
    +
    194  CALL sbyte (loc,0,inofst,32)
    +
    195  inofst = inofst + 32
    +
    196  4676 CONTINUE
    +
    197  CALL sbyte (loc,0,inofst,24)
    +
    198  RETURN
    +
    199  END
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    w3ai39
    subroutine w3ai39(NFLD, N)
    translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
    Definition: w3ai39.f:26
    +
    sbyte
    subroutine sbyte(IOUT, IN, ISKIP, NBYTE)
    Definition: sbyte.f:12
    +
    w3ai15
    subroutine w3ai15(NBUFA, NBUFB, N1, N2, MINUS)
    Converts a set of binary numbers to an equivalent set of ascii number fields in core.
    Definition: w3ai15.f:48
    +
    w3fi92
    subroutine w3fi92(LOC, TTAAII, KARY, KWBX, IERR)
    Build 80 character queue descriptor using information supplied by user, placing the completed queue d...
    Definition: w3fi92.f:54
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    + + + + diff --git a/ver-2.10.0/w3fm07_8f.html b/ver-2.10.0/w3fm07_8f.html new file mode 100644 index 00000000..d31efaed --- /dev/null +++ b/ver-2.10.0/w3fm07_8f.html @@ -0,0 +1,192 @@ + + + + + + + +NCEPLIBS-w3emc: w3fm07.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fm07.f File Reference
    +
    +
    + +

    Nine-point smoother for rectangular grids. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fm07 (FIN, FOUT, CWORK, GAMMA, NCOL, NROW)
     Smooths data on a rectangular grid using a nine-point smoothing operator. More...
     
    +

    Detailed Description

    +

    Nine-point smoother for rectangular grids.

    +
    Author
    P. Chase
    +
    Date
    1975-04-01
    + +

    Definition in file w3fm07.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fm07()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fm07 (real, dimension(ncol,nrow) FIN,
    real, dimension(ncol,nrow) FOUT,
    complex, dimension(ncol,*) CWORK,
    complex GAMMA,
     NCOL,
     NROW 
    )
    +
    + +

    Smooths data on a rectangular grid using a nine-point smoothing operator.

    +

    Program history log: P. Chase 1975-04-01 Ralph Jones 1984-07-01 Change to ibm vs fortran Ralph Jones 1991-04-24 Change to cray cft77 fortran

    +
    Parameters
    + + + + + + + +
    [in]FIN- Real size(ncol*nrow) array of data to be smoothed
    [in]CWORK- Real size(2*ncol*(nrow+2)) work array
    [in]GAMMA- Complex smoothing parameter. The imaginary part must be positive.
    [in]NCOL- Integer number of columns in the grid
    [in]NROW- Integer number of rows in the grid
    [out]FOUT- Real size(ncol*nrow) array of smoothed data. May be the same array as 'fin' or overlap it in any fashion.
    +
    +
    +
    Author
    P. Chase
    +
    Date
    1975-04-01
    + +

    Definition at line 24 of file w3fm07.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fm07_8f.js b/ver-2.10.0/w3fm07_8f.js new file mode 100644 index 00000000..32533957 --- /dev/null +++ b/ver-2.10.0/w3fm07_8f.js @@ -0,0 +1,4 @@ +var w3fm07_8f = +[ + [ "w3fm07", "w3fm07_8f.html#a3fb4f69f29d16715851691eae8cd482b", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fm07_8f_source.html b/ver-2.10.0/w3fm07_8f_source.html new file mode 100644 index 00000000..f4b3da2f --- /dev/null +++ b/ver-2.10.0/w3fm07_8f_source.html @@ -0,0 +1,208 @@ + + + + + + + +NCEPLIBS-w3emc: w3fm07.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fm07.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Nine-point smoother for rectangular grids.
    +
    3 C> @author P. Chase @date 1975-04-01
    +
    4 
    +
    5 C> Smooths data on a rectangular grid using a nine-point
    +
    6 C> smoothing operator.
    +
    7 C>
    +
    8 C> Program history log:
    +
    9 C> P. Chase 1975-04-01
    +
    10 C> Ralph Jones 1984-07-01 Change to ibm vs fortran
    +
    11 C> Ralph Jones 1991-04-24 Change to cray cft77 fortran
    +
    12 C>
    +
    13 C> @param[in] FIN - Real size(ncol*nrow) array of data to be smoothed
    +
    14 C> @param[in] CWORK - Real size(2*ncol*(nrow+2)) work array
    +
    15 C> @param[in] GAMMA - Complex smoothing parameter. The imaginary part must
    +
    16 C> be positive.
    +
    17 C> @param[in] NCOL - Integer number of columns in the grid
    +
    18 C> @param[in] NROW - Integer number of rows in the grid
    +
    19 C> @param[out] FOUT - Real size(ncol*nrow) array of smoothed data. May
    +
    20 C> be the same array as 'fin' or overlap it in any fashion.
    +
    21 C>
    +
    22 C> @author P. Chase @date 1975-04-01
    +
    23  SUBROUTINE w3fm07(FIN,FOUT,CWORK,GAMMA,NCOL,NROW)
    +
    24 C
    +
    25  REAL FIN(NCOL,NROW)
    +
    26  REAL FOUT(NCOL,NROW)
    +
    27 C
    +
    28  COMPLEX CWORK(NCOL,*),GAMMA,GAMMX,GAMA,GAMB,GAMC
    +
    29 C
    +
    30  gammx = gamma
    +
    31  xswtch = aimag(gammx)
    +
    32  ncolm = ncol-1
    +
    33  nrowm = nrow-1
    +
    34 C
    +
    35 C INITIALIZE WORK ARRAY. WORK ARRAY STARTS UP TWO ROWS SO IT CAN SMOOTH
    +
    36 C DOWNWARD WITHOUT OVERLAP OF SMOOTHED AND UNSMOOTHED DATA
    +
    37 C
    +
    38  DO 10 j = 1,nrow
    +
    39  DO 10 i = 1,ncol
    +
    40  cwork(i,j+2) = cmplx(fin(i,j),0.)
    +
    41  10 CONTINUE
    +
    42  IF (xswtch .EQ. 0.) GO TO 30
    +
    43  DO 20 j = 1,nrow,nrowm
    +
    44  jj = j+isign(1,nrowm-j)
    +
    45  DO 20 i = 1,ncol,ncolm
    +
    46  ii = i+isign(1,ncolm-i)
    +
    47  cwork(i,j+2) = cmplx(fin(i,jj)+fin(ii,j)-fin(ii,jj),0.)
    +
    48  20 CONTINUE
    +
    49 C
    +
    50 C SET SMOOTHING OPERATORS
    +
    51 C
    +
    52  30 gama = 0.50 * gammx * (1.0 - gammx)
    +
    53  gamb = 0.25 * gammx * gammx
    +
    54  gamc = 0.50 * gammx
    +
    55 C
    +
    56 C SMOOTH WORK ARRAY, PUTTING SMOOTHED POINTS DOWN TWO ROWS
    +
    57 C
    +
    58  cwork(1,1) = cwork(1,3)
    +
    59  cwork(ncol,1) = cwork(ncol,3)
    +
    60  DO 40 i = 2,ncolm
    +
    61  cwork(i,1) = cwork(i,3)+gamc*(cwork(i-1,3)-2.*cwork(i,3)+
    +
    62  & cwork(i+1,3))
    +
    63  40 CONTINUE
    +
    64  DO 60 j = 2,nrowm
    +
    65  DO 50 i = 1,ncol,ncolm
    +
    66  cwork(i,j) = cwork(i,j+2)+gamc*(cwork(i,j+1)-2.*cwork(i,j+2)+
    +
    67  & cwork(i,j+3))
    +
    68  50 CONTINUE
    +
    69  DO 60 i = 2,ncolm
    +
    70  cwork(i,j) = cwork(i,j+2)+gama*(cwork(i+1,j+2)+cwork(i-1,j+2)+
    +
    71  & cwork(i,j+1)+cwork(i,j+3)-4.*cwork(i,j+2))+gamb*(cwork(i-1,j+1)+
    +
    72  & cwork(i+1,j+1)+cwork(i-1,j+3)+cwork(i+1,j+3)-4.*cwork(i,j+2))
    +
    73  60 CONTINUE
    +
    74  cwork(1,nrow) = cwork(1,nrow+2)
    +
    75  cwork(ncol,nrow) = cwork(ncol,nrow+2)
    +
    76  DO 70 i = 2,ncolm
    +
    77  cwork(i,nrow) = cwork(i,nrow+2)+gamc*(cwork(i-1,nrow+2)-2.*
    +
    78  & cwork(i,nrow+2)+cwork(i+1,nrow+2))
    +
    79  70 CONTINUE
    +
    80 C
    +
    81 C IF IMAGINARY PART OF SMOOTHING PARAMETER IS NOT POSITIVE, DONE
    +
    82 C
    +
    83  IF (xswtch .LE. 0.) GO TO 90
    +
    84 C
    +
    85 C OTHERWISE MOVE WORK ARRAY BACK UP TWO ROWS
    +
    86 C
    +
    87  DO 80 jj=1,nrow
    +
    88  j = nrow+1-jj
    +
    89  DO 80 i=1,ncol
    +
    90  cwork(i,j+2) = cwork(i,j)
    +
    91  80 CONTINUE
    +
    92 C
    +
    93 C SET SMOOTHING PARAMETER FOR CONJUGATE PASS AND GO DO IT
    +
    94 C
    +
    95  gammx = conjg(gammx)
    +
    96  xswtch = aimag(gammx)
    +
    97  GO TO 30
    +
    98 C
    +
    99 C DONE. OUTPUT SMOOTH ARRAY
    +
    100 C
    +
    101  90 DO 100 j = 1,nrow
    +
    102  DO 100 i = 1,ncol
    +
    103  fout(i,j) = real(cwork(i,j))
    +
    104  100 CONTINUE
    +
    105  RETURN
    +
    106  END
    +
    +
    +
    w3fm07
    subroutine w3fm07(FIN, FOUT, CWORK, GAMMA, NCOL, NROW)
    Smooths data on a rectangular grid using a nine-point smoothing operator.
    Definition: w3fm07.f:24
    + + + + diff --git a/ver-2.10.0/w3fm08_8f.html b/ver-2.10.0/w3fm08_8f.html new file mode 100644 index 00000000..8e2d6ef9 --- /dev/null +++ b/ver-2.10.0/w3fm08_8f.html @@ -0,0 +1,187 @@ + + + + + + + +NCEPLIBS-w3emc: w3fm08.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fm08.f File Reference
    +
    +
    + +

    Nine point smoother/desmoother. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fm08 (A, Z, LI, LJ)
     Nine point smoother/desmoother. More...
     
    +

    Detailed Description

    +

    Nine point smoother/desmoother.

    +
    Author
    J. Howcroft
    +
    Date
    1971-02-01
    + +

    Definition in file w3fm08.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fm08()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fm08 (real, dimension(li,lj) A,
    real, dimension(li,lj) Z,
     LI,
     LJ 
    )
    +
    + +

    Nine point smoother/desmoother.

    +

    Smoother pass uses an equivalent linear smoother with stencil (.25 .5 .25) and the desmoother uses stencil (-.25 1.5 -.25). Two grid interval waves are annihilated, four grid interval waves have a .75 response.

    +

    Program history log:

      +
    • J. Howcroft 1971-02-01
      • +
    • Ralph Jones 1984-07-01 Change to ibm vs fortran.
      • +
    • Ralph Jones 1994-07-27 Change to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + +
    [in,out]A
      +
    • [in] Real size (li,lj) array to hold field to be smoothed.
      • +
    • [out] Array holding smoothed field.
      • +
    +
    [in]Z- Real size (li,lj) work area.
    [in]LI- Integer number of columns.
    [in]LJ- Integer number of rows.
    +
    +
    +
    Author
    J. Howcroft
    +
    Date
    1971-02-01
    + +

    Definition at line 24 of file w3fm08.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fm08_8f.js b/ver-2.10.0/w3fm08_8f.js new file mode 100644 index 00000000..dcc80fb5 --- /dev/null +++ b/ver-2.10.0/w3fm08_8f.js @@ -0,0 +1,4 @@ +var w3fm08_8f = +[ + [ "w3fm08", "w3fm08_8f.html#ad2e28d805a383d0025c930544cb36155", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fm08_8f_source.html b/ver-2.10.0/w3fm08_8f_source.html new file mode 100644 index 00000000..0ef0018c --- /dev/null +++ b/ver-2.10.0/w3fm08_8f_source.html @@ -0,0 +1,155 @@ + + + + + + + +NCEPLIBS-w3emc: w3fm08.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fm08.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Nine point smoother/desmoother.
    +
    3 C> @author J. Howcroft @date 1971-02-01
    +
    4 
    +
    5 C> Nine point smoother/desmoother. Smoother pass uses an
    +
    6 C> equivalent linear smoother with stencil (.25 .5 .25) and the
    +
    7 C> desmoother uses stencil (-.25 1.5 -.25). Two grid interval waves
    +
    8 C> are annihilated, four grid interval waves have a .75 response.
    +
    9 C>
    +
    10 C> Program history log:
    +
    11 C> - J. Howcroft 1971-02-01
    +
    12 C> - Ralph Jones 1984-07-01 Change to ibm vs fortran.
    +
    13 C> - Ralph Jones 1994-07-27 Change to cray cft77 fortran.
    +
    14 C>
    +
    15 C> @param[inout] A
    +
    16 C> - [in] Real size (li,lj) array to hold field to be smoothed.
    +
    17 C> - [out] Array holding smoothed field.
    +
    18 C> @param[in] Z - Real size (li,lj) work area.
    +
    19 C> @param[in] LI - Integer number of columns.
    +
    20 C> @param[in] LJ - Integer number of rows.
    +
    21 C>
    +
    22 C> @author J. Howcroft @date 1971-02-01
    +
    23  SUBROUTINE w3fm08 (A,Z,LI,LJ)
    +
    24 C
    +
    25  REAL A(LI,LJ)
    +
    26  REAL Z(LI,LJ)
    +
    27 C
    +
    28  SAVE
    +
    29 C
    +
    30  li1 = li - 1
    +
    31  lj1 = lj - 1
    +
    32  DO 1 j=2,lj1
    +
    33  DO 1 i=2,li1
    +
    34  crux = a(i-1,j-1) + a(i+1,j-1) + a(i+1,j+1) + a(i-1,j+1)
    +
    35  plus = a(i,j-1) + a(i,j+1) + a(i-1,j) + a(i+1,j)
    +
    36  z(i,j) = 0.25 * a(i,j) + .125 * plus + .0625 * crux
    +
    37  1 CONTINUE
    +
    38  DO 2 i=1,li
    +
    39  z(i,1) = a(i,1)
    +
    40  z(i,lj) = a(i,lj)
    +
    41  2 CONTINUE
    +
    42  DO 3 j=1,lj
    +
    43  z(1,j) = a(1,j)
    +
    44  z(li,j) = a(li,j)
    +
    45  3 CONTINUE
    +
    46  DO 4 j=2,lj1
    +
    47  DO 4 i=2,li1
    +
    48  crux = z(i-1,j-1) + z(i+1,j-1) + z(i+1,j+1) + z(i-1,j+1)
    +
    49  plus = z(i,j-1) + z(i,j+1) + z(i-1,j) + z(i+1,j)
    +
    50  a(i,j) = 2.25 * z(i,j) - .375 * plus + .0625 * crux
    +
    51  4 CONTINUE
    +
    52  RETURN
    +
    53  END
    +
    +
    +
    w3fm08
    subroutine w3fm08(A, Z, LI, LJ)
    Nine point smoother/desmoother.
    Definition: w3fm08.f:24
    + + + + diff --git a/ver-2.10.0/w3fp04_8f.html b/ver-2.10.0/w3fp04_8f.html new file mode 100644 index 00000000..39cefc32 --- /dev/null +++ b/ver-2.10.0/w3fp04_8f.html @@ -0,0 +1,258 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp04.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fp04.f File Reference
    +
    +
    + +

    Print array of data points at lat/lon points. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fp04 (IFLD, ALAT, ALON, TITLE, IDIM, CMIL, CMIR, CMJB, CMJT, INUM, XFAC, IERR)
     Given an array of meteorological data and corresponding latitude/longitude position for each data point, these data values are printed at their approximate latitude/longitude positions on a polar stereographic projection. More...
     
    +

    Detailed Description

    +

    Print array of data points at lat/lon points.

    +
    Author
    J. Horodeck
    +
    Date
    1980-01-15
    + +

    Definition in file w3fp04.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fp04()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fp04 (integer, dimension(idim) IFLD,
    real, dimension(idim) ALAT,
    real, dimension(idim) ALON,
    integer, dimension(10) TITLE,
     IDIM,
     CMIL,
     CMIR,
     CMJB,
     CMJT,
     INUM,
     XFAC,
     IERR 
    )
    +
    + +

    Given an array of meteorological data and corresponding latitude/longitude position for each data point, these data values are printed at their approximate latitude/longitude positions on a polar stereographic projection.

    +

    PROGRAM HISTORY LOG:

      +
    • J. Horodeck 1980-01-15
      • +
    • Ralph Jones 1985-07-31 Change to cdc fortran 200
      • +
    • Ralph Jones 1990-08-15 Change to cray cft77 fortran
      • +
    +
    Parameters
    + + + + + + + + + + + + + +
    [in]IFLDReal or integer fullword array of data points.
    [in]ALATReal array of latitude positions (>0 for nh, <0 for sh) for the data to be plotted.
    [in]ALONReal array of longitudes (west of greenwich)
    [in]TITLEInteger size 10 alphanumeric array of characters for title to be written on printout.
    [in]IDIMInteger number of data values to plot (size of arrays ifld, alat and alon).
    [in]CMILReal left side of grid - minimum coarse mesh i coordinate (minimum value of 1.0).
    [in]CMIRReal right side of grid - maximum coarse mesh i coordinate (maximum value of 65.0).
    [in]CMJBReal bottom of grid - minimum coarse mesh j coordinate (minimum value of 1.0).
    [in]CMJTReal top of grid - maximum coarse mesh j coordinate (maximum value of 65.0).
    [in]INUMInteger three digit number for the following:
      +
    • Hundreds digit = type of data
        +
      • 1 = Fixed point
        • +
      • 2 = Floating point
        • +
      • 3 = Alphanumeric
        • +
      +
      • +
    • Tens digit = hemispheric reference
        +
      • 0 = Northern hemisphere
        • +
      • 1 = Southern hemisphere
        • +
      +
      • +
    • Units digit = number of characters to plot
      • +
    • Minimum = 1 character
      • +
    • Maximum = 4 characters
      • +
    +
    [in]XFACReal map scale factor (desired map scale = xfac
      +
    • 1:30,000,000 (standard nmc 65x65 grid scale))
      • +
    +
    [out]IERRInteger return code.
    +
    +
    +
    Note
    Because this code could produce considerable output the subset of the nmc 65x65 grid which can be printed is a function of the map scale factor, e.g. for xfac=5 the maximum range of i and j is 27.0, for xfac=2 the range is 64.0.
    +
    Author
    J. Horodeck
    +
    Date
    1980-01-15
    + +

    Definition at line 54 of file w3fp04.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fp04_8f.js b/ver-2.10.0/w3fp04_8f.js new file mode 100644 index 00000000..d94a6119 --- /dev/null +++ b/ver-2.10.0/w3fp04_8f.js @@ -0,0 +1,4 @@ +var w3fp04_8f = +[ + [ "w3fp04", "w3fp04_8f.html#af033f564bf5f078cbfc4700e62291470", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fp04_8f_source.html b/ver-2.10.0/w3fp04_8f_source.html new file mode 100644 index 00000000..0fa43ebb --- /dev/null +++ b/ver-2.10.0/w3fp04_8f_source.html @@ -0,0 +1,559 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp04.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fp04.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Print array of data points at lat/lon points.
    +
    3 C> @author J. Horodeck @date 1980-01-15
    +
    4 
    +
    5 C> Given an array of meteorological data and corresponding
    +
    6 C> latitude/longitude position for each data point, these data
    +
    7 C> values are printed at their approximate latitude/longitude
    +
    8 C> positions on a polar stereographic projection.
    +
    9 C>
    +
    10 C> PROGRAM HISTORY LOG:
    +
    11 C> - J. Horodeck 1980-01-15
    +
    12 C> - Ralph Jones 1985-07-31 Change to cdc fortran 200
    +
    13 C> - Ralph Jones 1990-08-15 Change to cray cft77 fortran
    +
    14 C>
    +
    15 C> @param[in] IFLD Real or integer fullword array of data points.
    +
    16 C> @param[in] ALAT Real array of latitude positions (>0 for nh,
    +
    17 C> <0 for sh) for the data to be plotted.
    +
    18 C> @param[in] ALON Real array of longitudes (west of greenwich)
    +
    19 C> @param[in] TITLE Integer size 10 alphanumeric array of
    +
    20 C> characters for title to be written on printout.
    +
    21 C> @param[in] IDIM Integer number of data values to plot (size of
    +
    22 C> arrays ifld, alat and alon).
    +
    23 C> @param[in] CMIL Real left side of grid - minimum coarse mesh
    +
    24 C> i coordinate (minimum value of 1.0).
    +
    25 C> @param[in] CMIR Real right side of grid - maximum coarse mesh
    +
    26 C> i coordinate (maximum value of 65.0).
    +
    27 C> @param[in] CMJB Real bottom of grid - minimum coarse mesh
    +
    28 C> j coordinate (minimum value of 1.0).
    +
    29 C> @param[in] CMJT Real top of grid - maximum coarse mesh j
    +
    30 C> coordinate (maximum value of 65.0).
    +
    31 C> @param[in] INUM Integer three digit number for the following:
    +
    32 C> - Hundreds digit = type of data
    +
    33 C> - 1 = Fixed point
    +
    34 C> - 2 = Floating point
    +
    35 C> - 3 = Alphanumeric
    +
    36 C> - Tens digit = hemispheric reference
    +
    37 C> - 0 = Northern hemisphere
    +
    38 C> - 1 = Southern hemisphere
    +
    39 C> - Units digit = number of characters to plot
    +
    40 C> - Minimum = 1 character
    +
    41 C> - Maximum = 4 characters
    +
    42 C> @param[in] XFAC Real map scale factor (desired map scale = xfac
    +
    43 C> * 1:30,000,000 (standard nmc 65x65 grid scale))
    +
    44 C> @param[out] IERR Integer return code.
    +
    45 C>
    +
    46 C> @note Because this code could produce considerable output
    +
    47 C> the subset of the nmc 65x65 grid which can be printed is a
    +
    48 C> function of the map scale factor, e.g. for xfac=5 the maximum
    +
    49 C> range of i and j is 27.0, for xfac=2 the range is 64.0.
    +
    50 C>
    +
    51 C> @author J. Horodeck @date 1980-01-15
    +
    52  SUBROUTINE w3fp04(IFLD,ALAT,ALON,TITLE,IDIM,CMIL,CMIR,
    +
    53  & CMJB,CMJT,INUM,XFAC,IERR)
    +
    54 C
    +
    55  REAL ALAT(IDIM), ALON(IDIM)
    +
    56 C
    +
    57  INTEGER IFLD(IDIM), TITLE(10)
    +
    58  INTEGER LINE(24), IL(17), IR(17), IJU(20), IJL(20)
    +
    59 C
    +
    60  LOGICAL A
    +
    61 C
    +
    62 C
    +
    63  CHARACTER*1 KH(120,77), MEAN(4), KB, KM, KP, LC,
    +
    64  & kk(5,77,20), DATA(4), l1, l2, l3,
    +
    65  & ipole(4), kn, ks
    +
    66  CHARACTER*4 L24, L116
    +
    67  CHARACTER*8 IFMTT
    +
    68  CHARACTER*24 FMT1
    +
    69  CHARACTER*28 FMT2
    +
    70  CHARACTER*24 FMT4
    +
    71 C
    +
    72  equivalence(mean(1),imean), (DATA(1),lfld)
    +
    73  equivalence(rfield,ifield)
    +
    74  equivalence(ifmtt,ifmt)
    +
    75 C
    +
    76  DATA jjaa /116/
    +
    77  DATA jjbb / 77/
    +
    78  DATA fmt1 /"(6X, ('+',I , X),//) "/
    +
    79  DATA fmt2 /"(' +',I3,1X, A1,' +',I3) "/
    +
    80  DATA fmt4 /"(//, 6X, ('+',I , X))"/
    +
    81  DATA kb /' '/, km/'-'/, kp/'+'/, lc/'X'/
    +
    82  DATA l1/'1'/, l2/'2'/, l3/'3'/, l24/' 24'/, l116/' 116'/
    +
    83  DATA ipole/'P','O','L','E'/, kn/'N'/, ks/'S'/
    +
    84 C
    +
    85  1001 FORMAT('1',16x,'PANEL #',i2,' OF ',i2,4x,10a8,/,/)
    +
    86  1003 FORMAT(6x,116a1)
    +
    87  2001 FORMAT(///,20x,'UPPER LEFT CORNER--LAT =',f6.2,' LON =',f7.2,'W'
    +
    88  & , 3x,'UPPER RIGHT CORNER--LAT =',f6.2,' LON =',f7.2,'W')
    +
    89  2002 FORMAT(20x,'LOWER LEFT CORNER--LAT =',f6.2,' LON =',f7.2,'W'
    +
    90  & , 3x,'LOWER RIGHT CORNER--LAT =',f6.2,' LON =',f7.2,'W')
    +
    91  2003 FORMAT(/,/, 16x, 'PANEL #', i2, ' OF ', i2, 4x, 10a8)
    +
    92  9001 FORMAT(/,5x,'CMIL = ',f8.1,' CMIR = ',f8.1,' HIGH AND LOW'
    +
    93  & ,' VALUES REVERSED......RETURN......')
    +
    94  9002 FORMAT(/,5x,'CMJB = ',f8.1,' CMJT = ',f8.1,' HIGH AND LOW'
    +
    95  & ,' VALUES REVERSED......RETURN......')
    +
    96  9003 FORMAT(/,5x,f8.1,' IS ILLEGAL VALUE FOR LOW I. IT IS NOW 1.0')
    +
    97  9004 FORMAT(/,5x,f8.1,' IS ILLEGAL VALUE FOR HIGH I. IT IS NOW 65.0')
    +
    98  9005 FORMAT(/,5x,f8.1,' IS ILLEGAL VALUE FOR LOW J. IT IS NOW 1.0')
    +
    99  9006 FORMAT(/,5x,f8.1,' IS ILLEGAL VALUE FOR HIGH J. IT IS NOW 65.0')
    +
    100  9007 FORMAT(/,5x,'REQUESTED NUMBER OF CHARACTERS TO PLOT(',i2,' )IS'
    +
    101  & ,' NOT ALLOWED. FOUR(4) IS MAXIMUM. THATS ALL YOU GET')
    +
    102  9008 FORMAT(/,5x,'REQUESTED SUBSET OF 65X65 GRID CANNOT CURRENTLY '
    +
    103  & ,'BE PLOTTED WITH MAP SCALE FACTOR',f5.1,/5x,'IF PLOT '
    +
    104  & ,'IS NECESSARY, CONTACT JOHN M. HORODECK,ESQ. NMC/DD'
    +
    105  & ,'/SEB FOR ASSISTANCE')
    +
    106  9009 FORMAT(/,5x,i4,' IS INVALID HEMISPHERIC REFERENCE'
    +
    107  & , '......RETURN......')
    +
    108  9010 FORMAT(/,5x,'HUNDREDS DIGIT OF INUM(INUM =',i4,') IS'
    +
    109  & , ' INVALID......RETURN......')
    +
    110 C
    +
    111 C TEST I,J VALUES FOR RANGE AND ORDER
    +
    112 C
    +
    113  IF (cmir.GT.cmil) GO TO 1
    +
    114  ierr = 1
    +
    115  print 9001, cmil, cmir
    +
    116  RETURN
    +
    117  1 CONTINUE
    +
    118  IF (cmjt.GT.cmjb) GO TO 2
    +
    119  ierr = 1
    +
    120  print 9002, cmjb, cmjt
    +
    121  RETURN
    +
    122  2 CONTINUE
    +
    123  IF (cmil.GE.1.0) GO TO 3
    +
    124  print 9003, cmil
    +
    125  cmil = 1.0
    +
    126  3 CONTINUE
    +
    127  IF (cmir.LE.65.0) GO TO 4
    +
    128  print 9004, cmir
    +
    129  cmir = 65.0
    +
    130  4 CONTINUE
    +
    131  IF (cmjb.GE.1.0) GO TO 5
    +
    132  print 9005, cmjb
    +
    133  cmjb = 1.0
    +
    134  5 CONTINUE
    +
    135  IF (cmjt.LE.65.0) GO TO 6
    +
    136  print 9006, cmjt
    +
    137  cmjt = 65.0
    +
    138  6 CONTINUE
    +
    139 C
    +
    140 C CALCULATE VARIOUS LIMITS
    +
    141 C
    +
    142  lnum = mod(inum,10)
    +
    143  nref = (mod(inum,100))/10
    +
    144 C
    +
    145 C TEST FOR INCORRECT ARGUMENTS PASSED
    +
    146 C
    +
    147  IF (lnum.LE.4) GO TO 7
    +
    148  print 9007, lnum
    +
    149  lnum = 4
    +
    150  7 CONTINUE
    +
    151  IF (nref.LE.1) GO TO 8
    +
    152  ierr = 1
    +
    153  print 9009, nref
    +
    154  RETURN
    +
    155  8 CONTINUE
    +
    156  IF ((inum/100).LE.3) GO TO 81
    +
    157  ierr = 1
    +
    158  print 9010, inum
    +
    159  RETURN
    +
    160  81 CONTINUE
    +
    161 C
    +
    162  lnump1 = lnum + 1
    +
    163  i1 = (cmil-1.0)*xfac + 1.0
    +
    164  i2 = (cmir-1.0)*xfac + 1.0
    +
    165  j1 = (cmjb-1.0)*xfac + 1.0
    +
    166  j2 = (cmjt-1.0)*xfac + 1.0
    +
    167 C
    +
    168 C WILL THIS PLOT BE TOO LARGE?
    +
    169 C
    +
    170  IF (((i2-i1).LT.139).AND.((j2-j1).LT.139)) GO TO 9
    +
    171  ierr = 1
    +
    172  print 9008, xfac
    +
    173  RETURN
    +
    174  9 CONTINUE
    +
    175 C
    +
    176  offi = i1 - 1
    +
    177  offj = j1 - 1
    +
    178  jja = (i2-i1)*5 + 1
    +
    179  jjb = (j2-j1)*4 + 1
    +
    180  jjam1 = jja - 1
    +
    181  jjbbm1 = jjbb - 1
    +
    182  jjaam1 = jjaa - 1
    +
    183  jjaapn = jjaa + lnum
    +
    184  ibegin = lnump1 + 1
    +
    185  ipage = (jjam1/jjaa) + 1
    +
    186  jpage = (jjb/jjbb) + 1
    +
    187  xmesh = 381.0/xfac
    +
    188  xip = 32.0*xfac + 1.0
    +
    189  xjp = 32.0*xfac + 1.0
    +
    190  iixip = (xip-offi)*5 - 4
    +
    191  jjxjp = (xjp-offj)*4 - 3
    +
    192 C
    +
    193 C PLOT DATA ONE PANEL AT A TIME IN SECTIONS
    +
    194 C
    +
    195  DO 150 nx=1,ipage
    +
    196  a = .false.
    +
    197 C
    +
    198 C SET LIMITS OF I TO BE PRINTED
    +
    199 C
    +
    200  il(nx) = i1 + (23*(nx-1))
    +
    201  IF (nx.NE.ipage) ir(nx) = i1 + (23*nx)
    +
    202  IF (nx.EQ.ipage) ir(nx) = i2
    +
    203  imax = ir(nx) - offi
    +
    204  imin = il(nx) - offi
    +
    205  m = 0
    +
    206 C
    +
    207 C FILL ARRAY WITH VALUES OF I TO BE PRINTED AT TOP OF PAGE
    +
    208 C
    +
    209  DO 10 i = imin,imax
    +
    210  m = m + 1
    +
    211  line(m) = i
    +
    212  10 CONTINUE
    +
    213 C
    +
    214 C CALCULATE WIDTH OF PANEL IN INTEGERS AND
    +
    215 C CHARACTERS FROM WHICH DETERMINE FORMAT
    +
    216 C FIELD COUNT AND CONVERT BINARY TO ASCII
    +
    217 C
    +
    218 C PRINT TOP LINE OF I
    +
    219 C
    +
    220  la = (imax-imin) + 1
    +
    221  mmm = (la*5) - 4
    +
    222  IF (la.EQ.24) GO TO 13
    +
    223  CALL w3ai15(la,ifmt,1,4,kp)
    +
    224  fmt1(5:8) = ifmtt(1:4)
    +
    225  fmt4(9:12) = ifmtt(1:4)
    +
    226  CALL w3ai15(mmm,ifmt,1,4,kp)
    +
    227  fmt2(13:16) = ifmtt(1:4)
    +
    228  GO TO 16
    +
    229  13 CONTINUE
    +
    230  fmt1(5:8) = l24
    +
    231  fmt2(13:16) = l116
    +
    232  fmt4(9:12) = l24
    +
    233  16 CONTINUE
    +
    234  IF (la.LT.100) GO TO 19
    +
    235  fmt1(15:15) = l3
    +
    236  fmt1(17:17) = l1
    +
    237  fmt4(19:19) = l3
    +
    238  fmt4(21:21) = l1
    +
    239  GO TO 22
    +
    240  19 CONTINUE
    +
    241  fmt1(15:15) = l2
    +
    242  fmt1(17:17) = l2
    +
    243  fmt4(19:19) = l2
    +
    244  fmt4(21:21) = l2
    +
    245  22 CONTINUE
    +
    246  print 1001, nx, ipage, title
    +
    247  WRITE(6,fmt1) (line(n), n=1,la)
    +
    248 C
    +
    249 C PREPARE TO PRINT SECTIONS OF EACH PANEL
    +
    250 C
    +
    251  DO 140 jnx=1,jpage
    +
    252 C
    +
    253 C SET LIMITS OF J TO BE PRINTED
    +
    254 C
    +
    255  iju(jnx) = j2 - (19*(jnx-1))
    +
    256  IF (jnx.NE.jpage) ijl(jnx) = j2 - (19*jnx)
    +
    257  IF (jnx.EQ.jpage) ijl(jnx) = j1
    +
    258  jmax = iju(jnx) - offj
    +
    259  jmin = ijl(jnx) - offj
    +
    260  ju = jjb - (4*jmax-3)
    +
    261  jl = jjb - (4*jmin-3)
    +
    262  nnn = (jmax-jmin)*4 + 1
    +
    263 C
    +
    264 C FILL CHARACTER ARRAY WITH BLANKS AND PUT X MARKERS IN CORNERS
    +
    265 C IF FIRST PANEL BLANK ENTIRE AREA,
    +
    266 C OTHERWISE TRANSFER FIRST INUM I BYTES TO LARGE ARRAY
    +
    267 C AND BLANK REMAINING ARRAY
    +
    268 C
    +
    269  DO 37 j=1,jjbb
    +
    270  IF (nx.NE.1) GO TO 31
    +
    271  DO 28 i=1,jjaapn
    +
    272  kh(i,j) = kb
    +
    273  28 CONTINUE
    +
    274  GO TO 37
    +
    275  31 CONTINUE
    +
    276  DO 32 i=1,lnump1
    +
    277  kh(i,j) = kk(i,j,jnx)
    +
    278  32 CONTINUE
    +
    279  DO 34 i=ibegin,jjaapn
    +
    280  kh(i,j) = kb
    +
    281  34 CONTINUE
    +
    282  37 CONTINUE
    +
    283  IF (jnx.NE.1) GO TO 40
    +
    284  kh(1,jjbb) = lc
    +
    285  kh(mmm,jjbb) = lc
    +
    286  200 CONTINUE
    +
    287  40 CONTINUE
    +
    288  IF (jnx.NE.jpage) GO TO 50
    +
    289  kh(1,1) = lc
    +
    290  kh(mmm,1) = lc
    +
    291  50 CONTINUE
    +
    292 C
    +
    293 C LOOP TO PUT DATA IN CHARACTER ARRAY
    +
    294 C
    +
    295  DO 110 i=1,idim
    +
    296 C
    +
    297 C TEST FOR BAD GEOGRAPHY
    +
    298 C
    +
    299  IF ((abs(alat(i)).GT.90.).OR.(alon(i).LT.0.0).OR.(alon
    +
    300  a (i).GT.360.0)) GO TO 90
    +
    301 C
    +
    302 C CHANGE LAT,LON TO I,J
    +
    303 C
    +
    304  IF (nref.EQ.0) GO TO 51
    +
    305  CALL w3fb04(alat(i),alon(i),-xmesh,260.0,deli,delj)
    +
    306  GO TO 52
    +
    307  51 CONTINUE
    +
    308  CALL w3fb04(alat(i),alon(i),xmesh,80.0,deli,delj)
    +
    309  52 CONTINUE
    +
    310  xi = xip + deli
    +
    311  xj = xjp + delj
    +
    312 C
    +
    313 C POSITION I,J COORDINATES IN CHARACTER ARRAY AND TEST
    +
    314 C IF VALUES RETURNED ARE WITHIN LIMITS OF MAP AND WITHIN SECTIONS
    +
    315 C
    +
    316  ii = 1.0 + (xi-offi-0.9001)*5.0
    +
    317  jj = 1.0 + (xj-offj-0.8751)*4.0
    +
    318  iw = (jjaam1*(nx-1)) + 1
    +
    319  ix = (jjaam1*nx) + 1
    +
    320  iy = jjb - (jjbbm1*(jnx-1))
    +
    321  IF (jnx.NE.jpage) iz = jjb - (jjbbm1*jnx)
    +
    322  IF (jnx.EQ.jpage) iz = 1
    +
    323  IF ((ii.LT.1).OR.(ii.GT.jja)) GO TO 100
    +
    324  IF ((jj.LT.1).OR.(jj.GT.jjb)) GO TO 100
    +
    325  IF ((ii.LT.iw).OR.(ii.GT.ix)) GO TO 100
    +
    326  IF ((jj.GT.iy).OR.(jj.LT.iz)) GO TO 100
    +
    327 C
    +
    328 C WRITE N+POLE IF IN THIS SECTION
    +
    329 C
    +
    330  IF (.NOT.((iixip.GE.iw.AND.iixip.LE.ix).AND.
    +
    331  a (jjxjp.LE.iy.AND.jjxjp.GE.iz))) GO TO 56
    +
    332  iixxp = iixip - (jjaam1*(nx-1))
    +
    333  jjxxp = jjxjp - (iz-1)
    +
    334  IF (nref.EQ.0) kh(iixxp-1,jjxxp) = kn
    +
    335  IF (nref.EQ.1) kh(iixxp-1,jjxxp) = ks
    +
    336  kh(iixxp,jjxxp) = kp
    +
    337  DO 53 l=1,4
    +
    338  kh(iixxp+l,jjxxp) = ipole(l)
    +
    339  53 CONTINUE
    +
    340  56 CONTINUE
    +
    341 C
    +
    342 C CONVERT CHARACTER ARRAY COORDINATES FROM
    +
    343 C TOTAL MAP VALUES TO SECTION VALUES
    +
    344 C
    +
    345  ii = ii - (jjaam1*(nx-1))
    +
    346  IF (jnx.NE.jpage) jj = jj - (iz-1)
    +
    347 C
    +
    348 C IF SPACE IS OCCUPIED SKIP THIS STATION
    +
    349 C
    +
    350  jnum = lnum + 1
    +
    351  DO 70 ik=1,jnum
    +
    352  in = ik - 1
    +
    353  IF (kh(ii+in,jj).EQ.kb) GO TO 60
    +
    354  GO TO 110
    +
    355  60 CONTINUE
    +
    356  70 CONTINUE
    +
    357 C
    +
    358 C PLACE VALUE TO BE PLOTTED IN CHARACTER ARRAY
    +
    359 C
    +
    360  ifield = ifld(i)
    +
    361 C
    +
    362 C TEST FOR TYPE OF DATA
    +
    363 C
    +
    364  IF ((inum/100).EQ.3) GO TO 82
    +
    365  IF ((inum/100).EQ.1) GO TO 73
    +
    366  jfld = rfield
    +
    367  GO TO 76
    +
    368  73 CONTINUE
    +
    369  jfld = ifield
    +
    370  76 CONTINUE
    +
    371 C
    +
    372 C IF ORIGINALLY FIXED POINT OR HAS BEEN CONVERTED
    +
    373 C FROM FLOATING POINT TO FIXED POINT
    +
    374 C
    +
    375  IF ((jfld/10000).GE.1) jfld = mod(jfld,10000)
    +
    376  iiabs = iabs(jfld)
    +
    377  CALL w3ai15(iiabs,imean,1,lnum,kp)
    +
    378  IF (jfld.LT.0) kh(ii,jj) = km
    +
    379  IF (jfld.GE.0) kh(ii,jj) = kp
    +
    380  DO 79 ia=1,lnum
    +
    381  kh(ii+ia,jj) = mean(ia)
    +
    382  79 CONTINUE
    +
    383  GO TO 110
    +
    384  82 CONTINUE
    +
    385 C
    +
    386 C FOR ALPHANUMERIC DATA
    +
    387 C
    +
    388  lfld = ifld(i)
    +
    389  kh(ii,jj) = kp
    +
    390  DO 85 iq=1,lnum
    +
    391  kh(ii+iq,jj) = DATA(iq)
    +
    392  85 CONTINUE
    +
    393  90 CONTINUE
    +
    394  100 CONTINUE
    +
    395  110 CONTINUE
    +
    396  jjn = 0
    +
    397 C
    +
    398 C PRINT JTH ROW AND VALUES OF J
    +
    399 C
    +
    400  DO 130 j=ju,jl,4
    +
    401  jn = nnn - (4*jjn)
    +
    402  IF (a) GO TO 115
    +
    403  jx = (jjb-j)/4 + 1
    +
    404  WRITE(6,fmt2) jx, (kh(i,jn), i=1,mmm), jx
    +
    405  115 CONTINUE
    +
    406  jjn = jjn + 1
    +
    407  IF (jn.NE.1) GO TO 118
    +
    408 C
    +
    409 C SAVE LAST INUM BYTES OF I
    +
    410 C
    +
    411  DO 117 l=1,jjbb
    +
    412  DO 116 i=116,jjaapn
    +
    413  ia = i - 115
    +
    414  kk(ia,l,jnx) = kh(i,l)
    +
    415  116 CONTINUE
    +
    416  117 CONTINUE
    +
    417  a = .true.
    +
    418  GO TO 140
    +
    419  118 CONTINUE
    +
    420  DO 120 im=1,3
    +
    421  jn = jn - 1
    +
    422  print 1003, (kh(i,jn), i=1,mmm)
    +
    423  120 CONTINUE
    +
    424  a = .false.
    +
    425  130 CONTINUE
    +
    426  140 CONTINUE
    +
    427  WRITE(6,fmt4) (line(n), n=1,la)
    +
    428 C
    +
    429 C CALCULATE AND PRINT LAT/LON AT CORNERS
    +
    430 C
    +
    431  al = il(nx)
    +
    432  ar = ir(nx)
    +
    433  xi1 = ((al-1.0)/xfac + 1.0) - 33.0
    +
    434  xi2 = ((ar-1.0)/xfac + 1.0) - 33.0
    +
    435  xj1 = cmjb - 33.0
    +
    436  xj2 = cmjt - 33.0
    +
    437  IF (nref.EQ.0) GO TO 142
    +
    438  CALL w3fb05(xi1,xj1,-xmesh,260.0,alat1,alon1)
    +
    439  CALL w3fb05(xi1,xj2,-xmesh,260.0,alat2,alon2)
    +
    440  CALL w3fb05(xi2,xj2,-xmesh,260.0,alat3,alon3)
    +
    441  CALL w3fb05(xi2,xj1,-xmesh,260.0,alat4,alon4)
    +
    442  GO TO 144
    +
    443  142 CONTINUE
    +
    444  CALL w3fb05(xi1,xj1,xmesh,80.0,alat1,alon1)
    +
    445  CALL w3fb05(xi1,xj2,xmesh,80.0,alat2,alon2)
    +
    446  CALL w3fb05(xi2,xj2,xmesh,80.0,alat3,alon3)
    +
    447  CALL w3fb05(xi2,xj1,xmesh,80.0,alat4,alon4)
    +
    448  144 CONTINUE
    +
    449  print 2001, alat2, alon2, alat3, alon3
    +
    450  print 2002, alat1, alon1, alat4, alon4
    +
    451  print 2003, nx, ipage, title
    +
    452  150 CONTINUE
    +
    453  ierr = 0
    +
    454  RETURN
    +
    455  END
    +
    +
    +
    w3fp04
    subroutine w3fp04(IFLD, ALAT, ALON, TITLE, IDIM, CMIL, CMIR, CMJB, CMJT, INUM, XFAC, IERR)
    Given an array of meteorological data and corresponding latitude/longitude position for each data poi...
    Definition: w3fp04.f:54
    +
    w3ai15
    subroutine w3ai15(NBUFA, NBUFB, N1, N2, MINUS)
    Converts a set of binary numbers to an equivalent set of ascii number fields in core.
    Definition: w3ai15.f:48
    +
    w3fb04
    subroutine w3fb04(ALAT, ALONG, XMESHL, ORIENT, XI, XJ)
    Converts the coordinates of a location on earth from the natural coordinate system of latitude/longit...
    Definition: w3fb04.f:40
    + + + + diff --git a/ver-2.10.0/w3fp05_8f.html b/ver-2.10.0/w3fp05_8f.html new file mode 100644 index 00000000..510384cc --- /dev/null +++ b/ver-2.10.0/w3fp05_8f.html @@ -0,0 +1,211 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp05.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fp05.f File Reference
    +
    +
    + +

    Printer contour subroutine. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fp05 (RDATA, KTBL, CNST, TITLE, KRECT, KCONTR, LINEV, IWIDTH)
     Prints a two-dimensional grid of any shape, with contouring, if desired. More...
     
    +

    Detailed Description

    +

    Printer contour subroutine.

    +
    Author
    Ralph Jones
    +
    Date
    1989-10-13
    + +

    Definition in file w3fp05.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fp05()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fp05 (real, dimension(1) RDATA,
    integer, dimension(407) KTBL,
    real, dimension(4) CNST,
    character*1, dimension(*) TITLE,
     KRECT,
     KCONTR,
     LINEV,
     IWIDTH 
    )
    +
    + +

    Prints a two-dimensional grid of any shape, with contouring, if desired.

    +

    grid values are scaled according to to constants specified by the programer, rounded, and printed as 4,3, or 2 digit integers with sign, the sign marking the grid position of the printed number. if contouring is requested, bessel's interpolation formula is used to optain the contour lines. contours are indicated by alphabetic characters ranging from a to h or numeric characters from 0 to 9. contour origin and interval are specified by the programmer in terms of printed values.

    +

    Program history log:

      +
    • Ralph Jones 1989-10-13
      • +
    • Ralph Jones 1992-05-02 Add save
      • +
    +
    Parameters
    + + + + + + + + + +
    [in]RDATAReal array of grid data to be printed.
    [in]KTBLInteger array with shape of array.
    [in]CNSTReal array of four elements, used in scaling for printing and contouring.
    [in]TITLEIs a array of 132 characters or less of hollerith data, 1st char. must be blank. printed at bottom of the map.
    [in]KRECT1 if grid is rectangular, 0 otherwise.
    [in]KCONTR1 for contouring , 0 otherwise.
    [in]LINEV0 is for 6 lines per vertical inch, non-zero 8 lines per vertical inch.
    [in]IWIDTHNumber of characters in print line, 132 is standard printer.
    +
    +
    +
    Note
    Normal subroutine return, unless number of rows is greater than 200, prints error message and exits.
    +
    Author
    Ralph Jones
    +
    Date
    1989-10-13
    + +

    Definition at line 38 of file w3fp05.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fp05_8f.js b/ver-2.10.0/w3fp05_8f.js new file mode 100644 index 00000000..a7f61b31 --- /dev/null +++ b/ver-2.10.0/w3fp05_8f.js @@ -0,0 +1,4 @@ +var w3fp05_8f = +[ + [ "w3fp05", "w3fp05_8f.html#a5d4251a5f962d24d56f5ce0b3b4212b8", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fp05_8f_source.html b/ver-2.10.0/w3fp05_8f_source.html new file mode 100644 index 00000000..e1a87d86 --- /dev/null +++ b/ver-2.10.0/w3fp05_8f_source.html @@ -0,0 +1,695 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp05.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fp05.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Printer contour subroutine.
    +
    3 C> @author Ralph Jones @date 1989-10-13
    +
    4 
    +
    5 C> Prints a two-dimensional grid of any shape, with
    +
    6 C> contouring, if desired. grid values are scaled according to
    +
    7 C> to constants specified by the programer, rounded, and printed
    +
    8 C> as 4,3, or 2 digit integers with sign, the sign marking the
    +
    9 C> grid position of the printed number. if contouring is requested,
    +
    10 C> bessel's interpolation formula is used to optain the contour lines.
    +
    11 C> contours are indicated by alphabetic characters ranging from a to
    +
    12 C> h or numeric characters from 0 to 9. contour origin and interval
    +
    13 C> are specified by the programmer in terms of printed values.
    +
    14 C>
    +
    15 C> Program history log:
    +
    16 C> - Ralph Jones 1989-10-13
    +
    17 C> - Ralph Jones 1992-05-02 Add save
    +
    18 C>
    +
    19 C> @param[in] RDATA Real array of grid data to be printed.
    +
    20 C> @param[in] KTBL Integer array with shape of array.
    +
    21 C> @param[in] CNST Real array of four elements, used in
    +
    22 C> scaling for printing and contouring.
    +
    23 C> @param[in] TITLE Is a array of 132 characters or less of
    +
    24 C> hollerith data, 1st char. must be blank.
    +
    25 C> printed at bottom of the map.
    +
    26 C> @param[in] KRECT 1 if grid is rectangular, 0 otherwise.
    +
    27 C> @param[in] KCONTR 1 for contouring , 0 otherwise.
    +
    28 C> @param[in] LINEV 0 is for 6 lines per vertical inch,
    +
    29 C> non-zero 8 lines per vertical inch.
    +
    30 C> @param[in] IWIDTH Number of characters in print line,
    +
    31 C> 132 is standard printer.
    +
    32 C>
    +
    33 C> @note Normal subroutine return, unless number of rows is greater than 200,
    +
    34 C> prints error message and exits.
    +
    35 C>
    +
    36 C> @author Ralph Jones @date 1989-10-13
    +
    37  SUBROUTINE w3fp05(RDATA,KTBL,CNST,TITLE,KRECT,KCONTR,LINEV,IWIDTH)
    +
    38 C
    +
    39  REAL CNST(4)
    +
    40  REAL RDATA(1)
    +
    41  REAL RWA(28)
    +
    42  REAL RWB(28)
    +
    43  REAL RWC(28)
    +
    44  REAL RWD(28)
    +
    45  REAL VDJA(29)
    +
    46  REAL VDJB(28)
    +
    47  REAL VDJC(28)
    +
    48 C
    +
    49  INTEGER KALFA(16)
    +
    50  INTEGER KALPH(20)
    +
    51  INTEGER KHTBL(10)
    +
    52  INTEGER KLINE(126)
    +
    53  INTEGER KLINES(132)
    +
    54  INTEGER KNUMB(20)
    +
    55  INTEGER KRLOC(200)
    +
    56  INTEGER KTBL(407)
    +
    57  INTEGER OUTPUT
    +
    58  INTEGER PAGNL
    +
    59  INTEGER PAGNR
    +
    60  INTEGER PAGN3
    +
    61  INTEGER PCCNT
    +
    62  INTEGER PCFST
    +
    63  INTEGER PGCNT
    +
    64  INTEGER PGCNTA
    +
    65  INTEGER PGFST
    +
    66  INTEGER PGFSTA
    +
    67  INTEGER PGMAX
    +
    68 C
    +
    69  LOGICAL DONE
    +
    70  LOGICAL LCNTR
    +
    71  LOGICAL RECT
    +
    72 C
    +
    73  CHARACTER*1 TITLE(*)
    +
    74 C
    +
    75  equivalence(crmx,vdja(29))
    +
    76  equivalence(kline(1),klines(8))
    +
    77  equivalence(vdjc(1),rwa(1))
    +
    78 C
    +
    79 C ... THE VAULUE CRMX IS MACHINE DEPENDENT, IT SHOULD BE
    +
    80 C ... SET TO A VALUE A LITTLE LESS THAN THE LARGEST POSITIVE
    +
    81 C ... FLOATING POINT NUMBER FOR THE COMPUTER.
    +
    82 C
    +
    83  SAVE
    +
    84 C
    +
    85  DATA crmx /10.e70/
    +
    86  DATA kalfa/
    +
    87  a 1ha,1h ,1hb,1h ,1hc,1h ,1hd,1h ,1he,1h ,1hf,
    +
    88  b 1h ,1hg,1h ,1hh,1h /
    +
    89  DATA khastr/1h*/
    +
    90  DATA khblnk/1h /
    +
    91  DATA khdolr/1h$/
    +
    92  DATA khmns /1h-/
    +
    93  DATA khplus/1h+/
    +
    94  DATA khrstr/1h1/
    +
    95  DATA khtbl /1h0,1h1,1h2,1h3,1h4,1h5,1h6,1h7,1h8,1h9/
    +
    96 C
    +
    97 C ... LIMNRW IS LIMIT ON NUMBER OF ROWS ALLOWED
    +
    98 C ... AND IS DIMENSION OF KRLOC ...
    +
    99 C
    +
    100  DATA limnrw/200/
    +
    101  DATA knumb /1h0,1h ,1h1,1h ,1h2,1h ,1h3,1h ,1h4,1h ,
    +
    102  1 1h5,1h ,1h6,1h ,1h7,1h ,1h8,1h ,1h9,1h /
    +
    103  DATA output/6/
    +
    104  DATA r5 /.2/
    +
    105  DATA r50 /.02/
    +
    106 C
    +
    107  8000 FORMAT (1h0,10x,44herror from w3fp05 ... number of rows in your,
    +
    108  1 9h array = ,i4,24h which exceeds limit of ,i4)
    +
    109  8100 FORMAT (1ht)
    +
    110  8200 FORMAT (1hs)
    +
    111  8300 FORMAT (1h /1h /1h )
    +
    112  8400 FORMAT (1h /1h )
    +
    113  8500 FORMAT (132a1)
    +
    114  8600 FORMAT (132a1)
    +
    115 C
    +
    116 C COMPUTE VALUES FOR PRINTER WIDTH
    +
    117 C
    +
    118  IF (iwidth.GE.132.OR.iwidth.LE.0) pgmax = 25
    +
    119  IF (iwidth.GE.1.AND.iwidth.LE.22) pgmax = 3
    +
    120  IF (iwidth.GT.22.AND.iwidth.LT.132) pgmax = (iwidth-7)/5
    +
    121  pagn3 = pgmax + 3
    +
    122  lw = pgmax * 5 + 7
    +
    123  vdja(pagn3 + 1) = crmx
    +
    124  mxpg = pgmax * 5 + 7
    +
    125 C
    +
    126  IF (linev .EQ. 0) GO TO 100
    +
    127 C ...OTHERWISE LINEV IS NON-ZERO, SO 8 LINES/INCH IS DESIRED...
    +
    128  linate = 1
    +
    129  r4 = 0.250
    +
    130  r32 = 0.03125
    +
    131  con2 = 10.0
    +
    132  nbtwn = 3
    +
    133  GO TO 200
    +
    134 C
    +
    135  100 CONTINUE
    +
    136  linate = 2
    +
    137  r4 = 0.33333333
    +
    138  r32 = 1.0/18.0
    +
    139  con2 = 6.0
    +
    140  nbtwn = 2
    +
    141 C
    +
    142  200 CONTINUE
    +
    143  pgcnta = 0
    +
    144  pgfsta = 0
    +
    145  rect = .false.
    +
    146  done = .false.
    +
    147  kz = 0
    +
    148  kza = 1000
    +
    149  a = cnst(1)
    +
    150  kca = 2*(1-krect)
    +
    151 C TO SET NO. OF DIGITS TO BE PRINTED
    +
    152 C WHICH IS A FUNCTION OF THE TENS POSITION IN KCONTR
    +
    153  nodig = iabs(kcontr/10)
    +
    154  nodig = 3 - nodig
    +
    155 C WHERE C(NODIG) + 1 IS NO. OF DIGITS TO BE PRINTED
    +
    156  IF (nodig.LT.1 .OR. nodig.GT.3) nodig = 3
    +
    157 C ANY OUT-OF-RANGE WILL GET 4 DIGITS
    +
    158  lcntr = .false.
    +
    159  nconq = iabs(mod(kcontr,10))
    +
    160  IF (nconq .EQ. 0) GO TO 400
    +
    161  IF (nconq .LE. 2) GO TO 300
    +
    162 C OTHERWISE RESET NCONQ
    +
    163  nconq = 0
    +
    164  GO TO 400
    +
    165  300 CONTINUE
    +
    166  lcntr = .true.
    +
    167 C WITH NCONQ=1 FOR LETTERS,AND =2 FOR NUMBERS IN CONTOUR BANDS
    +
    168  400 CONTINUE
    +
    169  IF (nconq .EQ. 2) GO TO 600
    +
    170 C OTHERWISE SET AS LETTERS
    +
    171 C
    +
    172  kcow = 16
    +
    173  DO 500 j = 1,kcow
    +
    174  kalph(j) = kalfa(j)
    +
    175  500 CONTINUE
    +
    176  GO TO 800
    +
    177 C
    +
    178  600 CONTINUE
    +
    179  kcow = 20
    +
    180  DO 700 j = 1,kcow
    +
    181  kalph(j) = knumb(j)
    +
    182  700 CONTINUE
    +
    183 C
    +
    184 800 CONTINUE
    +
    185  radj = 4 * kcow
    +
    186  kd=1
    +
    187 C *** SET UP TABLE OF INDICES CORRESPONDING TO FIRST ITEM IN EACH ROW
    +
    188 C *** THIS IS KRLOC
    +
    189 C *** PICK OUT SIZE AND ROW NUMBER OF LARGEST ROW (KCMX AND KCLMX)
    +
    190 C *** KZA LEFT-JUSTIFIES MAP IF ALL ROWS HAVE COMMON MINIMAL OFFSET
    +
    191  IF (ktbl(1 ).EQ.(-1)) GO TO 1100
    +
    192 C *** ONE-DIMENSIONAL FORM
    +
    193  ktf=3
    +
    194  kza=0
    +
    195  imin = ktbl(2)
    +
    196  jmax = ktbl(3)+ktbl(1)-1
    +
    197  nrws = ktbl(1)
    +
    198  IF (nrws .GT. limnrw) GO TO 1200
    +
    199  kc = kca * (nrws-1) + 1
    +
    200 C
    +
    201  DO 1000 j = 1,nrws
    +
    202  k = nrws-j+1
    +
    203  krloc(k) = kd
    +
    204  IF (ktbl(kc+4)+ktbl(kc+3).LE.kz ) GO TO 900
    +
    205  kclmx = k
    +
    206  imax = ktbl(kc+4)+ktbl(kc+3)
    +
    207  kz = imax
    +
    208  kcmx = krloc(k)+ktbl(kc+4)
    +
    209  900 CONTINUE
    +
    210  kd = kd+ktbl(kc+4)
    +
    211  kc = kc-kca
    +
    212  1000 CONTINUE
    +
    213  GO TO 1600
    +
    214 C *** TWO-DIMENSIONAL FORM
    +
    215 C *** THE TWO-DIMENSIONAL FORM IS COMPILER-DEPENDENT
    +
    216 C *** IT DEPENDS ON THE TWO-DIMENSIONAL ARRAY BEING STORED COLUMN-WISE
    +
    217 C *** THAT IS, WITH THE FIRST INDEX VARYING THE FASTEST
    +
    218  1100 CONTINUE
    +
    219  imin = ktbl(6)
    +
    220  jmin = ktbl(7)
    +
    221  nrws = ktbl(5)
    +
    222  IF (nrws .LE. limnrw) GO TO 1300
    +
    223 C ... ELSE, NRWS EXCEEDS LIMIT ALLOWED ...
    +
    224  1200 CONTINUE
    +
    225  WRITE (output,8000) nrws,limnrw
    +
    226  GO TO 7400
    +
    227 C
    +
    228  1300 CONTINUE
    +
    229  jmax = ktbl(7) +ktbl(5)-1
    +
    230  kc = 1
    +
    231  DO 1500 j = 1,nrws
    +
    232  krloc(j) = ktbl(2)*(ktbl(4)-j)+ktbl(kc+7)+1
    +
    233  IF (ktbl(kc+7)+ktbl(kc+8).LE.kz) GO TO 1400
    +
    234  imax = ktbl(kc+7)+ktbl(kc+8)
    +
    235  kz = imax
    +
    236  kcmx = krloc(j)+ktbl(kc+8)
    +
    237  kclmx = j
    +
    238  1400 CONTINUE
    +
    239  IF (ktbl(kc+7).LT.kza) kza = ktbl(kc+7)
    +
    240  kc = kc + kca
    +
    241  1500 CONTINUE
    +
    242  imax = imax-kza
    +
    243  ktf = 7
    +
    244  1600 CONTINUE
    +
    245  pagnl = 0
    +
    246  pagnr = pgmax
    +
    247  IF (.NOT.lcntr) GO TO 1700
    +
    248  adc = (cnst(1)-cnst(4))/cnst(3)+radj
    +
    249  bc = cnst(2)/cnst(3)
    +
    250 C *** PRINT I-LABELS ACROSS TOP OF MAP
    +
    251  1700 CONTINUE
    +
    252 C *** WHICH PREPARES CDC512 PRINTER FOR 8 LINES PER INCH
    +
    253  IF (linate.EQ.1) WRITE (output,8100)
    +
    254 C ...WHICH PREPARES PRINTER FOR 6 LINES PER INCH
    +
    255  IF (linate.EQ.2) WRITE (output,8200)
    +
    256  klines(1) = khrstr
    +
    257  assign 1800 to kbr
    +
    258  GO TO 6900
    +
    259 C
    +
    260  1800 CONTINUE
    +
    261  IF (.NOT.lcntr) GO TO 2000
    +
    262 C *** INITIALIZE CONTOUR WORKING AREA
    +
    263  DO 1900 j=1,pagn3
    +
    264  rwc(j)=crmx
    +
    265  rwd(j)=crmx
    +
    266  1900 CONTINUE
    +
    267 C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR FIRST TWO ROWS
    +
    268 C
    +
    269  2000 CONTINUE
    +
    270  kra = 1
    +
    271  kc = ktf+1
    +
    272  assign 2100 to kbr
    +
    273  GO TO 5900
    +
    274 C
    +
    275  2100 CONTINUE
    +
    276  kra = 2
    +
    277  kc = kc+kca
    +
    278  assign 2200 to kbr
    +
    279  GO TO 5900
    +
    280 C
    +
    281  2200 CONTINUE
    +
    282  kr = 0
    +
    283 C *** TEST IF THIS IS LAST PAGE
    +
    284  IF (imax.GT.pgmax-1) GO TO 2300
    +
    285  lmr = imax*5 + 2
    +
    286  done = .true.
    +
    287 C *** DO LEFT J-LABELS
    +
    288  2300 CONTINUE
    +
    289  jcurr = jmax
    +
    290 C
    +
    291  2400 CONTINUE
    +
    292  kr = kr + 1
    +
    293  kra = kr+2
    +
    294  kc = kc+kca
    +
    295  kta = mod(jcurr,10)
    +
    296  ktb = mod(jcurr,100)/10
    +
    297  ktc = mod(jcurr,1000)/100
    +
    298  IF (kr .EQ. 1 .OR. (.NOT. lcntr)) GO TO 2500
    +
    299  GO TO 2600
    +
    300  2500 CONTINUE
    +
    301  IF (linate.EQ.1) WRITE (output,8300)
    +
    302  IF (linate.EQ.2) WRITE (output,8400)
    +
    303  2600 CONTINUE
    +
    304  klines(2) = khplus
    +
    305  klines(1) = khblnk
    +
    306  IF (jcurr.LT.0) klines(2)=khmns
    +
    307  kta=iabs(kta)
    +
    308  ktb=iabs(ktb)
    +
    309  ktc = iabs(ktc)
    +
    310  IF (ktc .EQ. 0) GO TO 2700
    +
    311  klines(3) = khtbl(ktc+1)
    +
    312  klines(4) = khtbl(ktb+1)
    +
    313  klines(5) = khtbl(kta+1)
    +
    314  GO TO 2800
    +
    315 C
    +
    316  2700 CONTINUE
    +
    317  klines(3) = khtbl(ktb+1)
    +
    318  klines(4) = khtbl(kta+1)
    +
    319  klines(5) = khblnk
    +
    320 C
    +
    321  2800 CONTINUE
    +
    322  DO 2900 j = 6,mxpg
    +
    323  klines(j) = khblnk
    +
    324  2900 CONTINUE
    +
    325  IF (.NOT.done) GO TO 3000
    +
    326 C *** DO RIGHT J-LABELS IF LAST PAGE OF MAP
    +
    327  kline(lmr) = klines(2)
    +
    328  kline(lmr+1) = klines(3)
    +
    329  kline(lmr+2) = klines(4)
    +
    330  kline(lmr+3) = klines(5)
    +
    331 C *** FETCH AND CONVERT GRID VALUES TO A1 FORMAT FOR WHOLE LINE
    +
    332  3000 CONTINUE
    +
    333  krx = krloc(kr)
    +
    334  klx = 5*pgfst+1
    +
    335  IF (pgcnt.EQ.0) GO TO 4000
    +
    336  DO 3800 kk = 1,pgcnt
    +
    337  temp = rdata(krx)*cnst(2)+a
    +
    338  ktemp = abs(temp)+.5
    +
    339  kline(klx) = khplus
    +
    340  IF (temp.LT.0.0) kline(klx) = khmns
    +
    341  GO TO (3300,3200,3100),nodig
    +
    342  3100 CONTINUE
    +
    343  kta = mod(ktemp,10000)/1000
    +
    344 C
    +
    345  3200 CONTINUE
    +
    346  ktb = mod(ktemp,1000)/100
    +
    347 C
    +
    348  3300 CONTINUE
    +
    349  ktc = mod(ktemp,100)/10
    +
    350  ktd = mod(ktemp,10)
    +
    351  GO TO (3400,3500,3600),nodig
    +
    352  3400 CONTINUE
    +
    353  kline(klx+1) = khtbl(ktc+1)
    +
    354  kline(klx+2) = khtbl(ktd+1)
    +
    355  GO TO 3700
    +
    356  3500 CONTINUE
    +
    357  kline(klx+1) = khtbl(ktb+1)
    +
    358  kline(klx+2) = khtbl(ktc+1)
    +
    359  kline(klx+3) = khtbl(ktd+1)
    +
    360  GO TO 3700
    +
    361  3600 CONTINUE
    +
    362  kline(klx+1) = khtbl(kta+1)
    +
    363  kline(klx+2) = khtbl(ktb+1)
    +
    364  kline(klx+3) = khtbl(ktc+1)
    +
    365  kline(klx+4) = khtbl(ktd+1)
    +
    366  3700 CONTINUE
    +
    367  klx = klx + 5
    +
    368  krx = krx+1
    +
    369  3800 CONTINUE
    +
    370 C *** FOLLOWING CHECKS FOR POLE POINT AND INSERTS PROPER CHARACTER.
    +
    371  IF (jcurr.NE.0) GO TO 4000
    +
    372  IF (imin.LT.(-25).OR.imin.GT.0) GO TO 4000
    +
    373  kx = -imin
    +
    374  IF (kx.LT.pgfst.AND.kx.GT.pgcnt+pgfst) GO TO 4000
    +
    375  kx = 5*kx
    +
    376  IF (kline(kx+1).EQ.khmns) GO TO 3900
    +
    377  kline(kx) = khdolr
    +
    378  GO TO 4000
    +
    379  3900 CONTINUE
    +
    380  kline(kx+1) = khastr
    +
    381 C *** PRINT LINE OF MAP DATA
    +
    382  4000 CONTINUE
    +
    383  WRITE (output,8500) (klines(ii),ii=1,mxpg)
    +
    384  krloc(kr) = krx
    +
    385  jcurr = jcurr - 1
    +
    386 C *** TEST BOTTOM OF MAP
    +
    387  IF (kr.EQ.nrws) GO TO 5700
    +
    388 C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR NEXT ROW
    +
    389  assign 4100 to kbr
    +
    390  GO TO 5900
    +
    391 C
    +
    392  4100 CONTINUE
    +
    393  IF (.NOT.lcntr) GO TO 2400
    +
    394 C *** DO CONTOURING
    +
    395  DO 4200 jj=1,mxpg
    +
    396  klines(jj)=khblnk
    +
    397  4200 CONTINUE
    +
    398 C *** VERTICAL INTERPOLATIONS
    +
    399  DO 4700 kk = 1,pagn3
    +
    400  IF (rwb(kk).LT.crmx.AND.rwc(kk).LT.crmx) GO TO 4300
    +
    401  vdjb(kk) = crmx
    +
    402  vdjc(kk) = crmx
    +
    403  GO TO 4600
    +
    404  4300 CONTINUE
    +
    405  IF (rwa(kk).LT.crmx.AND.rwd(kk).LT.crmx) GO TO 4400
    +
    406  vdjc(kk) = 0.
    +
    407  GO TO 4500
    +
    408  4400 CONTINUE
    +
    409  vdjc(kk) = r32*(rwa(kk)+rwd(kk)-rwb(kk)-rwc(kk))
    +
    410  4500 CONTINUE
    +
    411  vdjb(kk) = r4*(rwc(kk)-rwb(kk)-con2*vdjc(kk))
    +
    412  4600 CONTINUE
    +
    413  vdja(kk)=rwb(kk)
    +
    414  4700 CONTINUE
    +
    415 C ...DO 2 OR 3 ROWS OF CONTOURING BETWEEN GRID ROWS...
    +
    416  DO 5600 ll = 1,nbtwn
    +
    417  DO 4800 kk = 1,pagn3
    +
    418  vdjb(kk) = vdjc(kk) + vdjb(kk)
    +
    419  vdja(kk) = vdjb(kk) + vdja(kk)
    +
    420  4800 CONTINUE
    +
    421 C ...WHERE VDJA HAS THE INTERPOLATED VALUE FOR THIS INTER-ROW
    +
    422 C *** HORIZONTAL INTERPOLATIONS
    +
    423  hdc = 0.0
    +
    424  IF (vdja(1).GE.crmx) GO TO 4900
    +
    425  hdc = r50*(vdja(4)+vdja(1)-vdja(2)-vdja(3))
    +
    426  4900 CONTINUE
    +
    427  kxb = 0
    +
    428  DO 5200 kk = 1,pgmax
    +
    429  IF (vdja(kk+1).GE.crmx) GO TO 5100
    +
    430  hda = vdja(kk+1)
    +
    431  IF (vdja(kk+2).GE.crmx) GO TO 5500
    +
    432  IF (vdja(kk+3).GE.crmx) hdc = 0.
    +
    433  hdb = r5*(vdja(kk+2)-vdja(kk+1)-15.*hdc)
    +
    434 C *** COMPUTE AND STORE CONTOUR CHARACTERS, 5 PER POINT
    +
    435  khda=hda
    +
    436  kdb = iabs(mod(khda,kcow))
    +
    437  kline(kxb+1) = kalph(kdb+1)
    +
    438  DO 5000 jj=2,5
    +
    439  hdb = hdb+hdc
    +
    440  hda = hda+hdb
    +
    441  khda = hda
    +
    442  kdb = iabs(mod(khda,kcow))
    +
    443  kxa = kxb+jj
    +
    444  kline(kxa) = kalph(kdb+1)
    +
    445  5000 CONTINUE
    +
    446  hdc = r50*(vdja(kk+4)+vdja(kk+1)-vdja(kk+2)-vdja(kk+3))
    +
    447  IF (vdja(kk+4).GE.crmx) hdc = 0.
    +
    448  5100 CONTINUE
    +
    449  kxb = kxb+5
    +
    450  5200 CONTINUE
    +
    451  5300 CONTINUE
    +
    452  WRITE (output,8500) (klines(ii),ii=1,mxpg)
    +
    453  DO 5400 kk = 1,mxpg
    +
    454  klines(kk) = khblnk
    +
    455  5400 CONTINUE
    +
    456  GO TO 5600
    +
    457 C
    +
    458  5500 CONTINUE
    +
    459  khda = hda
    +
    460  kdb = iabs(mod(khda,kcow))
    +
    461  kline(kxb+1) = kalph(kdb+1)
    +
    462  GO TO 5300
    +
    463  5600 CONTINUE
    +
    464  GO TO 2400
    +
    465 C
    +
    466  5700 CONTINUE
    +
    467  IF (linate.EQ.1) WRITE (output,8300)
    +
    468  IF (linate.EQ.2) WRITE (output,8400)
    +
    469  klines(1) = khblnk
    +
    470 C *** PRINT I-LABELS ACROSS BOTTOM OF PAGE
    +
    471  assign 5800 to kbr
    +
    472  GO TO 6900
    +
    473 C
    +
    474  5800 CONTINUE
    +
    475  IF (linate.EQ.1) WRITE (output,8300)
    +
    476  IF (linate.EQ.2) WRITE (output,8400)
    +
    477 C *** PRINT TITLE
    +
    478  WRITE (output,8600) (title(ii),ii=1,lw)
    +
    479 C *** TEST END OF MAP
    +
    480  IF (krloc(kclmx).EQ.kcmx) RETURN
    +
    481 C *** ADJUST PAGE LINE BOUNDARIES
    +
    482 C
    +
    483  IF (imax.GT.pgmax)imax = imax-pgmax
    +
    484  imin = ka
    +
    485  pagnl = pagnl + pgmax
    +
    486  pagnr = pagnr + pgmax
    +
    487  GO TO 1700
    +
    488 C *** ROUTINE TO PRE-STORE ROWS FOR CONTOURING AND COMPUTE LINE LIMITERS
    +
    489 C
    +
    490  5900 CONTINUE
    +
    491  pgfst = pgfsta
    +
    492  pgcnt = pgcnta
    +
    493  IF (kra.GT.nrws) GO TO 6800
    +
    494  krfst = ktbl(kc)-kza
    +
    495  krcnt = ktbl(kc+1)
    +
    496  kfx = krloc(kra)
    +
    497  IF (rect) GO TO 6100
    +
    498  IF (krfst-pagnl.LE.(-1)) GO TO 6400
    +
    499  pcfst = krfst-pagnl+1
    +
    500  IF (pcfst.GE.pagn3) GO TO 6700
    +
    501  pgfsta = pcfst-1
    +
    502  pccnt = min(pagnr-krfst+2,krcnt)
    +
    503  IF (pgfsta.EQ.0) GO TO 6600
    +
    504  pgcnta = min(pagnr-krfst,krcnt)
    +
    505  IF (pgcnta.GT.0) GO TO 6000
    +
    506  pgcnta = 0
    +
    507  GO TO 6100
    +
    508  6000 CONTINUE
    +
    509  rect = krect.EQ.1.AND.pgcnta.LE.krcnt
    +
    510  6100 CONTINUE
    +
    511  IF (.NOT.lcntr) GO TO kbr,(1800,2100,2200,4100,5800)
    +
    512  DO 6200 kk = 1,pagn3
    +
    513  rwa(kk) = rwb(kk)
    +
    514  rwb(kk) = rwc(kk)
    +
    515  rwc(kk) = rwd(kk)
    +
    516  rwd(kk) = crmx
    +
    517  6200 CONTINUE
    +
    518 C
    +
    519  IF (pccnt.EQ.0) GO TO kbr,(1800,2100,2200,4100,5800)
    +
    520  kpc = pcfst+1
    +
    521  kpd = pccnt
    +
    522  DO 6300 kk = 1,pccnt
    +
    523  rwd(kpc) = rdata(kfx)*bc+adc
    +
    524  kfx = kfx+1
    +
    525  kpc = kpc + 1
    +
    526  6300 CONTINUE
    +
    527  GO TO kbr,(1800,2100,2200,4100,5800)
    +
    528 C
    +
    529  6400 CONTINUE
    +
    530  pcfst = 0
    +
    531  pgfsta = 0
    +
    532  kfx = kfx-1
    +
    533  pccnt = krfst+krcnt-pagnl+1
    +
    534  IF (pccnt.LT.pagn3) GO TO 6500
    +
    535  pccnt = pagn3
    +
    536  pgcnta = pgmax
    +
    537  GO TO 6100
    +
    538  6500 CONTINUE
    +
    539  IF (pccnt.GT.0) GO TO 6600
    +
    540  pgcnta = 0
    +
    541  pccnt = 0
    +
    542  GO TO 6100
    +
    543 C
    +
    544  6600 CONTINUE
    +
    545  pgcnta = min(pgmax,krcnt+krfst-pagnl)
    +
    546  GO TO 6100
    +
    547 C
    +
    548  6700 CONTINUE
    +
    549  pgcnta = 0
    +
    550  6800 CONTINUE
    +
    551  pccnt = 0
    +
    552  GO TO 6100
    +
    553 C
    +
    554 C *** ROUTINE TO PRINT I-LABELS
    +
    555 C
    +
    556  6900 CONTINUE
    +
    557  DO 7000 kk = 2,mxpg
    +
    558  klines(kk) = khblnk
    +
    559  7000 CONTINUE
    +
    560 C
    +
    561 C
    +
    562  kk = 1
    +
    563  ka = imin
    +
    564  lbl = min(imax,pgmax)
    +
    565 C
    +
    566  DO 7300 jj = 1,lbl
    +
    567  kline(kk) = khplus
    +
    568  IF (ka.LT.0) kline(kk) = khmns
    +
    569  kta = iabs(mod(ka,100))/10
    +
    570  ktb = iabs(mod(ka,10))
    +
    571  ktc = iabs(mod(ka,1000))/100
    +
    572  IF (ktc .EQ. 0) GO TO 7100
    +
    573  kline(kk+1) = khtbl(ktc+1)
    +
    574  kline(kk+2) = khtbl(kta+1)
    +
    575  kline(kk+3) = khtbl(ktb+1)
    +
    576  GO TO 7200
    +
    577 C
    +
    578  7100 CONTINUE
    +
    579  kline(kk+1) = khtbl(kta+1)
    +
    580  kline(kk+2) = khtbl(ktb+1)
    +
    581 C
    +
    582  7200 CONTINUE
    +
    583  kk = kk + 5
    +
    584  ka = ka+1
    +
    585  7300 CONTINUE
    +
    586 C
    +
    587  WRITE (output,8500) (klines(ii),ii=1,mxpg)
    +
    588 C
    +
    589  GO TO kbr,(1800,2100,2200,4100,5800)
    +
    590 C
    +
    591  7400 RETURN
    +
    592 C
    +
    593  END
    +
    +
    +
    w3fp05
    subroutine w3fp05(RDATA, KTBL, CNST, TITLE, KRECT, KCONTR, LINEV, IWIDTH)
    Prints a two-dimensional grid of any shape, with contouring, if desired.
    Definition: w3fp05.f:38
    + + + + diff --git a/ver-2.10.0/w3fp06_8f.html b/ver-2.10.0/w3fp06_8f.html new file mode 100644 index 00000000..9d42de67 --- /dev/null +++ b/ver-2.10.0/w3fp06_8f.html @@ -0,0 +1,556 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp06.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fp06.f File Reference
    +
    +
    + +

    NMC title subroutine. +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + + + + + + + + + + + + + + + +

    +Functions/Subroutines

    subroutine climo (CF1, CF2, UNIT, FOR, AFTBEF)
     Sets time-averaged titles. More...
     
    subroutine line01 (ID, MASK, KTITLE)
     Creates the first line of title. More...
     
    subroutine line02 (ID, MASK, KTITLE)
     Creates the second line of title. More...
     
    subroutine line03 (ID, KTITLE)
     Creates the third line of title. More...
     
    subroutine setcl (CF2, UNIT, KTITLE)
     Encodes time-averaged title. More...
     
    subroutine value1 (S, C, E, NUM)
     Creates value1 of surface from ids. More...
     
    subroutine w3fp06 (ID, KTITLE, N)
     Provides a title for data fields formulated according to nmc o.n. More...
     
    +

    Detailed Description

    +

    NMC title subroutine.

    +
    Author
    Ralph Jones
    +
    Date
    1988-11-28
    + +

    Definition in file w3fp06.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ climo()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine climo (real CF1,
    real CF2,
    character*4 UNIT,
    character*5 FOR,
    character*7 AFTBEF 
    )
    +
    + +

    Sets time-averaged titles.

    +
    Author
    Ralph Jones
    +
    Date
    1988-11-28 Fills in the first thirteen characters in the title to make the title a time-averaged title.
    +

    Program history log:

      +
    • Ralph Jones 1988-11-28
      • +
    • Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + + + +
    [in]CF1Forecast period length.
    [in]CF2Length of the average.
    [in,out]UNIT
      +
    • [in] Originally set to ' hrs'.
      • +
    • [out] Set to ' dys' if necessary.
      • +
    +
    [in,out]FOR
      +
    • [in] Originally set to ' for '.
      • +
    • [out] Set to ' ctr '.
      • +
    +
    [in,out]AFTBEF
      +
    • [in] Originally set to ' after '.
      • +
    • [out] Set to ' befor ' if necessary.
      • +
    +
    +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1988-11-28
    + +

    Definition at line 942 of file w3fp06.f.

    + +
    +
    + +

    ◆ line01()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine line01 (integer(8), dimension(6) ID,
    integer(4), dimension(8) MASK,
    character * 324 KTITLE 
    )
    +
    + +

    Creates the first line of title.

    +
    Author
    Ralph Jones
    +
    Date
    1988-09-02 Creates the fist line of the title from the id words. call by w3fp06() to make 1st line of title. Words 1 to 22.
    +

    Program history log:

      +
    • Ralph Jones 1988-09-02
      • +
    • Ralph Jones 1993-02-23 Add q type 157 & 158 (core & tke) to tables.
      • +
    +
    Parameters
    + + + + +
    [in]IDId words (6 integer words) office note 84.
    [in]MASKMask for unpacking id words (8 integer words).
    [out]KTITLECharacter *324 array
    +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1988-09-02
    + +

    Definition at line 70 of file w3fp06.f.

    + +
    +
    + +

    ◆ line02()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine line02 (integer(8), dimension(6) ID,
    integer(4), dimension(8) MASK,
    character * 324 KTITLE 
    )
    +
    + +

    Creates the second line of title.

    +
    Author
    Ralph Jones
    +
    Date
    1988-11-28 Creates the second line of the title from the id words. called by w3fp06. words 23 to 54.
    +

    Program history log:

      +
    • Ralph Jones 1988-11-28
      • +
    • Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
      • +
    • Ralph Jones 1991-03-01 Changes for big records.
      • +
    +
    Parameters
    + + + + +
    [in]IDId words (6 integer words) office note 84
    [in]MASKMask for unpacking id words (8 words)
    [out]KTITLETitle character*324
    +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1988-11-28
    + +

    Definition at line 808 of file w3fp06.f.

    + +
    +
    + +

    ◆ line03()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine line03 (integer(8), dimension(6) ID,
    character * 324 KTITLE 
    )
    +
    + +

    Creates the third line of title.

    +
    Author
    Ralph Jones
    +
    Date
    1988-11-28 Creates the third line of the title from the id words. called by w3fp06 to create words 55 to 81 of the title.
    +

    Program history log:

      +
    • Ralph Jones 1988-11-28
      • +
    • Ralph Jones 1990-02-03 Convert to cray cft77 fortran.
      • +
    +
    Parameters
    + + + +
    [in]IDID words (6 integer) office note 84.
    [out]KTITLECharacter*324 array.
    +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1988-11-28
    + +

    Definition at line 896 of file w3fp06.f.

    + +
    +
    + +

    ◆ setcl()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine setcl ( CF2,
    character*4 UNIT,
    character*324 KTITLE 
    )
    +
    + +

    Encodes time-averaged title.

    +
    Author
    Ralph Jones
    +
    Date
    1988-11-28 Encodes the first thirteen characters in the title to make the title a time-averaged title.
    +

    Program history log:

      +
    • Ralph Jones 1988-11-28
      • +
    • Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + +
    [in]CF2Length of the forecast period
    [in]UNITUnits for cf2
    [in,out]KTITLE
      +
    • [in] Title to be modified
      • +
    • [out] Title with the time-averaged included
      • +
    +
    +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1988-11-28
    + +

    Definition at line 1013 of file w3fp06.f.

    + +
    +
    + +

    ◆ value1()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine value1 (integer S,
    integer C,
    integer E,
    character*8 NUM 
    )
    +
    + +

    Creates value1 of surface from ids.

    +
    Author
    Ralph Jones
    +
    Date
    1988-11-28 Creates the numerical value for the surface to be built into the first line of the title.
    +

    Program history log:

      +
    • Ralph Jones 1988-11-28
      • +
    • Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
      • +
    +
    Parameters
    + + + + +
    [in]SInteger number of surface.
    [in]C,ENumerical value of the surface (SURFACE = S * 10 ** E).
    [out]NUM7 character value of the surface for the title.
    +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1988-11-28
    + +

    Definition at line 746 of file w3fp06.f.

    + +
    +
    + +

    ◆ w3fp06()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fp06 (integer(8), dimension(6) ID,
    character * 324 KTITLE,
     N 
    )
    +
    + +

    Provides a title for data fields formulated according to nmc o.n.

    +
      +
    1. the extracted information is converted into up to 81 words and stored at a user provided location.
      2. +
    +

    Program history log:

      +
    • Ralph Jones 1988-11-28
      • +
    • Ralph Jones 1990-02-12 Convert to cray cft77 fortran
      • +
    • Ralph Jones 1991-04-26 Add q type 23, 136, 137, 71, 159, 75, 118, 119, 24 to tables, changes for big records.
      • +
    • Ralph Jones 1993-02-23 Add q type 157 & 158 (core & tke) to tables
      • +
    +
    Parameters
    + + + +
    [in]NInteger number of lines of output desired
      +
    • = 1 First 88 char. the abbreviated title (line 1 starts at arg2(1))
      • +
    • = 2 First 216 char. decimal values of the parameters
      • +
    • = 3 All 324 char., hexidecimal dump of the 12 word field label (line 3 char. 221)
      • +
    +
    ID,KTITLE
    +
    +
    +
    Note
    See NMC O.N. 84 for data field abbreviations.
    +
    Author
    Ralph Jones
    +
    Date
    1988-11-28
    + +

    Definition at line 26 of file w3fp06.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fp06_8f.js b/ver-2.10.0/w3fp06_8f.js new file mode 100644 index 00000000..37049d16 --- /dev/null +++ b/ver-2.10.0/w3fp06_8f.js @@ -0,0 +1,10 @@ +var w3fp06_8f = +[ + [ "climo", "w3fp06_8f.html#aaf8401635d84331960b1c2985cd74a51", null ], + [ "line01", "w3fp06_8f.html#a771b5aa20028a43dd4e5fed735c85797", null ], + [ "line02", "w3fp06_8f.html#a69e9f6991efd633d1734e87d0c0cf6f1", null ], + [ "line03", "w3fp06_8f.html#a07285bde2b2eda3dea091bbb82ab27ee", null ], + [ "setcl", "w3fp06_8f.html#a67cf94ad0864f312b980ca2315e729e2", null ], + [ "value1", "w3fp06_8f.html#a857d20cd6a97ba1e266d803b2092670c", null ], + [ "w3fp06", "w3fp06_8f.html#afb6a19727a1186c10ede9bba2d3315c0", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fp06_8f_source.html b/ver-2.10.0/w3fp06_8f_source.html new file mode 100644 index 00000000..f91d3255 --- /dev/null +++ b/ver-2.10.0/w3fp06_8f_source.html @@ -0,0 +1,1141 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp06.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fp06.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief NMC title subroutine.
    +
    3 C> @author Ralph Jones @date 1988-11-28
    +
    4 
    +
    5 C> Provides a title for data fields formulated according to
    +
    6 C> nmc o.n. 84. the extracted information is converted into up to
    +
    7 C> 81 words and stored at a user provided location.
    +
    8 C>
    +
    9 C> Program history log:
    +
    10 C> - Ralph Jones 1988-11-28
    +
    11 C> - Ralph Jones 1990-02-12 Convert to cray cft77 fortran
    +
    12 C> - Ralph Jones 1991-04-26 Add q type 23, 136, 137, 71, 159, 75, 118,
    +
    13 C> 119, 24 to tables, changes for big records.
    +
    14 C> - Ralph Jones 1993-02-23 Add q type 157 & 158 (core & tke) to tables
    +
    15 C>
    +
    16 C> @param[in] N Integer number of lines of output desired
    +
    17 C> - = 1 First 88 char. the abbreviated title (line 1 starts at arg2(1))
    +
    18 C> - = 2 First 216 char. decimal values of the parameters
    +
    19 C> - = 3 All 324 char., hexidecimal dump of the 12 word field label (line 3 char. 221)
    +
    20 C> @param ID, KTITLE
    +
    21 C>
    +
    22 C> @note See NMC O.N. 84 for data field abbreviations.
    +
    23 C>
    +
    24 C> @author Ralph Jones @date 1988-11-28
    +
    25  SUBROUTINE w3fp06(ID,KTITLE,N)
    +
    26 C
    +
    27  INTEGER(8) ID(6)
    +
    28  INTEGER(4) MASK(8)
    +
    29 C
    +
    30  CHARACTER * 324 KTITLE
    +
    31 C
    +
    32  DATA mask(1)/z'0000000F'/
    +
    33  DATA mask(2)/z'000000FF'/
    +
    34  DATA mask(3)/z'00000FFF'/
    +
    35  DATA mask(4)/z'0000FFFF'/
    +
    36  DATA mask(5)/z'000FFFFF'/
    +
    37  DATA mask(6)/z'00FFFFFF'/
    +
    38  DATA mask(7)/z'0FFFFFFF'/
    +
    39  DATA mask(8)/z'FFFFFFFF'/
    +
    40 C
    +
    41  CALL line01(id,mask,ktitle)
    +
    42  IF (n.GT.1) GO TO 10
    +
    43  RETURN
    +
    44 C
    +
    45  10 CONTINUE
    +
    46  CALL line02(id,mask,ktitle)
    +
    47  IF (n.GT.2) GO TO 20
    +
    48  RETURN
    +
    49 C
    +
    50  20 CONTINUE
    +
    51  CALL line03(id,ktitle)
    +
    52  RETURN
    +
    53  END
    +
    54 C> @brief Creates the first line of title.
    +
    55 C> @author Ralph Jones @date 1988-09-02
    +
    56 
    +
    57 C> Creates the fist line of the title from the id words.
    +
    58 C> call by w3fp06() to make 1st line of title. Words 1 to 22.
    +
    59 C>
    +
    60 C> Program history log:
    +
    61 C> - Ralph Jones 1988-09-02
    +
    62 C> - Ralph Jones 1993-02-23 Add q type 157 & 158 (core & tke) to tables.
    +
    63 C>
    +
    64 C> @param[in] ID Id words (6 integer words) office note 84.
    +
    65 C> @param[in] MASK Mask for unpacking id words (8 integer words).
    +
    66 C> @param[out] KTITLE Character *324 array
    +
    67 C>
    +
    68 C> @author Ralph Jones @date 1988-09-02
    +
    69  SUBROUTINE line01(ID,MASK,KTITLE)
    +
    70 
    +
    71 C
    +
    72 C CREATES THE FIRST 22 WORDS OF TITLER
    +
    73 C
    +
    74  INTEGER(8) ID(6)
    +
    75  INTEGER(4) MASK(8)
    +
    76  INTEGER(4) SHFMSK(17)
    +
    77 C
    +
    78  CHARACTER * 4 UNIT
    +
    79  CHARACTER * 4 UNIT1
    +
    80  CHARACTER * 4 DAYS
    +
    81  CHARACTER * 5 FOR
    +
    82  CHARACTER * 5 FOR1
    +
    83  CHARACTER * 1 DASH
    +
    84  CHARACTER * 8 KNAME(9)
    +
    85  CHARACTER * 8 KNAME1(3)
    +
    86  CHARACTER * 324 KTITLE
    +
    87  CHARACTER * 8 KWRITE(3)
    +
    88  CHARACTER * 8 INUM1
    +
    89  CHARACTER * 8 INUM2
    +
    90  CHARACTER * 6 QNAME1
    +
    91  CHARACTER * 6 QNAME2
    +
    92  CHARACTER * 6 QNAME3
    +
    93  CHARACTER * 2 DN
    +
    94  CHARACTER * 6 QNAME(166)
    +
    95  CHARACTER * 6 QWRITE
    +
    96  CHARACTER * 4 SNAME(18)
    +
    97  CHARACTER * 20 VUNIT(2)
    +
    98  CHARACTER * 7 AFTER
    +
    99  CHARACTER * 7 AFTBEF
    +
    100 C
    +
    101  INTEGER KK(3)
    +
    102  INTEGER LL(166)
    +
    103  INTEGER JKEEP(17)
    +
    104  INTEGER JLIST(17)
    +
    105  INTEGER C1,C2,E1,E2,S1,S2,Q,M,G
    +
    106  INTEGER YY,MM,DD,HH,F1,F2,JT,JN
    +
    107 C
    +
    108 C IDWORDS: MASK CONTROL (INTEGER)
    +
    109 C
    +
    110  DATA shfmsk( 1)/z'20020100'/
    +
    111  DATA shfmsk( 2)/z'28020400'/
    +
    112  DATA shfmsk( 3)/z'30020400'/
    +
    113  DATA shfmsk( 4)/z'38020400'/
    +
    114  DATA shfmsk( 5)/z'08050100'/
    +
    115  DATA shfmsk( 6)/z'00020100'/
    +
    116  DATA shfmsk( 7)/z'08050200'/
    +
    117  DATA shfmsk( 8)/z'00020200'/
    +
    118  DATA shfmsk( 9)/z'3C010200'/
    +
    119  DATA shfmsk(10)/z'28030100'/
    +
    120  DATA shfmsk(11)/z'28030200'/
    +
    121  DATA shfmsk(12)/z'34030100'/
    +
    122  DATA shfmsk(13)/z'20020400'/
    +
    123  DATA shfmsk(14)/z'30020400'/
    +
    124  DATA shfmsk(15)/z'1C010100'/
    +
    125  DATA shfmsk(16)/z'1C010200'/
    +
    126  DATA shfmsk(17)/z'20020200'/
    +
    127 C
    +
    128 C REFERENCE TABLE FOR SNAME.
    +
    129 C
    +
    130  DATA jlist(1)/1/
    +
    131  DATA jlist(2)/2/
    +
    132  DATA jlist(3)/6/
    +
    133  DATA jlist(4)/7/
    +
    134  DATA jlist(5)/8/
    +
    135  DATA jlist(6)/16/
    +
    136  DATA jlist(7)/19/
    +
    137  DATA jlist(8)/128/
    +
    138  DATA jlist(9)/129/
    +
    139  DATA jlist(10)/130/
    +
    140  DATA jlist(11)/144/
    +
    141  DATA jlist(12)/145/
    +
    142  DATA jlist(13)/146/
    +
    143  DATA jlist(14)/147/
    +
    144  DATA jlist(15)/148/
    +
    145  DATA jlist(16)/131/
    +
    146  DATA jlist(17)/132/
    +
    147 C
    +
    148 C SNAME TABLE.
    +
    149 C
    +
    150  DATA sname( 1)/' GPM'/
    +
    151  DATA sname( 2)/' PA '/
    +
    152  DATA sname( 3)/' M '/
    +
    153  DATA sname( 4)/' M '/
    +
    154  DATA sname( 5)/' MB '/
    +
    155  DATA sname( 6)/' DEG'/
    +
    156  DATA sname( 7)/' POT'/
    +
    157  DATA sname( 8)/' MSL'/
    +
    158  DATA sname( 9)/' SFC'/
    +
    159  DATA sname(10)/' TRO'/
    +
    160  DATA sname(11)/' BDY'/
    +
    161  DATA sname(12)/' TRS'/
    +
    162  DATA sname(13)/' STS'/
    +
    163  DATA sname(14)/' QCP'/
    +
    164  DATA sname(15)/' SIG'/
    +
    165  DATA sname(16)/'MWSL'/
    +
    166  DATA sname(17)/'PLYR'/
    +
    167  DATA sname(18)/' '/
    +
    168 C
    +
    169 C REFERENCE TABLE FOR QNAME.
    +
    170 C
    +
    171  DATA ll( 1)/ 1/
    +
    172  DATA ll( 2)/ 2/
    +
    173  DATA ll( 3)/ 6/
    +
    174  DATA ll( 4)/ 8/
    +
    175  DATA ll( 5)/ 16/
    +
    176  DATA ll( 6)/ 17/
    +
    177  DATA ll( 7)/ 18/
    +
    178  DATA ll( 8)/ 19/
    +
    179  DATA ll( 9)/ 20/
    +
    180  DATA ll(10)/ 21/
    +
    181  DATA ll(11)/ 40/
    +
    182  DATA ll(12)/ 41/
    +
    183  DATA ll(13)/ 42/
    +
    184  DATA ll(14)/ 43/
    +
    185  DATA ll(15)/ 44/
    +
    186  DATA ll(16)/ 48/
    +
    187  DATA ll(17)/ 49/
    +
    188  DATA ll(18)/ 50/
    +
    189  DATA ll(19)/ 51/
    +
    190  DATA ll(20)/ 52/
    +
    191  DATA ll(21)/ 53/
    +
    192  DATA ll(22)/ 54/
    +
    193  DATA ll(23)/ 55/
    +
    194  DATA ll(24)/ 56/
    +
    195  DATA ll(25)/ 57/
    +
    196  DATA ll(26)/ 58/
    +
    197  DATA ll(27)/ 59/
    +
    198  DATA ll(28)/ 60/
    +
    199  DATA ll(29)/ 72/
    +
    200  DATA ll(30)/ 73/
    +
    201  DATA ll(31)/ 74/
    +
    202  DATA ll(32)/ 80/
    +
    203  DATA ll(33)/ 81/
    +
    204  DATA ll(34)/ 88/
    +
    205  DATA ll(35)/ 89/
    +
    206  DATA ll(36)/ 90/
    +
    207  DATA ll(37)/ 91/
    +
    208  DATA ll(38)/ 92/
    +
    209  DATA ll(39)/ 93/
    +
    210  DATA ll(40)/ 94/
    +
    211  DATA ll(41)/ 95/
    +
    212  DATA ll(42)/ 96/
    +
    213  DATA ll(43)/112/
    +
    214  DATA ll(44)/113/
    +
    215  DATA ll(45)/114/
    +
    216  DATA ll(46)/115/
    +
    217  DATA ll(47)/120/
    +
    218  DATA ll(48)/121/
    +
    219  DATA ll(49)/160/
    +
    220  DATA ll(50)/161/
    +
    221  DATA ll(51)/162/
    +
    222  DATA ll(52)/163/
    +
    223  DATA ll(53)/164/
    +
    224  DATA ll(54)/165/
    +
    225  DATA ll(55)/166/
    +
    226  DATA ll(56)/167/
    +
    227  DATA ll(57)/168/
    +
    228  DATA ll(58)/169/
    +
    229  DATA ll(59)/170/
    +
    230  DATA ll(60)/171/
    +
    231  DATA ll(61)/176/
    +
    232  DATA ll(62)/177/
    +
    233  DATA ll(63)/178/
    +
    234  DATA ll(64)/184/
    +
    235  DATA ll(65)/185/
    +
    236  DATA ll(66)/186/
    +
    237  DATA ll(67)/187/
    +
    238  DATA ll(68)/188/
    +
    239  DATA ll(69)/384/
    +
    240  DATA ll(70)/385/
    +
    241  DATA ll(71)/386/
    +
    242  DATA ll(72)/387/
    +
    243  DATA ll(73)/388/
    +
    244  DATA ll(74)/389/
    +
    245  DATA ll(75)/390/
    +
    246  DATA ll(76)/391/
    +
    247  DATA ll(77)/ 97/
    +
    248  DATA ll(78)/ 98/
    +
    249  DATA ll(79)/ 99/
    +
    250  DATA ll(80)/100/
    +
    251  DATA ll(81)/101/
    +
    252  DATA ll(82)/102/
    +
    253  DATA ll(83)/103/
    +
    254  DATA ll(84)/172/
    +
    255  DATA ll(85)/200/
    +
    256  DATA ll(86)/201/
    +
    257  DATA ll(87)/202/
    +
    258  DATA ll(88)/203/
    +
    259  DATA ll(89)/392/
    +
    260  DATA ll(90)/ 7/
    +
    261  DATA ll(91)/ 61/
    +
    262  DATA ll(92)/104/
    +
    263  DATA ll(93)/173/
    +
    264  DATA ll(94)/174/
    +
    265  DATA ll(95)/175/
    +
    266  DATA ll(96)/304/
    +
    267  DATA ll(97)/305/
    +
    268  DATA ll(98)/400/
    +
    269  DATA ll(99)/401/
    +
    270  DATA ll(100)/402/
    +
    271  DATA ll(101)/403/
    +
    272  DATA ll(102)/404/
    +
    273  DATA ll(103)/405/
    +
    274  DATA ll(104)/ 9/
    +
    275  DATA ll(105)/105/
    +
    276  DATA ll(106)/116/
    +
    277  DATA ll(107)/106/
    +
    278  DATA ll(108)/107/
    +
    279  DATA ll(109)/108/
    +
    280  DATA ll(110)/179/
    +
    281  DATA ll(111)/180/
    +
    282  DATA ll(112)/181/
    +
    283  DATA ll(113)/182/
    +
    284  DATA ll(114)/183/
    +
    285  DATA ll(115)/189/
    +
    286  DATA ll(116)/190/
    +
    287  DATA ll(117)/191/
    +
    288  DATA ll(118)/192/
    +
    289  DATA ll(119)/193/
    +
    290  DATA ll(120)/194/
    +
    291  DATA ll(121)/195/
    +
    292  DATA ll(122)/196/
    +
    293  DATA ll(123)/197/
    +
    294  DATA ll(124)/198/
    +
    295  DATA ll(125)/199/
    +
    296  DATA ll(126)/204/
    +
    297  DATA ll(127)/210/
    +
    298  DATA ll(128)/211/
    +
    299  DATA ll(129)/212/
    +
    300  DATA ll(130)/213/
    +
    301  DATA ll(131)/214/
    +
    302  DATA ll(132)/215/
    +
    303  DATA ll(133)/216/
    +
    304  DATA ll(134)/117/
    +
    305  DATA ll(135)/209/
    +
    306  DATA ll(136)/ 22/
    +
    307  DATA ll(137)/ 62/
    +
    308  DATA ll(138)/ 63/
    +
    309  DATA ll(139)/ 82/
    +
    310  DATA ll(140)/ 83/
    +
    311  DATA ll(141)/ 84/
    +
    312  DATA ll(142)/ 85/
    +
    313  DATA ll(143)/205/
    +
    314  DATA ll(144)/206/
    +
    315  DATA ll(145)/207/
    +
    316  DATA ll(146)/208/
    +
    317  DATA ll(147)/217/
    +
    318  DATA ll(148)/109/
    +
    319  DATA ll(149)/110/
    +
    320  DATA ll(150)/111/
    +
    321  DATA ll(151)/86/
    +
    322  DATA ll(152)/87/
    +
    323  DATA ll(153)/218/
    +
    324  DATA ll(154)/133/
    +
    325  DATA ll(155)/134/
    +
    326  DATA ll(156)/135/
    +
    327  DATA ll(157)/23/
    +
    328  DATA ll(158)/136/
    +
    329  DATA ll(159)/137/
    +
    330  DATA ll(160)/71/
    +
    331  DATA ll(161)/159/
    +
    332  DATA ll(162)/75/
    +
    333  DATA ll(163)/157/
    +
    334  DATA ll(164)/119/
    +
    335  DATA ll(165)/24/
    +
    336  DATA ll(166)/158/
    +
    337 C
    +
    338 C QNAME TABLE: CHARACTER*6
    +
    339 C
    +
    340  DATA qname( 1)/' HGT '/
    +
    341  DATA qname( 2)/' P ALT'/
    +
    342  DATA qname( 3)/' DIST '/
    +
    343  DATA qname( 4)/' PRES '/
    +
    344  DATA qname( 5)/' TMP '/
    +
    345  DATA qname( 6)/' DPT '/
    +
    346  DATA qname( 7)/' DEPR '/
    +
    347  DATA qname( 8)/' POT '/
    +
    348  DATA qname( 9)/' T MAX'/
    +
    349  DATA qname(10)/' T MIN'/
    +
    350  DATA qname(11)/' V VEL'/
    +
    351  DATA qname(12)/' NETVD'/
    +
    352  DATA qname(13)/' DZDT '/
    +
    353  DATA qname(14)/' OROW '/
    +
    354  DATA qname(15)/' FRCVV'/
    +
    355  DATA qname(16)/' U GRD'/
    +
    356  DATA qname(17)/' V GRD'/
    +
    357  DATA qname(18)/' WIND '/
    +
    358  DATA qname(19)/' T WND'/
    +
    359  DATA qname(20)/' VW SH'/
    +
    360  DATA qname(21)/' U DIV'/
    +
    361  DATA qname(22)/' V DIV'/
    +
    362  DATA qname(23)/' WDIR '/
    +
    363  DATA qname(24)/' WWND '/
    +
    364  DATA qname(25)/' SWND '/
    +
    365  DATA qname(26)/' RATS '/
    +
    366  DATA qname(27)/' VECW '/
    +
    367  DATA qname(28)/' SFAC '/
    +
    368  DATA qname(29)/' ABS V'/
    +
    369  DATA qname(30)/' REL V'/
    +
    370  DATA qname(31)/' DIV '/
    +
    371  DATA qname(32)/' STRM '/
    +
    372  DATA qname(33)/' V POT'/
    +
    373  DATA qname(34)/' R H '/
    +
    374  DATA qname(35)/' P WAT'/
    +
    375  DATA qname(36)/' A PCP'/
    +
    376  DATA qname(37)/' P O P'/
    +
    377  DATA qname(38)/' P O Z'/
    +
    378  DATA qname(39)/' SNO D'/
    +
    379  DATA qname(40)/' ACPCP'/
    +
    380  DATA qname(41)/' SPF H'/
    +
    381  DATA qname(42)/' L H2O'/
    +
    382  DATA qname(43)/' LFT X'/
    +
    383  DATA qname(44)/' TOTOS'/
    +
    384  DATA qname(45)/' K X '/
    +
    385  DATA qname(46)/' C INS'/
    +
    386  DATA qname(47)/' L WAV'/
    +
    387  DATA qname(48)/' S WAV'/
    +
    388  DATA qname(49)/' DRAG '/
    +
    389  DATA qname(50)/' LAND '/
    +
    390  DATA qname(51)/' KFACT'/
    +
    391  DATA qname(52)/' 10TSL'/
    +
    392  DATA qname(53)/' 7TSL '/
    +
    393  DATA qname(54)/' RCPOP'/
    +
    394  DATA qname(55)/' RCMT '/
    +
    395  DATA qname(56)/' RCMP '/
    +
    396  DATA qname(57)/' ORTHP'/
    +
    397  DATA qname(58)/' ALBDO'/
    +
    398  DATA qname(59)/' ENFLX'/
    +
    399  DATA qname(60)/' TTHTG'/
    +
    400  DATA qname(61)/' LAT '/
    +
    401  DATA qname(62)/' LON '/
    +
    402  DATA qname(63)/' RADIC'/
    +
    403  DATA qname(64)/' PROB '/
    +
    404  DATA qname(65)/' CPROB'/
    +
    405  DATA qname(66)/' USTAR'/
    +
    406  DATA qname(67)/' TSTAR'/
    +
    407  DATA qname(68)/' MIXHT'/
    +
    408  DATA qname(69)/' WTMP '/
    +
    409  DATA qname(70)/' WVHGT'/
    +
    410  DATA qname(71)/' SWELL'/
    +
    411  DATA qname(72)/' WVSWL'/
    +
    412  DATA qname(73)/' WVPER'/
    +
    413  DATA qname(74)/' WVDIR'/
    +
    414  DATA qname(75)/' SWPER'/
    +
    415  DATA qname(76)/' SWDIR'/
    +
    416  DATA qname(77)/' RRATE'/
    +
    417  DATA qname(78)/' TSTM '/
    +
    418  DATA qname(79)/' CSVR '/
    +
    419  DATA qname(80)/' CTDR '/
    +
    420  DATA qname(81)/' MIXR '/
    +
    421  DATA qname(82)/' PSVR '/
    +
    422  DATA qname(83)/' MCONV'/
    +
    423  DATA qname(84)/' ENRGY'/
    +
    424  DATA qname(85)/' RDNCE'/
    +
    425  DATA qname(86)/' BRTMP'/
    +
    426  DATA qname(87)/' TCOZ '/
    +
    427  DATA qname(88)/' OZMR '/
    +
    428  DATA qname(89)/' ICWAT'/
    +
    429  DATA qname(90)/' DEPTH'/
    +
    430  DATA qname(91)/' GUST '/
    +
    431  DATA qname(92)/' VAPP '/
    +
    432  DATA qname(93)/' TOTHF'/
    +
    433  DATA qname(94)/' SPEHF'/
    +
    434  DATA qname(95)/' SORAD'/
    +
    435  DATA qname(96)/' UOGRD'/
    +
    436  DATA qname(97)/' VOGRD'/
    +
    437  DATA qname(98)/' HTSGW'/
    +
    438  DATA qname(99)/' PERPW'/
    +
    439  DATA qname(100)/' DIRPW'/
    +
    440  DATA qname(101)/' PERSW'/
    +
    441  DATA qname(102)/' DIRSW'/
    +
    442  DATA qname(103)/' WCAPS'/
    +
    443  DATA qname(104)/' PTEND'/
    +
    444  DATA qname(105)/' NCPCP'/
    +
    445  DATA qname(106)/' 4LFTX'/
    +
    446  DATA qname(107)/' ICEAC'/
    +
    447  DATA qname(108)/' NPRAT'/
    +
    448  DATA qname(109)/' CPRAT'/
    +
    449  DATA qname(110)/'CEILHT'/
    +
    450  DATA qname(111)/' VISIB'/
    +
    451  DATA qname(112)/'LIQPCP'/
    +
    452  DATA qname(113)/'FREPCP'/
    +
    453  DATA qname(114)/'FROPCP'/
    +
    454  DATA qname(115)/' MIXLY'/
    +
    455  DATA qname(116)/' DLRFL'/
    +
    456  DATA qname(117)/' ULRFL'/
    +
    457  DATA qname(118)/' DSRFL'/
    +
    458  DATA qname(119)/' USRFL'/
    +
    459  DATA qname(120)/' UTHFL'/
    +
    460  DATA qname(121)/' UTWFL'/
    +
    461  DATA qname(122)/' TTLWR'/
    +
    462  DATA qname(123)/' TTSWR'/
    +
    463  DATA qname(124)/' TTRAD'/
    +
    464  DATA qname(125)/' MSTAV'/
    +
    465  DATA qname(126)/' SWABS'/
    +
    466  DATA qname(127)/' CDLYR'/
    +
    467  DATA qname(128)/' CDCON'/
    +
    468  DATA qname(129)/' PBCLY'/
    +
    469  DATA qname(130)/' PTCLY'/
    +
    470  DATA qname(131)/' PBCON'/
    +
    471  DATA qname(132)/' PTCON'/
    +
    472  DATA qname(133)/' SFEXC'/
    +
    473  DATA qname(134)/' A EVP'/
    +
    474  DATA qname(135)/' STCOF'/
    +
    475  DATA qname(136)/' TSOIL'/
    +
    476  DATA qname(137)/'D DUDT'/
    +
    477  DATA qname(138)/'D DVDT'/
    +
    478  DATA qname(139)/' U STR'/
    +
    479  DATA qname(140)/' V STR'/
    +
    480  DATA qname(141)/' TUVRD'/
    +
    481  DATA qname(142)/' TVVRD'/
    +
    482  DATA qname(143)/' TTLRG'/
    +
    483  DATA qname(144)/' TTSHL'/
    +
    484  DATA qname(145)/' TTDEP'/
    +
    485  DATA qname(146)/' TTVDF'/
    +
    486  DATA qname(147)/' ZSTAR'/
    +
    487  DATA qname(148)/' TQDEP'/
    +
    488  DATA qname(149)/' TQSHL'/
    +
    489  DATA qname(150)/' TQVDF'/
    +
    490  DATA qname(151)/'XGWSTR'/
    +
    491  DATA qname(152)/'YGWSTR'/
    +
    492  DATA qname(153)/' STDZG'/
    +
    493  DATA qname(154)/' A LEV'/
    +
    494  DATA qname(155)/' T AIL'/
    +
    495  DATA qname(156)/' B AIL'/
    +
    496  DATA qname(157)/' EPOT '/
    +
    497  DATA qname(158)/' MSLSA'/
    +
    498  DATA qname(159)/' MSLMA'/
    +
    499  DATA qname(160)/'MGSTRM'/
    +
    500  DATA qname(161)/' CONDP'/
    +
    501  DATA qname(162)/' POT V'/
    +
    502  DATA qname(163)/' CAPE '/
    +
    503  DATA qname(164)/' CIN '/
    +
    504  DATA qname(165)/' VTMP '/
    +
    505  DATA qname(166)/' TKE '/
    +
    506 C
    +
    507 C REFERENCE TABLE FOR G (GENERATING PROGRAM NAME)
    +
    508 C
    +
    509  DATA kk(1)/57/
    +
    510  DATA kk(2)/58/
    +
    511  DATA kk(3)/59/
    +
    512 C
    +
    513 C G TABLE (GENERATING PROGRM NAME):
    +
    514 C
    +
    515  DATA kname/' ECMWF', ' READING', ',UK. ',
    +
    516  & ' FNOC', ' MONTERE', 'Y, CA. ',
    +
    517  & ' AFGWC ', 'OFFUTT A', 'FB, NB. '/
    +
    518  DATA kname1/' WMC N','MC WASHI', 'NGTON '/
    +
    519 C
    +
    520  DATA after /' AFTER '/
    +
    521  DATA dn /'DN'/
    +
    522  DATA qname1/' THCK '/
    +
    523  DATA qname2/' THKDN'/
    +
    524  DATA qname3/' PRSDN'/
    +
    525 C
    +
    526  DATA vunit(1)/' 0-HR FCST VALID AT '/
    +
    527  DATA vunit(2)/' ANALYSIS VALID AT '/
    +
    528  DATA unit1 /' HRS'/
    +
    529  DATA days /' DYS'/
    +
    530  DATA for1 /' FOR '/
    +
    531  DATA dash /'-'/
    +
    532 C
    +
    533  200 FORMAT ( ' ',a7,a4,' ',a7)
    +
    534  210 FORMAT ( a4,1x,a6,a5,f4.1,a4,a7,
    +
    535  & i2.2,a1,i2.2,a1,i2.2,1x,i2.2,'Z',3a8)
    +
    536  220 FORMAT ( 13x,a7)
    +
    537  230 FORMAT ( ' Q IS AN ILLEGAL OFFICE NOTE 84 DATA TYPE, Q = ',
    +
    538  & i5,35x)
    +
    539  240 FORMAT ( a4,1x,a6,a20,
    +
    540  & i2.2,a1,i2.2,a1,i2.2,1x,i2.2,'Z',3a8)
    +
    541 C
    +
    542 C 1. UNPACK ID WORDS.
    +
    543 C
    +
    544  DO 10 n = 1,17
    +
    545  itemp = 0
    +
    546  ktemp = 0
    +
    547  itemp = shfmsk(n)
    +
    548  nshift = iand(ishft(itemp,-24),255)
    +
    549  nmask = iand(ishft(itemp,-16),255)
    +
    550  nid = iand(ishft(itemp,-8),255)
    +
    551  itemp = mask(nmask)
    +
    552  ktemp = id(nid)
    +
    553  jkeep(n) = iand(itemp,ishft(ktemp,-nshift))
    +
    554  10 CONTINUE
    +
    555 C
    +
    556  f1 = jkeep(1)
    +
    557  dd = jkeep(2)
    +
    558  mm = jkeep(3)
    +
    559  yy = jkeep(4)
    +
    560  c1 = jkeep(5)
    +
    561  e1 = jkeep(6)
    +
    562  c2 = jkeep(7)
    +
    563  e2 = jkeep(8)
    +
    564  m = jkeep(9)
    +
    565  s1 = jkeep(10)
    +
    566  s2 = jkeep(11)
    +
    567  q = jkeep(12)
    +
    568  hh = jkeep(13)
    +
    569  g = jkeep(14)
    +
    570  jt = jkeep(15)
    +
    571  jn = jkeep(16)
    +
    572  f2 = jkeep(17)
    +
    573 C
    +
    574  ks = iand(ishft(id(3),-40_8),255_8)
    +
    575 C
    +
    576 C 2. FIND WHICH PARAMETER (Q) IS INDICATED BE THE ID WORDS.
    +
    577 C
    +
    578  DO 20 n = 1,166
    +
    579  nn = n
    +
    580  IF (q.EQ.ll(n)) GO TO 30
    +
    581  20 CONTINUE
    +
    582 C
    +
    583 C CAN NOT FIND A LEGAL Q
    +
    584  GO TO 170
    +
    585 C
    +
    586  30 CONTINUE
    +
    587  unit(1:4) = unit1(1:4)
    +
    588  for(1:5) = for1(1:5)
    +
    589  aftbef(1:7) = after(1:7)
    +
    590 C
    +
    591  IF (e1.GT.128) e1 = -(jkeep(6)-128)
    +
    592  IF (e2.GT.128) e2 = -(jkeep(8)-128)
    +
    593 C
    +
    594 C 3. FIND WHICH SURFACE IS INDICATED BY THE ID WORDS
    +
    595 C AS BEING THE FIRST SURFACE.
    +
    596 C
    +
    597  DO 40 i = 1,17
    +
    598  IF (s1.EQ.jlist(i)) THEN
    +
    599  k1 = i
    +
    600  GO TO 50
    +
    601  ENDIF
    +
    602  40 CONTINUE
    +
    603  k1 = 18
    +
    604 C
    +
    605  50 CONTINUE
    +
    606 C
    +
    607 C 4. BEGIN PROCESSING OF A ONE-SURFACE TITLE
    +
    608 C
    +
    609  IF (m.EQ.0.OR.m.EQ.8) THEN
    +
    610  k2 = k1
    +
    611  CALL value1(s1,c1,e1,inum1)
    +
    612  WRITE (ktitle(1:20),220) inum1
    +
    613  GO TO 80
    +
    614  ENDIF
    +
    615 C
    +
    616 C 5. FIND WHICH SURFACE IS INDICATED BY THE ID WORDS
    +
    617 C AS BEING THE SECOND SURFACE.
    +
    618 C
    +
    619  DO 60 i = 1,17
    +
    620  IF (s2.EQ.jlist(i)) THEN
    +
    621  k2 = i
    +
    622  GO TO 70
    +
    623  ENDIF
    +
    624  60 CONTINUE
    +
    625  k2 = 18
    +
    626 C
    +
    627  70 CONTINUE
    +
    628 C
    +
    629 C 6. BEGIN PROCESSING OF A TWO-SURFACE TITLE
    +
    630 C
    +
    631  CALL value1(s1,c1,e1,inum1)
    +
    632  CALL value1(s2,c2,e2,inum2)
    +
    633  WRITE (ktitle(1:20),200) inum1 , sname(k1) , inum2
    +
    634 C
    +
    635  80 CONTINUE
    +
    636  qwrite = qname(nn)
    +
    637 C
    +
    638  IF (q.EQ.1 .AND. m.EQ.1.AND. s1.EQ.8) qwrite = qname1
    +
    639  IF (q.EQ.1 .AND. m.EQ.1.AND. s1.EQ.8.AND.ks.EQ.2) qwrite = qname2
    +
    640  IF (q.EQ.8 .AND. s1.EQ.128.AND.ks.EQ.2) qwrite = qname3
    +
    641  IF (jt.EQ.6) qwrite(5:6) = dn(1:2)
    +
    642 C
    +
    643 C 7. SET DATE/TIME FIELDS
    +
    644 C
    +
    645 C A. CHECK IF F1 AND F2 ARE IN HRS, HALF DAYS OR DAYS.
    +
    646 C
    +
    647  rf1 = f1
    +
    648  rf2 = f2
    +
    649 C
    +
    650 C B: IF F1 IN HALF DAYS: CONVERT TO HOURS
    +
    651 C
    +
    652  IF (jn.EQ.15.OR.jt.EQ.7) THEN
    +
    653  rf1 = rf1 * 12.0
    +
    654  rf2 = rf2 * 12.0
    +
    655  ENDIF
    +
    656 C
    +
    657 C C: IF F1 IN DAYS: CONVERT TO HOURS
    +
    658 C
    +
    659  IF (jt.EQ.10) THEN
    +
    660  rf1 = rf1 * 24.0
    +
    661  rf2 = rf2 * 24.0
    +
    662  ENDIF
    +
    663 C
    +
    664 C D: CONVERT HOURS TO DAYS IF HOURS GREATER THAN 72
    +
    665 C
    +
    666  IF (jt.NE.6) THEN
    +
    667  IF (rf1.GT.72.0.OR.rf2.GT.72.0) THEN
    +
    668  rf1 = rf1 / 24.0
    +
    669  rf2 = rf2 / 24.0
    +
    670  unit(1:4) = days(1:4)
    +
    671  ENDIF
    +
    672  ENDIF
    +
    673 C
    +
    674  IF (jt.EQ.6) THEN
    +
    675  IF (f1.GT.127) THEN
    +
    676  f1 = and(f1,127)
    +
    677  f1 = -f1
    +
    678  ENDIF
    +
    679  cf1 = f1
    +
    680  cf2 = f2
    +
    681  CALL climo(cf1,cf2,unit,for,aftbef)
    +
    682  rf1 = cf1
    +
    683  CALL setcl(cf2,unit,ktitle)
    +
    684  ENDIF
    +
    685 C
    +
    686 C 8. SET GENERATING PROGRAM NAME
    +
    687 C
    +
    688  DO 110 k = 1,3
    +
    689  IF (g.EQ.kk(k)) GO TO 130
    +
    690  110 CONTINUE
    +
    691 C
    +
    692  DO 120 l = 1,3
    +
    693  kwrite(l) = kname1(l)
    +
    694  120 CONTINUE
    +
    695  GO TO 150
    +
    696 C
    +
    697  130 CONTINUE
    +
    698  DO 140 l = 1,3
    +
    699  kwrite(l) = kname( 3*(k-1) + l)
    +
    700  140 CONTINUE
    +
    701 C
    +
    702 C 9. ENCODE THE TITLE LINE
    +
    703 C
    +
    704 C 9.1 DISTINGUISH BETWEEN ANALYSIS AND ZERO FORECASTS
    +
    705 C AND 'REAL' FORECASTS
    +
    706 C
    +
    707  150 CONTINUE
    +
    708  IF (f1.NE.0) GO TO 160
    +
    709  IF (g.EQ.19.OR.g.EQ.22.OR.g.EQ.43.OR.g.EQ.44.OR.g.EQ.49.OR.
    +
    710  & g.EQ.55.OR.g.EQ.56.OR.g.EQ.64) THEN
    +
    711  iii = 2
    +
    712  IF (m.EQ.8.OR.m.EQ.9.OR.m.EQ.10) iii = 1
    +
    713  ELSE
    +
    714  iii = 1
    +
    715  ENDIF
    +
    716 C
    +
    717  WRITE (ktitle(21:88),240) sname(k2), qwrite, vunit(iii),
    +
    718  & yy, dash, mm, dash, dd, hh, (kwrite(l),l=1,3)
    +
    719  RETURN
    +
    720 C
    +
    721  160 CONTINUE
    +
    722  WRITE (ktitle(21:88),210) sname(k2), qwrite, for, rf1, unit,
    +
    723  & aftbef, yy, dash, mm, dash, dd, hh, (kwrite(l),l=1,3)
    +
    724  RETURN
    +
    725 C
    +
    726  170 CONTINUE
    +
    727  WRITE (ktitle(1:88),230) q
    +
    728  RETURN
    +
    729  END
    +
    730 C> @brief Creates value1 of surface from ids.
    +
    731 C> @author Ralph Jones @date 1988-11-28
    +
    732 
    +
    733 C> Creates the numerical value for the surface
    +
    734 C> to be built into the first line of the title.
    +
    735 C>
    +
    736 C> Program history log:
    +
    737 C> - Ralph Jones 1988-11-28
    +
    738 C> - Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
    +
    739 C>
    +
    740 C> @param[in] S Integer number of surface.
    +
    741 C> @param[in] C,E Numerical value of the surface (SURFACE = S * 10 ** E).
    +
    742 C> @param[out] NUM 7 character value of the surface for the title.
    +
    743 C>
    +
    744 C> @author Ralph Jones @date 1988-11-28
    +
    745  SUBROUTINE value1(S,C,E,NUM)
    +
    746 
    +
    747 C
    +
    748  INTEGER C
    +
    749  INTEGER E
    +
    750  INTEGER S
    +
    751 C
    +
    752  CHARACTER*8 JNUM
    +
    753  CHARACTER*8 KNUM
    +
    754  CHARACTER*7 LTEMP
    +
    755  CHARACTER*8 NUM
    +
    756  CHARACTER*1 POINT
    +
    757  CHARACTER*1 ZERO
    +
    758 C
    +
    759  DATA jnum /' 0.0000 '/
    +
    760  DATA knum /' '/
    +
    761  DATA point /'.'/
    +
    762  DATA zero /'0'/
    +
    763 C
    +
    764  101 FORMAT ( i6,' ')
    +
    765 C
    +
    766  IF (s.GE.128.AND.s.LE.132) GO TO 110
    +
    767  IF (c.EQ.0) GO TO 100
    +
    768  WRITE (ltemp(1:7),101) c
    +
    769  j = e + 6
    +
    770  k = j + 1
    +
    771  IF (j.EQ.0) GO TO 90
    +
    772  num(1:j) = ltemp(1:j)
    +
    773 C
    +
    774  90 CONTINUE
    +
    775  num(k:k) = point
    +
    776  num(k+1:8) = ltemp(k:7)
    +
    777  IF (j.EQ.0) num(2:2) = zero
    +
    778  GO TO 150
    +
    779 C
    +
    780  100 CONTINUE
    +
    781  num = jnum
    +
    782  GO TO 150
    +
    783 C
    +
    784  110 CONTINUE
    +
    785  num = knum
    +
    786 C
    +
    787  150 CONTINUE
    +
    788 C
    +
    789  RETURN
    +
    790  END
    +
    791 C> @brief Creates the second line of title.
    +
    792 C> @author Ralph Jones @date 1988-11-28
    +
    793 
    +
    794 C> Creates the second line of the title from the id words.
    +
    795 C> called by w3fp06. words 23 to 54.
    +
    796 C>
    +
    797 C> Program history log:
    +
    798 C> - Ralph Jones 1988-11-28
    +
    799 C> - Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
    +
    800 C> - Ralph Jones 1991-03-01 Changes for big records.
    +
    801 C>
    +
    802 C> @param[in] ID Id words (6 integer words) office note 84
    +
    803 C> @param[in] MASK Mask for unpacking id words (8 words)
    +
    804 C> @param[out] KTITLE Title character*324
    +
    805 C>
    +
    806 C> @author Ralph Jones @date 1988-11-28
    +
    807  SUBROUTINE line02(ID,MASK,KTITLE)
    +
    808 
    +
    809 C
    +
    810  INTEGER(8) ID(6)
    +
    811  INTEGER(8) IKEEP(17)
    +
    812  INTEGER(4) MASK(8)
    +
    813  INTEGER(8) MASK32,MASKN
    +
    814  INTEGER(4) SHFMSK(17)
    +
    815  integer(8) irtemp
    +
    816  real(4) rtemp(2)
    +
    817  equivalence(irtemp,rtemp(1))
    +
    818 C
    +
    819  CHARACTER * 324 KTITLE
    +
    820 C
    +
    821 C IDWORDS: MASK CONTROL (INTEGER)
    +
    822 C
    +
    823  DATA maskn /z'FFFFFFFFFFFF0000'/
    +
    824  DATA mask32/z'00000000FFFFFFFF'/
    +
    825  DATA shfmsk( 1)/z'3C010200'/
    +
    826  DATA shfmsk( 2)/z'1C010100'/
    +
    827  DATA shfmsk( 3)/z'1C010200'/
    +
    828  DATA shfmsk( 4)/z'20020100'/
    +
    829  DATA shfmsk( 5)/z'20020200'/
    +
    830  DATA shfmsk( 6)/z'38020300'/
    +
    831  DATA shfmsk( 7)/z'30020300'/
    +
    832  DATA shfmsk( 8)/z'28020300'/
    +
    833  DATA shfmsk( 9)/z'20020300'/
    +
    834  DATA shfmsk(10)/z'3C010300'/
    +
    835  DATA shfmsk(11)/z'18020400'/
    +
    836  DATA shfmsk(12)/z'10020400'/
    +
    837  DATA shfmsk(13)/z'00040400'/
    +
    838  DATA shfmsk(14)/z'30040500'/
    +
    839  DATA shfmsk(15)/z'00040500'/
    +
    840  DATA shfmsk(16)/z'00080500'/
    +
    841  DATA shfmsk(17)/z'20040600'/
    +
    842 C
    +
    843  100 FORMAT(' M=',i2,' T=',i2,' N=',i2,' F1=',i3,' F2=',i3,' CD=',i3,
    +
    844  1' CM=',i3,' KS=',i3,' K=',i3,' GES=',i2,' R=',i3,' G=',i3,
    +
    845  2' J=',i5,' B=',i5,' Z=',i5,' A=',e15.8,' N=',i5,' ')
    +
    846 C
    +
    847 C UNPACK ID WORDS.
    +
    848 C
    +
    849  DO 10 n = 1,17
    +
    850  itemp = shfmsk(n)
    +
    851  nshift = iand(ishft(itemp,-24),255)
    +
    852  nmask = iand(ishft(itemp,-16),255)
    +
    853  nid = iand(ishft(itemp,-8),255)
    +
    854  jtemp = mask(nmask)
    +
    855  ktemp = id(nid)
    +
    856  ikeep(n) = iand(jtemp,ishft(ktemp,-nshift))
    +
    857  10 CONTINUE
    +
    858 C
    +
    859 C CONVERT IBM 32 BIT F.P. NUMBER TO IEEE F.P. NUMBER
    +
    860 C
    +
    861 C CALL USSCTC(ID(5),5,A,1)
    +
    862  irtemp=id(5)
    +
    863  call q9ie32(rtemp(2),rtemp(1),1,istat)
    +
    864  a=rtemp(1)
    +
    865 C
    +
    866 C CONVERT 16 BIT SIGNED INTEGER INTO A 64 BIT INTEGER.
    +
    867 C
    +
    868  IF (btest(ikeep(17),15_8)) THEN
    +
    869  ikeep(17) = ior(ikeep(17),maskn)
    +
    870  ENDIF
    +
    871 C
    +
    872 C TEST FOR BIG RECORD
    +
    873 C
    +
    874  IF (ikeep(13).EQ.0) THEN
    +
    875  ikeep(13) = iand(id(6),mask32)
    +
    876  END IF
    +
    877 C
    +
    878  WRITE (ktitle(89:216),100) (ikeep(i),i=1,15) , a , ikeep(17)
    +
    879  RETURN
    +
    880  END
    +
    881 C> @brief Creates the third line of title.
    +
    882 C> @author Ralph Jones @date 1988-11-28
    +
    883 
    +
    884 C> Creates the third line of the title from the id words.
    +
    885 C> called by w3fp06 to create words 55 to 81 of the title.
    +
    886 C>
    +
    887 C> Program history log:
    +
    888 C> - Ralph Jones 1988-11-28
    +
    889 C> - Ralph Jones 1990-02-03 Convert to cray cft77 fortran.
    +
    890 C>
    +
    891 C> @param[in] ID ID words (6 integer) office note 84.
    +
    892 C> @param[out] KTITLE Character*324 array.
    +
    893 C>
    +
    894 C> @author Ralph Jones @date 1988-11-28
    +
    895  SUBROUTINE line03(ID,KTITLE)
    +
    896 
    +
    897 C
    +
    898  INTEGER(8) ID(6)
    +
    899  INTEGER(8) MASK32
    +
    900  INTEGER ID84(12)
    +
    901 C
    +
    902  CHARACTER * 324 KTITLE
    +
    903 C
    +
    904  DATA mask32/z'00000000FFFFFFFF'/
    +
    905 C
    +
    906 C FORTRAN INTERNAL WRITE STATEMENT REPLACES ENCODE
    +
    907 C
    +
    908  100 FORMAT ( 12(1x,z8))
    +
    909 C
    +
    910  DO 10 j = 1,11,2
    +
    911  id84(j) = ishft(id(j/2+1),-32_8)
    +
    912  id84(j+1) = iand(id(j/2+1),mask32)
    +
    913  10 CONTINUE
    +
    914 C
    +
    915  WRITE (ktitle(217:324),100) (id84(i),i=1,12)
    +
    916  RETURN
    +
    917  END
    +
    918 C> @brief Sets time-averaged titles.
    +
    919 C> @author Ralph Jones @date 1988-11-28
    +
    920 
    +
    921 C> Fills in the first thirteen characters in the title
    +
    922 C> to make the title a time-averaged title.
    +
    923 C>
    +
    924 C> Program history log:
    +
    925 C> - Ralph Jones 1988-11-28
    +
    926 C> - Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
    +
    927 C>
    +
    928 C> @param[in] CF1 Forecast period length.
    +
    929 C> @param[in] CF2 Length of the average.
    +
    930 C> @param[inout] UNIT
    +
    931 C> - [in] Originally set to ' hrs'.
    +
    932 C> - [out] Set to ' dys' if necessary.
    +
    933 C> @param[inout] FOR
    +
    934 C> - [in] Originally set to ' for '.
    +
    935 C> - [out] Set to ' ctr '.
    +
    936 C> @param[inout] AFTBEF
    +
    937 C> - [in] Originally set to ' after '.
    +
    938 C> - [out] Set to ' befor ' if necessary.
    +
    939 C>
    +
    940 C> @author Ralph Jones @date 1988-11-28
    +
    941  SUBROUTINE climo(CF1,CF2,UNIT,FOR,AFTBEF)
    +
    942 
    +
    943 C
    +
    944  REAL CF1
    +
    945  REAL CF2
    +
    946 C
    +
    947  CHARACTER*7 AFTBEF
    +
    948  CHARACTER*7 BEFOR
    +
    949  CHARACTER*5 FOR
    +
    950  CHARACTER*5 FOR1
    +
    951  CHARACTER*4 UNIT
    +
    952  CHARACTER*4 UNIT1
    +
    953  CHARACTER*4 UNIT2
    +
    954 C
    +
    955  DATA befor /' BEFOR '/
    +
    956  DATA for1 /' CTR '/
    +
    957  DATA unit1 /' DYS'/
    +
    958  DATA unit2 /' HRS'/
    +
    959 C
    +
    960 C SET FOR TO ' CTR '
    +
    961 C
    +
    962  for(1:5) = for1(1:5)
    +
    963 C
    +
    964 C DIFFERENCE = CENTERDAY - RUNDATE = F1 + 2 DAYS
    +
    965 C CHANGE CF1 TO HOURS, ADD 48 HOURS
    +
    966 C
    +
    967  diff = cf1 * 12.0 + 48.0
    +
    968 C
    +
    969 C IF DIFF NEGATIVE, SET AFTBEF TO ' BEFOR '
    +
    970 C
    +
    971  IF (diff.LT.0.0) aftbef(1:7) = befor(1:7)
    +
    972 C
    +
    973  cf2 = cf2 * 12.0
    +
    974 C
    +
    975  IF (abs(diff).LE.72.0) THEN
    +
    976  cf1 = abs(diff)
    +
    977  cf2 = cf2 / 24.0
    +
    978 C
    +
    979 C SET UNIT TO ' HRS '
    +
    980 C
    +
    981  unit(1:4) = unit2(1:4)
    +
    982  GO TO 100
    +
    983  ENDIF
    +
    984 C
    +
    985  cf1 = abs(diff / 24.0 )
    +
    986  cf2 = cf2 / 24.0
    +
    987 C
    +
    988 C SET UNIT TO ' DYS '
    +
    989 C
    +
    990  unit(1:4) = unit1(1:4)
    +
    991 C
    +
    992  100 CONTINUE
    +
    993  RETURN
    +
    994  END
    +
    995 C> @brief Encodes time-averaged title
    +
    996 C> @author Ralph Jones @date 1988-11-28
    +
    997 
    +
    998 C> Encodes the first thirteen characters in the title
    +
    999 C> to make the title a time-averaged title.
    +
    1000 C>
    +
    1001 C> Program history log:
    +
    1002 C> - Ralph Jones 1988-11-28
    +
    1003 C> - Ralph Jones 1989-11-01 Convert to cray cft77 fortran.
    +
    1004 C>
    +
    1005 C> @param[in] CF2 Length of the forecast period
    +
    1006 C> @param[in] UNIT Units for cf2
    +
    1007 C> @param[inout] KTITLE
    +
    1008 C> - [in] Title to be modified
    +
    1009 C> - [out] Title with the time-averaged included
    +
    1010 C>
    +
    1011 C> @author Ralph Jones @date 1988-11-28
    +
    1012  SUBROUTINE setcl(CF2,UNIT,KTITLE)
    +
    1013 
    +
    1014 C
    +
    1015  CHARACTER*324 KTITLE
    +
    1016  CHARACTER*13 BLANK
    +
    1017  CHARACTER*4 UNIT
    +
    1018  CHARACTER*4 DUNIT
    +
    1019  CHARACTER*4 HUNIT
    +
    1020 C
    +
    1021  DATA blank /' '/
    +
    1022  DATA dunit /'-DAY'/
    +
    1023  DATA hunit /'-HR '/
    +
    1024 C
    +
    1025  100 FORMAT (1x, f4.1, a4, ' AVG' )
    +
    1026 C
    +
    1027  ktitle(1:13) = blank(1:13)
    +
    1028 C
    +
    1029  WRITE (ktitle(1:13),100) cf2 , dunit(1:4)
    +
    1030 C
    +
    1031  RETURN
    +
    1032  END
    +
    +
    +
    line01
    subroutine line01(ID, MASK, KTITLE)
    Creates the first line of title.
    Definition: w3fp06.f:70
    +
    line03
    subroutine line03(ID, KTITLE)
    Creates the third line of title.
    Definition: w3fp06.f:896
    +
    setcl
    subroutine setcl(CF2, UNIT, KTITLE)
    Encodes time-averaged title.
    Definition: w3fp06.f:1013
    +
    value1
    subroutine value1(S, C, E, NUM)
    Creates value1 of surface from ids.
    Definition: w3fp06.f:746
    +
    w3fp06
    subroutine w3fp06(ID, KTITLE, N)
    Provides a title for data fields formulated according to nmc o.n.
    Definition: w3fp06.f:26
    +
    q9ie32
    subroutine q9ie32(A, B, N, ISTAT)
    Convert ibm370 32 bit floating point numbers to ieee 32 bit task 754 floating point numbers.
    Definition: q9ie32.f:28
    +
    line02
    subroutine line02(ID, MASK, KTITLE)
    Creates the second line of title.
    Definition: w3fp06.f:808
    +
    climo
    subroutine climo(CF1, CF2, UNIT, FOR, AFTBEF)
    Sets time-averaged titles.
    Definition: w3fp06.f:942
    + + + + diff --git a/ver-2.10.0/w3fp10_8f.html b/ver-2.10.0/w3fp10_8f.html new file mode 100644 index 00000000..4889404e --- /dev/null +++ b/ver-2.10.0/w3fp10_8f.html @@ -0,0 +1,220 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp10.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fp10.f File Reference
    +
    +
    + +

    Printer contour subroutine. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fp10 (RDATA, KTBL, CNST, TITLE, KRECT, KCONTR, LINEV, IWIDTH)
     Prints a two-dimensional grid of any shape, with contouring, if desired. More...
     
    +

    Detailed Description

    +

    Printer contour subroutine.

    +
    Author
    Ralph Jones
    +
    Date
    1989-09-08
    + +

    Definition in file w3fp10.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fp10()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fp10 (real, dimension(*) RDATA,
    integer, dimension(*) KTBL,
    real, dimension(4) CNST,
    integer, dimension(33) TITLE,
     KRECT,
     KCONTR,
     LINEV,
     IWIDTH 
    )
    +
    + +

    Prints a two-dimensional grid of any shape, with contouring, if desired.

    +

    Grid values are scaled according to to constants specified by the programer, rounded, and printed as 4,3, or 2 digit integers with sign, the sign marking the grid position of the printed number. If contouring is requested, bessel's interpolation formula is used to optain the contour lines. Contours are indicated by alphabetic characters ranging from a to h or numeric characters from 0 to 9. Contour origin and interval are specified by the programmer in terms of printed values.

    +

    +Program History Log

    + + + + + + + +
    Date Programmer Comments
    1989-09-08 Ralph Jones Initial
    1992-05-02 Ralph Jones Convert to cray cft77 fortran, add save.
    +
    Parameters
    + + + + + + + + + +
    [in]RDATAReal array of grid data to be printed.
    [in]KTBLInteger array with shape of array.
    [in]CNSTReal array of four elements, used in scaling for printing and contouring.
    [in]TITLEIs a array of 132 characters or less of hollerith data, 1st char. must be blank. printed at bottom of the map.
    [in]KRECT1 if grid is rectangular, 0 otherwise.
    [in]KCONTR1 for contouring , 0 otherwise.
    [in]LINEV0 is for 6 lines per vertical inch, non-zero 8 lines per vertical inch.
    [in]IWIDTHNumber of characters in print line, 132 is standard printer.
    +
    +
    +

    Return conditions: Normal subroutine return, unless number of rows is greater than 200, prints error message and exits.

    +
    Note
    Special version of w3fp05(), 1st point is upper left hand corner. Written on request of peter chase because some grib fields can start with the upper left hand corner as the 1st point of a grid.
    +
    Author
    Ralph Jones
    +
    Date
    1989-09-08
    +

    The value CRMX is machine dependent, it should be set to a value a little less than the largest positive floating point number for the computer.

    +

    LIMNRW is limit on number of rows allowed and is dimension of KRLOC

    + +

    Definition at line 46 of file w3fp10.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fp10_8f.js b/ver-2.10.0/w3fp10_8f.js new file mode 100644 index 00000000..539c5b8b --- /dev/null +++ b/ver-2.10.0/w3fp10_8f.js @@ -0,0 +1,4 @@ +var w3fp10_8f = +[ + [ "w3fp10", "w3fp10_8f.html#a2d0f404c14f9e2ea8e6a9f0e911a825e", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fp10_8f_source.html b/ver-2.10.0/w3fp10_8f_source.html new file mode 100644 index 00000000..1f29d16e --- /dev/null +++ b/ver-2.10.0/w3fp10_8f_source.html @@ -0,0 +1,796 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp10.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fp10.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Printer contour subroutine.
    +
    3 C> @author Ralph Jones @date 1989-09-08
    +
    4 
    +
    5 C> Prints a two-dimensional grid of any shape, with
    +
    6 C> contouring, if desired. Grid values are scaled according to
    +
    7 C> to constants specified by the programer, rounded, and printed
    +
    8 C> as 4,3, or 2 digit integers with sign, the sign marking the
    +
    9 C> grid position of the printed number. If contouring is requested,
    +
    10 C> bessel's interpolation formula is used to optain the contour lines.
    +
    11 C> Contours are indicated by alphabetic characters ranging from a to
    +
    12 C> h or numeric characters from 0 to 9. Contour origin and interval
    +
    13 C> are specified by the programmer in terms of printed values.
    +
    14 C>
    +
    15 C> ### Program History Log
    +
    16 C> Date | Programmer | Comments
    +
    17 C> -----|------------|---------
    +
    18 C> 1989-09-08 | Ralph Jones | Initial
    +
    19 C> 1992-05-02 | Ralph Jones | Convert to cray cft77 fortran, add save.
    +
    20 C>
    +
    21 C> @param[in] RDATA Real array of grid data to be printed.
    +
    22 C> @param[in] KTBL Integer array with shape of array.
    +
    23 C> @param[in] CNST Real array of four elements, used in
    +
    24 C> scaling for printing and contouring.
    +
    25 C> @param[in] TITLE Is a array of 132 characters or less of
    +
    26 C> hollerith data, 1st char. must be blank.
    +
    27 C> printed at bottom of the map.
    +
    28 C> @param[in] KRECT 1 if grid is rectangular, 0 otherwise.
    +
    29 C> @param[in] KCONTR 1 for contouring , 0 otherwise.
    +
    30 C> @param[in] LINEV 0 is for 6 lines per vertical inch,
    +
    31 C> non-zero 8 lines per vertical inch.
    +
    32 C> @param[in] IWIDTH Number of characters in print line,
    +
    33 C> 132 is standard printer.
    +
    34 C>
    +
    35 C> Return conditions: Normal subroutine return, unless number of rows is
    +
    36 C> greater than 200, prints error message and exits.
    +
    37 C>
    +
    38 C> @note Special version of w3fp05(), 1st point is upper left hand
    +
    39 C> corner. Written on request of peter chase because some
    +
    40 C> grib fields can start with the upper left hand corner
    +
    41 C> as the 1st point of a grid.
    +
    42 C>
    +
    43 C> @author Ralph Jones @date 1989-09-08
    +
    44  SUBROUTINE w3fp10(RDATA,KTBL,CNST,TITLE,KRECT,KCONTR,
    +
    45  & LINEV,IWIDTH)
    +
    46 C
    +
    47  REAL CNST(4)
    +
    48  REAL RDATA(*)
    +
    49  REAL RWA(28)
    +
    50  REAL RWB(28)
    +
    51  REAL RWC(28)
    +
    52  REAL RWD(28)
    +
    53  REAL VDJA(29)
    +
    54  REAL VDJB(28)
    +
    55  REAL VDJC(28)
    +
    56 C
    +
    57  INTEGER TITLE(33)
    +
    58  INTEGER KRLOC(200)
    +
    59  INTEGER KTBL(*)
    +
    60  INTEGER OUTPUT
    +
    61  INTEGER PAGNL
    +
    62  INTEGER PAGNR
    +
    63  INTEGER PAGN3
    +
    64  INTEGER PCCNT
    +
    65  INTEGER PCFST
    +
    66  INTEGER PGCNT
    +
    67  INTEGER PGCNTA
    +
    68  INTEGER PGFST
    +
    69  INTEGER PGFSTA
    +
    70  INTEGER PGMAX
    +
    71 C
    +
    72  LOGICAL DONE
    +
    73  LOGICAL LCNTR
    +
    74  LOGICAL RECT
    +
    75 C
    +
    76  CHARACTER*1 KALFA(16)
    +
    77  CHARACTER*1 KALPH(20)
    +
    78  CHARACTER*1 KHASTR
    +
    79  CHARACTER*1 KHBLNK
    +
    80  CHARACTER*1 KHDOLR
    +
    81  CHARACTER*1 KHMNS
    +
    82  CHARACTER*1 KHPLUS
    +
    83  CHARACTER*1 KHRSTR
    +
    84  CHARACTER*1 KHTBL(10)
    +
    85  CHARACTER*1 KLINE(126)
    +
    86  CHARACTER*1 KLINES(132)
    +
    87  CHARACTER*1 KNUMB(20)
    +
    88 C
    +
    89  equivalence(crmx,vdja(29))
    +
    90  equivalence(kline(1),klines(8))
    +
    91  equivalence(vdjc(1),rwa(1))
    +
    92 C
    +
    93 C ... THE VALUE CRMX IS MACHINE DEPENDENT, IT SHOULD BE
    +
    94 C ... SET TO A VALUE A LITTLE LESS THAN THE LARGEST POSITIVE
    +
    95 C ... FLOATING POINT NUMBER FOR THE COMPUTER.
    +
    96 C
    +
    97  SAVE
    +
    98 C> The value CRMX is machine dependent, it should be
    +
    99 C> set to a value a little less than the largest positive
    +
    100 C> floating point number for the computer.
    +
    101  DATA crmx /10.e70/
    +
    102  DATA kalfa /'A',' ','B',' ','C',' ','D',' ','E',' ','F',
    +
    103  & ' ','G',' ','H',' '/
    +
    104  DATA khastr/'*'/
    +
    105  DATA khblnk/' '/
    +
    106  DATA khdolr/'$'/
    +
    107  DATA khmns /'-'/
    +
    108  DATA khplus/'+'/
    +
    109  DATA khrstr/'1'/
    +
    110  DATA khtbl /'0','1','2','3','4','5','6','7','8','9'/
    +
    111 
    +
    112 C> LIMNRW is limit on number of rows allowed and is dimension of KRLOC
    +
    113  DATA limnrw/200/
    +
    114  DATA knumb /'0',' ','1',' ','2',' ','3',' ','4',' ',
    +
    115  & '5',' ','6',' ','7',' ','8',' ','9',' '/
    +
    116  DATA output/6/
    +
    117  DATA r5 /.2/
    +
    118  DATA r50 /.02/
    +
    119 C
    +
    120  8000 FORMAT (1h0,10x,44herror from w3fp10 ... number of rows in your,
    +
    121  & 9h array = ,i4,24h which exceeds limit of ,i4)
    +
    122  8100 FORMAT ( 1ht)
    +
    123  8200 FORMAT ( 1hs)
    +
    124  8300 FORMAT ( 1h ,/,1h ,/,1h )
    +
    125  8400 FORMAT ( 1h ,/,1h )
    +
    126  8500 FORMAT ( 132a1)
    +
    127  8600 FORMAT ( 33a4)
    +
    128 C
    +
    129 C COMPUTE VALUES FOR PRINTER WIDTH
    +
    130 C
    +
    131  IF (iwidth.GE.132.OR.iwidth.LE.0) pgmax = 25
    +
    132  IF (iwidth.GE.1.AND.iwidth.LE.22) pgmax = 3
    +
    133  IF (iwidth.GT.22.AND.iwidth.LT.132) pgmax = (iwidth-7) / 5
    +
    134  lw = (pgmax * 5 + 7) / 4
    +
    135  pagn3 = pgmax + 3
    +
    136  vdja(pagn3+1) = crmx
    +
    137  mxpg = pgmax * 5 + 7
    +
    138 C
    +
    139  IF (linev .NE. 0) THEN
    +
    140 C
    +
    141 C ...OTHERWISE LINEV IS NON-ZERO, SO 8 LINES/INCH IS DESIRED...
    +
    142 C
    +
    143  linate = 1
    +
    144  r4 = 0.250
    +
    145  r32 = 0.03125
    +
    146  con2 = 10.0
    +
    147  nbtwn = 3
    +
    148 C
    +
    149  ELSE
    +
    150 C
    +
    151  linate = 2
    +
    152  r4 = 0.33333333
    +
    153  r32 = 1.0 / 18.0
    +
    154  con2 = 6.0
    +
    155  nbtwn = 2
    +
    156  ENDIF
    +
    157 C
    +
    158  pgcnta = 0
    +
    159  pgfsta = 0
    +
    160  rect = .false.
    +
    161  done = .false.
    +
    162  kz = 0
    +
    163  kza = 1000
    +
    164  a = cnst(1)
    +
    165  kca = 2 * (1 - krect)
    +
    166 C
    +
    167 C TO SET NO. OF DIGITS TO BE PRINTED
    +
    168 C WHICH IS A FUNCTION OF THE TENS POSITION IN KCONTR
    +
    169 C
    +
    170  nodig = iabs(kcontr/10)
    +
    171  nodig = 3 - nodig
    +
    172 C
    +
    173 C WHERE C(NODIG) + 1 IS NO. OF DIGITS TO BE PRINTED
    +
    174 C
    +
    175  IF (nodig.LT.1 .OR. nodig.GT.3) nodig = 3
    +
    176 C
    +
    177 C ANY OUT-OF-RANGE WILL GET 4 DIGITS
    +
    178 C
    +
    179  lcntr = .false.
    +
    180  nconq = iabs(mod(kcontr,10))
    +
    181  IF (nconq .EQ. 0) GO TO 400
    +
    182  IF (nconq .LE. 2) GO TO 300
    +
    183 C
    +
    184 C OTHERWISE RESET NCONQ
    +
    185 C
    +
    186  nconq = 0
    +
    187  GO TO 400
    +
    188 C
    +
    189  300 CONTINUE
    +
    190  lcntr = .true.
    +
    191 C
    +
    192 C WITH NCONQ = 1 FOR LETTERS,AND = 2 FOR NUMBERS IN CONTOUR BANDS
    +
    193 C
    +
    194  400 CONTINUE
    +
    195  IF (nconq .NE. 2) THEN
    +
    196 C
    +
    197 C OTHERWISE SET AS LETTERS
    +
    198 C
    +
    199  kcow = 16
    +
    200  DO 500 j = 1,kcow
    +
    201  kalph(j) = kalfa(j)
    +
    202  500 CONTINUE
    +
    203 C
    +
    204  ELSE
    +
    205 C
    +
    206  kcow = 20
    +
    207  DO 700 j = 1,kcow
    +
    208  kalph(j) = knumb(j)
    +
    209  700 CONTINUE
    +
    210 C
    +
    211  ENDIF
    +
    212 C
    +
    213  radj = 4 * kcow
    +
    214  kd = 1
    +
    215 C
    +
    216 C *** SET UP TABLE OF INDICES CORRESPONDING TO FIRST ITEM IN EACH ROW
    +
    217 C *** THIS IS KRLOC
    +
    218 C *** PICK OUT SIZE AND ROW NUMBER OF LARGEST ROW (KCMX AND KCLMX)
    +
    219 C *** KZA LEFT-JUSTIFIES MAP IF ALL ROWS HAVE COMMON MINIMAL OFFSET
    +
    220 C
    +
    221  IF (ktbl(1 ).NE.(-1)) THEN
    +
    222 C
    +
    223 C *** ONE-DIMENSIONAL FORM
    +
    224 C
    +
    225  ktf = 3
    +
    226  kza = 0
    +
    227  imin = ktbl(2)
    +
    228  jmin = ktbl(3)
    +
    229  jmax = ktbl(3) + ktbl(1) - 1
    +
    230  nrws = ktbl(1)
    +
    231  IF (nrws .GT. limnrw) THEN
    +
    232  WRITE (output,8000) nrws , limnrw
    +
    233  RETURN
    +
    234  ENDIF
    +
    235  kc = 1
    +
    236 C
    +
    237  DO 1000 j = 1,nrws
    +
    238  krloc(j) = kd
    +
    239  IF (ktbl(kc+4) + ktbl(kc+3).LE.kz ) GO TO 900
    +
    240  kclmx = j
    +
    241  imax = ktbl(kc+4) + ktbl(kc+3)
    +
    242  kz = imax
    +
    243  kcmx = krloc(j) + ktbl(kc+4)
    +
    244  900 CONTINUE
    +
    245  kd = kd + ktbl(kc+4)
    +
    246  kc = kc + kca
    +
    247  1000 CONTINUE
    +
    248 C
    +
    249  ELSE
    +
    250 C
    +
    251 C *** TWO-DIMENSIONAL FORM
    +
    252 C *** THE TWO-DIMENSIONAL FORM IS COMPILER-DEPENDENT
    +
    253 C *** IT DEPENDS ON THE TWO-DIMENSIONAL ARRAY BEING STORED COLUMN-WISE
    +
    254 C *** THAT IS, WITH THE FIRST INDEX VARYING THE FASTEST
    +
    255 C
    +
    256  imin = ktbl(6)
    +
    257  jmin = ktbl(7)
    +
    258  nrws = ktbl(5)
    +
    259  IF (nrws .GT. limnrw) THEN
    +
    260  WRITE (output,8000) nrws , limnrw
    +
    261  RETURN
    +
    262  ENDIF
    +
    263 C
    +
    264  jmax = ktbl(7) + ktbl(5) -1
    +
    265  kc = 1
    +
    266  DO 1500 j = 1,nrws
    +
    267  krloc(j) = ktbl(2) * (ktbl(4)-nrws+j-1) + ktbl(kc+7) + 1
    +
    268  IF (ktbl(kc+7) + ktbl(kc+8).LE.kz) GO TO 1400
    +
    269  imax = ktbl(kc+7) + ktbl(kc+8)
    +
    270  kz = imax
    +
    271  kcmx = krloc(j) + ktbl(kc+8)
    +
    272  kclmx = j
    +
    273  1400 CONTINUE
    +
    274  IF (ktbl(kc+7).LT.kza) kza = ktbl(kc+7)
    +
    275  kc = kc + kca
    +
    276  1500 CONTINUE
    +
    277  imax = imax - kza
    +
    278  ktf = 7
    +
    279  ENDIF
    +
    280 C
    +
    281  pagnl = 0
    +
    282  pagnr = pgmax
    +
    283  IF (.NOT.lcntr) GO TO 1700
    +
    284  adc = (cnst(1) - cnst(4)) / cnst(3) + radj
    +
    285  bc = cnst(2) / cnst(3)
    +
    286 C
    +
    287 C *** PRINT I-LABELS ACROSS TOP OF MAP
    +
    288 C
    +
    289  1700 CONTINUE
    +
    290 C
    +
    291 C *** WHICH PREPARES CDC512 PRINTER FOR 8 LINES PER INCH
    +
    292 C
    +
    293  IF (linate.EQ.1) WRITE (output,8100)
    +
    294 C
    +
    295 C ...WHICH PREPARES PRINTER FOR 6 LINES PER INCH
    +
    296 C
    +
    297  IF (linate.EQ.2) WRITE (output,8200)
    +
    298  klines(1) = khrstr
    +
    299  kbr = 1
    +
    300  GO TO 6900
    +
    301 C
    +
    302  1800 CONTINUE
    +
    303  IF (.NOT.lcntr) GO TO 2000
    +
    304 C
    +
    305 C *** INITIALIZE CONTOUR WORKING AREA
    +
    306 C
    +
    307  DO 1900 j = 1,pagn3
    +
    308  rwc(j) = crmx
    +
    309  rwd(j) = crmx
    +
    310  1900 CONTINUE
    +
    311 C
    +
    312 C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR FIRST TWO ROWS
    +
    313 C
    +
    314  2000 CONTINUE
    +
    315  kra = 1
    +
    316  kc = ktf + 1
    +
    317  kbr = 2
    +
    318  GO TO 5900
    +
    319 C
    +
    320  2100 CONTINUE
    +
    321  kra = 2
    +
    322  kc = kc + kca
    +
    323  kbr = 3
    +
    324  GO TO 5900
    +
    325 C
    +
    326  2200 CONTINUE
    +
    327  kr = 0
    +
    328 C
    +
    329 C *** TEST IF THIS IS LAST PAGE
    +
    330 C
    +
    331  IF (imax.GT.pgmax-1) GO TO 2300
    +
    332  lmr = imax * 5 + 2
    +
    333  done = .true.
    +
    334 C
    +
    335 C *** DO LEFT J-LABELS
    +
    336 C
    +
    337  2300 CONTINUE
    +
    338  jcurr = jmin
    +
    339 C
    +
    340  2400 CONTINUE
    +
    341  kr = kr + 1
    +
    342  kra = kr + 2
    +
    343  kc = kc + kca
    +
    344  kta = mod(jcurr,10)
    +
    345  ktb = mod(jcurr,100)/10
    +
    346  ktc = mod(jcurr,1000)/100
    +
    347  IF (kr .EQ. 1 .OR. (.NOT. lcntr)) GO TO 2500
    +
    348  GO TO 2600
    +
    349 C
    +
    350  2500 CONTINUE
    +
    351  IF (linate.EQ.1) WRITE (output,8300)
    +
    352  IF (linate.EQ.2) WRITE (output,8400)
    +
    353 C
    +
    354  2600 CONTINUE
    +
    355  klines(2) = khplus
    +
    356  klines(1) = khblnk
    +
    357  IF (jcurr.LT.0) klines(2) = khmns
    +
    358  kta = iabs(kta)
    +
    359  ktb = iabs(ktb)
    +
    360  ktc = iabs(ktc)
    +
    361  IF (ktc .EQ. 0) GO TO 2700
    +
    362  klines(3) = khtbl(ktc+1)
    +
    363  klines(4) = khtbl(ktb+1)
    +
    364  klines(5) = khtbl(kta+1)
    +
    365  GO TO 2800
    +
    366 C
    +
    367  2700 CONTINUE
    +
    368  klines(3) = khtbl(ktb+1)
    +
    369  klines(4) = khtbl(kta+1)
    +
    370  klines(5) = khblnk
    +
    371 C
    +
    372  2800 CONTINUE
    +
    373  DO 2900 j = 6,mxpg
    +
    374  klines(j) = khblnk
    +
    375  2900 CONTINUE
    +
    376  IF (.NOT.done) GO TO 3000
    +
    377 C
    +
    378 C *** DO RIGHT J-LABELS IF LAST PAGE OF MAP
    +
    379 C
    +
    380  kline(lmr) = klines(2)
    +
    381  kline(lmr+1) = klines(3)
    +
    382  kline(lmr+2) = klines(4)
    +
    383  kline(lmr+3) = klines(5)
    +
    384 C
    +
    385 C *** FETCH AND CONVERT GRID VALUES TO A1 FORMAT FOR WHOLE LINE
    +
    386 C
    +
    387  3000 CONTINUE
    +
    388  krx = krloc(kr)
    +
    389  klx = 5 * pgfst + 1
    +
    390  IF (pgcnt.EQ.0) GO TO 4000
    +
    391  DO 3800 kk = 1,pgcnt
    +
    392  temp = rdata(krx) * cnst(2) + a
    +
    393  ktemp = abs(temp) + 0.5
    +
    394  kline(klx) = khplus
    +
    395  IF (temp.LT.0.0) kline(klx) = khmns
    +
    396  GO TO (3300,3200,3100),nodig
    +
    397  3100 CONTINUE
    +
    398  kta = mod(ktemp,10000)/1000
    +
    399 C
    +
    400  3200 CONTINUE
    +
    401  ktb = mod(ktemp,1000)/100
    +
    402 C
    +
    403  3300 CONTINUE
    +
    404  ktc = mod(ktemp,100)/10
    +
    405  ktd = mod(ktemp,10)
    +
    406  GO TO (3400,3500,3600),nodig
    +
    407 C
    +
    408  3400 CONTINUE
    +
    409  kline(klx+1) = khtbl(ktc+1)
    +
    410  kline(klx+2) = khtbl(ktd+1)
    +
    411  GO TO 3700
    +
    412 C
    +
    413  3500 CONTINUE
    +
    414  kline(klx+1) = khtbl(ktb+1)
    +
    415  kline(klx+2) = khtbl(ktc+1)
    +
    416  kline(klx+3) = khtbl(ktd+1)
    +
    417  GO TO 3700
    +
    418 C
    +
    419  3600 CONTINUE
    +
    420  kline(klx+1) = khtbl(kta+1)
    +
    421  kline(klx+2) = khtbl(ktb+1)
    +
    422  kline(klx+3) = khtbl(ktc+1)
    +
    423  kline(klx+4) = khtbl(ktd+1)
    +
    424 C
    +
    425  3700 CONTINUE
    +
    426  klx = klx + 5
    +
    427  krx = krx + 1
    +
    428  3800 CONTINUE
    +
    429 C
    +
    430 C *** FOLLOWING CHECKS FOR POLE POINT AND INSERTS PROPER CHARACTER.
    +
    431 C
    +
    432  IF (jcurr.NE.0) GO TO 4000
    +
    433  IF (imin.LT.(-25).OR.imin.GT.0) GO TO 4000
    +
    434  kx = -imin
    +
    435  IF (kx.LT.pgfst.AND.kx.GT.pgcnt+pgfst) GO TO 4000
    +
    436  kx = 5 * kx
    +
    437  IF (kline(kx+1).EQ.khmns) GO TO 3900
    +
    438  kline(kx) = khdolr
    +
    439  GO TO 4000
    +
    440 C
    +
    441  3900 CONTINUE
    +
    442  kline(kx+1) = khastr
    +
    443 C
    +
    444 C *** PRINT LINE OF MAP DATA
    +
    445 C
    +
    446  4000 CONTINUE
    +
    447  WRITE (output,8500) (klines(ii),ii=1,mxpg)
    +
    448  krloc(kr) = krx
    +
    449  jcurr = jcurr + 1
    +
    450 C JCURR = JCURR + JRWMP
    +
    451 C
    +
    452 C *** TEST BOTTOM OF MAP
    +
    453 C
    +
    454  IF (kr.EQ.nrws) GO TO 5700
    +
    455 C
    +
    456 C *** SET UP CONTOUR DATA AND PAGE LIMITERS FOR NEXT ROW
    +
    457 C
    +
    458  kbr = 4
    +
    459  GO TO 5900
    +
    460 C
    +
    461  4100 CONTINUE
    +
    462  IF (.NOT.lcntr) GO TO 2400
    +
    463 C
    +
    464 C *** DO CONTOURING
    +
    465 C
    +
    466  DO 4200 jj = 1,mxpg
    +
    467  klines(jj) = khblnk
    +
    468  4200 CONTINUE
    +
    469 C
    +
    470 C *** VERTICAL INTERPOLATIONS
    +
    471 C
    +
    472  DO 4700 kk = 1,pagn3
    +
    473  IF (rwb(kk).LT.crmx.AND.rwc(kk).LT.crmx) GO TO 4300
    +
    474  vdjb(kk) = crmx
    +
    475  vdjc(kk) = crmx
    +
    476  GO TO 4600
    +
    477 C
    +
    478  4300 CONTINUE
    +
    479  IF (rwa(kk).LT.crmx.AND.rwd(kk).LT.crmx) GO TO 4400
    +
    480  vdjc(kk) = 0.
    +
    481  GO TO 4500
    +
    482 C
    +
    483  4400 CONTINUE
    +
    484  vdjc(kk) = r32*(rwa(kk)+rwd(kk)-rwb(kk)-rwc(kk))
    +
    485 C
    +
    486  4500 CONTINUE
    +
    487  vdjb(kk) = r4*(rwc(kk)-rwb(kk)-con2*vdjc(kk))
    +
    488 C
    +
    489  4600 CONTINUE
    +
    490  vdja(kk)=rwb(kk)
    +
    491 C
    +
    492  4700 CONTINUE
    +
    493 C
    +
    494 C ...DO 2 OR 3 ROWS OF CONTOURING BETWEEN GRID ROWS...
    +
    495 C
    +
    496  DO 5600 ll = 1,nbtwn
    +
    497  DO 4800 kk = 1,pagn3
    +
    498  vdjb(kk) = vdjc(kk) + vdjb(kk)
    +
    499  vdja(kk) = vdjb(kk) + vdja(kk)
    +
    500  4800 CONTINUE
    +
    501 C
    +
    502 C ...WHERE VDJA HAS THE INTERPOLATED VALUE FOR THIS INTER-ROW
    +
    503 C *** HORIZONTAL INTERPOLATIONS
    +
    504 C
    +
    505  hdc = 0.0
    +
    506  IF (vdja(1).GE.crmx) GO TO 4900
    +
    507  hdc = r50*(vdja(4)+vdja(1)-vdja(2)-vdja(3))
    +
    508 C
    +
    509  4900 CONTINUE
    +
    510  kxb = 0
    +
    511  DO 5200 kk = 1,pgmax
    +
    512  IF (vdja(kk+1).GE.crmx) GO TO 5100
    +
    513  hda = vdja(kk+1)
    +
    514  IF (vdja(kk+2).GE.crmx) GO TO 5500
    +
    515  IF (vdja(kk+3).GE.crmx) hdc = 0.0
    +
    516  hdb = r5 * (vdja(kk+2) - vdja(kk+1) - 15.0 * hdc)
    +
    517 C
    +
    518 C *** COMPUTE AND STORE CONTOUR CHARACTERS, 5 PER POINT
    +
    519 C
    +
    520  khda = hda
    +
    521  kdb = iabs(mod(khda,kcow))
    +
    522  kline(kxb+1) = kalph(kdb+1)
    +
    523  DO 5000 jj = 2,5
    +
    524  hdb = hdb + hdc
    +
    525  hda = hda + hdb
    +
    526  khda = hda
    +
    527  kdb = iabs(mod(khda,kcow))
    +
    528  kxa = kxb + jj
    +
    529  kline(kxa) = kalph(kdb+1)
    +
    530  5000 CONTINUE
    +
    531  hdc = r50*(vdja(kk+4)+vdja(kk+1)-vdja(kk+2)-vdja(kk+3))
    +
    532  IF (vdja(kk+4).GE.crmx) hdc = 0.0
    +
    533 C
    +
    534  5100 CONTINUE
    +
    535  kxb = kxb + 5
    +
    536 C
    +
    537  5200 CONTINUE
    +
    538 C
    +
    539  5300 CONTINUE
    +
    540  WRITE (output,8500) (klines(ii),ii=1,mxpg)
    +
    541  DO 5400 kk = 1,mxpg
    +
    542  klines(kk) = khblnk
    +
    543  5400 CONTINUE
    +
    544  GO TO 5600
    +
    545 C
    +
    546  5500 CONTINUE
    +
    547  khda = hda
    +
    548  kdb = iabs(mod(khda,kcow))
    +
    549  kline(kxb+1) = kalph(kdb+1)
    +
    550  GO TO 5300
    +
    551 C
    +
    552  5600 CONTINUE
    +
    553  GO TO 2400
    +
    554 C
    +
    555  5700 CONTINUE
    +
    556  IF (linate.EQ.1) WRITE (output,8300)
    +
    557  IF (linate.EQ.2) WRITE (output,8400)
    +
    558  klines(1) = khblnk
    +
    559 C
    +
    560 C *** PRINT I-LABELS ACROSS BOTTOM OF PAGE
    +
    561 C
    +
    562  kbr = 5
    +
    563  GO TO 6900
    +
    564 C
    +
    565  5800 CONTINUE
    +
    566  IF (linate.EQ.1) WRITE (output,8300)
    +
    567  IF (linate.EQ.2) WRITE (output,8400)
    +
    568 C
    +
    569 C *** PRINT TITLE
    +
    570 C
    +
    571  WRITE (output,8600) (title(ii),ii=1,lw)
    +
    572 C
    +
    573 C *** TEST END OF MAP
    +
    574 C
    +
    575  IF (krloc(kclmx).EQ.kcmx) RETURN
    +
    576 C
    +
    577 C *** ADJUST PAGE LINE BOUNDARIES
    +
    578 C
    +
    579  IF (imax.GT.pgmax) imax = imax - pgmax
    +
    580  imin = ka
    +
    581  pagnl = pagnl + pgmax
    +
    582  pagnr = pagnr + pgmax
    +
    583  GO TO 1700
    +
    584 C
    +
    585 C *** ROUTINE TO PRE-STORE ROWS FOR CONTOURING AND COMPUTE LINE LIMITERS
    +
    586 C
    +
    587  5900 CONTINUE
    +
    588  pgfst = pgfsta
    +
    589  pgcnt = pgcnta
    +
    590  IF (kra.GT.nrws) GO TO 6800
    +
    591  krfst = ktbl(kc) - kza
    +
    592  krcnt = ktbl(kc+1)
    +
    593  kfx = krloc(kra)
    +
    594  IF (rect) GO TO 6100
    +
    595  IF (krfst-pagnl.LE.(-1)) GO TO 6400
    +
    596  pcfst = krfst - pagnl + 1
    +
    597  IF (pcfst.GE.pagn3) GO TO 6700
    +
    598  pgfsta = pcfst-1
    +
    599  pccnt = min(pagnr-krfst+2,krcnt)
    +
    600  IF (pgfsta.EQ.0) GO TO 6600
    +
    601  pgcnta = min(pagnr-krfst,krcnt)
    +
    602  IF (pgcnta.GT.0) GO TO 6000
    +
    603  pgcnta = 0
    +
    604  GO TO 6100
    +
    605 C
    +
    606  6000 CONTINUE
    +
    607  rect = krect.EQ.1.AND.pgcnta.LE.krcnt
    +
    608 C
    +
    609  6100 CONTINUE
    +
    610  IF (.NOT.lcntr) GO TO (1800,2100,2200,4100,5800) kbr
    +
    611  DO 6200 kk = 1,pagn3
    +
    612  rwa(kk) = rwb(kk)
    +
    613  rwb(kk) = rwc(kk)
    +
    614  rwc(kk) = rwd(kk)
    +
    615  rwd(kk) = crmx
    +
    616  6200 CONTINUE
    +
    617 C
    +
    618  IF (pccnt.EQ.0) GO TO (1800,2100,2200,4100,5800) kbr
    +
    619  kpc = pcfst + 1
    +
    620  DO 6300 kk = 1,pccnt
    +
    621  rwd(kpc) = rdata(kfx) * bc + adc
    +
    622  kfx = kfx + 1
    +
    623  kpc = kpc + 1
    +
    624  6300 CONTINUE
    +
    625  GO TO (1800,2100,2200,4100,5800) kbr
    +
    626 C
    +
    627  6400 CONTINUE
    +
    628  pcfst = 0
    +
    629  pgfsta = 0
    +
    630  kfx = kfx - 1
    +
    631  pccnt = krfst + krcnt - pagnl + 1
    +
    632  IF (pccnt.LT.pagn3) GO TO 6500
    +
    633  pccnt = pagn3
    +
    634  pgcnta = pgmax
    +
    635  GO TO 6100
    +
    636 C
    +
    637  6500 CONTINUE
    +
    638  IF (pccnt.GT.0) GO TO 6600
    +
    639  pgcnta = 0
    +
    640  pccnt = 0
    +
    641  GO TO 6100
    +
    642 C
    +
    643  6600 CONTINUE
    +
    644  pgcnta = min(pgmax,krcnt+krfst-pagnl)
    +
    645  GO TO 6100
    +
    646 C
    +
    647  6700 CONTINUE
    +
    648  pgcnta = 0
    +
    649 C
    +
    650  6800 CONTINUE
    +
    651  pccnt = 0
    +
    652  GO TO 6100
    +
    653 C
    +
    654 C *** ROUTINE TO PRINT I-LABELS
    +
    655 C
    +
    656  6900 CONTINUE
    +
    657  DO 7000 kk = 2,mxpg
    +
    658  klines(kk) = khblnk
    +
    659  7000 CONTINUE
    +
    660 C
    +
    661  kk = 1
    +
    662  ka = imin
    +
    663  lbl = min(imax,pgmax)
    +
    664 C
    +
    665  DO 7300 jj = 1,lbl
    +
    666  kline(kk) = khplus
    +
    667  IF (ka.LT.0) kline(kk) = khmns
    +
    668  kta = iabs(mod(ka,100)) / 10
    +
    669  ktb = iabs(mod(ka,10))
    +
    670  ktc = iabs(mod(ka,1000)) / 100
    +
    671  IF (ktc .EQ. 0) GO TO 7100
    +
    672  kline(kk+1) = khtbl(ktc+1)
    +
    673  kline(kk+2) = khtbl(kta+1)
    +
    674  kline(kk+3) = khtbl(ktb+1)
    +
    675  GO TO 7200
    +
    676 C
    +
    677  7100 CONTINUE
    +
    678  kline(kk+1) = khtbl(kta+1)
    +
    679  kline(kk+2) = khtbl(ktb+1)
    +
    680 C
    +
    681  7200 CONTINUE
    +
    682  kk = kk + 5
    +
    683  ka = ka + 1
    +
    684 C
    +
    685  7300 CONTINUE
    +
    686 C
    +
    687  WRITE (output,8500) (klines(ii),ii=1,mxpg)
    +
    688 C
    +
    689  GO TO (1800,2100,2200,4100,5800) kbr
    +
    690 C
    +
    691  7400 CONTINUE
    +
    692  RETURN
    +
    693 C
    +
    694  END
    +
    +
    +
    w3fp10
    subroutine w3fp10(RDATA, KTBL, CNST, TITLE, KRECT, KCONTR, LINEV, IWIDTH)
    Prints a two-dimensional grid of any shape, with contouring, if desired.
    Definition: w3fp10.f:46
    + + + + diff --git a/ver-2.10.0/w3fp11_8f.html b/ver-2.10.0/w3fp11_8f.html new file mode 100644 index 00000000..99e4de57 --- /dev/null +++ b/ver-2.10.0/w3fp11_8f.html @@ -0,0 +1,282 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp11.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fp11.f File Reference
    +
    +
    + +

    One-line GRIB titler from pds section. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fp11 (IPDS0, IPDS, TITL, IERR)
     Converts GRIB formatted product definition section version 1 to a one line readable title. More...
     
    +

    Detailed Description

    +

    One-line GRIB titler from pds section.

    +
    Author
    Ralph Jones
    +
    Date
    1991-06-19
    + +

    Definition in file w3fp11.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fp11()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fp11 (character * 8 IPDS0,
    character * (*) IPDS,
    character * 86 TITL,
    integer IERR 
    )
    +
    + +

    Converts GRIB formatted product definition section version 1 to a one line readable title.

    +

    GRIB section 0 is also tested to verify that GRIB data is being deciphered.

    +

    +Program History Log:

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Date Programmer Comments
    1991-06-19 Ralph Jones Initial
    1992-05-29 Ralph Jones Add water temp to tables
    1993-01-19 Ralph Jones Add montgomary stream function to tables. add code for surface value 113. add condensation pressure to tables
    1993-02-19 Ralph Jones Add cape and tke (157 & 158) to tables
    1993-02-24 Ralph Jones Add GRIB type pmsle (130) to tables
    1993-03-26 Ralph Jones Add GRIB type sglyr (175) to tables
    1993-03-27 Ralph Jones Changes for revised o.n.388 mar. 3,1993
    1993-03-29 Ralph Jones Add save statement
    1993-04-16 Ralph Jones Add GRIB type lat, lon (176,177) to tables
    1993-04-25 Ralph Jones Add GRIB type 204, 205, 211, 212, 218
    1993-05-18 Ralph Jones Add test for model 70
    1993-06-26 Ralph Jones Add GRIB type 128, 129, take out test for MODEL 86.
    1993-08-07 Ralph Jones Add GRIB type 156 (cin), 150 (cbmzw), 151 (cbtzw), 152 (cbtmw) to tables.
    1993-10-14 Ralph Jones Change for o.n. 388 rev. oct. 8,1993
    1993-10-29 Ralph Jones Change for 'l cdc' 'm cdc' 'h cdc'
    1993-10-14 Ralph Jones Change for o.n. 388 rev. nov. 19,1993
    1994-02-05 Ralph Jones Change for o.n. 388 rev. dec. 14,1993. add model number 86 and 87.
    1994-03-24 Ralph Jones Add GRIB type 24 (toto3), 206 (uvpi)
    1994-06-04 Ralph Jones Change uvpi to uvi
    1994-06-16 Ralph Jones Add GRIB type 144,145,146,147,148,149 soilw,pevpr,cwork,u-gwd,v-gwd,pv to tables.
    1994-06-22 Ralph Jones Add ncar (60) to centers
    1994-07-25 Ralph Jones Correction for 71, 72, 213 (t cdc), (cdcon), (cdlyr)
    1994-10-27 Ralph Jones Add GRIB type 191 (prob), 192 (probn), add test for model 90, 91, 92, 93, add sub center 2.
    1995-02-09 Ralph Jones Correction for century for fnoc
    1995-04-11 Ralph Jones Correction for lmh and lmv
    1995-06-20 Ralph Jones Add GRIB type 189 (vstm), 190 (hlcy), 193 (pop), 194 (cpofp), 195 (cpozp), 196 (ustm), 197 (vstm) to tables.
    1995-08-07 Ralph Jones Add GRIB type 153 (clwmr), 154 (o3mr), 221 (hpbl), 237 (o3tot).
    1995-09-07 Ralph Jones Take out GRIB type 24 (toto3), change to GRIB type 10 (tozne). add level 117, potential vortiticity (pv) level, add eta
    Level 119, add 120 layer betwwen two eta levels. change name of level 107 to (sigl), change name of level 108 to (sigy).
    1995-09-26 Ralph Jones Add level 204 (htfl) highest tropsphere freezing level.
    1995-10-19 Ralph Jones Change some of the level abreviations.
    1995-12-13 Ralph Jones Add 8 sub-centers to tables
    1996-03-04 Ralph Jones Changes for o.n. 388 jan 2, 1996
    1996-03-22 Ralph Jones Change scusf to csusf
    1996-10-01 Mark Iredell Recognize forecast time units 1 to 12 and correct for year 2000
    1996-10-31 Ralph Jones Change array and table for ics1 to 10.
    1996-10-01 Mark Iredell Allow parameter table version up to 127
    1998-05-26 Stephen Gilbert Added 17 new parameters ( GRIB table 2 ). added 6 new special levels for clouds. added subcenter 11 (tdl) under center 7 (ncep)
    1998-12-21 Stephen Gilbert Replaced function ichar with mova2i.
    1901-01-05 Boi Vuong Add level 247 (ehlt) equilibrium level
    1902-05-01 Boi Vuong Changes for o.n. 388 mar 21, 2002
    1902-03-25 Boi Vuong Add GRIB table version 129 and 130
    1903-07-02 Stephen Gilbert Added 5 new params to table version 129
    1904-14-04 Boi Vuong Add GRIB table version 131 and added 12 new parameter to table version 129
    1904-08-09 Boi Vuong Add parameter (thflx) to table version 129
    1905-02-08 Cooke Corrected entry for freezing rain, crfzr to cfrzr in the hhnam1 array
    1906-08-11 Boi Vuong Add levels (235,236,237,238,240,245) and added new parameters to table version 129 and added
    One parameter 154 to table version 130 and added table version 128
    1907-04-05 Boi Vuong Add parameters to table version 128, 129 and 130
    1907-05-15 Boi Vuong Added time range indicator 51 and new table 140
    +
    Parameters
    + + + + + +
    [in]IPDS0GRIB section 0 read as character*8
    [in]IPDSGRIB pds section read as character*28
    [out]TITLCharacter*86 output print line
    [out]IERR0 - Completed satisfactorily 1 - GRIB section 0, can not find 'GRIB' 2 - GRIB is not version 1 3 - Length of pds section is less than 28 4 - Could not match type indicator 5 - Could not match type level 6 - Could not interpret originator of code 7 - Could not interpret sub center 7 originator of code 8 - Could not interpret sub center 9 originator of code 9 - Parameter table version not 1 or 2
    +
    +
    + +

    Definition at line 79 of file w3fp11.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fp11_8f.js b/ver-2.10.0/w3fp11_8f.js new file mode 100644 index 00000000..26f7219c --- /dev/null +++ b/ver-2.10.0/w3fp11_8f.js @@ -0,0 +1,4 @@ +var w3fp11_8f = +[ + [ "w3fp11", "w3fp11_8f.html#a60348721f6e1b543427aba610af0a85d", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fp11_8f_source.html b/ver-2.10.0/w3fp11_8f_source.html new file mode 100644 index 00000000..871f5c14 --- /dev/null +++ b/ver-2.10.0/w3fp11_8f_source.html @@ -0,0 +1,918 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp11.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fp11.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief One-line GRIB titler from pds section.
    +
    3 C> @author Ralph Jones @date 1991-06-19
    +
    4 
    +
    5 C> Converts GRIB formatted product definition section version
    +
    6 C> 1 to a one line readable title. GRIB section 0 is also tested to
    +
    7 C> verify that GRIB data is being deciphered.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comments
    +
    11 C> -----|------------|---------
    +
    12 C> 1991-06-19 | Ralph Jones | Initial
    +
    13 C> 1992-05-29 | Ralph Jones | Add water temp to tables
    +
    14 C> 1993-01-19 | Ralph Jones | Add montgomary stream function to tables. add code for surface value 113. add condensation pressure to tables
    +
    15 C> 1993-02-19 | Ralph Jones | Add cape and tke (157 & 158) to tables
    +
    16 C> 1993-02-24 | Ralph Jones | Add GRIB type pmsle (130) to tables
    +
    17 C> 1993-03-26 | Ralph Jones | Add GRIB type sglyr (175) to tables
    +
    18 C> 1993-03-27 | Ralph Jones | Changes for revised o.n.388 mar. 3,1993
    +
    19 C> 1993-03-29 | Ralph Jones | Add save statement
    +
    20 C> 1993-04-16 | Ralph Jones | Add GRIB type lat, lon (176,177) to tables
    +
    21 C> 1993-04-25 | Ralph Jones | Add GRIB type 204, 205, 211, 212, 218
    +
    22 C> 1993-05-18 | Ralph Jones | Add test for model 70
    +
    23 C> 1993-06-26 | Ralph Jones | Add GRIB type 128, 129, take out test for MODEL 86.
    +
    24 C> 1993-08-07 | Ralph Jones | Add GRIB type 156 (cin), 150 (cbmzw), 151 (cbtzw), 152 (cbtmw) to tables.
    +
    25 C> 1993-10-14 | Ralph Jones | Change for o.n. 388 rev. oct. 8,1993
    +
    26 C> 1993-10-29 | Ralph Jones | Change for 'l cdc' 'm cdc' 'h cdc'
    +
    27 C> 1993-10-14 | Ralph Jones | Change for o.n. 388 rev. nov. 19,1993
    +
    28 C> 1994-02-05 | Ralph Jones | Change for o.n. 388 rev. dec. 14,1993. add model number 86 and 87.
    +
    29 C> 1994-03-24 | Ralph Jones | Add GRIB type 24 (toto3), 206 (uvpi)
    +
    30 C> 1994-06-04 | Ralph Jones | Change uvpi to uvi
    +
    31 C> 1994-06-16 | Ralph Jones | Add GRIB type 144,145,146,147,148,149 soilw,pevpr,cwork,u-gwd,v-gwd,pv to tables.
    +
    32 C> 1994-06-22 | Ralph Jones | Add ncar (60) to centers
    +
    33 C> 1994-07-25 | Ralph Jones | Correction for 71, 72, 213 (t cdc), (cdcon), (cdlyr)
    +
    34 C> 1994-10-27 | Ralph Jones | Add GRIB type 191 (prob), 192 (probn), add test for model 90, 91, 92, 93, add sub center 2.
    +
    35 C> 1995-02-09 | Ralph Jones | Correction for century for fnoc
    +
    36 C> 1995-04-11 | Ralph Jones | Correction for lmh and lmv
    +
    37 C> 1995-06-20 | Ralph Jones | Add GRIB type 189 (vstm), 190 (hlcy), 193 (pop), 194 (cpofp), 195 (cpozp), 196 (ustm), 197 (vstm) to tables.
    +
    38 C> 1995-08-07 | Ralph Jones | Add GRIB type 153 (clwmr), 154 (o3mr), 221 (hpbl), 237 (o3tot).
    +
    39 C> 1995-09-07 | Ralph Jones | Take out GRIB type 24 (toto3), change to GRIB type 10 (tozne). add level 117, potential vortiticity (pv) level, add eta
    +
    40 C> ^ | ^ | Level 119, add 120 layer betwwen two eta levels. change name of level 107 to (sigl), change name of level 108 to (sigy).
    +
    41 C> 1995-09-26 | Ralph Jones | Add level 204 (htfl) highest tropsphere freezing level.
    +
    42 C> 1995-10-19 | Ralph Jones | Change some of the level abreviations.
    +
    43 C> 1995-12-13 | Ralph Jones | Add 8 sub-centers to tables
    +
    44 C> 1996-03-04 | Ralph Jones | Changes for o.n. 388 jan 2, 1996
    +
    45 C> 1996-03-22 | Ralph Jones | Change scusf to csusf
    +
    46 C> 1996-10-01 | Mark Iredell | Recognize forecast time units 1 to 12 and correct for year 2000
    +
    47 C> 1996-10-31 | Ralph Jones | Change array and table for ics1 to 10.
    +
    48 C> 1996-10-01 | Mark Iredell | Allow parameter table version up to 127
    +
    49 C> 1998-05-26 | Stephen Gilbert | Added 17 new parameters ( GRIB table 2 ). added 6 new special levels for clouds. added subcenter 11 (tdl) under center 7 (ncep)
    +
    50 C> 1998-12-21 | Stephen Gilbert | Replaced function ichar with mova2i.
    +
    51 C> 1901-01-05 | Boi Vuong | Add level 247 (ehlt) equilibrium level
    +
    52 C> 1902-05-01 | Boi Vuong | Changes for o.n. 388 mar 21, 2002
    +
    53 C> 1902-03-25 | Boi Vuong | Add GRIB table version 129 and 130
    +
    54 C> 1903-07-02 | Stephen Gilbert | Added 5 new params to table version 129
    +
    55 C> 1904-14-04 | Boi Vuong | Add GRIB table version 131 and added 12 new parameter to table version 129
    +
    56 C> 1904-08-09 | Boi Vuong | Add parameter (thflx) to table version 129
    +
    57 C> 1905-02-08 | Cooke | Corrected entry for freezing rain, crfzr to cfrzr in the hhnam1 array
    +
    58 C> 1906-08-11 | Boi Vuong | Add levels (235,236,237,238,240,245) and added new parameters to table version 129 and added
    +
    59 C> ^ | ^ | One parameter 154 to table version 130 and added table version 128
    +
    60 C> 1907-04-05 | Boi Vuong | Add parameters to table version 128, 129 and 130
    +
    61 C> 1907-05-15 | Boi Vuong | Added time range indicator 51 and new table 140
    +
    62 C>
    +
    63 C> @param[in] IPDS0 GRIB section 0 read as character*8
    +
    64 C> @param[in] IPDS GRIB pds section read as character*28
    +
    65 C> @param[out] TITL Character*86 output print line
    +
    66 C> @param[out] IERR
    +
    67 C> 0 - Completed satisfactorily
    +
    68 C> 1 - GRIB section 0, can not find 'GRIB'
    +
    69 C> 2 - GRIB is not version 1
    +
    70 C> 3 - Length of pds section is less than 28
    +
    71 C> 4 - Could not match type indicator
    +
    72 C> 5 - Could not match type level
    +
    73 C> 6 - Could not interpret originator of code
    +
    74 C> 7 - Could not interpret sub center 7 originator of code
    +
    75 C> 8 - Could not interpret sub center 9 originator of code
    +
    76 C> 9 - Parameter table version not 1 or 2
    +
    77 C>
    +
    78  SUBROUTINE w3fp11 (IPDS0, IPDS, TITL, IERR)
    +
    79  INTEGER CENTER(17)
    +
    80  INTEGER SCNTR1(16)
    +
    81  INTEGER SCNTR2(14)
    +
    82  INTEGER FCSTIM
    +
    83  INTEGER HH(252)
    +
    84  INTEGER HH1(105)
    +
    85  INTEGER HH2(105)
    +
    86  INTEGER HH3(42)
    +
    87  INTEGER HH128(72)
    +
    88  INTEGER HH129(98)
    +
    89  INTEGER HH130(112)
    +
    90  INTEGER HH131(241)
    +
    91  INTEGER HH140(112)
    +
    92  INTEGER HHH(73)
    +
    93  INTEGER IERR
    +
    94  INTEGER P1
    +
    95  INTEGER P2
    +
    96  INTEGER TIMERG
    +
    97 C
    +
    98  CHARACTER * 6 HHNAM(252)
    +
    99  CHARACTER * 6 HHNAM1(105)
    +
    100  CHARACTER * 6 HHNAM2(105)
    +
    101  CHARACTER * 6 HHNAM3(42)
    +
    102  CHARACTER * 6 HHNAM128(72)
    +
    103  CHARACTER * 6 HHNAM129(98)
    +
    104  CHARACTER * 6 HHNAM130(112)
    +
    105  CHARACTER * 6 HHNAM140(112)
    +
    106  CHARACTER * 6 HHNAM131(241)
    +
    107  CHARACTER * 4 HHHNAM(73)
    +
    108  CHARACTER * (*) IPDS
    +
    109  CHARACTER * 8 IPDS0
    +
    110  CHARACTER * 28 IDPDS
    +
    111  CHARACTER * 4 GRIB
    +
    112  CHARACTER * 28 KNAM1(17)
    +
    113  CHARACTER * 28 KNAM2(16)
    +
    114  CHARACTER * 28 KNAM3(14)
    +
    115  CHARACTER * 3 MONTH(12)
    +
    116  CHARACTER * 4 TIMUN(12)
    +
    117  CHARACTER * 2 TIMUN1(12)
    +
    118  CHARACTER * 86 TITL
    +
    119 C
    +
    120  equivalence(hh(1),hh1(1))
    +
    121  equivalence(hh(106),hh2(1))
    +
    122  equivalence(hh(211),hh3(1))
    +
    123  equivalence(hhnam(1),hhnam1(1))
    +
    124  equivalence(hhnam(106),hhnam2(1))
    +
    125  equivalence(hhnam(211),hhnam3(1))
    +
    126 C
    +
    127  SAVE
    +
    128 C
    +
    129  DATA center/ 7, 8, 9, 34, 52, 54, 57,
    +
    130  & 58, 59, 60, 61, 62, 74, 85,
    +
    131  & 97, 98, 99/
    +
    132 C
    +
    133 C TABLE 3 - TYPE AND VALUE OF LEVELS (PDS OCTETS 10, 11 AND 12)
    +
    134 C
    +
    135  DATA hhh / 1, 2, 3, 4, 5, 6, 7,
    +
    136  & 8, 9, 20, 100, 101, 102, 103,
    +
    137  & 104, 105, 106, 107, 108, 109, 110,
    +
    138  & 111, 112, 113, 114, 115, 116, 117,
    +
    139  & 119, 120, 121, 125, 126, 128, 141,
    +
    140  & 160, 200, 201, 204, 212, 213, 214,
    +
    141  & 222, 223, 224, 232, 233, 234, 209,
    +
    142  & 210, 211, 242, 243, 244, 246, 247,
    +
    143  & 206, 207, 248, 249, 251, 252, 235,
    +
    144  & 236, 237, 238, 215, 220, 239, 240,
    +
    145  & 245, 253, 254/
    +
    146  DATA hhhnam/'SFC ','CBL ','CTL ','0DEG','ADCL','MWSL','TRO ',
    +
    147  & 'NTAT','SEAB','TMPL','ISBL','ISBY','MSL ','GPML',
    +
    148  & 'GPMY','HTGL','HTGY','SIGL','SIGY','HYBL','HYBY',
    +
    149  & 'DBLL','DBLY','THEL','THEY','SPDL','SPDY','PVL ',
    +
    150  & 'ETAL','ETAY','IBYH','HGLH','ISBP','SGYH','IBYM',
    +
    151  & 'DBSL','EATM','EOCN','HTFL','LCBL','LCTL','LCY ',
    +
    152  & 'MCBL','MCTL','MCY ','HCBL','HCTL','HCY ','BCBL',
    +
    153  & 'BCTL','BCY ','CCBL','CCTL','CCY ','MTHE','EHLT',
    +
    154  & 'GCBL','GCTL','SCBL','SCTL','DCBL','DCTL','OITL',
    +
    155  & 'OLYR','OBML','OBIL','CEIL','PBLR','S26C','OMXL',
    +
    156  & 'LLTW','LBLS','HTLS'/
    +
    157 C
    +
    158 C GRIB TABLE VERSION 2 (PDS OCTET 4 = 2)
    +
    159 C
    +
    160  DATA hh1 /
    +
    161  & 1, 2, 3, 5, 6, 7, 8,
    +
    162  & 9, 10, 11, 12, 13, 14, 15,
    +
    163  & 16, 17, 18, 19, 20, 21, 22,
    +
    164  & 23, 24, 25, 26, 27, 28, 29,
    +
    165  & 30, 31, 32, 33, 34, 35, 36,
    +
    166  & 37, 38, 39, 40, 41, 42, 43,
    +
    167  & 44, 45, 46, 47, 48, 49, 50,
    +
    168  & 51, 52, 53, 54, 55, 56, 57,
    +
    169  & 58, 59, 60, 61, 62, 63, 64,
    +
    170  & 65, 66, 67, 68, 69, 70, 71,
    +
    171  & 72, 73, 74, 75, 76, 77, 78,
    +
    172  & 79, 80, 81, 82, 83, 84, 85,
    +
    173  & 86, 87, 88, 89, 90, 91, 92,
    +
    174  & 93, 94, 95, 96, 97, 98, 99,
    +
    175  & 100, 101, 102, 103, 104, 105, 106/
    +
    176  DATA hh2 /
    +
    177  & 107, 108, 109, 110, 111, 112, 113,
    +
    178  & 114, 115, 116, 117, 121, 122, 123,
    +
    179  & 124, 125, 126, 127, 128, 129, 130,
    +
    180  & 131, 132, 133, 134, 135, 136, 137,
    +
    181  & 138, 139, 140, 141, 142, 143, 144,
    +
    182  & 145, 146, 147, 148, 149, 150, 151,
    +
    183  & 152, 153, 154, 155, 156, 157, 158,
    +
    184  & 159, 160, 161, 162, 163, 164, 165,
    +
    185  & 166, 167, 168, 169, 172, 173, 174,
    +
    186  & 175, 176, 177, 181, 182, 183, 184,
    +
    187  & 189, 190, 191, 192, 193, 194, 195,
    +
    188  & 196, 197, 201, 204, 205, 206, 207,
    +
    189  & 208, 209, 211, 212, 213, 214, 215,
    +
    190  & 216, 217, 218, 219, 220 ,221, 222,
    +
    191  & 223, 226, 227, 228, 229, 231, 232/
    +
    192  DATA hh3 /
    +
    193  & 233, 234, 235, 237, 238, 239, 241,
    +
    194  & 242, 243, 244, 245, 246, 247, 248,
    +
    195  & 249, 250, 251, 252, 253, 254, 255,
    +
    196  & 4, 118, 119, 120, 170, 171, 178,
    +
    197  & 179, 185, 186, 187, 198, 199, 200,
    +
    198  & 224, 225, 230, 180, 202, 210, 240/
    +
    199  DATA hhnam1/
    +
    200  &' PRES ',' PRMSL',' PTEND',' ICAHT',' GP ',' HGT ',' DIST ',
    +
    201  &' HSTDV',' TOZNE',' TMP ',' VTMP ',' POT ',' EPOT ',' T MAX',
    +
    202  &' T MIN',' DPT ',' DEPR ',' LAPR ',' VIS ',' RDSP1',' RDSP2',
    +
    203  &' RDSP3',' PLI ',' TMP A',' PRESA',' GP A ',' WVSP1',' WVSP2',
    +
    204  &' WVSP3',' WDIR ',' WIND ',' U GRD',' V GRD',' STRM ',' V POT',
    +
    205  &' MNTSF',' SGCVV',' V VEL',' DZDT ',' ABS V',' ABS D',' REL V',
    +
    206  &' REL D',' VUCSH',' VVCSH',' DIR C',' SP C ',' UOGRD',' VOGRD',
    +
    207  &' SPF H',' R H ',' MIXR ',' P WAT',' VAPP ',' SAT D',' EVP ',
    +
    208  &' C ICE',' PRATE',' TSTM ',' A PCP',' NCPCP',' ACPCP',' SRWEQ',
    +
    209  &' WEASD',' SNO D',' MIXHT',' TTHDP',' MTHD ',' MTH A',' T CDC',
    +
    210  &' CDCON',' L CDC',' M CDC',' H CDC',' C WAT',' BLI ',' SNO C',
    +
    211  &' SNO L',' WTMP ',' LAND ',' DSL M',' SFC R',' ALBDO',' TSOIL',
    +
    212  &' SOILM',' VEG ',' SALTY',' DEN ',' WATR ',' ICE C',' ICETK',
    +
    213  &' DICED',' SICED',' U ICE',' V ICE',' ICE G',' ICE D',' SNO M',
    +
    214  &' HTSGW',' WVDIR',' WVHGT',' WVPER',' SWDIR',' SWELL',' SWPER'/
    +
    215  DATA hhnam2/
    +
    216  &' DIRPW',' PERPW',' DIRSW',' PERSW',' NSWRS',' NLWRS',' NSWRT',
    +
    217  &' NLWRT',' LWAVR',' SWAVR',' G RAD',' LHTFL',' SHTFL',' BLYDP',
    +
    218  &' U FLX',' V FLX',' WMIXE',' IMG D',' MSLSA',' MSLMA',' MSLET',
    +
    219  &' LFT X',' 4LFTX',' K X ',' S X ',' MCONV',' VW SH',' TSLSA',
    +
    220  &' BVF2 ',' PV MW',' CRAIN',' CFRZR',' CICEP',' CSNOW',' SOILW',
    +
    221  &' PEVPR',' CWORK',' U-GWD',' V-GWD',' PV ',' COVMZ',' COVTZ',
    +
    222  &' COVTM',' CLWMR',' O3MR ',' GFLUX',' CIN ',' CAPE ',' TKE ',
    +
    223  &' CONDP',' CSUSF',' CSDSF',' CSULF',' CSDLF',' CFNSF',' CFNLF',
    +
    224  &' VBDSF',' VDDSF',' NBDSF',' NDDSF',' M FLX',' LMH ',' LMV ',
    +
    225  &' MLYNO',' NLAT ',' ELON ',' LPS X',' LPS Y',' HGT X',' HGT Y',
    +
    226  &' VPTMP',' HLCY ',' PROB ',' PROBN',' POP ',' CPOFP',' CPOZP',
    +
    227  &' USTM ',' VSTM ',' ICWAT',' DSWRF',' DLWRF',' UVI ',' MSTAV',
    +
    228  &' SFEXC',' MIXLY',' USWRF',' ULWRF',' CDLYR',' CPRAT',' TTDIA',
    +
    229  &' TTRAD',' TTPHY',' PREIX',' TSD1D',' NLGSP',' HPBL ',' 5WAVH',
    +
    230  &' CNWAT',' BMIXL',' AMIXL',' PEVAP',' SNOHF',' MFLUX',' DTRF '/
    +
    231  DATA hhnam3/
    +
    232  &' UTRF ',' BGRUN',' SSRUN',' O3TOT',' SNOWC',' SNO T',' LRGHR',
    +
    233  &' CNVHR',' CNVMR',' SHAHR',' SHAMR',' VDFHR',' VDFUA',' VDFVA',
    +
    234  &' VDFMR',' SWHR ',' LWHR ',' CD ',' FRICV',' RI ',' MISS ',
    +
    235  &' PVORT',' BRTMP',' LWRAD',' SWRAD',' RWMR ',' SNMR ',' ICMR ',
    +
    236  &' GRMR ',' TURB ',' ICNG ',' LTNG ',' NCIP ',' EVBS ',' EVCW ',
    +
    237  &' SOTYP',' VGTYP',' 5WAVA',' GUST ',' CWDI ',' TRANS',' COVTW'/
    +
    238 C
    +
    239 C GRIB TABLE VERSION 128 (PDS OCTET 4 = 128)
    +
    240 C ( OCEANGRAPHIC PARAMETER )
    +
    241 C
    +
    242  DATA hh128/
    +
    243  & 128, 129, 130, 131, 132, 133, 134,
    +
    244  & 135, 136, 137, 138, 139, 140, 141,
    +
    245  & 142, 143, 144, 145, 146, 147, 148,
    +
    246  & 149, 150, 151, 152, 153, 154, 155,
    +
    247  & 156, 157, 158, 159, 160, 161, 162,
    +
    248  & 163, 164, 165, 166, 167, 168, 169,
    +
    249  & 170, 171, 172, 173, 174, 175, 176,
    +
    250  & 177, 178, 179, 180, 181, 182, 183,
    +
    251  & 184, 185, 186, 187, 188, 189, 190,
    +
    252  & 191, 192, 193, 194, 254, 40, 41,
    +
    253  & 42, 43/
    +
    254  DATA hhnam128/
    +
    255  &'ADEPTH',' DEPTH',' ELEV ','MXEL24','MNEL24',' ',' ',
    +
    256  &' O2 ',' PO4 ',' NO3 ',' SIO4 ',' CO2AQ',' HCO3 ',' CO3 ',
    +
    257  &' TCO2 ',' TALK ',' ',' ',' S11 ',' S12 ',' S22 ',
    +
    258  &' INV1 ',' INV2 ',' ',' ',' ',' ',' WVRGH',
    +
    259  &'WVSTRS',' WHITE','SWDIRW','SWFREW',' WVAGE','PWVAGE',' ',
    +
    260  &' ',' ',' LTURB',' ',' ',' ',' ',
    +
    261  &'AIHFLX','AOHFLX','IOHFLX','IOSFLX',' ',' OMLT ',' OMLS ',
    +
    262  &'P2OMLT',' OMLU ',' OMLV ',' ASHFL',' ASSFL',' BOTLD',' UBARO',
    +
    263  &' VBARO',' INTFD',' WTMPC',' SALIN',' EMNP ',' ',' KENG ',
    +
    264  &' ',' LAYTH',' SSTT ',' SSST ',' ','A RAIN','A SNOW',
    +
    265  &'A ICE ','A FRZR'/
    +
    266 C
    +
    267 C GRIB TABLE VERSION 129 (PDS OCTET 4 = 129)
    +
    268 C
    +
    269  DATA hh129/
    +
    270  & 128, 129, 130, 131, 132, 133, 134,
    +
    271  & 135, 136, 137, 138, 139, 140, 141,
    +
    272  & 142, 143, 144, 145, 146, 147, 148,
    +
    273  & 149, 150, 151, 152, 153, 154, 155,
    +
    274  & 156, 157, 158, 159, 160, 161, 162,
    +
    275  & 163, 164, 165, 166, 167, 168, 169,
    +
    276  & 170, 171, 172, 173, 174, 175, 176,
    +
    277  & 177, 178, 179, 180, 181, 182, 183,
    +
    278  & 184, 185, 186, 187, 188, 189, 190,
    +
    279  & 191, 192, 193, 194, 195, 196, 197,
    +
    280  & 198, 199, 200, 201, 201, 203, 204,
    +
    281  & 205, 206, 207, 208, 209, 210, 211,
    +
    282  & 212, 213, 214, 215, 216, 217, 218,
    +
    283  & 219, 220, 221, 222, 223, 224, 225/
    +
    284  DATA hhnam129/
    +
    285  &' PAOT ',' PAOP ',' ',' FRAIN',' FICE ',' FRIME',' CUEFI',
    +
    286  &' TCOND',' TCOLW',' TCOLI',' TCOLR',' TCOLS',' TCOLC',' PLPL ',
    +
    287  &' HLPL ',' CEMS ',' COPD ',' PSIZ ',' TCWAT',' TCICE',' WDIF ',
    +
    288  &' WSTP ',' PTAN ',' PTNN ',' PTBN ',' PPAN ',' PPNN ',' PPBN ',
    +
    289  &' PMTC ',' PMTF ',' AETMP',' AEDPT',' AESPH',' AEUWD',' AEVWD',
    +
    290  &' LPMTF',' LIPMF',' REFZR',' REFZI',' REFZC',' TCLSW',' TCOLM',
    +
    291  &' ELRDI',' TSEC ',' TSECA',' NUM ',' AEPRS',' ICSEV',' ICPRB',
    +
    292  &' LAVNI',' HAVNI',' FLGHT',' OZCON',' OZCAT',' VEDH ',' SIGV ',
    +
    293  &' EWGT ',' CICEL',' CIVIS',' CIFLT',' LAVV ',' LOVV ',' USCT ',
    +
    294  &' VSCT ',' LAUV ',' LOUV ',' TCHP ',' DBSS ',' ODHA ',' OHC ',
    +
    295  &' SSHG ',' SLTFL',' DUVB ',' CDUVB',' THFLX',' UVAR ',' VVAR ',
    +
    296  &'UVVCC ',' MCLS ',' LAPP ',' LOPP ',' ',' REFO ',' REFD ',
    +
    297  &' REFC ','SBT122','SBT123','SBT124','SBT125',' MINRH',' MAXRH',
    +
    298  &' CEIL ','PBLREG',' ',' ',' ',' ',' '/
    +
    299 C
    +
    300 C GRIB TABLE VERSION 130 (PDS OCTET 4 = 130)
    +
    301 C ( FOR LAND MODELING AND LAND DATA ASSIMILATION )
    +
    302 C
    +
    303  DATA hh130/
    +
    304  & 144, 145, 146, 147, 148, 149, 150,
    +
    305  & 151, 152, 153, 154, 155, 156, 157,
    +
    306  & 158, 159, 160, 161, 162, 163, 164,
    +
    307  & 165, 166, 167, 168, 169, 170, 171,
    +
    308  & 172, 173, 174, 175, 176, 177, 178,
    +
    309  & 179, 180, 181, 182, 183, 184, 185,
    +
    310  & 186, 187, 188, 189, 190, 191, 192,
    +
    311  & 193, 194, 195, 196, 197, 198, 199,
    +
    312  & 200, 201, 202, 203, 204, 205, 206,
    +
    313  & 207, 208, 209, 210, 211, 212, 213,
    +
    314  & 214, 215, 216, 217, 218, 219, 220,
    +
    315  & 221, 222, 223, 224, 225, 226, 227,
    +
    316  & 228, 229, 230, 231, 232, 233, 234,
    +
    317  & 235, 236, 237, 238, 239, 240, 241,
    +
    318  & 242, 243, 244, 245, 246, 247, 248,
    +
    319  & 249, 250, 251, 252, 253, 254, 255/
    +
    320  DATA hhnam130/
    +
    321  &' SOIL ',' PEVPR',' VEGT ',' BARET',' AVSFT',' RADT ',' SSTOR',
    +
    322  &' LSOIL',' EWATR',' ',' LSPA ',' GFLUX',' CIN ',' CAPE ',
    +
    323  &' TKE ','MXSALB',' SOILL',' ASNOW',' ARAIN',' GWREC',' QREC ',
    +
    324  &' SNOWT',' VBDSF',' VDDSF',' NBDSF',' NDDSF','SNFALB',' ',
    +
    325  &' M FLX',' ',' ',' ',' NLAT ',' ELON ','FLDCAP',
    +
    326  &' ACOND',' SNOAG',' CCOND',' LAI ',' SFCRH',' SALBD',' ',
    +
    327  &' ',' NDVI ',' DRIP ','VBSLAB','VWSALB','NBSALB','NWSALB',
    +
    328  &' ',' ',' ',' ',' ',' SBSNO',' EVBS ',
    +
    329  &' EVCW ',' ',' ',' RSMIN',' DSWRF',' DLWRF',' ',
    +
    330  &' MSTAV',' SFEXC',' ',' TRANS',' USWRF',' ULWRF',' ',
    +
    331  &' ',' ',' ',' ',' ',' WILT ',' FLDCP',
    +
    332  &' HPBL ',' SLTYP',' CNWAT',' SOTYP',' VGTYP',' BMIXL',' AMIXL',
    +
    333  &' PEVAP',' SNOHF',' SMREF',' SMDRY',' ',' ',' BGRUN',
    +
    334  &' SSRUN',' ',' ',' SNOWC',' SNOT ',' POROS',' ',
    +
    335  &' ',' ',' ',' ',' RCS ',' RCT ',' RCQ ',
    +
    336  &' RCSOL',' ',' ',' CD ',' FRICV',' RI ',' '/
    +
    337 C
    +
    338 C GRIB TABLE VERSION 140 (PDS OCTET 4 = 140)
    +
    339 C ( FOR WORLD AREA FORECAST SYSTEM (WAF/ICAO)
    +
    340 C
    +
    341  DATA hh140/
    +
    342  & 144, 145, 146, 147, 148, 149, 150,
    +
    343  & 151, 152, 153, 154, 155, 156, 157,
    +
    344  & 158, 159, 160, 161, 162, 163, 164,
    +
    345  & 165, 166, 167, 168, 169, 170, 171,
    +
    346  & 172, 173, 174, 175, 176, 177, 178,
    +
    347  & 179, 180, 181, 182, 183, 184, 185,
    +
    348  & 186, 187, 188, 189, 190, 191, 192,
    +
    349  & 193, 194, 195, 196, 197, 198, 199,
    +
    350  & 200, 201, 202, 203, 204, 205, 206,
    +
    351  & 207, 208, 209, 210, 211, 212, 213,
    +
    352  & 214, 215, 216, 217, 218, 219, 220,
    +
    353  & 221, 222, 223, 224, 225, 226, 227,
    +
    354  & 228, 229, 230, 231, 232, 233, 234,
    +
    355  & 235, 236, 237, 238, 239, 240, 241,
    +
    356  & 242, 243, 244, 245, 246, 247, 248,
    +
    357  & 249, 250, 251, 252, 253, 254, 255/
    +
    358  DATA hhnam140/
    +
    359  &' ',' ',' ',' ',' ',' ',' ',
    +
    360  &' ',' ',' ',' ',' ',' ',' ',
    +
    361  &' ',' ',' ',' ',' ',' ',' ',
    +
    362  &' ',' ',' ',' ',' ',' ',' ',
    +
    363  &' ',' ',' ',' MEIP ',' MAIP ',' MECTP',' MACTP',
    +
    364  &' MECAT',' MACAT',' CBHE ',' PCBB ',' PCBT ',' PECBB',' PECBT',
    +
    365  &' HCBB ',' HCBT ',' HECBB',' HECBT',' ',' ',' ',
    +
    366  &' ',' ',' ',' ',' ',' ',' ',
    +
    367  &' ',' ',' ',' ',' ',' ',' ',
    +
    368  &' ',' ',' ',' ',' ',' ',' ',
    +
    369  &' ',' ',' ',' ',' ',' ',' ',
    +
    370  &' ',' ',' ',' ',' ',' ',' ',
    +
    371  &' ',' ',' ',' ',' ',' ',' ',
    +
    372  &' ',' ',' ',' ',' ',' ',' ',
    +
    373  &' ',' ',' ',' ',' ',' ',' ',
    +
    374  &' ',' ',' ',' ',' ',' ',' MISS '/
    +
    375 C
    +
    376 C GRIB TABLE VERSION 131 (PDS OCTET 4 = 131)
    +
    377 C
    +
    378  DATA hh131/
    +
    379  & 1, 2, 3, 4, 5, 6, 7,
    +
    380  & 8, 9, 10, 11, 12, 13, 14,
    +
    381  & 15, 16, 17, 18, 19, 20, 21,
    +
    382  & 22, 23, 24, 25, 26, 27, 28,
    +
    383  & 29, 30, 31, 32, 33, 34, 35,
    +
    384  & 36, 37, 38, 39, 40, 41, 42,
    +
    385  & 43, 44, 45, 46, 47, 48, 49,
    +
    386  & 50, 51, 52, 53, 54, 55, 56,
    +
    387  & 57, 58, 59, 60, 61, 62, 63,
    +
    388  & 64, 65, 66, 67, 68, 69, 70,
    +
    389  & 71, 72, 73, 74, 75, 76, 77,
    +
    390  & 78, 79, 80, 81, 82, 83, 84,
    +
    391  & 85, 86, 87, 88, 89, 90, 91,
    +
    392  & 92, 93, 94, 95, 96, 97, 98,
    +
    393  & 99, 100, 101, 102, 103, 104, 105,
    +
    394  & 106, 107, 108, 109, 110, 111, 112,
    +
    395  & 113, 114, 115, 116, 117, 118, 119,
    +
    396  & 120, 121, 122, 123, 124, 125, 126,
    +
    397  & 127, 128, 130, 131, 132, 134, 135,
    +
    398  & 136, 139, 140, 141, 142, 143, 144,
    +
    399  & 145, 146, 147, 148, 149, 150, 151,
    +
    400  & 152, 153, 155, 156, 157, 158, 159,
    +
    401  & 160, 161, 162, 163, 164, 165, 166,
    +
    402  & 167, 168, 169, 170, 171, 172, 173,
    +
    403  & 174, 175, 176, 177, 178, 179, 180,
    +
    404  & 181, 182, 183, 184, 187, 188, 189,
    +
    405  & 190, 191, 192, 194, 196, 197, 198,
    +
    406  & 199, 200, 202, 203, 204, 205, 206,
    +
    407  & 207, 208, 210, 211, 212, 213, 214,
    +
    408  & 216, 218, 219, 220, 221, 222, 223,
    +
    409  & 224, 225, 226, 227, 228, 229, 230,
    +
    410  & 231, 232, 233, 234, 235, 237, 238,
    +
    411  & 239, 240, 241, 242, 243, 244, 245,
    +
    412  & 246, 247, 248, 249, 250, 251, 252,
    +
    413  & 253, 254, 255/
    +
    414  DATA hhnam131/
    +
    415  &' PRES ',' PRMSL',' PTEND',' PVORT',' ICAHT',' GP ',' HGT ',
    +
    416  &' DIST ',' HSTDV',' TOZNE',' TMP ',' VTMP ',' POT ',' EPOT ',
    +
    417  &' TMAX ',' TMIN ',' DPT ',' DEPR ',' LAPR ',' VIS ',' RDSP1',
    +
    418  &' RDSP2',' RDSP3',' PLI ',' TMPA ',' PRESA',' GPA ',' WVSP1',
    +
    419  &' WVSP2',' WVSP3',' WDIR ',' WIND ',' UGRD ',' VGRD ',' STRM ',
    +
    420  &' VPOT ',' MNTSF',' SGVCC',' VVEL ',' DZDT ',' ABSV ',' ABSD ',
    +
    421  &' RELV ',' RELD ',' VUCSH',' VVCSH',' DIRC ',' SPC ',' UOGRD',
    +
    422  &' VOGRD',' SPFH ',' RH ',' MIXR ',' PWAT ',' VAPP ',' SATD ',
    +
    423  &' EVP ',' CICE ',' PRATE',' TSTM ',' APCP ',' NCPCP',' ACPCP',
    +
    424  &' SRWEQ',' WEASD',' SNOD ',' MIXHT',' TTHDP',' MTHD ',' MTHA ',
    +
    425  &' TCDC ',' CDCON',' LCDC ',' MCDC ',' HCDC ',' CWAT ',' BLI ',
    +
    426  &' SNOC ',' SNOL ',' WTMP ',' LAND ',' DSLM ',' SFCR ',' ALBDO',
    +
    427  &' TSOIL',' SOILM',' VEG ',' SALTY',' DEN ',' WATR ',' ICEC ',
    +
    428  &' ICETK',' DICED',' SICED',' UICE ',' VICE ',' ICEG ',' ICED ',
    +
    429  &' SNOM ',' HTSGW',' WVDIR',' WVHGT',' WVPER',' SWDIR',' SWELL',
    +
    430  &' SWPER',' DIRPW',' PERPW',' DIRSW',' PERSW',' NSWRS',' NLWRS',
    +
    431  &' NSWRT',' NLWRT',' LWAVR',' SWAVR',' GRAD ',' BRTMP',' LWRAD',
    +
    432  &' SWRAT',' LHTFL',' SHTFL',' BLYDP',' UFLX ',' VFLX ',' WMIXE',
    +
    433  &' IMGD ',' MSLSA',' MSLET',' LFTX ',' 4LFTX',' PRESN',' MCONV',
    +
    434  &' VWSH ',' PVMW ',' CRAIN',' CFRZR',' CICEP',' CSNOW',' SOILW',
    +
    435  &' PEVPR',' VEGT ',' BARET',' AVSFT',' RADT ',' SSTOR',' LSOIL',
    +
    436  &' EWATR',' CLWMR',' GFLUX',' CIN ',' CAPE ',' TKE ','MXSALB',
    +
    437  &' SOILL',' ASNOW',' ARAIN',' GWREC',' QREC ',' SNOWT',' VBDSF',
    +
    438  &' VDDSF',' NBDSF',' NDDSF','SNFALB',' RLYRS',' FLX ',' LMH ',
    +
    439  &' LMV ',' MLYNO',' NLAT ',' ELON ',' ICMR ',' ACOND',' SNOAG',
    +
    440  &' CCOND',' LAI ',' SFCRH',' SALBD',' NDVI ',' DRIP ',' LANDN',
    +
    441  &' HLCY ',' NLATN',' ELONN',' CPOFP',' USTM ',' VSTM ',' SBSNO',
    +
    442  &' EVBS ',' EVCW ',' APCPN',' RSMIN',' DSWRF',' DLWRF','ACPCPN',
    +
    443  &' MSTAV',' SFEXC',' TRANS',' USWRF',' ULWRF',' CDLYR',' CPRAT',
    +
    444  &' TTRAD',' HGTN ',' WILT ',' FLDCP',' HPBL ',' SLTYP',' CNWAT',
    +
    445  &' SOTYP',' VGTYP',' BMIXL',' AMIXL',' PEVAP',' SNOHF',' SMREF',
    +
    446  &' SMDRY',' WVINC',' WCINC',' BGRUN',' SSRUN','MVCONV',' SNOWC',
    +
    447  &' SNOT ',' POROS','WCCONV','WVUFLX','WVVFLX','WCUFLX','WCVFLX',
    +
    448  &' RCS ',' RCT ',' RCQ ',' RCSOL',' SWHR ',' LWHR ',' CD ',
    +
    449  &' FRICV',' RI ',' MISS '/
    +
    450 C
    +
    451 C ONE LINE CHANGE FOR HDS (IBM370) (ASCII NAME GRIB IN HEX)
    +
    452 C
    +
    453 C DATA GRIB /Z47524942/
    +
    454 C
    +
    455 C ONE LINE CHANGE FOR CRAY AND WORKSTATIONS
    +
    456 C
    +
    457  DATA grib /'GRIB'/
    +
    458 C
    +
    459 C TABLE O (PDS OCTET 5) NATIONAL/INTERNATIONAL
    +
    460 C ORIGINATING CENTERS
    +
    461 C
    +
    462  DATA knam1 /
    +
    463  & ' US NWS - NCEP (WMC) ',' US NWS - NWSTG (WMC) ',
    +
    464  & ' US NWS - Other (WMC)',' JMA - Tokyo (RSMC) ',
    +
    465  & ' TPC (NHC),Miami(RSMC)',' CMS - Montreal (RSMC)',
    +
    466  & ' U.S. Air Force - GWC ',' U.S. Navy - FNOC ',
    +
    467  & ' NOAA FSL, Boulder, CO',' NCAR, Boulder, CO ',
    +
    468  & ' SARGO, Landover, MD ',' US Naval, Oceanograph',
    +
    469  & ' U.K Met. Office RSMC)',' French WS - Toulouse ',
    +
    470  & ' European Space Agency',' ECMWF (RSMC) ',
    +
    471  & ' De Bilt, Netherlands '/
    +
    472 C
    +
    473 C TABLE C (PDS OCTET 26) NATIONAL SUB-CENTERS
    +
    474 C
    +
    475  DATA knam2 /
    +
    476  & ' NCEP RE-ANALYSIS PRO.',' NCEP ENSEMBLE PRODUCT',
    +
    477  & ' NCEP CENTRAL OPS. ',' ENV. MODELING CENTER ',
    +
    478  & ' HYDRO. PRED. CENTER ',' OCEAN PRED. CENTER ',
    +
    479  & ' CLIMATE PRED. CENTER ',' AVIATION WEATHER CEN.',
    +
    480  & ' STORM PRED. CENTER ',' TROPICAL PRED. CENTER',
    +
    481  & ' NWS TECH. DEV. LAB. ',' NESDIS OFF. RES. APP.',
    +
    482  & ' FAA ',' NWS MET. DEV. LAB. ',
    +
    483  & ' NARR PROJECT ',' SPACE ENV. CENTER '/
    +
    484  DATA knam3 /
    +
    485  & ' ABRFC TULSA, OK ',' AKRFC ANCHORAGE, AK ',
    +
    486  & ' CBRFC SALT LAKE, UT ',' CNRFC SACRAMENTO, CA',
    +
    487  & ' LMRFC SLIDEL, LA. ',' MARFC STATE CO., PA ',
    +
    488  & ' MBRFC KANSAS CITY MO',' NCRFC MINNEAPOLIS MN',
    +
    489  & ' NERFC HARTFORD, CT. ',' NWRFC PORTLAND, OR ',
    +
    490  & ' OHRFC CINCINNATI, OH',' SERFC ATLANTA, GA ',
    +
    491  & ' WGRFC FORT WORTH, TX',' OUN NORMAN OK WFO '/
    +
    492  DATA month /'JAN','FEB','MAR','APR','MAY','JUN',
    +
    493  & 'JUL','AUG','SEP','OCT','NOV','DEC'/
    +
    494  DATA scntr1/ 1, 2, 3, 4, 5, 6, 7,
    +
    495  & 8, 9, 10, 11, 12, 13, 14,
    +
    496  & 15, 16/
    +
    497  DATA scntr2/ 150, 151, 152, 153, 154, 155, 156,
    +
    498  & 157, 158, 159, 160, 161, 162, 170/
    +
    499  DATA timun /'HRS.','DAYS','MOS.','YRS.','DECS','NORM','CENS',
    +
    500  & 2*'----','3HRS','6HRS','HDYS'/
    +
    501  DATA timun1/'HR','DY','MO','YR','DC','NO','CN',
    +
    502  & 2*'--','3H','6H','HD'/
    +
    503 C
    +
    504 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    505 C
    +
    506 C 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM.
    +
    507 C - NO. OF ENTRIES IN TYPE LEVEL
    +
    508 C - NO. OF ENTRIES IN CNTR PROD. DTA.
    +
    509 C - NO. OF ENTRIES IN SUB CNTR1 PROD. DTA.
    +
    510 C - NO. OF ENTRIES IN SUB CNTR2 PROD. DTA.
    +
    511 C
    +
    512  iq = 252
    +
    513  is = 73
    +
    514  ic = 17
    +
    515  ih128 = 72
    +
    516  ih129 = 98
    +
    517  ih130 = 112
    +
    518  ih140 = 112
    +
    519  ih131 = 241
    +
    520  ics1 = 16
    +
    521  ics2 = 14
    +
    522  ierr = 0
    +
    523 C
    +
    524  titl(1:30) = ' '
    +
    525  titl(31:60) = ' '
    +
    526  titl(61:86) = ' '
    +
    527 C
    +
    528 C ---------------------------------------------------------------------
    +
    529 C$ 2.0 TEST SECTION 0 FOR ASCII 'GRIB'
    +
    530 C
    +
    531  IF (grib(1:4) .NE. ipds0(1:4)) THEN
    +
    532  ierr = 1
    +
    533  RETURN
    +
    534  ENDIF
    +
    535 C
    +
    536 C TEST SECTION 0 FOR GRIB VERSION 1
    +
    537 C
    +
    538  IF (mova2i(ipds0(8:8)).NE.1) THEN
    +
    539  ierr = 2
    +
    540  RETURN
    +
    541  END IF
    +
    542 C
    +
    543 C TEST THE LENGTH OF THE PDS (SECTION 1)
    +
    544 C
    +
    545  lenpds = mova2i(ipds(1:1)) * 65536 + mova2i(ipds(2:2)) * 256 +
    +
    546  & mova2i(ipds(3:3))
    +
    547  IF (lenpds.GE.28) THEN
    +
    548  idpds(1:28) = ipds(1:28)
    +
    549  ELSE
    +
    550  ierr = 3
    +
    551  RETURN
    +
    552  ENDIF
    +
    553 C
    +
    554 C TEST PDS (OCTET 4) FOR PARAMETER TABLE VERSION
    +
    555 C NUMBER 1 OR 2 OR 128, 129 OR 130 OR 131 OR 140
    +
    556 C
    +
    557  iver = mova2i(idpds(4:4))
    +
    558  IF (iver.GT.131) THEN
    +
    559  ierr = 9
    +
    560  RETURN
    +
    561  END IF
    +
    562 C
    +
    563 C 4.0 FIND THE INDICATOR AND TYPE LEVELS
    +
    564 C
    +
    565  iqq = mova2i(idpds(9:9))
    +
    566  IF (iver.EQ.128) THEN
    +
    567  DO k = 1, ih128
    +
    568  IF (iqq .EQ. hh128(k)) THEN
    +
    569  titl(21:27) = hhnam128(k)
    +
    570  GO TO 150
    +
    571  END IF
    +
    572  END DO
    +
    573  ELSE IF (iver.EQ.129) THEN
    +
    574  DO k = 1, ih129
    +
    575  IF (iqq .EQ. hh129(k)) THEN
    +
    576  titl(21:27) = hhnam129(k)
    +
    577  GO TO 150
    +
    578  END IF
    +
    579  END DO
    +
    580  ELSE IF (iver.EQ.130) THEN
    +
    581  DO k = 1, ih130
    +
    582  IF (iqq .EQ. hh130(k)) THEN
    +
    583  titl(21:27) = hhnam130(k)
    +
    584  GO TO 150
    +
    585  END IF
    +
    586  END DO
    +
    587  ELSE IF (iver.EQ.131) THEN
    +
    588  DO k = 1, ih131
    +
    589  IF (iqq .EQ. hh131(k)) THEN
    +
    590  titl(21:27) = hhnam131(k)
    +
    591  GO TO 150
    +
    592  END IF
    +
    593  END DO
    +
    594  ELSE IF (iver.EQ.140) THEN
    +
    595  DO k = 1, ih140
    +
    596  IF (iqq .EQ. hh140(k)) THEN
    +
    597  titl(21:27) = hhnam140(k)
    +
    598  GO TO 150
    +
    599  END IF
    +
    600  END DO
    +
    601  ELSE
    +
    602  DO ii = 1,iq
    +
    603  IF (iqq .EQ. hh(ii)) GO TO 100
    +
    604  END DO
    +
    605  IF (iqq.EQ.77.AND.iver.EQ.1) GO TO 100
    +
    606  IF (iqq.EQ.24) GO TO 100
    +
    607  ierr = 4
    +
    608  RETURN
    +
    609  END IF
    +
    610 C
    +
    611  100 CONTINUE
    +
    612  IF (iqq .NE. 77 .AND. iqq .NE. 24) THEN
    +
    613  titl(21:27) = hhnam(ii)
    +
    614  ELSE IF (iqq .EQ. 77) THEN
    +
    615  titl(21:27) = ' CONDP '
    +
    616 C
    +
    617 C TAKE OUT AFTER ALL PROGRAMS ARE CHANGED THAT USE 24
    +
    618 C FOR TOTAL OZONE.
    +
    619 C
    +
    620  ELSE IF (iqq .EQ. 24) THEN
    +
    621  titl(21:27) = ' TOTO3 '
    +
    622  END IF
    +
    623  IF (iqq.EQ.137.AND.iver.EQ.1) titl(21:27) = ' VISIB '
    +
    624  150 CONTINUE
    +
    625  iss = mova2i(idpds(10:10))
    +
    626 C
    +
    627 C CORRECTION FOR 'NLAT' 'ELON' 'L CDC' 'M CDC', 'H CDC',
    +
    628 C 'T CDC'
    +
    629 C
    +
    630  IF (iss.EQ.0.AND.(iqq.EQ.176.OR.iqq.EQ.177.
    +
    631  & or.iqq.EQ.71.OR.iqq.EQ.73.OR.iqq.EQ.74.
    +
    632  & or.iqq.EQ.72.OR.iqq.EQ.75.OR.iqq.EQ.213.
    +
    633  & or.iqq.EQ.173.OR.iqq.EQ.174)) THEN
    +
    634  GO TO 300
    +
    635  END IF
    +
    636  DO jj = 1,is
    +
    637  IF (iss .EQ. hhh(jj)) GO TO 200
    +
    638  END DO
    +
    639  ierr = 5
    +
    640  RETURN
    +
    641 C
    +
    642  200 CONTINUE
    +
    643  IF (iss.EQ.4.OR.iss.EQ.5.OR.iss.EQ.20.OR.iss.EQ.100.OR.
    +
    644  & iss.EQ.103.OR.iss.EQ.105.OR.iss.EQ.107.OR.iss.EQ.109.OR.
    +
    645  & iss.EQ.111.OR.iss.EQ.113.OR.iss.EQ.115.OR.iss.EQ.117.OR.
    +
    646  & iss.EQ.119.OR.iss.EQ.125.OR.iss.EQ.126.OR.iss.EQ.160.OR.
    +
    647  & iss.EQ.236)THEN
    +
    648  titl(16:20) = hhhnam(jj)
    +
    649  level = mova2i(idpds(11:11)) * 256 + mova2i(idpds(12:12))
    +
    650  IF (iss.EQ.107.OR.iss.EQ.119) THEN
    +
    651  alevel = float(level) / 10000.0
    +
    652  WRITE (titl(9:15),fmt='(F6.4)') alevel
    +
    653  ELSE IF (iss.EQ.5) THEN
    +
    654 C DO NOTHING
    +
    655  ELSE
    +
    656  WRITE (titl(11:15),fmt='(I4)') level
    +
    657  END IF
    +
    658  ELSE IF (iss.EQ.1.OR.iss.EQ.6.OR.iss.EQ.7.OR.iss.EQ.8.OR.
    +
    659  & iss.EQ.9 .OR.iss.EQ.102.OR.iss.EQ.200.OR.iss.EQ.201.OR.
    +
    660  & iss.EQ.204.OR.iss.EQ.212.OR.iss.EQ.213.OR.iss.EQ.214.OR.
    +
    661  & iss.EQ.222.OR.iss.EQ.223.OR.iss.EQ.224.OR.iss.EQ.232.OR.
    +
    662  & iss.EQ.233.OR.iss.EQ.234.OR.iss.EQ.209.OR.iss.EQ.210.OR.
    +
    663  & iss.EQ.211.OR.iss.EQ.242.OR.iss.EQ.243.OR.iss.EQ.244.OR.
    +
    664  & iss.EQ.245.OR.iss.EQ.235.OR.iss.EQ.237.OR.iss.EQ.238.OR.
    +
    665  & iss.EQ.246.OR.iss.EQ.247.OR.iss.EQ.206.OR.iss.EQ.207.OR.
    +
    666  & iss.EQ.248.OR.iss.EQ.249.OR.iss.EQ.251.OR.iss.EQ.252) THEN
    +
    667  titl(16:20) = hhhnam(jj)
    +
    668  titl(1:4) = ' '
    +
    669  titl(11:15) = ' '
    +
    670  ELSE IF (iss.EQ.101.OR.iss.EQ.104.OR.iss.EQ.106.OR.iss.EQ.108.
    +
    671  & or.iss.EQ.110.OR.iss.EQ.112.OR.iss.EQ.114.OR.iss.EQ.116.OR.
    +
    672  & iss.EQ.120.OR.iss.EQ.121.OR.iss.EQ.128.OR.iss.EQ.141) THEN
    +
    673  titl(6:11) = hhhnam(jj)
    +
    674  titl(16:20) = hhhnam(jj)
    +
    675  itemp = mova2i(idpds(11:11))
    +
    676  WRITE (unit=titl(1:4),fmt='(I4)') itemp
    +
    677  jtemp = mova2i(idpds(12:12))
    +
    678  WRITE (unit=titl(11:15),fmt='(I4)') jtemp
    +
    679  END IF
    +
    680 C
    +
    681 C 5.0 INSERT THE YEAR,DAY,MONTH AND TIME
    +
    682 C
    +
    683  300 CONTINUE
    +
    684  ihr = mova2i(idpds(16:16))
    +
    685  iday = mova2i(idpds(15:15))
    +
    686  imon = mova2i(idpds(14:14))
    +
    687  iyr = mova2i(idpds(13:13))
    +
    688  icen = mova2i(idpds(25:25))
    +
    689 C
    +
    690 C SUBTRACT 1 FROM CENTURY TO MAKE 4 DIGIT YEAR
    +
    691 C
    +
    692  icen = icen - 1
    +
    693 C
    +
    694  iyr = icen * 100 + iyr
    +
    695  WRITE (unit=titl(59:62),fmt='(I4)') iyr
    +
    696  WRITE (unit=titl(52:53),fmt='(I2)') iday
    +
    697  WRITE (unit=titl(38:49),fmt='(A6,I2.2,A2)') 'AFTER ',ihr,'Z '
    +
    698  titl(55:57) = month(imon)
    +
    699  fcstim = mova2i(idpds(18:18))
    +
    700  titl(34:36) = timun(fcstim)
    +
    701  p1 = mova2i(idpds(19:19))
    +
    702  p2 = mova2i(idpds(20:20))
    +
    703  timerg = mova2i(idpds(21:21))
    +
    704  IF (timerg.EQ.10) THEN
    +
    705  p1 = p1 * 256 + p2
    +
    706  p2 = 0
    +
    707  END IF
    +
    708 C
    +
    709 C ADD CORRECTION IF BYTE 21 (TIME RANGE) IS 2
    +
    710 C
    +
    711  IF (timerg.EQ.2) THEN
    +
    712  titl(4:20) = titl(11:27)
    +
    713  titl(21:21) = ' '
    +
    714  WRITE (unit=titl(22:24),fmt='(I3)') p1
    +
    715  titl(25:28) = ' TO '
    +
    716  WRITE (unit=titl(29:32),fmt='(I3)') p2
    +
    717 C
    +
    718 C PRECIP AMOUNTS
    +
    719 C
    +
    720  ELSE IF (timerg.EQ.4) THEN
    +
    721  WRITE (unit=titl(29:32),fmt='(I3)') p2
    +
    722  mtemp = p2 - p1
    +
    723  WRITE (unit=titl(2:4),fmt='(I3)') mtemp
    +
    724  titl(6:7) = timun1(fcstim)
    +
    725  titl(8:12) = ' ACUM'
    +
    726 C
    +
    727 C AVERAGE
    +
    728 C
    +
    729  ELSE IF (timerg.EQ.3) THEN
    +
    730  WRITE (unit=titl(29:32),fmt='(I3)') p2
    +
    731  mtemp = p2 - p1
    +
    732  WRITE (unit=titl(2:4),fmt='(I3)') mtemp
    +
    733  titl(6:7) = timun1(fcstim)
    +
    734  titl(8:12) = ' AVG'
    +
    735 C
    +
    736 C CLIMATOLOGICAL MEAN VALUE
    +
    737 C
    +
    738  ELSE IF (timerg.EQ.51) THEN
    +
    739  WRITE (unit=titl(29:32),fmt='(I3)') p2
    +
    740  mtemp = p2 - p1
    +
    741  WRITE (unit=titl(2:4),fmt='(I3)') mtemp
    +
    742  titl(6:7) = timun1(fcstim)
    +
    743  titl(8:12) = ' AVG'
    +
    744  ELSE
    +
    745  WRITE (unit=titl(29:32),fmt='(I3)') p1
    +
    746  ENDIF
    +
    747 C
    +
    748 C TEST FOR ANALYSIS (MAKE CORRECTION IF MODEL IS ANALYSIS)
    +
    749 C
    +
    750  IF (timerg.EQ.0.AND.p1.EQ.0) THEN
    +
    751  titl(29:42) = ' ANALYSIS VT '
    +
    752  model = mova2i(idpds(6:6))
    +
    753  IF (model.EQ.10.OR.model.EQ.39.OR.model.EQ.45.OR.
    +
    754  & model.EQ.53.OR.model.EQ.68.OR.model.EQ.69.OR.
    +
    755  & model.EQ.70.OR.model.EQ.73.OR.model.EQ.74.OR.
    +
    756  & model.EQ.75.OR.model.EQ.76.OR.model.EQ.77.OR.
    +
    757  & model.EQ.78.OR.model.EQ.79.OR.model.EQ.80.OR.
    +
    758  & model.EQ.83.OR.model.EQ.84.OR.model.EQ.85.OR.
    +
    759  & model.EQ.86.OR.model.EQ.87.OR.model.EQ.88.OR.
    +
    760  & model.EQ.90.OR.model.EQ.91.OR.model.EQ.92.OR.
    +
    761  & model.EQ.105.OR.model.EQ.110.OR.model.EQ.150.OR.
    +
    762  & model.EQ.151) THEN
    +
    763  titl(29:42) = ' 00-HR FCST '
    +
    764  ENDIF
    +
    765  ENDIF
    +
    766 C
    +
    767 C TEST FOR 00-HR FCST (INITIALIZED ANALYSIS)
    +
    768 C
    +
    769  IF (timerg.EQ.1.AND.p1.EQ.0) THEN
    +
    770  titl(29:42) = ' 00-HR FCST '
    +
    771  ENDIF
    +
    772 C
    +
    773 C$ 3.0 FIND WHO GENERATED THE CODE
    +
    774 C$ CHECK FOR SUB-CENTERS
    +
    775 C
    +
    776  igenc = mova2i(idpds(5:5))
    +
    777  isubc = mova2i(idpds(26:26))
    +
    778 C
    +
    779 C TEST FOR SUB-CENTERS WHEN CENTER IS 7
    +
    780 C
    +
    781 
    +
    782  IF (isubc.NE.0.AND.igenc.EQ.7) THEN
    +
    783  DO j = 1,ics1
    +
    784  IF (isubc .EQ. scntr1(j)) THEN
    +
    785  titl(63:86) = knam2(j)
    +
    786  RETURN
    +
    787  END IF
    +
    788  END DO
    +
    789  ierr = 7
    +
    790  END IF
    +
    791 C
    +
    792 C TEST FOR SUB-CENTERS WHEN CENTER IS 9
    +
    793 C
    +
    794  IF (isubc.NE.0.AND.igenc.EQ.9) THEN
    +
    795  DO j = 1,ics2
    +
    796  IF (isubc .EQ. scntr2(j)) THEN
    +
    797  titl(63:86) = knam3(j)
    +
    798  RETURN
    +
    799  END IF
    +
    800  END DO
    +
    801  ierr = 8
    +
    802  END IF
    +
    803 C
    +
    804 C TEST TO SEE IF CENTER IN TABLES
    +
    805 C
    +
    806  DO i = 1,ic
    +
    807  IF (igenc .EQ. center(i)) THEN
    +
    808  titl(63:86) = knam1(i)
    +
    809  RETURN
    +
    810  END IF
    +
    811  END DO
    +
    812 C
    +
    813  ierr = 6
    +
    814  RETURN
    +
    815  END
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    w3fp11
    subroutine w3fp11(IPDS0, IPDS, TITL, IERR)
    Converts GRIB formatted product definition section version 1 to a one line readable title.
    Definition: w3fp11.f:79
    + + + + diff --git a/ver-2.10.0/w3fp12_8f.html b/ver-2.10.0/w3fp12_8f.html new file mode 100644 index 00000000..c30f47c9 --- /dev/null +++ b/ver-2.10.0/w3fp12_8f.html @@ -0,0 +1,224 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp12.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fp12.f File Reference
    +
    +
    + +

    Creates the product definition section. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fp12 (ID8, IFLAG, IDPDS, ICENT, ISCALE, IER)
     Formats the product definition section according to the specifications set by WMO. More...
     
    +

    Detailed Description

    +

    Creates the product definition section.

    +
    Author
    A.J. McClees
    +
    Date
    1991-07-30
    + +

    Definition in file w3fp12.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fp12()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fp12 (integer(8), dimension ( 4) ID8,
    character*1 IFLAG,
    character*1, dimension (28) IDPDS,
    integer ICENT,
    integer ISCALE,
     IER 
    )
    +
    + +

    Formats the product definition section according to the specifications set by WMO.

    +

    Using o.n. 84 id's (1st 8 words) as the input data. New subroutine corresponds to the revision #1 of the WMO GRIB standards made march 15, 1991.

    +

    +Program History Log:

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Date Programmer Comments
    1991-07-30 A.J. McClees New subroutine which formats the pds section from the o.n. 84 id's from the GRIB edition 1 dated march 15, 1991.
    1992-01-06 A.J. McClees Delete paramater 202 (accumulated evap) and make parameter 57 (evaporation) the equivalent of o.n.84 117.
    1992-11-02 Ralph Jones Correction at same level as w3fp12() in v77w3lib on hds
    1993-03-29 Ralph Jones Add save statement
    1993-04-16 Ralph Jones Add 176, 177 lat, lon to tables
    1993-08-03 Ralph Jones Add 156 (cin), 204 (dswrf), 205 (dlwrf) 211 (uswrf), 212 (ulwrf) to tables
    1995-02-07 Ralph Jones Change pds byte 4, version number to 2.
    1995-07-14 Ralph Jones Correction for sfc lft x
    1998-03-10 Boi Vuong Remove the cdir$ integer=64 directive
    1998-12-21 Stephen Gilbert Replaced Function ICHAR with mova2i().
    1999-02-15 B. Facey Replace w3fs04 with w3movdat().
    1999-03-15 Stephen Gilbert Specified 8-byte integer array explicitly for ID8
    1999-03-22 B. Facey Remove the date recalculation for mean charts. this includes the previous change to w3movdat.
    +
    Parameters
    + + + + + + + +
    [in]ID8First 8 id workds (o.n.84) integer*4
    [in]ICENTCentury, 2 digits, for 1991 it is 20.
    [in]IFLAGIndication of inclusion or omission of grid definition and/or bit map code character*1
    [in]ISCALE10 scaler integer*4
    [out]IDPDSGRIB product definition section character*1 (28)
    [out]IER= 0 completed smoothly = 1 Indicator parameter N.A. to GRIB = 2 Level indicator N.A. to GRIB = 3 Time range N.A. to GRIB notation = 4 Layers or levels N.A. to GRIB
    +
    +
    +
    Author
    A.J. McClees
    +
    Date
    1991-07-30
    + +

    Definition at line 41 of file w3fp12.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fp12_8f.js b/ver-2.10.0/w3fp12_8f.js new file mode 100644 index 00000000..073b9d80 --- /dev/null +++ b/ver-2.10.0/w3fp12_8f.js @@ -0,0 +1,4 @@ +var w3fp12_8f = +[ + [ "w3fp12", "w3fp12_8f.html#a43259ead9ef06e1822639a8f2aa106aa", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fp12_8f_source.html b/ver-2.10.0/w3fp12_8f_source.html new file mode 100644 index 00000000..c0232789 --- /dev/null +++ b/ver-2.10.0/w3fp12_8f_source.html @@ -0,0 +1,698 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp12.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fp12.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Creates the product definition section
    +
    3 C> @author A.J. McClees @date 1991-07-30
    +
    4 
    +
    5 C> Formats the product definition section according to the
    +
    6 C> specifications set by WMO. Using o.n. 84 id's (1st 8 words)
    +
    7 C> as the input data. New subroutine corresponds to the revision
    +
    8 C> #1 of the WMO GRIB standards made march 15, 1991.
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comments
    +
    12 C> -----|------------|---------
    +
    13 C> 1991-07-30 | A.J. McClees | New subroutine which formats the pds section from the o.n. 84 id's from the GRIB edition 1 dated march 15, 1991.
    +
    14 C> 1992-01-06 | A.J. McClees | Delete paramater 202 (accumulated evap) and make parameter 57 (evaporation) the equivalent of o.n.84 117.
    +
    15 C> 1992-11-02 | Ralph Jones | Correction at same level as w3fp12() in v77w3lib on hds
    +
    16 C> 1993-03-29 | Ralph Jones | Add save statement
    +
    17 C> 1993-04-16 | Ralph Jones | Add 176, 177 lat, lon to tables
    +
    18 C> 1993-08-03 | Ralph Jones | Add 156 (cin), 204 (dswrf), 205 (dlwrf) 211 (uswrf), 212 (ulwrf) to tables
    +
    19 C> 1995-02-07 | Ralph Jones | Change pds byte 4, version number to 2.
    +
    20 C> 1995-07-14 | Ralph Jones | Correction for sfc lft x
    +
    21 C> 1998-03-10 | Boi Vuong | Remove the cdir$ integer=64 directive
    +
    22 C> 1998-12-21 | Stephen Gilbert | Replaced Function ICHAR with mova2i().
    +
    23 C> 1999-02-15 | B. Facey | Replace w3fs04 with w3movdat().
    +
    24 C> 1999-03-15 | Stephen Gilbert | Specified 8-byte integer array explicitly for ID8
    +
    25 C> 1999-03-22 | B. Facey | Remove the date recalculation for mean charts. this includes the previous change to w3movdat.
    +
    26 C>
    +
    27 C> @param[in] ID8 First 8 id workds (o.n.84) integer*4
    +
    28 C> @param[in] ICENT Century, 2 digits, for 1991 it is 20.
    +
    29 C> @param[in] IFLAG Indication of inclusion or omission of grid definition and/or bit map code character*1
    +
    30 C> @param[in] ISCALE 10 scaler integer*4
    +
    31 C> @param[out] IDPDS GRIB product definition section character*1 (28)
    +
    32 C> @param[out] IER
    +
    33 C> = 0 completed smoothly
    +
    34 C> = 1 Indicator parameter N.A. to GRIB
    +
    35 C> = 2 Level indicator N.A. to GRIB
    +
    36 C> = 3 Time range N.A. to GRIB notation
    +
    37 C> = 4 Layers or levels N.A. to GRIB
    +
    38 C>
    +
    39 C> @author A.J. McClees @date 1991-07-30
    +
    40  SUBROUTINE w3fp12(ID8, IFLAG, IDPDS, ICENT, ISCALE, IER)
    +
    41 C
    +
    42  INTEGER E1
    +
    43  INTEGER E2
    +
    44  INTEGER F1
    +
    45  INTEGER F2
    +
    46  DATA f1/0/, f2/0/
    +
    47  INTEGER HH (163)
    +
    48  INTEGER(8) ID8 ( 4)
    +
    49  INTEGER(8) IDWK ( 4)
    +
    50  INTEGER(8) MSK1,MSK2,MSK3,MSK4,MSK5,MSK6,MSK7
    +
    51  INTEGER ISIGN
    +
    52  INTEGER ISCALE
    +
    53  INTEGER ICENT
    +
    54  INTEGER LL (163)
    +
    55  INTEGER L
    +
    56  INTEGER M
    +
    57  INTEGER N
    +
    58  INTEGER Q
    +
    59  INTEGER S1
    +
    60  INTEGER T
    +
    61  DATA t/0/
    +
    62 C
    +
    63  CHARACTER*1 IDPDS (28)
    +
    64  CHARACTER*1 IFLAG
    +
    65  CHARACTER*1 IHOLD ( 8)
    +
    66  CHARACTER*1 IPDS1 ( 8)
    +
    67  CHARACTER*1 KDATE ( 8)
    +
    68  CHARACTER*1 LIDWK (32)
    +
    69 C
    +
    70  equivalence(idwk(1),lidwk(1))
    +
    71  equivalence(l,ipds1(1))
    +
    72  equivalence(nbytes,ihold(1))
    +
    73  equivalence(jdate,kdate(1))
    +
    74  REAL RINC(5)
    +
    75  INTEGER NDATE(8), MDATE(8)
    +
    76 C
    +
    77  DATA ll / 8, 8, 9, 255, 255, 255, 1, 6, 255, 255,
    +
    78  & 16, 24, 19, 23, 20, 21, 17, 18, 255, 180,
    +
    79  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    +
    80  & 55, 50, 48, 56, 49, 57, 80, 81, 71, 255,
    +
    81  & 40, 42, 72, 74, 73, 255, 255, 255, 255, 255,
    +
    82  & 304, 305, 95, 88, 101, 89, 104, 255, 117, 255,
    +
    83  & 97, 98, 90, 105, 94, 255, 255, 93, 188, 255,
    +
    84  & 255, 255, 255, 211, 255, 255, 255, 255, 255, 255,
    +
    85  & 255, 384, 161, 255, 255, 169, 22, 255, 255, 255,
    +
    86  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    +
    87  & 255, 400, 389, 385, 388, 391, 386, 390, 402, 401,
    +
    88  & 404, 403, 204, 255, 255, 255, 255, 255, 255, 255,
    +
    89  & 255, 255, 195, 194, 255, 255, 255, 255, 255, 255,
    +
    90  & 255, 255, 112, 116, 114, 255, 103, 52, 255, 255,
    +
    91  & 255, 255, 119, 157, 158, 159, 255, 176, 177, 392,
    +
    92  & 192, 190, 199, 216, 189, 193, 191, 210, 198, 255,
    +
    93  & 255, 1, 255/
    +
    94  DATA hh / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
    +
    95  & 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
    +
    96  & 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
    +
    97  & 31, 32, 33, 33, 34, 34, 35, 36, 37, 38,
    +
    98  & 39, 40, 41, 42, 43, 44, 45, 46, 47, 48,
    +
    99  & 49, 50, 51, 52, 53, 54, 55, 56, 57, 58,
    +
    100  & 59, 60, 61, 62, 63, 64, 65, 66, 67, 68,
    +
    101  & 69, 70, 71, 72, 73, 74, 75, 76, 77, 78,
    +
    102  & 79, 80, 81, 82, 83, 84, 85, 86, 87, 88,
    +
    103  & 89, 90, 91, 92, 93, 94, 95, 96, 97, 98,
    +
    104  & 99, 100, 101, 102, 103, 104, 105, 106, 107, 108,
    +
    105  & 109, 110, 111, 112, 113, 114, 115, 116, 117, 118,
    +
    106  & 119, 120, 121, 122, 123, 124, 125, 126, 127, 128,
    +
    107  & 129, 130, 131, 132, 133, 134, 135, 136, 137, 150,
    +
    108  & 151, 152, 156, 157, 158, 159, 175, 176, 177, 201,
    +
    109  & 204, 205, 207, 208, 209, 211, 212, 213, 216, 218,
    +
    110  & 220, 222, 255/
    +
    111 C DATA MSK1 /Z'00000FFF'/,
    +
    112 C & MSK2 /Z'0FFFFF00'/,
    +
    113 C & MSK3 /Z'0000007F'/,
    +
    114 C & MSK4 /Z'00000080'/,
    +
    115 C & MSK5 /Z'F0000000'/,
    +
    116 C & MSK6 /Z'00000200'/,
    +
    117 C & MSK7 /Z'000000FF'/
    +
    118 C CHANGE HEX TO DECIMAL TO MAKE SUBROUTINE MORE PORTABLE
    +
    119  DATA msk1 /4095/,
    +
    120  & msk2 /268435200/,
    +
    121  & msk3 /127/,
    +
    122  & msk4 /128/,
    +
    123  & msk5 /z'00000000F0000000'/
    +
    124  & msk6 /512/,
    +
    125  & msk7 /255/
    +
    126 C
    +
    127 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    128 C
    +
    129 C$ 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM.
    +
    130 C$ - NO. OF ENTRIES IN TYPE LEVEL
    +
    131 C
    +
    132  iq = 163
    +
    133 C
    +
    134 C$ 1.1 COPY O.N. 84 ID'S INTO WORK SPACE
    +
    135 C
    +
    136  DO 100 n = 1,4
    +
    137  idwk(n) = id8(n)
    +
    138  100 CONTINUE
    +
    139 C ---------------------------------------------------------------------
    +
    140 C 2.0 NO. OF OCTETS IN THE PDS IN THE FIRST 3
    +
    141 C$ 2.1 SET CNTR ID, DATA TYPE, GRID DEF AND FLAG
    +
    142 C
    +
    143  nbytes = 28
    +
    144  idpds(1) = ihold(6)
    +
    145  idpds(2) = ihold(7)
    +
    146  idpds(3) = ihold(8)
    +
    147  idpds(4) = char(2)
    +
    148  idpds(5) = char(7)
    +
    149  idpds(6) = lidwk(30)
    +
    150  jscale = iscale
    +
    151  IF (jscale.LT.0) THEN
    +
    152  jscale = -jscale
    +
    153  idpds(27) = char(128)
    +
    154  idpds(28) = char(jscale)
    +
    155  ELSE
    +
    156  idpds(27) = char(0)
    +
    157  idpds(28) = char(jscale)
    +
    158  END IF
    +
    159 C
    +
    160  IF (lidwk(30) .EQ. char(69)) THEN
    +
    161  IF (lidwk(29) .EQ. char(3)) THEN
    +
    162  idpds(6) = char(68)
    +
    163  ELSE IF (lidwk(29) .EQ. char(4)) THEN
    +
    164  idpds(6) = char(69)
    +
    165  ENDIF
    +
    166  ENDIF
    +
    167  IF (lidwk(30) .EQ. char(78)) THEN
    +
    168  IF (lidwk(29) .EQ. char(3)) THEN
    +
    169  idpds(6) = char(77)
    +
    170  ELSE IF (lidwk(29) .EQ. char(4)) THEN
    +
    171  idpds(6) = char(78)
    +
    172  ENDIF
    +
    173  ENDIF
    +
    174  idpds(7) = lidwk(20)
    +
    175  IF (lidwk(20) .EQ. char(26)) idpds(7) = char(6)
    +
    176  idpds(8) = iflag
    +
    177  idpds(24) = char(0)
    +
    178  idpds(26) = char(0)
    +
    179 C---------------------------------------------------------------------
    +
    180 C
    +
    181 C$ 3.0 FORM INDICATOR PARAMETER
    +
    182 C
    +
    183  q = ishft(idwk(1),-52_8)
    +
    184  DO 300 i = 1,iq
    +
    185  ii = i
    +
    186  IF (q .EQ. ll(i)) GO TO 310
    +
    187  300 CONTINUE
    +
    188 C
    +
    189  ier = 1
    +
    190  print 320, ier, q, id8
    +
    191  320 FORMAT (' W3FP12 (320) - IER = ',i2,', Q = ',i3,/,
    +
    192  & ' OFFICE NOTE 84 PARAMETER N.A. IN GRIB',
    +
    193  & /,1x,4(z16,' '))
    +
    194  RETURN
    +
    195 C
    +
    196  310 i = ii
    +
    197  s1 = iand(ishft(idwk(1),-40_8),msk1)
    +
    198  c1 = ishft(iand(idwk(1),msk2),-8_8)
    +
    199  isig1 = iand(idwk(1),msk4)
    +
    200  e1 = iand(idwk(1),msk3)
    +
    201  IF (isig1 .NE. 0) e1 = -e1
    +
    202  m = ishft(iand(ishft(idwk(2),-32_8),msk5),-28_8)
    +
    203  n = ishft(iand(idwk(2),msk5),-28_8)
    +
    204  ks = ishft(iand(ishft(idwk(3),-32_8),msk6),-8_8)
    +
    205  IF (m.NE.0) THEN
    +
    206  c2 = ishft(iand(idwk(2),msk2),-8_8)
    +
    207  isig2 = iand(idwk(2),msk4)
    +
    208  e2 = iand(idwk(2),msk3)
    +
    209  IF (isig2 .NE. 0) e2 = -e2
    +
    210  ENDIF
    +
    211  idpds(9) = char(hh(i))
    +
    212 C
    +
    213 C N IS A SPECIAL TEST FOR WAVE HGTS, M AND KS ARE SPECIAL FOR
    +
    214 C ACCUMULATED PRECIP
    +
    215 C
    +
    216  IF (n .EQ. 5 .AND. q .EQ. 1) THEN
    +
    217  idpds(9) = char(222)
    +
    218  ENDIF
    +
    219  IF (ks .EQ. 2) THEN
    +
    220  IF (m .EQ. 0 .AND. q .EQ. 8) THEN
    +
    221  idpds(9) = char(211)
    +
    222  END IF
    +
    223 C
    +
    224  IF (m .EQ. 0 .AND. q .EQ. 1) THEN
    +
    225  idpds(9) = char(210)
    +
    226  ENDIF
    +
    227 C
    +
    228  IF (m .EQ. 1 .AND. q .EQ. 1) THEN
    +
    229  ier = 1
    +
    230  print 330, ier, id8
    +
    231  330 FORMAT (' W3FP12 (330) - IER =',i2,/,
    +
    232  & ' OFFICE NOTE 84 PARAMETER N.A. IN GRIB',
    +
    233  & /,1x,4(z16,' '))
    +
    234  RETURN
    +
    235  ENDIF
    +
    236  ENDIF
    +
    237 C
    +
    238 C$ 4.0 DETERMINE IF LAYERS OR LEVEL AND FORM TYPE
    +
    239 C
    +
    240 C ......... M = THE M MARKER FROM O.N.84 CHECK ABOVE
    +
    241 C ......... S1 = S1 TYPE OF SURFACE
    +
    242 C
    +
    243  IF (m .EQ. 0) THEN
    +
    244  IF (s1.EQ.0.AND.(q.EQ.176.OR.q.EQ.177)) THEN
    +
    245  idpds(10) = char(0)
    +
    246  idpds(11) = char(0)
    +
    247  idpds(12) = char(0)
    +
    248 C
    +
    249  ELSE IF (s1 .EQ. 8) THEN
    +
    250  idpds(10) = char(100)
    +
    251  l = c1 * (10. ** e1) + .5
    +
    252  idpds(11) = ipds1(7)
    +
    253  idpds(12) = ipds1(8)
    +
    254 C
    +
    255  ELSE IF (s1 .EQ. 1) THEN
    +
    256  idpds(10) = char(103)
    +
    257  l = c1 * (10. ** e1) + .5
    +
    258  idpds(11) = ipds1(7)
    +
    259  idpds(12) = ipds1(8)
    +
    260 C
    +
    261  ELSE IF (s1 .EQ. 6) THEN
    +
    262  idpds(10) = char(105)
    +
    263  l = c1 * (10. ** e1) + .5
    +
    264  idpds(11) = ipds1(7)
    +
    265  idpds(12) = ipds1(8)
    +
    266 C
    +
    267  ELSE IF (s1 .EQ. 7) THEN
    +
    268  idpds(10) = char(111)
    +
    269 C CONVERT FROM METERS TO CENTIMETERS
    +
    270  IF (isig1 .NE. 0) e1 = e1 + 2
    +
    271  l = c1 * (10. ** e1) + .5
    +
    272  idpds(11) = ipds1(7)
    +
    273  idpds(12) = ipds1(8)
    +
    274 C
    +
    275  ELSE IF (s1.EQ.148 .OR. s1 .EQ. 144 .OR. s1 .EQ. 145) THEN
    +
    276  idpds(10) = char(107)
    +
    277  l = (c1 * (10. ** e1) * 10**4) + .5
    +
    278  idpds(11) = ipds1(7)
    +
    279  idpds(12) = ipds1(8)
    +
    280 C
    +
    281  ELSE IF (s1 .EQ. 16) THEN
    +
    282  l = c1 * (10. ** e1) + .5
    +
    283  IF (l .EQ. 273) THEN
    +
    284  idpds(10) = char(4)
    +
    285  idpds(11) = char(0)
    +
    286  idpds(12) = char(0)
    +
    287  ELSE
    +
    288  ier = 2
    +
    289  print 410, ier, s1, id8
    +
    290  RETURN
    +
    291  ENDIF
    +
    292 C
    +
    293  ELSE IF (s1 .EQ. 19) THEN
    +
    294  l = c1 * (10. ** e1) + .5
    +
    295  idpds(10) = char(113)
    +
    296  idpds(11) = ipds1(7)
    +
    297  idpds(12) = ipds1(8)
    +
    298 C
    +
    299 C SET LEVEL AND PARAMETER FOR MSL PRESSURE
    +
    300 C
    +
    301  ELSE IF (s1 .EQ. 128) THEN
    +
    302  IF (q.EQ.8) THEN
    +
    303  idpds(9) = char(2)
    +
    304  END IF
    +
    305  idpds(10) = char(102)
    +
    306  idpds(11) = char(0)
    +
    307  idpds(12) = char(0)
    +
    308 C
    +
    309  ELSE IF (s1 .EQ. 129) THEN
    +
    310  idpds(10) = char(1)
    +
    311  idpds(11) = char(0)
    +
    312  idpds(12) = char(0)
    +
    313 C
    +
    314  ELSE IF (s1 .EQ. 130) THEN
    +
    315  idpds(10) = char(7)
    +
    316  idpds(11) = char(0)
    +
    317  idpds(12) = char(0)
    +
    318 C
    +
    319  ELSE IF (s1 .EQ. 131) THEN
    +
    320  idpds(10) = char(6)
    +
    321  idpds(11) = char(0)
    +
    322  idpds(12) = char(0)
    +
    323 C
    +
    324  ELSE IF (s1 .EQ. 133) THEN
    +
    325  idpds(10) = char(1)
    +
    326  idpds(11) = char(0)
    +
    327  idpds(12) = char(0)
    +
    328 C
    +
    329  ELSE IF (s1 .EQ. 136) THEN
    +
    330  IF (q.EQ.8) THEN
    +
    331  IF (t.EQ.2.AND.f1.EQ.0.AND.f2.EQ.3) THEN
    +
    332  idpds(9) = char(137)
    +
    333  ELSE
    +
    334  idpds(9) = char(128)
    +
    335  END IF
    +
    336  END IF
    +
    337  idpds(10) = char(102)
    +
    338  idpds(11) = char(0)
    +
    339  idpds(12) = char(0)
    +
    340 C
    +
    341  ELSE IF (s1 .EQ. 137) THEN
    +
    342  IF (q.EQ.8) THEN
    +
    343  idpds(9) = char(129)
    +
    344  END IF
    +
    345  idpds(10) = char(102)
    +
    346  idpds(11) = char(0)
    +
    347  idpds(12) = char(0)
    +
    348 C
    +
    349  ELSE IF (s1 .EQ. 138) THEN
    +
    350  IF (q.EQ.8) THEN
    +
    351  idpds(9) = char(130)
    +
    352  END IF
    +
    353  idpds(10) = char(102)
    +
    354  idpds(11) = char(0)
    +
    355  idpds(12) = char(0)
    +
    356 C
    +
    357  ELSE
    +
    358  ier = 2
    +
    359  print 410, ier, s1, id8
    +
    360  410 FORMAT (' W3FP12 (410) - IER = ',i2,', S1 = ',i5,/,
    +
    361  & ' SURFACE TYPE N.A. IN GRIB',/,' ID8 = ',
    +
    362  & 4(z16,' '))
    +
    363  RETURN
    +
    364  ENDIF
    +
    365 C
    +
    366  ELSE IF (m .EQ. 1) THEN
    +
    367  IF ((s1 .EQ. 8) .AND. (q .EQ. 1)) THEN
    +
    368  idpds(9) = char(101)
    +
    369  idpds(10) = char(101)
    +
    370  jjj = ((c1 * 10. ** e1) * .1) + .5
    +
    371  idpds(11) = char(jjj)
    +
    372  kkk = ((c2 * 10. ** e2) * .1) + .5
    +
    373  idpds(12) = char(kkk)
    +
    374  END IF
    +
    375 C
    +
    376  ELSE IF (m .EQ. 2) THEN
    +
    377  IF (s1 .EQ. 8) THEN
    +
    378  idpds(10) = char(101)
    +
    379  jjj = ((c1 * 10. ** e1) * .1) + .5
    +
    380  idpds(11) = char(jjj)
    +
    381  kkk = ((c2 * 10. ** e2) * .1) + .5
    +
    382  idpds(12) = char(kkk)
    +
    383  IF (idpds(9) .EQ. char(131)) idpds(12) = char(100)
    +
    384 C
    +
    385  ELSE IF (s1 .EQ. 1) THEN
    +
    386  idpds(10) = char(104)
    +
    387  jjj = ((c1 * 10. ** e1) * .1) + .5
    +
    388  idpds(11) = char(jjj)
    +
    389  kkk = ((c2 * 10. ** e2) * .1) + .5
    +
    390  idpds(12) = char(kkk)
    +
    391 C
    +
    392  ELSE IF (s1 .EQ. 6) THEN
    +
    393  idpds(10) = char(106)
    +
    394  jjj = ((c1 * 10. ** e1) * .1) + .5
    +
    395  idpds(11) = char(jjj)
    +
    396  kkk = ((c2 * 10. ** e2) * .1) + .5
    +
    397  idpds(12) = char(kkk)
    +
    398 C
    +
    399  ELSE IF (s1.EQ.148 .OR. s1 .EQ. 144 .OR. s1 .EQ. 145) THEN
    +
    400  idpds(10) = char(108)
    +
    401  jjj = ((c1 * 10. ** e1) * 10**2) + .5
    +
    402  idpds(11) = char(jjj)
    +
    403  kkk = ((c2 * 10. ** e2) * 10**2) + .5
    +
    404  idpds(12) = char(kkk)
    +
    405 C
    +
    406  ELSE
    +
    407  ier = 2
    +
    408  print 420, ier, s1, id8
    +
    409  420 FORMAT (' W3FP12 (420) - IER = ',i2,', S1 = ',i5,/,
    +
    410  & ' SURFACE LAYERS N.A. IN GRIB',
    +
    411  & /,' ID8= ',4(z16,' '))
    +
    412  RETURN
    +
    413  ENDIF
    +
    414  ELSE IF (m .GT. 2) THEN
    +
    415  ier = 4
    +
    416  print 500, ier, m, id8
    +
    417  500 FORMAT ('W3FP12 (500) - IER = ',i2,', M = ',/,
    +
    418  & ' THE M FROM O.N. 84 N.A. IN GRIB',
    +
    419  & /,' ID8 = ',4(z16,' '))
    +
    420  RETURN
    +
    421  ENDIF
    +
    422 C
    +
    423 C$ 6.0 DATE - YR.,MO,DA,& INITIAL HR AND CENTURY
    +
    424 C
    +
    425  idpds(13) = lidwk(25)
    +
    426  idpds(14) = lidwk(26)
    +
    427  idpds(15) = lidwk(27)
    +
    428  idpds(16) = lidwk(28)
    +
    429  idpds(17) = char(0)
    +
    430  idpds(25) = char(icent)
    +
    431 C---------------------------------------------------------------------
    +
    432 C
    +
    433 C$ OCTET (17) N.A. FROM O.N. 84 DATA
    +
    434 C
    +
    435 C$ 7.0 INDICATOR OF TIME UNIT, TIME RANGE 1 AND 2, AND TIME
    +
    436 C RANGE FLAG
    +
    437 C
    +
    438  t = ishft((iand(idwk(1),msk5)),-28_8)
    +
    439  f1 = iand(ishft(idwk(1),-32_8),msk7)
    +
    440  f2 = iand(ishft(idwk(2),-32_8),msk7)
    +
    441  IF (t .EQ. 0) THEN
    +
    442  idpds(18) = char(1)
    +
    443  idpds(19) = char(f1)
    +
    444  idpds(20) = char(0)
    +
    445  idpds(21) = char(0)
    +
    446  idpds(22) = char(0)
    +
    447  idpds(23) = char(0)
    +
    448 C
    +
    449  ELSE IF (t .EQ. 1) THEN
    +
    450  print 710, t, id8
    +
    451  ier = 3
    +
    452  RETURN
    +
    453 C
    +
    454  ELSE IF (t .EQ. 2) THEN
    +
    455  IF (mova2i(idpds(9)).NE.137) THEN
    +
    456  print 710, t, id8
    +
    457  ier = 3
    +
    458  RETURN
    +
    459  END IF
    +
    460 C
    +
    461  ELSE IF (t .EQ. 3) THEN
    +
    462  IF (q .EQ. 89 .OR. q .EQ. 90 .OR. q .EQ. 94
    +
    463  & .OR. q .EQ. 105) THEN
    +
    464 C
    +
    465  idpds(18) = char(1)
    +
    466 C CORRECTION FOR 00 HR FCST
    +
    467  itemp = f1 - f2
    +
    468  IF (itemp.LT.0) itemp = 0
    +
    469 C IDPDS(19) = CHAR (F1 - F2)
    +
    470  idpds(19) = char(itemp)
    +
    471  idpds(20) = char(f1)
    +
    472  idpds(21) = char(4)
    +
    473  idpds(22) = char(0)
    +
    474  idpds(23) = char(0)
    +
    475 C
    +
    476  ELSE
    +
    477  idpds(18) = char(1)
    +
    478 C CORRECTION FOR 00 HR FCST
    +
    479  itemp = f1 - f2
    +
    480  IF (itemp.LT.0) itemp = 0
    +
    481 C IDPDS(19) = CHAR (F1 - F2)
    +
    482  idpds(19) = char(itemp)
    +
    483  idpds(20) = char(f1)
    +
    484  idpds(21) = char(5)
    +
    485  idpds(22) = char(0)
    +
    486  idpds(23) = char(0)
    +
    487  END IF
    +
    488 C
    +
    489  ELSE IF (t .EQ. 4) THEN
    +
    490 C
    +
    491  IF (f1 .EQ. 0 .AND. f2 .NE. 0) THEN
    +
    492  idpds(18) = char(4)
    +
    493  idpds(19) = char(0)
    +
    494  idpds(20) = char(1)
    +
    495  idpds(21) = char(124)
    +
    496  l = f2
    +
    497  idpds(22) = ipds1(7)
    +
    498  idpds(23) = ipds1(8)
    +
    499 C
    +
    500  ELSE IF (f1 .NE. 0 .AND. f2 .EQ. 0) THEN
    +
    501  idpds(18) = char(2)
    +
    502  idpds(19) = char(0)
    +
    503  idpds(20) = char(1)
    +
    504  idpds(21) = char(124)
    +
    505  l = f1
    +
    506  idpds(22) = ipds1(7)
    +
    507  idpds(23) = ipds1(8)
    +
    508 C
    +
    509  ENDIF
    +
    510 C
    +
    511  ELSE IF (t .EQ. 5) THEN
    +
    512  idpds(18) = char(1)
    +
    513 C CORRECTION FOR 00 HR FCST
    +
    514  itemp = f1 - f2
    +
    515  IF (itemp.LT.0) itemp = 0
    +
    516 C IDPDS(19) = CHAR (F1 - F2)
    +
    517  idpds(19) = char(itemp)
    +
    518  idpds(20) = char(f1)
    +
    519  idpds(21) = char(2)
    +
    520  idpds(22) = char(0)
    +
    521  idpds(23) = char(0)
    +
    522 C
    +
    523  ELSE IF (t .EQ. 6) THEN
    +
    524  jsign = iand(ishft(idwk(1),-32_8),msk4)
    +
    525  jsigo = iand(ishft(idwk(2),-32_8),msk4)
    +
    526  f1 = iand(ishft(idwk(1),-32_8),msk3)
    +
    527  f2 = iand(ishft(idwk(2),-32_8),msk3)
    +
    528  IF (jsign .NE. 0) f1 = -f1
    +
    529  IF (jsigo .NE. 0) f2 = -f2
    +
    530  idpds(18) = char(1)
    +
    531 C****CALCULATE NEW DATE BASED ON THE BEGINNING OF THE DATA IN MEAN
    +
    532 C INCR = (F1)
    +
    533 C IF (INCR.LT.0) THEN
    +
    534 C RINC=0
    +
    535 C RINC(2)=INCR
    +
    536 C PRINT *, 'INCR=',INCR
    +
    537 C CALL W3FS04 (IDWK(4),JDATE,INCR,IERR)
    +
    538 C IYR=ICHAR(LIDWK(25))
    +
    539 C PRINT *, 'IYR = ', IYR
    +
    540 C IF(IYR.LT.20)THEN
    +
    541 C MDATE(1)=2000+IYR
    +
    542 C ELSE
    +
    543 C MDATE(1)=1900+IYR
    +
    544 C ENDIF
    +
    545 C MDATE(2) = ICHAR(LIDWK(26))
    +
    546 C MDATE(3) = ICHAR(LIDWK(27))
    +
    547 C MDATE(4) = ICHAR(LIDWK(28))
    +
    548 C PRINT *, 'CHANGE DATE BY - ', RINC(2)
    +
    549 C CALL W3MOVDAT(RINC,MDATE,NDATE)
    +
    550 C PRINT *,'NEW DATE =',NDATE(1),NDATE(2),NDATE(3),NDATE(5)
    +
    551 C IYEAR = MOD(NDATE(1),100)
    +
    552 C LIDWK(25) = CHAR(IYEAR)
    +
    553 C LIDWK(26) = CHAR(NDATE(2))
    +
    554 C LIDWK(27) = CHAR(NDATE(3))
    +
    555 C LIDWK(28) = CHAR(NDATE(4))
    +
    556 C END IF
    +
    557  idpds(13) = lidwk(25)
    +
    558  idpds(14) = lidwk(26)
    +
    559  idpds(15) = lidwk(27)
    +
    560  idpds(16) = lidwk(28)
    +
    561  IF (f1.LT.0) THEN
    +
    562  idpds(19) = char(0)
    +
    563  idpds(21) = char(123)
    +
    564  ELSE
    +
    565  nf1 = f1 * 12
    +
    566  idpds(19) = char(nf1)
    +
    567  idpds(21) = char(113)
    +
    568  END IF
    +
    569  idpds(20) = char(24)
    +
    570 C*****THE NUMBER OF CASES AVERAGED IS ASSUMING ONE TIME A DAY
    +
    571 C L = (F2/2) + 1
    +
    572 C***THE ABOVE CALCULATION WOULD BE CORR. IF ID8(3) WERE CORR.
    +
    573  l = (f2+1) / 2
    +
    574  idpds(22) = ipds1(7)
    +
    575  idpds(23) = ipds1(8)
    +
    576 C
    +
    577  ELSE IF (t .EQ. 7) THEN
    +
    578  print 710, t, id8
    +
    579  ier = 3
    +
    580  RETURN
    +
    581 C
    +
    582  ELSE IF (t .EQ. 10) THEN
    +
    583  print 710, t, id8
    +
    584  ier = 3
    +
    585  RETURN
    +
    586 C
    +
    587  710 FORMAT (' W3FP12 (710) - NOT APPLICABLE (YET) TO GRIB. ',
    +
    588  & ', T = ',i2,/,
    +
    589  & ' O.N. 84 IDS ARE ',/,
    +
    590  & 1x,4(z16,' '))
    +
    591 C
    +
    592  ENDIF
    +
    593  ier = 0
    +
    594  RETURN
    +
    595  END
    +
    +
    +
    w3fp12
    subroutine w3fp12(ID8, IFLAG, IDPDS, ICENT, ISCALE, IER)
    Formats the product definition section according to the specifications set by WMO.
    Definition: w3fp12.f:41
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    + + + + diff --git a/ver-2.10.0/w3fp13_8f.html b/ver-2.10.0/w3fp13_8f.html new file mode 100644 index 00000000..86ff3537 --- /dev/null +++ b/ver-2.10.0/w3fp13_8f.html @@ -0,0 +1,203 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp13.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fp13.f File Reference
    +
    +
    + +

    Convert GRIB PDS edition 1 to O.N. 84 ID. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fp13 (GRIB, PDS, ID8, IERR)
     Converts GRIB version 1 formatted product definition section to an office note 84 id label. More...
     
    +

    Detailed Description

    +

    Convert GRIB PDS edition 1 to O.N. 84 ID.

    +
    Author
    A.J. McClees
    +
    Date
    1991-10-07
    + +

    Definition in file w3fp13.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fp13()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fp13 (character * 8 GRIB,
    character * 1, dimension ( *) PDS,
    integer, dimension (12) ID8,
     IERR 
    )
    +
    + +

    Converts GRIB version 1 formatted product definition section to an office note 84 id label.

    +

    Formats all that is appli- cable in the first 8 words of O.N. 84. (caution ****see remarks)

    +

    +Program History Log:

    + + + + + + + + + + + + + + + + + + + + + +
    Date Programmer Comments
    1991-10-07 A.J. McClees Initial
    1992-01-06 Ralph Jones Convert to silicongraphics 3.3 fortran 77
    1993-03-29 Ralph Jones Add save statement
    1994-04-17 Ralph Jones Complete rewrite to use sbyte, make code portable, upgrade to on388
    1994-05-05 Ralph Jones Correction in two tables
    1996-08-02 Ralph Jones Error using T marker
    1996-09-03 Ralph Jones Add mercator grids 8 and 53 to tables
    1999-02-15 B. Facey Replace w3fs04 with w3movdat().
    2002-10-15 Boi Vuong Replaced function ichar with mova2i()
    +
    Parameters
    + + + + + +
    [in]GRIBGRIB section 0 read as character*8
    [in]PDSGRIB PDS section 1 read as character*1 PDS(*)
    [out]ID812 Integer*4 formatted O.N. 84 ID. 6 integer 64 bit words on cray
    [out]IERR0 - Completed satisfactorily 1 - Grib block 0 not correct 2 - Length of pds not correct 3 - Could not match type indicator 4 - Grid type not in tables 5 - Could not match type level 6 - Could not interpret originator of code
    +
    +
    +
    Note
    Some of the id's will not be exact to the o.n. 84 for locating field on the dataset. These differences are mainly due to truncation errors with layers. For example: .18019 sig .47191 sig r h for 36.o hrs will convert to: .18000 sig .47000 sig r h for 36.0 hrs !!!!!!!the above id's now forced to be exact!!!!!!!!! If j the word count is greater then 32743, j is stored in the 12th id word. Bits 16-31 of the 8th id word are set to zero.
    +
    Author
    A.J. McClees
    +
    Date
    1991-10-07
    + +

    Definition at line 46 of file w3fp13.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fp13_8f.js b/ver-2.10.0/w3fp13_8f.js new file mode 100644 index 00000000..11279f7c --- /dev/null +++ b/ver-2.10.0/w3fp13_8f.js @@ -0,0 +1,4 @@ +var w3fp13_8f = +[ + [ "w3fp13", "w3fp13_8f.html#a4bb36ff2a73a0614b75ec00e2b804740", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fp13_8f_source.html b/ver-2.10.0/w3fp13_8f_source.html new file mode 100644 index 00000000..0bd02c2e --- /dev/null +++ b/ver-2.10.0/w3fp13_8f_source.html @@ -0,0 +1,1016 @@ + + + + + + + +NCEPLIBS-w3emc: w3fp13.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fp13.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert GRIB PDS edition 1 to O.N. 84 ID.
    +
    3 C> @author A.J. McClees @date 1991-10-07
    +
    4 
    +
    5 C> Converts GRIB version 1 formatted product definition
    +
    6 C> section to an office note 84 id label. Formats all that is appli-
    +
    7 C> cable in the first 8 words of O.N. 84. (caution ****see remarks)
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comments
    +
    11 C> -----|------------|---------
    +
    12 C> 1991-10-07 | A.J. McClees | Initial
    +
    13 C> 1992-01-06 | Ralph Jones | Convert to silicongraphics 3.3 fortran 77
    +
    14 C> 1993-03-29 | Ralph Jones | Add save statement
    +
    15 C> 1994-04-17 | Ralph Jones | Complete rewrite to use sbyte, make code portable, upgrade to on388
    +
    16 C> 1994-05-05 | Ralph Jones | Correction in two tables
    +
    17 C> 1996-08-02 | Ralph Jones | Error using T marker
    +
    18 C> 1996-09-03 | Ralph Jones | Add mercator grids 8 and 53 to tables
    +
    19 C> 1999-02-15 | B. Facey | Replace w3fs04 with w3movdat().
    +
    20 C> 2002-10-15 | Boi Vuong | Replaced function ichar with mova2i()
    +
    21 C>
    +
    22 C> @param[in] GRIB GRIB section 0 read as character*8
    +
    23 C> @param[in] PDS GRIB PDS section 1 read as character*1 PDS(*)
    +
    24 C> @param[out] ID8 12 Integer*4 formatted O.N. 84 ID. 6 integer 64 bit words on cray
    +
    25 C> @param[out] IERR
    +
    26 C> 0 - Completed satisfactorily
    +
    27 C> 1 - Grib block 0 not correct
    +
    28 C> 2 - Length of pds not correct
    +
    29 C> 3 - Could not match type indicator
    +
    30 C> 4 - Grid type not in tables
    +
    31 C> 5 - Could not match type level
    +
    32 C> 6 - Could not interpret originator of code
    +
    33 C>
    +
    34 C> @note Some of the id's will not be exact to the o.n. 84
    +
    35 C> for locating field on the dataset. These differences
    +
    36 C> are mainly due to truncation errors with layers.
    +
    37 C> For example: .18019 sig .47191 sig r h for 36.o hrs
    +
    38 C> will convert to: .18000 sig .47000 sig r h for 36.0 hrs
    +
    39 C> !!!!!!!the above id's now forced to be exact!!!!!!!!!
    +
    40 C> If j the word count is greater then 32743, j is stored
    +
    41 C> in the 12th id word. Bits 16-31 of the 8th id word are
    +
    42 C> set to zero.
    +
    43 C>
    +
    44 C> @author A.J. McClees @date 1991-10-07
    +
    45  SUBROUTINE w3fp13 (GRIB, PDS, ID8, IERR )
    +
    46 C
    +
    47  INTEGER HH (255)
    +
    48  INTEGER HH1 (127)
    +
    49  INTEGER HH2 (128)
    +
    50  INTEGER LL (255)
    +
    51  INTEGER LL1 (127)
    +
    52  INTEGER LL2 (128)
    +
    53  INTEGER ICXG2 (9)
    +
    54  INTEGER ICXGB2 (9)
    +
    55  INTEGER ICXG1 (7)
    +
    56  INTEGER ICXGB1 (7)
    +
    57 C
    +
    58  INTEGER C1
    +
    59  INTEGER C2
    +
    60  INTEGER E1
    +
    61  INTEGER E2
    +
    62  INTEGER FTU
    +
    63  INTEGER F1
    +
    64  INTEGER F2
    +
    65  INTEGER ID (25)
    +
    66  INTEGER ID8 (12)
    +
    67  INTEGER IDATE
    +
    68  INTEGER JDATE
    +
    69  INTEGER IGEN ( 4)
    +
    70  INTEGER NGRD (34)
    +
    71  INTEGER NPTS (34)
    +
    72  INTEGER P1
    +
    73  INTEGER P2
    +
    74  INTEGER S1
    +
    75 C INTEGER S2
    +
    76  INTEGER T
    +
    77  INTEGER TR
    +
    78 C
    +
    79  CHARACTER * 8 GRIB
    +
    80  CHARACTER * 8 IGRIB
    +
    81  REAL RINC(5)
    +
    82  INTEGER NDATE(8), MDATE(8)
    +
    83  CHARACTER * 1 IWORK ( 8)
    +
    84  CHARACTER * 1 JWORK ( 8)
    +
    85  CHARACTER * 1 PDS ( *)
    +
    86 C
    +
    87  SAVE
    +
    88 C
    +
    89  equivalence(hh(1),hh1(1))
    +
    90  equivalence(hh(128),hh2(1))
    +
    91  equivalence(ll(1),ll1(1))
    +
    92  equivalence(ll(128),ll2(1))
    +
    93  equivalence(idate,iwork(1))
    +
    94  equivalence(jdate,jwork(1))
    +
    95 C
    +
    96  DATA hh1 / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10,
    +
    97  & 11, 12, 13, 14, 15, 16, 17, 18, 19, 20,
    +
    98  & 21, 22, 23, 24, 25, 26, 27, 28, 29, 30,
    +
    99  & 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
    +
    100  & 41, 42, 43, 44, 45, 46, 47, 48, 49, 50,
    +
    101  & 51, 52, 53, 54, 55, 56, 57, 58, 59, 60,
    +
    102  & 61, 62, 63, 64, 65, 66, 67, 68, 69, 70,
    +
    103  & 71, 72, 73, 74, 75, 76, 77, 78, 79, 80,
    +
    104  & 81, 82, 83, 84, 85, 86, 87, 88, 89, 90,
    +
    105  & 91, 92, 93, 94, 95, 96, 97, 98, 99, 100,
    +
    106  & 101, 102, 103, 104, 105, 106, 107, 108, 109, 110,
    +
    107  & 111, 112, 113, 114, 115, 116, 117, 118, 119, 120,
    +
    108  & 121, 122, 123, 124, 125, 126, 127/
    +
    109  DATA hh2 / 128, 129, 130,
    +
    110  & 131, 132, 133, 134, 135, 136, 137, 138, 139, 140,
    +
    111  & 141, 142, 143, 144, 145, 146, 147, 148, 149, 150,
    +
    112  & 151, 152, 153, 154, 155, 156, 157, 158, 159, 160,
    +
    113  & 161, 162, 163, 164, 165, 166, 167, 168, 169, 170,
    +
    114  & 171, 172, 173, 174, 175, 176, 177, 178, 179, 180,
    +
    115  & 181, 182, 183, 184, 185, 186, 187, 188, 189, 190,
    +
    116  & 191, 192, 193, 194, 195, 196, 197, 198, 199, 200,
    +
    117  & 201, 202, 203, 204, 205, 206, 207, 208, 209, 210,
    +
    118  & 211, 212, 213, 214, 215, 216, 217, 218, 219, 220,
    +
    119  & 221, 222, 223, 224, 225, 226, 227, 228, 229, 230,
    +
    120  & 231, 232, 233, 234, 235, 236, 237, 238, 239, 240,
    +
    121  & 241, 242, 243, 244, 245, 246, 247, 248, 249, 250,
    +
    122  & 251, 252, 253, 254, 255/
    +
    123 C
    +
    124  DATA igen / 7, 58, 66, 98/
    +
    125 C
    +
    126 C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB LAYER.
    +
    127 C ICXG2 1.0000, .98230, .96470,
    +
    128 C .85000, .84368, .47191,
    +
    129 C .18017, .81573, .25011
    +
    130 C #################
    +
    131 C
    +
    132  DATA icxg2 /z'00002710', z'00017FB6', z'000178D6',
    +
    133  a z'00014C08', z'00014990', z'0000B857',
    +
    134  a z'00004663', z'00013EA5', z'000061B3'/
    +
    135 C
    +
    136 C ########### NUMBERS CALCULATED BY GRIB LAYER.
    +
    137 C ICXGB2 1.00000, .98000, .96000,
    +
    138 C .85000, .84000, .47000,
    +
    139 C .18000, .82000, .25000
    +
    140 C #################
    +
    141 C
    +
    142  DATA icxgb2/z'00002710', z'00017ED0', z'00017700',
    +
    143  a z'00014C00', z'00014820', z'0000B798',
    +
    144  a z'00004650', z'00014050', z'000061A8'/
    +
    145 C
    +
    146 C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB SINGLE.
    +
    147 C ICXG1 .98230, .89671, .78483
    +
    148 C .94316, .84367, .999.00, .25011
    +
    149 C #################
    +
    150 C
    +
    151  DATA icxg1 /z'00017FB6', z'00015E47', z'00013293',
    +
    152  a z'0001706C', z'0001498F', z'0000863C', z'000061B3'/
    +
    153 C
    +
    154 C ########### NUMBERS CALCULATED BY GRIB LAYER.
    +
    155 C ICXGB1 .98230, .89670, .78480
    +
    156 C .94320, .84370, 998.00, .25000
    +
    157 C #################
    +
    158 C
    +
    159  DATA icxgb1/z'00017FB6', z'00015E46', z'00013290',
    +
    160  a z'00017070', z'00014992', z'000185D8', z'000061A8'/
    +
    161 C
    +
    162  DATA ll1 / 8, 8, 9, 255, 255, 255, 1, 6, 255, 255,
    +
    163  & 16, 24, 19, 23, 20, 21, 17, 18, 255, 180,
    +
    164  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    +
    165  & 55, 50, 48, 49, 80, 81, 71, 255, 40, 42,
    +
    166  & 72, 74, 73, 255, 255, 255, 255, 255, 304, 305,
    +
    167  & 95, 88, 101, 89, 104, 255, 117, 255, 97, 98,
    +
    168  & 90, 105, 94, 255, 255, 93, 188, 255, 255, 255,
    +
    169  & 255, 211, 255, 255, 255, 255, 255, 255, 255, 384,
    +
    170  & 161, 255, 255, 169, 22, 255, 255, 255, 255, 255,
    +
    171  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 400,
    +
    172  & 389, 385, 388, 391, 386, 390, 402, 401, 404, 403,
    +
    173  & 204, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    +
    174  & 195, 194, 255, 255, 255, 255, 255/
    +
    175  DATA ll2 / 255, 255, 255,
    +
    176  & 112, 116, 114, 255, 103, 52, 255, 255, 255, 255,
    +
    177  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    +
    178  & 255, 255, 255, 255, 255, 119, 157, 158, 159, 255,
    +
    179  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    +
    180  & 255, 255, 255, 255, 255, 176, 177, 255, 255, 255,
    +
    181  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    +
    182  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    +
    183  & 392, 255, 255, 192, 190, 255, 199, 216, 189, 255,
    +
    184  & 193, 191, 210, 107, 255, 198, 255, 255, 255, 255,
    +
    185  & 255, 1, 255, 255, 255, 255, 255, 255, 255, 255,
    +
    186  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    +
    187  & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255,
    +
    188  & 255, 160, 255, 255, 255/
    +
    189 C
    +
    190  DATA npts / 1679, 259920, 3021, 2385, 5104, 4225,
    +
    191  & 4225, 5365, 5365, 8326, 8326,
    +
    192  & 5967, 6177, 6177, 12321, 12321, 12321,
    +
    193  & 32400, 32400, 5022, 12902, 25803,
    +
    194  & 24162, 48232, 18048, 6889, 10283,
    +
    195  & 3640, 16170, 6889, 19305, 11040,
    +
    196  & 72960, 6693/
    +
    197 C
    +
    198  DATA ngrd / 1, 4, 5, 6, 8, 27,
    +
    199  & 28, 29, 30, 33, 34,
    +
    200  & 53, 55, 56, 75, 76, 77,
    +
    201  & 85, 86, 87, 90, 91,
    +
    202  & 92, 93, 98, 100, 101,
    +
    203  & 103, 104, 105, 106, 107,
    +
    204  & 126, 214/
    +
    205 C
    +
    206 C DATA MSK1 /Z0000FFFF/,
    +
    207 C & MSK2 /Z00000080/,
    +
    208 C & MSK3 /Z00000000/,
    +
    209 C & MSK4 /Z00000200/
    +
    210 C CHANGE HEX TO DECIMAL TO MAKE SUBROUTINE MORE PORTABLE
    +
    211 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    212  DATA msk1 /65535/,
    +
    213  & msk2 /128/,
    +
    214  & msk3 /0/,
    +
    215  & msk4 /512/
    +
    216 C
    +
    217 C MAKE SECTION 0, PUT 'GRIB' IN ASCII
    +
    218 C
    +
    219  igrib(1:1) = char(71)
    +
    220  igrib(2:2) = char(82)
    +
    221  igrib(3:3) = char(73)
    +
    222  igrib(4:4) = char(66)
    +
    223  igrib(5:5) = char(0)
    +
    224  igrib(6:6) = char(0)
    +
    225  igrib(7:7) = char(0)
    +
    226  igrib(8:8) = char(1)
    +
    227 C
    +
    228 C CONVERT PDS INTO 25 INTEGER NUMBERS
    +
    229 C
    +
    230  CALL w3fi69(pds,id)
    +
    231 C
    +
    232 C ID(1) = NUMBER OF BYTES IN PDS
    +
    233 C ID(2) = PARAMETER TABLE VERSION NUMBER
    +
    234 C ID(3) = IDENTIFICATION OF ORIGINATING CENTER
    +
    235 C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER)
    +
    236 C ID(5) = GRID IDENTIFICATION
    +
    237 C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED
    +
    238 C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED
    +
    239 C ID(8) = INDICATOR OF PARAMETER AND UNITS
    +
    240 C ID(9) = INDICATOR OF TYPE OF LEVEL OR LAYER
    +
    241 C ID(10) = LEVEL 1
    +
    242 C ID(11) = LEVEL 2
    +
    243 C ID(12) = YEAR OF CENTURY
    +
    244 C ID(13) = MONTH OF YEAR
    +
    245 C ID(14) = DAY OF MONTH
    +
    246 C ID(15) = HOUR OF DAY
    +
    247 C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0)
    +
    248 C ID(17) = FCST TIME UNIT
    +
    249 C ID(18) = P1 PERIOD OF TIME
    +
    250 C ID(19) = P2 PERIOD OF TIME
    +
    251 C ID(20) = TIME RANGE INDICATOR
    +
    252 C ID(21) = NUMBER INCLUDED IN AVERAGE
    +
    253 C ID(22) = NUMBER MISSING FROM AVERAGES OR ACCUMULATIONS
    +
    254 C ID(23) = CENTURY
    +
    255 C ID(24) = IDENTIFICATION OF SUB-CENTER (TABLE 0 - PART 2)
    +
    256 C ID(25) = SCALING POWER OF 10
    +
    257 C
    +
    258 C THE 1ST 8 32 BIT WORDS WITH THE OFFICE NOTE 84 ID'S ARE
    +
    259 C IN 27 PARTS, SBYTE IS USED WITH BIT COUNTS TO MAKE THIS
    +
    260 C DATA. THIS MAKE IT WORD SIZE INDEPENDENT, AND MAKES THIS
    +
    261 C SUBROUTINE PORTABLE. TABLE WITH STARTING BITS IS NEXT.
    +
    262 C THE STARTING BIT AND NO. OF BITS IS USED AS THE 3RD AND
    +
    263 C 4TH PARAMETER FOR SBYTE. READ GBYTES DOCUMENT FROM NCAR
    +
    264 C FOR INFORMATION ABOUT SBYTE. SEE PAGE 38, FIGURE 1, IN
    +
    265 C OFFICE NOTE 84.
    +
    266 C
    +
    267 C NO. NAME STARTING BIT NO. OF BITS
    +
    268 C -----------------------------------------
    +
    269 C 1 Q 0 12
    +
    270 C 2 S1 12 12
    +
    271 C 3 F1 24 8
    +
    272 C 4 T 32 4
    +
    273 C 5 C1 36 20
    +
    274 C 6 E1 56 8
    +
    275 C 7 M 64 4
    +
    276 C 8 X 68 8
    +
    277 C 9 S2 76 12
    +
    278 C 10 F2 88 8
    +
    279 C 11 N 96 4
    +
    280 C 12 C2 100 20
    +
    281 C 13 E2 120 8
    +
    282 C 14 CD 128 8
    +
    283 C 15 CM 136 8
    +
    284 C 16 KS 144 8
    +
    285 C 17 K 152 8
    +
    286 C 18 GES 160 4
    +
    287 C 19 164 12
    +
    288 C 20 NW 176 16
    +
    289 C 21 YY 192 8
    +
    290 C 22 MM 200 8
    +
    291 C 23 DD 208 8
    +
    292 C 24 II 216 8
    +
    293 C 25 R 224 8
    +
    294 C 26 G 232 8
    +
    295 C 27 J 240 16
    +
    296 C OR 27 J 352 32 J > 32743
    +
    297 C----------------------------------------------
    +
    298 C
    +
    299 C$ 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM.
    +
    300 C$ - NO. OF ENTRIES IN TYPE LEVEL
    +
    301 C$ - NO. OF ENTRIES IN CNTR PROD. DTA.
    +
    302 C$ - INITIAL ZEROS IN O.N. 84 LABEL
    +
    303 C
    +
    304  iq = 255
    +
    305  ic = 4
    +
    306  in = 34
    +
    307 C
    +
    308 C TEST FOR 32 OR 64 BIT COMPUTER (CRAY)
    +
    309 C
    +
    310  CALL w3fi01(lw)
    +
    311  IF (lw.EQ.4) THEN
    +
    312  nwords = 12
    +
    313  ELSE
    +
    314  nwords = 6
    +
    315  END IF
    +
    316 C
    +
    317 C ZERO OUTPUT ARRAY
    +
    318 C
    +
    319  DO n = 1,nwords
    +
    320  id8(n) = 0
    +
    321  END DO
    +
    322 C
    +
    323 C ---------------------------------------------------------------------
    +
    324 C$ 2.0 VERIFY GRIB IN SECTION 0
    +
    325 C
    +
    326  IF (.NOT. grib(1:4) .EQ. igrib(1:4)) THEN
    +
    327  ierr = 1
    +
    328  RETURN
    +
    329  END IF
    +
    330 C
    +
    331 C 2.1 VERIFY THE NO. OF OCTETS IN THE PDS
    +
    332 C
    +
    333  IF (id(1).NE.28) THEN
    +
    334  ierr = 2
    +
    335  print *,'IERR = ',ierr,',LENGTH OF PDS = ',id(1)
    +
    336  RETURN
    +
    337  END IF
    +
    338 C
    +
    339 C$ 3.0 GENERATING MODEL, TYPE GRID, AND NO. OF GRID PTS.
    +
    340 C
    +
    341 C IF CENTER NOT U.S., STORE CENTER IN G MARKER
    +
    342 C IF CENTER U.S. STORE MODEL NO. IN G MARKER
    +
    343 C
    +
    344  IF (id(3) .NE. 7) THEN
    +
    345  CALL sbyte(id8,id(3),232,8)
    +
    346  ELSE
    +
    347  CALL sbyte(id8,id(4),232,8)
    +
    348  END IF
    +
    349 C
    +
    350  DO kk = 1,in
    +
    351  IF (id(5) .EQ. ngrd(kk)) THEN
    +
    352  igrdpt = npts(kk)
    +
    353  IF (id(5) .EQ. 6) id(5) = 26
    +
    354  CALL sbyte(id8,id(5),152,8)
    +
    355  IF (igrdpt.LE.32743) THEN
    +
    356  CALL sbyte(id8,igrdpt,240,16)
    +
    357  ELSE
    +
    358  CALL sbyte(id8,igrdpt,352,32)
    +
    359  END IF
    +
    360  GO TO 350
    +
    361  END IF
    +
    362  END DO
    +
    363  ierr = 4
    +
    364  print *,'IERR = ',ierr,',GRID TYPE = ',id(5)
    +
    365  RETURN
    +
    366 C
    +
    367  350 CONTINUE
    +
    368 C
    +
    369 C COMPUTE R MARKER FROM MODEL NUMBERS FOR U.S. CENTER
    +
    370 C
    +
    371 C (ERL) run
    +
    372  IF (id(3).EQ.7) THEN
    +
    373  IF (id(4).EQ.19.OR.id(4).EQ.53.OR.id(4).EQ.83.OR.
    +
    374  & id(4).EQ.84.OR.id(4).EQ.85) THEN
    +
    375  CALL sbyte(id8,0,224,8)
    +
    376 C (NMC) run
    +
    377  ELSE IF (id(4).EQ.25) THEN
    +
    378  CALL sbyte(id8,1,224,8)
    +
    379 C (RGL) run
    +
    380  ELSE IF (id(4).EQ.39.OR.id(4).EQ.64) THEN
    +
    381  CALL sbyte(id8,2,224,8)
    +
    382 C (AVN) run
    +
    383  ELSE IF (id(4).EQ.10.OR.id(4).EQ.42.OR.
    +
    384  & id(4).EQ.68.OR.id(4).EQ.73.OR.
    +
    385  & id(4).EQ.74.OR.id(4).EQ.75.OR.
    +
    386  & id(4).EQ.77.OR.id(4).EQ.81.OR.
    +
    387  & id(4).EQ.88) THEN
    +
    388  CALL sbyte(id8,3,224,8)
    +
    389 C (MRF) run
    +
    390  ELSE IF (id(4).EQ.69.OR.id(4).EQ.76.OR.
    +
    391  & id(4).EQ.78.OR.id(4).EQ.79.OR.
    +
    392  & id(4).EQ.80.oR.id(4).EQ.87) THEN
    +
    393  CALL sbyte(id8,4,224,8)
    +
    394 C (FNL) run
    +
    395  ELSE IF (id(4).EQ.43.OR.id(4).EQ.44.OR.
    +
    396  & id(4).EQ.82) THEN
    +
    397  CALL sbyte(id8,5,224,8)
    +
    398 C (HCN) run
    +
    399  ELSE IF ( id(4).EQ.70) THEN
    +
    400  CALL sbyte(id8,6,224,8)
    +
    401 C (RUC) run
    +
    402  ELSE IF ( id(4).EQ.86) THEN
    +
    403  CALL sbyte(id8,7,224,8)
    +
    404 C Not applicable, set to 255
    +
    405  ELSE
    +
    406  CALL sbyte(id8,255,224,8)
    +
    407  END IF
    +
    408  END IF
    +
    409 C
    +
    410 C$ 4.0 FORM TYPE DATA PARAMETER
    +
    411 C
    +
    412  DO ii = 1,iq
    +
    413  iii = ii
    +
    414  IF (id(8) .EQ. hh(ii)) THEN
    +
    415  IF (ll(ii).NE.255) GO TO 410
    +
    416  print *,'PDS PARAMETER HAS NO OFFICE NOTE 84 Q TYPE'
    +
    417  print *,'PDS BYTE 9 PARAMETER = ',id(8)
    +
    418  ierr = 3
    +
    419  RETURN
    +
    420  END IF
    +
    421  END DO
    +
    422  ierr = 3
    +
    423  print *,'PDS BYTE 9, PARAMETER = ',id(8)
    +
    424  RETURN
    +
    425 C
    +
    426  410 CONTINUE
    +
    427 C
    +
    428 C Q DATA TYPE, BITS 1-12
    +
    429 C
    +
    430  CALL sbyte(id8,ll(iii),0,12)
    +
    431 C
    +
    432 C TEST FOR 32 OR 64 BIT COMPUTER (CRAY)
    +
    433 C
    +
    434  IF (lw.EQ.4) THEN
    +
    435  IF (id(8) .EQ. 211) id8(5) = ior(id8(5),msk4)
    +
    436  IF (id(8) .EQ. 210) id8(5) = ior(id8(5),msk4)
    +
    437  ELSE
    +
    438  IF (id(8) .EQ. 211) id8(3) = ior(id8(3),ishft(msk4,32))
    +
    439  IF (id(8) .EQ. 210) id8(3) = ior(id8(3),ishft(msk4,32))
    +
    440  END IF
    +
    441 C
    +
    442 C$ 5.0 FORM TYPE LEVEL
    +
    443 C
    +
    444  IF (id(9) .EQ. 100) THEN
    +
    445  m = 0
    +
    446  s1 = 8
    +
    447  CALL sbyte(id8,s1,12,12)
    +
    448  CALL sbyte(id8,m,64,4)
    +
    449  level = id(11)
    +
    450  IF (level .GE. 1 .AND. level .LE. 9) THEN
    +
    451  e1 = 4
    +
    452  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
    +
    453  e1 = 3
    +
    454  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
    +
    455  e1 = 2
    +
    456  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
    +
    457  e1 = 1
    +
    458  END IF
    +
    459  c1 = level * 10 ** e1
    +
    460  CALL sbyte(id8,c1,36,20)
    +
    461  e1 = ior(e1,msk2)
    +
    462  CALL sbyte(id8,e1,56,8)
    +
    463 C
    +
    464  ELSE IF (id(9) .EQ. 103) THEN
    +
    465  m = 0
    +
    466  s1 = 1
    +
    467  CALL sbyte(id8,s1,12,12)
    +
    468  CALL sbyte(id8,m,64,4)
    +
    469  level = id(11)
    +
    470  IF (level .GE. 1 .AND. level .LE. 9) THEN
    +
    471  e1 = 4
    +
    472  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
    +
    473  e1 = 3
    +
    474  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
    +
    475  e1 = 2
    +
    476  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
    +
    477  e1 = 1
    +
    478  END IF
    +
    479  c1 = level * 10 ** e1
    +
    480  CALL sbyte(id8,c1,36,20)
    +
    481  e1 = ior(e1,msk2)
    +
    482  CALL sbyte(id8,e1,56,8)
    +
    483 C
    +
    484  ELSE IF (id(9) .EQ. 105) THEN
    +
    485  m = 0
    +
    486  s1 = 6
    +
    487  CALL sbyte(id8,s1,12,12)
    +
    488  CALL sbyte(id8,m,64,4)
    +
    489  level = id(11)
    +
    490  IF (level .GE. 1 .AND. level .LE. 9) THEN
    +
    491  e1 = 4
    +
    492  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
    +
    493  e1 = 3
    +
    494  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
    +
    495  e1 = 2
    +
    496  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
    +
    497  e1 = 1
    +
    498  END IF
    +
    499  c1 = level * 10 ** e1
    +
    500  CALL sbyte(id8,c1,36,20)
    +
    501  e1 = ior(e1,msk2)
    +
    502  CALL sbyte(id8,e1,56,8)
    +
    503 C
    +
    504  ELSE IF (id(9) .EQ. 111) THEN
    +
    505  m = 0
    +
    506  s1 = 7
    +
    507  CALL sbyte(id8,s1,12,12)
    +
    508  CALL sbyte(id8,m,64,4)
    +
    509  level = id(11)
    +
    510  IF (level .GE. 1 .AND. level .LE. 9) THEN
    +
    511  e1 = 4
    +
    512  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
    +
    513  e1 = 3
    +
    514  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
    +
    515  e1 = 2
    +
    516  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
    +
    517  e1 = 1
    +
    518  END IF
    +
    519  c1 = level * 10 ** e1
    +
    520  CALL sbyte(id8,c1,36,20)
    +
    521 C XXXXXXX SCALE FROM CENTIMETERS TO METERS. XXXXXXXXXX
    +
    522  e1 = ior(e1,msk2)
    +
    523  e1 = e1 + 2
    +
    524  IF (c1 .EQ. 0) THEN
    +
    525  e1 = 0
    +
    526  END IF
    +
    527  CALL sbyte(id8,e1,56,8)
    +
    528 C
    +
    529  ELSE IF (id(9) .EQ. 107) THEN
    +
    530  m = 0
    +
    531  s1 = 148
    +
    532  CALL sbyte(id8,s1,12,12)
    +
    533  CALL sbyte(id8,m,64,4)
    +
    534  level = id(11)
    +
    535  IF (level .GE. 1 .AND. level .LE. 9) THEN
    +
    536  e1 = 4
    +
    537  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
    +
    538  e1 = 3
    +
    539  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
    +
    540  e1 = 2
    +
    541  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
    +
    542  e1 = 1
    +
    543  ELSE
    +
    544  e1 = 0
    +
    545  END IF
    +
    546  c1 = level * 10 ** e1
    +
    547  DO isi = 1,7
    +
    548  IF (c1 .EQ. icxgb1(isi)) THEN
    +
    549  c1 = icxg1(isi)
    +
    550  END IF
    +
    551  END DO
    +
    552  CALL sbyte(id8,c1,36,20)
    +
    553 C***********SCALING OF .0001 TAKEN INTO ACCOUNT
    +
    554  e1 = e1 + 4
    +
    555  e1 = ior(e1,msk2)
    +
    556  IF (c1 .EQ. 0) THEN
    +
    557  e1 = 0
    +
    558  END IF
    +
    559  CALL sbyte(id8,e1,56,8)
    +
    560 C
    +
    561  ELSE IF (id(9) .EQ. 4) THEN
    +
    562  m = 0
    +
    563  s1 = 16
    +
    564  CALL sbyte(id8,s1,12,12)
    +
    565  CALL sbyte(id8,m,64,4)
    +
    566 C LEVEL = ID(11)
    +
    567 C******* CONSTANT VALUE OF 273.16 WILL HAVE TO BE INSERTED
    +
    568 C LEVEL = IAND (IPDS(3),MSK1)
    +
    569 C IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN
    +
    570 C E1 = 4
    +
    571 C ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN
    +
    572 C E1 = 3
    +
    573 C ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN
    +
    574 C E1 = 2
    +
    575 C ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN
    +
    576 C E1 = 1
    +
    577 C END IF
    +
    578  e1 = 2
    +
    579  c1 = (273.16 * 10 ** e1) + .5
    +
    580  CALL sbyte(id8,c1,36,20)
    +
    581  e1 = ior(e1,msk2)
    +
    582  CALL sbyte(id8,e1,56,8)
    +
    583 C*************SPECIAL CASES *********************
    +
    584  ELSE IF (id(9) .EQ. 102) THEN
    +
    585  m = 0
    +
    586  s1 = 128
    +
    587  CALL sbyte(id8,s1,12,12)
    +
    588  CALL sbyte(id8,0,64,32)
    +
    589 C
    +
    590  ELSE IF (id(9) .EQ. 1) THEN
    +
    591  m = 0
    +
    592  s1 = 129
    +
    593 C***** S1 = 133 ALSO POSSIBILITY
    +
    594  CALL sbyte(id8,s1,12,12)
    +
    595  CALL sbyte(id8,0,64,32)
    +
    596 C
    +
    597  ELSE IF (id(9) .EQ. 7) THEN
    +
    598  m = 0
    +
    599  s1 = 130
    +
    600  CALL sbyte(id8,s1,12,12)
    +
    601  CALL sbyte(id8,0,64,32)
    +
    602 C
    +
    603  ELSE IF (id(9) .EQ. 6) THEN
    +
    604  m = 0
    +
    605  s1 = 131
    +
    606  CALL sbyte(id8,s1,12,12)
    +
    607  CALL sbyte(id8,0,64,32)
    +
    608 C
    +
    609  ELSE IF (id(9) .EQ. 101) THEN
    +
    610  m = 2
    +
    611  s1 = 8
    +
    612  CALL sbyte(id8,s1,12,12)
    +
    613  CALL sbyte(id8,m,64,4)
    +
    614  CALL sbyte(id8,s1,76,12)
    +
    615  level = id(10)
    +
    616  level = (level * .1) * 10 ** 2
    +
    617  IF (level .GE. 1 .AND. level .LE. 9) THEN
    +
    618  e1 = 4
    +
    619  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
    +
    620  e1 = 3
    +
    621  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
    +
    622  e1 = 2
    +
    623  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
    +
    624  e1 = 1
    +
    625  END IF
    +
    626  c1 = level * 10 ** e1
    +
    627  CALL sbyte(id8,c1,36,20)
    +
    628  e1 = ior(e1,msk2)
    +
    629  CALL sbyte(id8,e1,56,8)
    +
    630  level2 = id(11)
    +
    631  level2 = (level2 * .1) * 10 ** 2
    +
    632  IF (level2 .GE. 1 .AND. level2 .LE. 9) THEN
    +
    633  e2 = 4
    +
    634  ELSE IF (level2 .GE. 10 .AND. level2 .LE. 99) THEN
    +
    635  e2 = 3
    +
    636  ELSE IF (level2 .GE. 100 .AND. level2 .LE. 999) THEN
    +
    637  e2 = 2
    +
    638  ELSE IF (level2 .GE. 1000 .AND. level2 .LE. 9999) THEN
    +
    639  e2 = 1
    +
    640  END IF
    +
    641  c2 = level2 * 10 ** e2
    +
    642  CALL sbyte(id8,c2,100,20)
    +
    643  IF (c2 .EQ. 0) e2 = 0
    +
    644  e2 = ior(e2,msk2)
    +
    645  CALL sbyte(id8,e2,120,8)
    +
    646 C
    +
    647  ELSE IF (id(9) .EQ. 104) THEN
    +
    648  m = 2
    +
    649  s1 = 1
    +
    650  CALL sbyte(id8,s1,12,12)
    +
    651  CALL sbyte(id8,m,64,4)
    +
    652  CALL sbyte(id8,s1,76,12)
    +
    653  level = id(10)
    +
    654  level = (level * .1) * 10 ** 2
    +
    655  IF (level .GE. 1 .AND. level .LE. 9) THEN
    +
    656  e1 = 4
    +
    657  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
    +
    658  e1 = 3
    +
    659  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
    +
    660  e1 = 2
    +
    661  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
    +
    662  e1 = 1
    +
    663  END IF
    +
    664  c1 = level * 10 ** e1
    +
    665  CALL sbyte(id8,c1,36,20)
    +
    666  e1 = ior(e1,msk2)
    +
    667  CALL sbyte(id8,e1,56,8)
    +
    668  level2 = id(11)
    +
    669  level2 = (level2 * .1) * 10 ** 2
    +
    670  IF (level2 .GE. 1 .AND. level2 .LE. 9) THEN
    +
    671  e2 = 4
    +
    672  ELSE IF (level2 .GE. 10 .AND. level2 .LE. 99) THEN
    +
    673  e2 = 3
    +
    674  ELSE IF (level2 .GE. 100 .AND. level2 .LE. 999) THEN
    +
    675  e2 = 2
    +
    676  ELSE IF (level2 .GE. 1000 .AND. level2 .LE. 9999) THEN
    +
    677  e2 = 1
    +
    678  END IF
    +
    679  c2 = level2 * 10 ** e2
    +
    680  CALL sbyte(id8,c2,100,20)
    +
    681  e2 = ior(e2,msk2)
    +
    682  CALL sbyte(id8,e2,120,8)
    +
    683 C
    +
    684  ELSE IF (id(9) .EQ. 106) THEN
    +
    685  m = 2
    +
    686  s1 = 6
    +
    687  CALL sbyte(id8,s1,12,12)
    +
    688  CALL sbyte(id8,m,64,4)
    +
    689  CALL sbyte(id8,s1,76,12)
    +
    690  level = id(10)
    +
    691  level = (level * .1) * 10**2
    +
    692  IF (level .GE. 1 .AND. level .LE. 9) THEN
    +
    693  e1 = 4
    +
    694  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
    +
    695  e1 = 3
    +
    696  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
    +
    697  e1 = 2
    +
    698  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
    +
    699  e1 = 1
    +
    700  END IF
    +
    701  c1 = level * 10 ** e1
    +
    702  CALL sbyte(id8,c1,36,20)
    +
    703  e1 = ior(e1,msk2)
    +
    704  CALL sbyte(id8,e1,56,8)
    +
    705  level2 = id(10)
    +
    706  level2 = (level2 * .1) * 10 ** 2
    +
    707  IF (level2 .GE. 1 .AND. level2 .LE. 9) THEN
    +
    708  e2 = 4
    +
    709  ELSE IF (level2 .GE. 10 .AND. level2 .LE. 99) THEN
    +
    710  e2 = 3
    +
    711  ELSE IF (level2 .GE. 100 .AND. level2 .LE. 999) THEN
    +
    712  e2 = 2
    +
    713  ELSE IF (level2 .GE. 1000 .AND. level2 .LE. 9999) THEN
    +
    714  e2 = 1
    +
    715  END IF
    +
    716  c2 = level2 * 10 ** e2
    +
    717  CALL sbyte(id8,c2,100,20)
    +
    718  e2 = ior(e2,msk2)
    +
    719  CALL sbyte(id8,e2,120,8)
    +
    720 C
    +
    721  ELSE IF (id(9) .EQ. 108) THEN
    +
    722  m = 2
    +
    723  s1 = 148
    +
    724 C**** S1 = 144 ALSO POSSIBILITY
    +
    725 C**** S1 = 145 ALSO POSSIBILITY
    +
    726  CALL sbyte(id8,s1,12,12)
    +
    727  CALL sbyte(id8,m,64,4)
    +
    728  CALL sbyte(id8,s1,76,12)
    +
    729  level = id(10)
    +
    730  level = level
    +
    731  IF (level .GE. 1 .AND. level .LE. 9) THEN
    +
    732  e1 = 4
    +
    733  ELSE IF (level .GE. 10 .AND. level .LE. 99) THEN
    +
    734  e1 = 3
    +
    735  ELSE IF (level .GE. 100 .AND. level .LE. 999) THEN
    +
    736  e1 = 2
    +
    737  ELSE IF (level .GE. 1000 .AND. level .LE. 9999) THEN
    +
    738  e1 = 1
    +
    739  END IF
    +
    740  c1 = level * (10 ** e1)
    +
    741  DO isi = 1,9
    +
    742  IF (c1 .EQ. icxgb2(isi)) THEN
    +
    743  c1 = icxg2(isi)
    +
    744  END IF
    +
    745  END DO
    +
    746  CALL sbyte(id8,c1,36,20)
    +
    747  IF (c1 .EQ. 0) THEN
    +
    748  e1 = 0
    +
    749  CALL sbyte(id8,e1,56,8)
    +
    750  GO TO 700
    +
    751  END IF
    +
    752 C*****TAKE SCALING INTO ACCOUNT .01
    +
    753  e1 = e1 + 2
    +
    754  e1 = ior(e1,msk2)
    +
    755  CALL sbyte(id8,e1,56,8)
    +
    756 C
    +
    757  700 CONTINUE
    +
    758  level2 = id(11)
    +
    759  level2 = level2
    +
    760  IF (level2 .GE. 1 .AND. level2 .LE. 9) THEN
    +
    761  e2 = 4
    +
    762  ELSE IF (level2 .GE. 10 .AND. level2 .LE. 99) THEN
    +
    763  e2 = 3
    +
    764  ELSE IF (level2 .GE. 100 .AND. level2 .LE. 999) THEN
    +
    765  e2 = 2
    +
    766  ELSE IF (level2 .GE. 1000 .AND. level2 .LE. 9999) THEN
    +
    767  e2 = 1
    +
    768  END IF
    +
    769  c2 = level2 * 10 ** e2
    +
    770  DO isi = 1,9
    +
    771  IF (c2 .EQ. icxgb2(isi)) THEN
    +
    772  c2 = icxg2(isi)
    +
    773  END IF
    +
    774  END DO
    +
    775  CALL sbyte(id8,c2,100,20)
    +
    776  e2 = ior(e2,msk2)
    +
    777  CALL sbyte(id8,e2,120,8)
    +
    778 C*******TAKE SCALING INTO ACCOUNT .01
    +
    779  e2 = e2 + 2
    +
    780  e2 = ior(e2,msk2)
    +
    781  CALL sbyte(id8,e2,120,8)
    +
    782 C
    +
    783  END IF
    +
    784 C 5.1 FORCAST TIMES ,PLUS THE T MARKER AND CM FIELD
    +
    785 C
    +
    786  tr = id(20)
    +
    787  IF (tr .EQ. 0) THEN
    +
    788  p1 = id(18)
    +
    789  CALL sbyte(id8,id(18),24,8)
    +
    790  ELSE IF (tr .EQ. 4) THEN
    +
    791  p2 = id(19)
    +
    792  CALL sbyte(id8,p2,24,8)
    +
    793  p1 = id(18)
    +
    794  CALL sbyte(id8,(p2 - p1),88,8)
    +
    795  t = 3
    +
    796  CALL sbyte(id8,t,32,4)
    +
    797  ELSE IF (tr .EQ. 5) THEN
    +
    798  p2 = id(19)
    +
    799  CALL sbyte(id8,p2,24,8)
    +
    800  p1 = id(18)
    +
    801  CALL sbyte(id8,(p2 - p1),88,8)
    +
    802  t = 3
    +
    803  CALL sbyte(id8,t,32,4)
    +
    804 C
    +
    805  ELSE IF (tr .EQ. 124) THEN
    +
    806  ftu = id(17)
    +
    807  IF (ftu .EQ. 2) THEN
    +
    808  f1 = id(21)
    +
    809  CALL sbyte(id8,f1,24,8)
    +
    810  t = 4
    +
    811  CALL sbyte(id8,t,32,4)
    +
    812  ELSE IF (ftu .EQ. 4) THEN
    +
    813  f2 = id(21)
    +
    814  CALL sbyte(id8,f2,88,8)
    +
    815  t = 4
    +
    816  CALL sbyte(id8,t,32,4)
    +
    817  END IF
    +
    818 C
    +
    819  ELSE IF (tr .EQ.123) THEN
    +
    820  f1 = 3
    +
    821  f1 = ior(f1,msk2)
    +
    822  CALL sbyte(id8,f1,24,8)
    +
    823  f2 = 5 * 2
    +
    824  CALL sbyte(id8,f2,88,8)
    +
    825  t = 6
    +
    826  CALL sbyte(id8,t,32,4)
    +
    827  rinc = 0.0
    +
    828  rinc(2) = 36.0
    +
    829  iyr=mova2i(pds(13))
    +
    830  print *, 'IYR = ', iyr
    +
    831  IF(iyr.LT.20)THEN
    +
    832  mdate(1)=2000+iyr
    +
    833  ELSE
    +
    834  mdate(1)=1900+iyr
    +
    835  ENDIF
    +
    836  mdate(2) = mova2i(pds(14))
    +
    837  mdate(3) = mova2i(pds(15))
    +
    838  mdate(5) = mova2i(pds(16))
    +
    839 C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5)
    +
    840 C PRINT *, 'CHANGE DATE BY - ', RINC(2)
    +
    841  CALL w3movdat(rinc,mdate,ndate)
    +
    842 C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5)
    +
    843 C CALL W3FS04 (IDATE,JDATE,3,IERR)
    +
    844  iyear = mod(ndate(1),100)
    +
    845  jwork(1) = char(iyear)
    +
    846  jwork(2) = char(ndate(2))
    +
    847  jwork(3) = char(ndate(3))
    +
    848  jwork(4) = char(ndate(5))
    +
    849  idate = jdate
    +
    850  GO TO 710
    +
    851 C
    +
    852  ELSE IF (tr .EQ.3) THEN
    +
    853  p1 = id(18)
    +
    854  p2 = id(19)
    +
    855  f1 = p1 / 12
    +
    856  CALL sbyte(id8,f1,24,8)
    +
    857 C
    +
    858 C ***** NAVG IS IN BITES 22 23 *****
    +
    859 C USING BITE 23 ONLY *******
    +
    860 C FIX LATER ******************************************
    +
    861 C
    +
    862 C NAVG = MOVA2I(PDS(23))
    +
    863  f2 = (p2 - p1) / 12
    +
    864  CALL sbyte(id8,f2,88,8)
    +
    865  t = 6
    +
    866  CALL sbyte(id8,t,32,4)
    +
    867  rinc = 0.0
    +
    868  rinc(2) = -36.0
    +
    869  iyr=mova2i(pds(13))
    +
    870  print *, 'IYR = ', iyr
    +
    871  IF(iyr.LT.20)THEN
    +
    872  mdate(1)=2000+iyr
    +
    873  ELSE
    +
    874  mdate(1)=1900+iyr
    +
    875  ENDIF
    +
    876  mdate(2) = mova2i(pds(14))
    +
    877  mdate(3) = mova2i(pds(15))
    +
    878  mdate(5) = mova2i(pds(16))
    +
    879 C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5)
    +
    880 C PRINT *, 'CHANGE DATE BY - ', RINC(2)
    +
    881  CALL w3movdat(rinc,mdate,ndate)
    +
    882 C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5)
    +
    883 C CALL W3FS04 (IDATE,JDATE,-3,IERR)
    +
    884  iyear = mod(ndate(1),100)
    +
    885  jwork(1) = char(iyear)
    +
    886  jwork(2) = char(ndate(2))
    +
    887  jwork(3) = char(ndate(3))
    +
    888  jwork(4) = char(ndate(5))
    +
    889  idate = jdate
    +
    890  GO TO 710
    +
    891  END IF
    +
    892 C
    +
    893 C$ 7.0 TRANSFER THE DATE
    +
    894 C
    +
    895  iwork(1) = pds(13)
    +
    896  iwork(2) = pds(14)
    +
    897  iwork(3) = pds(15)
    +
    898  iwork(4) = pds(16)
    +
    899 C
    +
    900  710 CONTINUE
    +
    901 C
    +
    902 C TEST FOR 64 BIT COMPUTER (CRAY)
    +
    903 C
    +
    904  IF (lw.EQ.8) idate = ishft(idate,-32)
    +
    905  CALL sbyte(id8,idate,192,32)
    +
    906 C
    +
    907  ierr = 0
    +
    908  RETURN
    +
    909  END
    +
    +
    +
    w3fp13
    subroutine w3fp13(GRIB, PDS, ID8, IERR)
    Converts GRIB version 1 formatted product definition section to an office note 84 id label.
    Definition: w3fp13.f:46
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    sbyte
    subroutine sbyte(IOUT, IN, ISKIP, NBYTE)
    Definition: sbyte.f:12
    +
    w3fi69
    subroutine w3fi69(PDS, ID)
    Converts an edition 1 grib produce definition section (pds) to a 25, or 27 word integer array.
    Definition: w3fi69.f:29
    +
    w3movdat
    subroutine w3movdat(rinc, idat, jdat)
    This subprogram returns the date and time that is a given NCEP relative time interval from an NCEP ab...
    Definition: w3movdat.f:24
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    + + + + diff --git a/ver-2.10.0/w3fq07_8f.html b/ver-2.10.0/w3fq07_8f.html new file mode 100644 index 00000000..98e7af7d --- /dev/null +++ b/ver-2.10.0/w3fq07_8f.html @@ -0,0 +1,237 @@ + + + + + + + +NCEPLIBS-w3emc: w3fq07.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fq07.f File Reference
    +
    +
    + +

    Sends fax,varian,afos,awips, maps & bulls. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fq07 (LPARM, NUMBYT, OUTFIL, CARDFIL, KRTN)
     Sets up the arguments for sub dbn_alert which posts transmission availability to various statfiles. More...
     
    +

    Detailed Description

    +

    Sends fax,varian,afos,awips, maps & bulls.

    +
    Author
    Peter Henrichsen
    +
    Date
    1997-01-09
    + +

    Definition in file w3fq07.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fq07()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fq07 (character*(*) LPARM,
     NUMBYT,
    integer OUTFIL,
    integer CARDFIL,
     KRTN 
    )
    +
    + +

    Sets up the arguments for sub dbn_alert which posts transmission availability to various statfiles.

    +

    The input key words for w3fq07() may be read in via the parm field or from a data card see remarks for examples.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comments
    1997-01-09 Peter Henrichsen Initial
    +
    Parameters
    + + + + + + +
    [in]LPARMCharacter*1 100 byte array containing ascii flags and key words.
    [in]NUMBYTInteger number of bytes of ascii data in lparm.
    [in]OUTFILInteger unit number of file to post to the telecommunications gateway computer system.
    [in]CARDFILInteger unit number of file to read to get data control card in lue of parm. this is only necessary when parm(5:5) = 'a'.
    [out]KRTNSee return conditions. Return conditions: KRTN = 0 good return, file posted for transmission KRTN = 1 good return, file not posted for transmission test flag was on ie k=test or there was an "n" the 1st byte of the input data card. KRTN = 2 bad return, posting not attempted, the "k" key was missing. KRTN = 3 bad return, posting not attempted, parm less than than 6 bytes. KRTN = 4 bad return, card reader empty. KRTN = 5 bad return, error return from sub dbn_alert.
    +
    +
    +

    FTNNF001 - File that contains the data to send. where 'nn' can be any number from 01 to 99 except 5 or 6. This file must be assigned with u:nn.

    +

    FTXXF001 - Input cards, only necessary if lparm(3-6) ='card'. a sample data card is: m=ft24f001,k=afos (all on one card starting in col 1). If col 1 = 'n' then the data set is not posted to the monitior,ie., w3fq07() will return to calling program with out sending the product. (xx has default of 05. however this number can be any unit number you wish.

    +
    Note
    The key words that are passed to sub in lparm may be in any order in the lparm array or data card. there is one key word that is mandatory. they are: K=KKKKKKK Where KKKKKKKK is up to a 24 byte ascii keyword left-justified which identifies what dbnet is to do with the input data file.
    +

    'KKKKKKKK' Is generally a keyword such as: 'FAXX', 'TRAN','AFOS','AWIP' but may be: any one of these type-keys.

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    Type-keys Functions
    AFOS Posts AFOS utf map file to CRAY OSO'S statusfile.
    AWIP Posts AWIPS map file to CRAY OSO'S statusfile.
    FAXX Posts nmc6bit map file to CRAY OSO'S statusfile.
    GRIB Posts wmo grib file to CRAY OSO'S statusfile.
    TRAN Posts wmo bulletin file to CRAY OSO'S statusfile.
    XTRN Posts xtrn file to CRAY OSO'S statusfile.
    IG_DATA_ipsa1 Sends data file to the intergraph ipsa1.
    IG_DATA_ipsa2 Sends data file to the intergraph ipsa2.
    IG_DATA_lzr_srv1 Sends data file to the intergraph lzr_srv1.
    IG_PLTF_ipsa1 Sends AFOS plot file to the intergraph ipsa1.
    IG_PLTF_ipsa2 Sends AFOS plot file to the intergraph ipsa2.
    IG_PLTF_lzr_srv1 Sends AFOS plot file to the intergraph lzr_srv1.
    IG_6BIT_lzr_srv1 Sends nmc6bit file to the intergraph lzr_srv1.
    TPC_6BIT_nhc-hp13 Sends nmc6bit file to nhc-hp13 at TPC.
    OSO_IG_6BIT_lzr_srv1 Posts nmc6bit file to CRAY OSO'S statusfile and then Sends nmc6bit file to the intergraph lzr_srv1.
    OSO_TPC_6BIT_nhc-hp13 Posts nmc6bit file to CRAY OSO'S statusfile and then Sends nmc6bit file to nhc-hp13 at TPC.
    +

    Where outfil is the file number containg the data.

    +

    A sample: M=PETERS,K=FAXX where A ',' or A ' ' Terminates the key word. Where a comma or blank terminates the key word.

    +

    The M= is an optional key word. the 'M' key word is the model name if missing the "missing" is used other wise it may by any 24 byte ASCII string.

    +

    A sample: M=AVN,K=AFOS, where a comma or blank terminates the key word.

    +
    Author
    Peter Henrichsen
    +
    Date
    1997-01-09
    + +

    Definition at line 81 of file w3fq07.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fq07_8f.js b/ver-2.10.0/w3fq07_8f.js new file mode 100644 index 00000000..77546f30 --- /dev/null +++ b/ver-2.10.0/w3fq07_8f.js @@ -0,0 +1,4 @@ +var w3fq07_8f = +[ + [ "w3fq07", "w3fq07_8f.html#a621d5a7f77939450e814033c6f3b1535", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fq07_8f_source.html b/ver-2.10.0/w3fq07_8f_source.html new file mode 100644 index 00000000..36abbf98 --- /dev/null +++ b/ver-2.10.0/w3fq07_8f_source.html @@ -0,0 +1,561 @@ + + + + + + + +NCEPLIBS-w3emc: w3fq07.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fq07.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Sends fax,varian,afos,awips, maps & bulls
    +
    3 C> @author Peter Henrichsen @date 1997-01-09
    +
    4 
    +
    5 C> Sets up the arguments for sub dbn_alert which posts transmission
    +
    6 C> availability to various statfiles. The input key words for w3fq07() may be
    +
    7 C> read in via the parm field or from a data card see remarks for examples.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comments
    +
    11 C> -----|------------|---------
    +
    12 C> 1997-01-09 | Peter Henrichsen | Initial
    +
    13 C>
    +
    14 C> @param[in] LPARM Character*1 100 byte array containing ascii
    +
    15 C> flags and key words.
    +
    16 C> @param[in] NUMBYT Integer number of bytes of ascii data in lparm.
    +
    17 C> @param[in] OUTFIL Integer unit number of file to post to the
    +
    18 C> telecommunications gateway computer system.
    +
    19 C> @param[in] CARDFIL Integer unit number of file to read to get data
    +
    20 C> control card in lue of parm. this is only necessary
    +
    21 C> when parm(5:5) = 'a'.
    +
    22 C> @param[out] KRTN See return conditions.
    +
    23 C> Return conditions:
    +
    24 C> KRTN = 0 good return, file posted for transmission
    +
    25 C> KRTN = 1 good return, file not posted for transmission test flag was on ie
    +
    26 C> k=test or there was an "n" the 1st byte of the input data card.
    +
    27 C> KRTN = 2 bad return, posting not attempted, the "k" key was missing.
    +
    28 C> KRTN = 3 bad return, posting not attempted, parm less than than 6 bytes.
    +
    29 C> KRTN = 4 bad return, card reader empty.
    +
    30 C> KRTN = 5 bad return, error return from sub dbn_alert.
    +
    31 C>
    +
    32 C> FTNNF001 - File that contains the data to send. where 'nn' can be any
    +
    33 C> number from 01 to 99 except 5 or 6. This file must be assigned with u:nn.
    +
    34 C>
    +
    35 C> FTXXF001 - Input cards, only necessary if lparm(3-6) ='card'. a sample data
    +
    36 C> card is: m=ft24f001,k=afos (all on one card starting in col 1).
    +
    37 C> If col 1 = 'n' then the data set is not posted to the monitior,ie., w3fq07()
    +
    38 C> will return to calling program with out sending the product.
    +
    39 C> (xx has default of 05. however this number can be any unit number you wish.
    +
    40 C>
    +
    41 C> @note The key words that are passed to sub in lparm may be in any order in
    +
    42 C> the lparm array or data card. there is one key word that is mandatory. they are:
    +
    43 C> K=KKKKKKK Where KKKKKKKK is up to a 24 byte ascii keyword left-justified
    +
    44 C> which identifies what dbnet is to do with the input data file.
    +
    45 C>
    +
    46 C> 'KKKKKKKK' Is generally a keyword such as: 'FAXX', 'TRAN','AFOS','AWIP'
    +
    47 C> but may be: any one of these type-keys.
    +
    48 C>
    +
    49 C> Type-keys | Functions
    +
    50 C> ----------|----------
    +
    51 C> AFOS | Posts AFOS utf map file to CRAY OSO'S statusfile.
    +
    52 C> AWIP | Posts AWIPS map file to CRAY OSO'S statusfile.
    +
    53 C> FAXX | Posts nmc6bit map file to CRAY OSO'S statusfile.
    +
    54 C> GRIB | Posts wmo grib file to CRAY OSO'S statusfile.
    +
    55 C> TRAN | Posts wmo bulletin file to CRAY OSO'S statusfile.
    +
    56 C> XTRN | Posts xtrn file to CRAY OSO'S statusfile.
    +
    57 C> IG_DATA_ipsa1 | Sends data file to the intergraph ipsa1.
    +
    58 C> IG_DATA_ipsa2 | Sends data file to the intergraph ipsa2.
    +
    59 C> IG_DATA_lzr_srv1 | Sends data file to the intergraph lzr_srv1.
    +
    60 C> IG_PLTF_ipsa1 | Sends AFOS plot file to the intergraph ipsa1.
    +
    61 C> IG_PLTF_ipsa2 | Sends AFOS plot file to the intergraph ipsa2.
    +
    62 C> IG_PLTF_lzr_srv1 | Sends AFOS plot file to the intergraph lzr_srv1.
    +
    63 C> IG_6BIT_lzr_srv1 | Sends nmc6bit file to the intergraph lzr_srv1.
    +
    64 C> TPC_6BIT_nhc-hp13 | Sends nmc6bit file to nhc-hp13 at TPC.
    +
    65 C> OSO_IG_6BIT_lzr_srv1 | Posts nmc6bit file to CRAY OSO'S statusfile and then Sends nmc6bit file to the intergraph lzr_srv1.
    +
    66 C> OSO_TPC_6BIT_nhc-hp13 | Posts nmc6bit file to CRAY OSO'S statusfile and then Sends nmc6bit file to nhc-hp13 at TPC.
    +
    67 C>
    +
    68 C> Where outfil is the file number containg the data.
    +
    69 C>
    +
    70 C> A sample: M=PETERS,K=FAXX where A ',' or A ' ' Terminates the key word.
    +
    71 C> Where a comma or blank terminates the key word.
    +
    72 C>
    +
    73 C> The M= is an optional key word. the 'M' key word is the model name
    +
    74 C> if missing the "missing" is used other wise it may by any
    +
    75 C> 24 byte ASCII string.
    +
    76 C>
    +
    77 C> A sample: M=AVN,K=AFOS, where a comma or blank terminates the key word.
    +
    78 C>
    +
    79 C> @author Peter Henrichsen @date 1997-01-09
    +
    80  SUBROUTINE w3fq07(LPARM,NUMBYT,OUTFIL,CARDFIL,KRTN)
    +
    81 C
    +
    82 C
    +
    83  CHARACTER*(*) LPARM
    +
    84 C
    +
    85  CHARACTER*80 BLNK80
    +
    86  CHARACTER*80 FILNAM
    +
    87  CHARACTER*80 OUTXT
    +
    88  CHARACTER*80 STRING
    +
    89 
    +
    90 C
    +
    91  CHARACTER*55 CHTEST
    +
    92  DATA chtest
    +
    93  1/'THIS WAS A TEST, PRODUCTS NOT POSTED FOR TRANSMISSION.:'/
    +
    94 C '1234567890123456789012345678901234567890123456789012345
    +
    95 C
    +
    96  CHARACTER*52 NOTSNT
    +
    97  DATA notsnt
    +
    98  1 /'** FILE NOT POSTED FOR TRANSMISSION AVAILABILITY **:'/
    +
    99 C '1234567890123456789012345678901234567890123456789012'/
    +
    100 C
    +
    101 
    +
    102  CHARACTER*52 MESAG1
    +
    103  DATA mesag1
    +
    104  1 /'FILE NOT POSTED FOR TRANSMISSION, FOUND BYPASS FLAG:'/
    +
    105 C 1 /'1234567890123456789012345678901234567890123456789012/
    +
    106  CHARACTER*56 MESAG2
    +
    107  DATA mesag2
    +
    108  1 /'FILE NOT POSTED FOR TRANSMISSION, "K" KEY FLAG MISSINGS:'/
    +
    109 C 1 /'12345678901234567890123456789012345678901234567890123456
    +
    110  CHARACTER*46 MESAG3
    +
    111  DATA mesag3
    +
    112  1 /'ERROR W3FQ07, LESS THAN 6 BYTES IN PARM FIELD:'/
    +
    113 C 1 /'12345678901234567890123456789012345678901234567890123456'/
    +
    114 
    +
    115  CHARACTER*55 MESAG4
    +
    116  DATA mesag4
    +
    117  1 /'ERROR W3FQ07, CARD FILE EMPTY. CHECK JCL CARD FIILE :'/
    +
    118  CHARACTER*42 MESAG5
    +
    119  DATA mesag5
    +
    120  1 /'ERROR RETURN FROM SUB DBN_ALERT,RETURN= :'/
    +
    121 C 1 /'12345678901234567890123456789012345678901234567890123456'/
    +
    122 C
    +
    123  CHARACTER*40 BLNK40
    +
    124  DATA blnk40
    +
    125  1 /' '/
    +
    126  CHARACTER*24 BUFFER
    +
    127  DATA buffer/' '/
    +
    128  CHARACTER*24 JOBNAM
    +
    129  DATA jobnam/'UNKOWN '/
    +
    130 C
    +
    131  CHARACTER*12 CTEXT
    +
    132  CHARACTER*4 CPLMIZ
    +
    133  DATA cplmiz /'L999'/
    +
    134 C
    +
    135  CHARACTER*04 LTRS
    +
    136  DATA ltrs /'K=M='/
    +
    137 C
    +
    138  CHARACTER*24 BLANK
    +
    139  DATA blank /' '/
    +
    140 
    +
    141  CHARACTER*24 IFAXX
    +
    142  DATA ifaxx /'FAXX '/
    +
    143 
    +
    144  CHARACTER*24 KEYWRD
    +
    145  CHARACTER*24 MODNAM
    +
    146 C
    +
    147  CHARACTER*4 AWIP
    +
    148  DATA awip /'AWIP'/
    +
    149  CHARACTER*4 IFAX
    +
    150  DATA ifax /'FAX '/
    +
    151 
    +
    152 C
    +
    153  CHARACTER*1 IQUOT
    +
    154 C
    +
    155  DATA inunit /5/
    +
    156  INTEGER CARDFIL
    +
    157  INTEGER OUTFIL
    +
    158  INTEGER NK,NM,NJ,NF,KRET4
    +
    159 C
    +
    160 
    +
    161  LOGICAL*1 BYPASS
    +
    162  LOGICAL*1 GOTFLN
    +
    163  LOGICAL*1 GOTKEY
    +
    164  LOGICAL*1 GOTMOD
    +
    165  LOGICAL*1 GOTJOB
    +
    166  LOGICAL*1 LCARDS
    +
    167  LOGICAL*1 KPRINT
    +
    168 C
    +
    169  iquot = char(27)
    +
    170  blnk80 = blnk40//blnk40
    +
    171 C
    +
    172 C
    +
    173  WRITE(6,fmt='('' USING W3FQ07 CRAY VERSION 97.008 08:40.'')')
    +
    174 C
    +
    175 C . . . PICKUP PARAMETERS.
    +
    176 C
    +
    177 C . . . CHECK TO SEE IF BYTE COUNT LESS THAN 6 IF SO PRODUCT NOT SENT.
    +
    178 C
    +
    179  IF(numbyt.LT.6) THEN
    +
    180 C
    +
    181 C . . . BYTE COUNT LESS THAN 6.
    +
    182 C
    +
    183  krtn = 3
    +
    184  WRITE(6,fmt='('' W3FQ07: '',A)') notsnt(1:52)
    +
    185  WRITE(6,fmt='('' W3FQ07: '',A)') mesag3(1:46)
    +
    186  CALL consol(notsnt)
    +
    187  CALL consol(mesag3)
    +
    188  ELSE
    +
    189 
    +
    190 C
    +
    191 C . . . BYTE COUNT GREATER THAN OR EQUAL TO 6,
    +
    192 C . . . START TO PROCESS FLAGS
    +
    193 C
    +
    194 C
    +
    195  lcards = .false.
    +
    196  gotkey = .false.
    +
    197  gotmod = .false.
    +
    198  gotjob = .false.
    +
    199  gotfln = .false.
    +
    200 
    +
    201  IF(lparm(5:5).EQ.'A') lcards = .true.
    +
    202 C
    +
    203 C . . . . FILL KEYS WITH BLANKS.
    +
    204 C
    +
    205  IF(lcards)THEN
    +
    206 C
    +
    207  numbyt = 80
    +
    208 C
    +
    209 C . . . BLANK OUT LPARM.............................
    +
    210 C
    +
    211  lparm(1:numbyt) = blnk80(1:numbyt)
    +
    212 C
    +
    213 C . . . READ DATA CARD TO GET DATA KEYWORDS TO SEND.
    +
    214 C
    +
    215 C CHECK TO SEE IF CARDFIL IS GOOD
    +
    216 C
    +
    217  IF(cardfil.GT.0)THEN
    +
    218  ELSE
    +
    219  cardfil = inunit
    +
    220  ENDIF
    +
    221  WRITE(6,fmt='('' W3FQ07: READING CARD FROM UNIT '',
    +
    222  1 I4)') cardfil
    +
    223  READ(cardfil,fmt='(80A1)',END=940)
    +
    224  1 (lparm(i:i),i=1,numbyt)
    +
    225 C
    +
    226  WRITE(6,fmt='('' W3FQ07: PARM='',
    +
    227  1 A)')lparm(1:numbyt)
    +
    228 C
    +
    229 C CHECK TO SEE IF INTERFACE OFF FLAG IS SET....
    +
    230 C . . . . IF THERE IS AN 'N' IN THE 1ST COL OF DATA CARD CALL TO
    +
    231 C DBN_ALERT WILL BE BYPASSED.
    +
    232 C
    +
    233  IF(lparm(1:1).EQ.'N') bypass = .true.
    +
    234 C
    +
    235 C
    +
    236 C CHECK TO SEE IF EXTRA PRINT FLAG IS SET....
    +
    237 C . . . . IF THERE IS AN 'P' IN THE 1ST COL OF DATA CARD
    +
    238 C TURN ON 'KPRNT' FLAG.
    +
    239 C
    +
    240  kprint = .false.
    +
    241  IF(lparm(1:1).EQ.'P') kprint = .true.
    +
    242  ENDIF
    +
    243  IF(kprint)THEN
    +
    244  WRITE(6,fmt='('' PARM='',A)') lparm(1:numbyt)
    +
    245  ENDIF
    +
    246 C
    +
    247  IF(bypass)THEN
    +
    248  WRITE(6,fmt='(1H0,A)')mesag1(1:52)
    +
    249  krtn = 7
    +
    250  CALL consol(mesag1)
    +
    251  ELSE
    +
    252  IF(.NOT.lcards)
    +
    253  1 WRITE(6,fmt='('' PARM='',A)') lparm(1:numbyt)
    +
    254  num = 0
    +
    255  DO 840 lk = 1,10,2
    +
    256 C
    +
    257  DO 820 mm = 1,numbyt
    +
    258 C
    +
    259  next = mm+1
    +
    260  IF(lparm(mm:next).EQ.ltrs(lk:lk+1))THEN
    +
    261  kstart = next + 1
    +
    262  loc = next + 1
    +
    263 C WRITE(6,FMT='('' FOUND'',A,'' AT LOC '',I3,
    +
    264 C 1 '' AND WILL START SEARCHING AT'',I4,'' IN ARRAY '',
    +
    265 C 2 ''OF LENGHT'',I4)')LPARM(MM:NEXT),MM,KSTART,NUMBYT
    +
    266 C
    +
    267  lloc = 0
    +
    268  DO 8010 ni = kstart,numbyt
    +
    269  loc = ni
    +
    270  IF(lparm(ni:ni).EQ.',')THEN
    +
    271  ELSE IF(lparm(ni:ni).EQ.iquot)THEN
    +
    272  ELSE IF(lparm(ni:ni).EQ.' ')THEN
    +
    273  ELSE
    +
    274  lloc = ni
    +
    275  GO TO 8010
    +
    276  ENDIF
    +
    277  GO TO 8015
    +
    278 8010 CONTINUE
    +
    279  WRITE(6,fmt='('' I FELL THROUGH LOOP WITH LOC='',I4,
    +
    280  1 '' WITH LLOC='',I4,'' & KSTART='',I4,
    +
    281  2 '' NUMBYT='',I4,'' THEREFORE ADD "1" TO LOC'')')
    +
    282  3 loc,lloc,kstart,numbyt
    +
    283  IF(lloc.EQ.kstart) loc = lloc + 1
    +
    284 8015 CONTINUE
    +
    285  IF(loc.GT.kstart) THEN
    +
    286 C
    +
    287 C HAVE A FLAG LOAD IT INTO PROPER WORD
    +
    288 C
    +
    289 C IF(KPRINT) THEN
    +
    290  WRITE(6,fmt='('' FOUND THE KEY WORD: '',A,
    +
    291  1 '' AT LOCATION '',I2,'' IN LPARM ARRAY.'',/)')
    +
    292  2 lparm(kstart:lloc),kstart
    +
    293 C ENDIF
    +
    294  IF(lk.EQ.1) THEN
    +
    295 
    +
    296  keywrd = lparm(kstart:lloc)
    +
    297  nk = lloc - kstart+1
    +
    298  gotkey = .true.
    +
    299  num = num + 1
    +
    300  ELSE IF(lk.EQ.3) THEN
    +
    301  modnam = lparm(kstart:lloc)
    +
    302  nm = lloc - kstart+1
    +
    303  gotmod = .true.
    +
    304  num = num + 1
    +
    305  ENDIF
    +
    306  ELSE
    +
    307  GO TO 820
    +
    308  ENDIF
    +
    309  ELSE
    +
    310 C GO SEARCH SOME MORE.
    +
    311  GO TO 820
    +
    312  ENDIF
    +
    313 C
    +
    314  GOTO 840
    +
    315  820 CONTINUE
    +
    316 C
    +
    317  840 CONTINUE
    +
    318  numgod = 2
    +
    319 C
    +
    320  IF(num.LT.numgod) THEN
    +
    321 C
    +
    322 C DID NOT FIND A MATCH OF A KEY LETTER CHECK TO SEE WHICH
    +
    323 C ONE IT WAS.
    +
    324 C
    +
    325  IF(gotkey)THEN
    +
    326  modnam(1:8) = 'MISSGING'
    +
    327  nm = 8
    +
    328  gotmod = .true.
    +
    329  ELSE
    +
    330  krtn = 2
    +
    331  WRITE(6,fmt='('' W3FQ07: '',A)') notsnt(1:52)
    +
    332  WRITE(6,fmt='('' W3FQ07: '',A)') mesag2(1:46)
    +
    333 C
    +
    334  CALL consol(notsnt)
    +
    335  CALL consol(mesag2)
    +
    336  GO TO 900
    +
    337  ENDIF
    +
    338  ENDIF
    +
    339 C
    +
    340 C
    +
    341  WRITE(6,fmt='('' PARM='',A)') lparm(1:numbyt)
    +
    342  WRITE(6,fmt='('' MODNAM='',A,'' KEYWRD='',A,
    +
    343  1 /)')modnam(1:nm),keywrd(1:nk)
    +
    344 C
    +
    345 C
    +
    346 C CHECK TO SEE IF FIRST 4 BYTES OF KEYWRD = FAX .
    +
    347 C IF IT DOES, CHANGE IT TO FAXX .
    +
    348 C
    +
    349  IF(keywrd(1:nk).EQ.'FAX')THEN
    +
    350  keywrd(1:4) = 'FAXX'
    +
    351  nk = 4
    +
    352  ENDIF
    +
    353  IF(keywrd(1:nk).EQ.'TEST')THEN
    +
    354  bypass = .true.
    +
    355  WRITE(6,fmt='('' W3FQ07: BYPASS FLAG ON, '',
    +
    356  1 ''SKIP POSTING FILE.'',/)')
    +
    357  GO TO 900
    +
    358  ENDIF
    +
    359 C
    +
    360 C MUST NOW I MUST GET THE JOB NAME AND UNIT NAME FOR
    +
    361 C CALL TO DBN_ALERT.
    +
    362 C
    +
    363 C . . . READ IN JOBNAME
    +
    364  jchars = getenv('QSUB_REQNAME',buffer)
    +
    365  nj = 0
    +
    366  IF(buffer(1:8).EQ.' ')THEN
    +
    367  jobnam(1:8) = 'MSG_JOBNM'
    +
    368  nj = 8
    +
    369  ELSE
    +
    370  DO ii =1,8
    +
    371  IF(buffer(ii:ii).NE.' ')THEN
    +
    372  nj = nj + 1
    +
    373  jobnam(nj:nj) = buffer(ii:ii)
    +
    374  ENDIF
    +
    375  ENDDO
    +
    376  ENDIF
    +
    377 C
    +
    378  WRITE(6,fmt='('' W3FQ07: JOB NAME JOBNAM= :'',A,
    +
    379  1 ''!'')') jobnam(1:24)
    +
    380  WRITE(6,fmt='('' W3FQ07: JOB NAME= '',A,
    +
    381  1 '' NJ='',I3)') jobnam(1:nj),nj
    +
    382 C
    +
    383 C . . . READ IN FILE NAME
    +
    384 C
    +
    385  krtn = 0
    +
    386 
    +
    387  CALL asnqunit(outfil,string,istat)
    +
    388  WRITE(6,fmt='('' W3FQ07:OUTFIL NAME= '',
    +
    389  1 A,'' ISTAT='',I4)')string(1:80),istat
    +
    390 C SEARCH FOR LENGHT OF FILE NAME.
    +
    391 C
    +
    392  kret = istat
    +
    393  IF(kret.EQ.0) THEN
    +
    394  istrt = 0
    +
    395  DO i = 1,80
    +
    396  IF(istrt.EQ.0)THEN
    +
    397  IF(string(i:i).EQ.'/')THEN
    +
    398  istrt = i
    +
    399  ENDIF
    +
    400  ELSE
    +
    401  IF(string(i:i).EQ.' ')THEN
    +
    402  iend = i
    +
    403  GOTO 775
    +
    404  ENDIF
    +
    405  ENDIF
    +
    406  ENDDO
    +
    407  775 nf = iend - istrt
    +
    408  outxt(1:nf) = string(istrt:iend)
    +
    409  WRITE(6,fmt='('' W3FQ07: OUTXT= '',
    +
    410  1 A,'' NF='',I3)')outxt(1:nf),nf
    +
    411 C
    +
    412  WRITE(6,fmt='('' W3FQ07: CALLING DBN_ALERT WITH'',
    +
    413  1 '' :'',A,'' NK='',I2,'' '',A,'' NM='',I2,'' '',
    +
    414  2 A,'' NJ='',I2,'' '',A,'' NF='',I3)')keywrd(1:nk),
    +
    415  3 nk,modnam(1:nm),nm,jobnam(1:nj),nj,outxt(1:nf),nf
    +
    416 
    +
    417  CALL dbn_alert(keywrd,nk,modnam,nm,jobnam,nj,
    +
    418  1 outxt,nf,kret4)
    +
    419  kret=kret4
    +
    420 C
    +
    421  ENDIF
    +
    422  IF(kret.EQ.0) THEN
    +
    423 C COMES HERE FOR NORMAL STOP.
    +
    424 C
    +
    425  filnam(1:8) = 'POSTING '
    +
    426  filnam(9:9+nk-1) = keywrd(1:nk)
    +
    427  jloc = 9 + nk
    +
    428  filnam(jloc:jloc+6) = ' FILE '
    +
    429  loc = jloc + 6
    +
    430  filnam(loc+1:loc+1+nf) = outxt(1:nf)
    +
    431  joc = loc + nf + 1
    +
    432  filnam(joc:joc) = ':'
    +
    433  WRITE(6,fmt='('' W3FQ07: KRET='',I4,'' THEREFORE '',
    +
    434  1 A)')kret,filnam(1:joc)
    +
    435  CALL consol(filnam)
    +
    436  ELSE
    +
    437  krtn = 5
    +
    438  CALL int2ch(kret,ctext,2,cplmiz)
    +
    439  mesag5(40:41) = ctext(1:2)
    +
    440  WRITE(6,fmt='('' W3FQ07: '',
    +
    441  1 A)')mesag5(1:42)
    +
    442  CALL consol(notsnt)
    +
    443  CALL consol(mesag5)
    +
    444  ENDIF
    +
    445 C
    +
    446  900 CONTINUE
    +
    447  ENDIF
    +
    448  GO TO 1000
    +
    449  940 CONTINUE
    +
    450  CALL int2ch(cardfil,ctext,2,cplmiz)
    +
    451  mesag4(53:54) = ctext(1:2)
    +
    452  CALL consol(notsnt)
    +
    453  CALL consol(mesag4)
    +
    454  WRITE(6,fmt='('' W3FQ07: '',A)') notsnt
    +
    455  WRITE(6,fmt='('' W3FQ07: '',A)') mesag4
    +
    456  krtn = 4
    +
    457  ENDIF
    +
    458 1000 RETURN
    +
    459  END
    +
    +
    +
    w3fq07
    subroutine w3fq07(LPARM, NUMBYT, OUTFIL, CARDFIL, KRTN)
    Sets up the arguments for sub dbn_alert which posts transmission availability to various statfiles.
    Definition: w3fq07.f:81
    + + + + diff --git a/ver-2.10.0/w3fs13_8f.html b/ver-2.10.0/w3fs13_8f.html new file mode 100644 index 00000000..0120e8ea --- /dev/null +++ b/ver-2.10.0/w3fs13_8f.html @@ -0,0 +1,186 @@ + + + + + + + +NCEPLIBS-w3emc: w3fs13.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fs13.f File Reference
    +
    +
    + +

    Year, month, and day to day of year. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fs13 (IYR, IMO, IDA, JDY)
     0converts year, month and day to day of year. More...
     
    +

    Detailed Description

    +

    Year, month, and day to day of year.

    +
    Author
    Ralph Jones
    +
    Date
    1985-08-31
    + +

    Definition in file w3fs13.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fs13()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fs13 ( IYR,
     IMO,
     IDA,
     JDY 
    )
    +
    + +

    0converts year, month and day to day of year.

    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comments
    1985-07-31 Ralph Jones Initial.
    1989-11-02 Ralph Jones Convert to cray cft77 fortran.
    +
    Parameters
    + + + + + +
    [in]IYRYear of century, 00-99 or year of era, 1901-2099
    [in]IMOMonth of year, 1-12
    [in]IDADay of month, 1-31
    [out]JDYDay of year, 1-366
    +
    +
    +
    Note
    This procedure is valid only from the years 1901-2099 inclusive.
    + +

    Definition at line 21 of file w3fs13.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fs13_8f.js b/ver-2.10.0/w3fs13_8f.js new file mode 100644 index 00000000..ebd520e1 --- /dev/null +++ b/ver-2.10.0/w3fs13_8f.js @@ -0,0 +1,4 @@ +var w3fs13_8f = +[ + [ "w3fs13", "w3fs13_8f.html#a7ae96960810e2a780cc1dfaa4740e4ec", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fs13_8f_source.html b/ver-2.10.0/w3fs13_8f_source.html new file mode 100644 index 00000000..ecbbbc0d --- /dev/null +++ b/ver-2.10.0/w3fs13_8f_source.html @@ -0,0 +1,134 @@ + + + + + + + +NCEPLIBS-w3emc: w3fs13.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fs13.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Year, month, and day to day of year.
    +
    3 C> @author Ralph Jones @date 1985-08-31
    +
    4 
    +
    5 C> 0converts year, month and day to day of year.
    +
    6 C>
    +
    7 C> ### Program History Log:
    +
    8 C> Date | Programmer | Comments
    +
    9 C> -----|------------|---------
    +
    10 C> 1985-07-31 | Ralph Jones | Initial.
    +
    11 C> 1989-11-02 | Ralph Jones | Convert to cray cft77 fortran.
    +
    12 C>
    +
    13 C> @param[in] IYR Year of century, 00-99 or year of era, 1901-2099
    +
    14 C> @param[in] IMO Month of year, 1-12
    +
    15 C> @param[in] IDA Day of month, 1-31
    +
    16 C> @param[out] JDY Day of year, 1-366
    +
    17 C>
    +
    18 C> @note This procedure is valid only from the years 1901-2099 inclusive.
    +
    19 C>
    +
    20  SUBROUTINE w3fs13(IYR,IMO,IDA,JDY)
    +
    21 C
    +
    22  INTEGER JTABLE(24)
    +
    23 C
    +
    24  DATA jtable/0,0,31,31,60,59,91,90,121,120,152,151,
    +
    25  & 182,181,213,212,244,243,274,273,305,304,335,334/
    +
    26 C
    +
    27  iset = 0
    +
    28  IF (iand(iyr,3).EQ.0) iset = 1
    +
    29  i = imo * 2 - iset
    +
    30  jdy = jtable(i) + ida
    +
    31  RETURN
    +
    32  END
    +
    +
    +
    w3fs13
    subroutine w3fs13(IYR, IMO, IDA, JDY)
    0converts year, month and day to day of year.
    Definition: w3fs13.f:21
    + + + + diff --git a/ver-2.10.0/w3fs15_8f.html b/ver-2.10.0/w3fs15_8f.html new file mode 100644 index 00000000..a5228831 --- /dev/null +++ b/ver-2.10.0/w3fs15_8f.html @@ -0,0 +1,209 @@ + + + + + + + +NCEPLIBS-w3emc: w3fs15.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fs15.f File Reference
    +
    +
    + +

    Updating office note 85 date/time word. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fs15 (IDATE, JTAU, NDATE)
     Updates or backdates a fullword date/time word (o.n. More...
     
    +

    Detailed Description

    +

    Updating office note 85 date/time word.

    +
    Author
    Ralph Jones
    +
    Date
    1987-02-09
    + +

    Definition in file w3fs15.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fs15()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fs15 (character*1, dimension(4) IDATE,
     JTAU,
    character*1, dimension(4) NDATE 
    )
    +
    + +

    Updates or backdates a fullword date/time word (o.n.

    +

    84) by a specified number of hours.

    +

    +Program History Log:

    + + + + + + + + + + + + + + + + + + + +
    Date Programmer Comments
    Unknown Robert Allard Initial.
    1987-02-19 Ralph Jones Clean up code
    1987-02-19 Ralph Jones Change to microsoft fortran 4.10
    1989-05-12 Ralph Jones Correct order of bytes in date word for pc
    1989-08-04 Ralph Jones Clean up code, get rid of assign, correction for memory set to indefinite.
    1989-10-25 Ralph Jones Change to cray cft77 fortran
    1995-11-15 Ralph Jones Add save statement
    2002-10-15 Boi Vuong Replaced function ichar with mova2i
    +
    Parameters
    + + + + +
    [in]IDATEPacked binary date/time as follows: + + + + + + + + + + +
    Byte Variable Range
    Byte 1 is year of century 00-99
    Byte 2 is month 01-12
    Byte 3 is day of month 01-31
    Byte 4 is hour 00-23
    +Subroutine takes advantage of fortran address passing, IDATE and NDATE may be a character*1 array of four, the left 32 bits of 64 bit integer word. An office note 85 label can be stored in 4 integer words. If integer the 2nd word is used. Output is stored in left 32 bits. for a office note 84 label the 7th word is in the 4th cray 64 bit integer, the left 32 bits.
    [in]JTAUNumber of hours to update (if positive) or backdate (if negative)
    [out]NDATENew date/time word returned in the same format as 'IDATE'. 'NDATE' and 'IDATE' may be the same variable.
    +
    +
    +
    Note
    This routine is valid only for the 20th century.
    +
    +The format of the date/time word is the same as the seventh word of the packed data field label (see o.n. 84) and the third word of a binary data set label (see o.n. 85).
    +

    Exit states: An error found by out of range tests on the given date/time information will be indicated by returning a binary zero word in 'NDATE'.

    +
    Author
    Ralph Jones
    +
    Date
    1987-02-09
    + +

    Definition at line 47 of file w3fs15.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fs15_8f.js b/ver-2.10.0/w3fs15_8f.js new file mode 100644 index 00000000..90f21db1 --- /dev/null +++ b/ver-2.10.0/w3fs15_8f.js @@ -0,0 +1,4 @@ +var w3fs15_8f = +[ + [ "w3fs15", "w3fs15_8f.html#ada3b10209aac56c01b05d096d84e6471", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fs15_8f_source.html b/ver-2.10.0/w3fs15_8f_source.html new file mode 100644 index 00000000..9a6123f6 --- /dev/null +++ b/ver-2.10.0/w3fs15_8f_source.html @@ -0,0 +1,296 @@ + + + + + + + +NCEPLIBS-w3emc: w3fs15.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fs15.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Updating office note 85 date/time word.
    +
    3 C> @author Ralph Jones @date 1987-02-09
    +
    4 
    +
    5 C> Updates or backdates a fullword date/time word (o.n. 84) by a specified
    +
    6 C> number of hours.
    +
    7 C>
    +
    8 C> ### Program History Log:
    +
    9 C> Date | Programmer | Comments
    +
    10 C> -----|------------|---------
    +
    11 C> Unknown | Robert Allard | Initial.
    +
    12 C> 1987-02-19 | Ralph Jones | Clean up code
    +
    13 C> 1987-02-19 | Ralph Jones | Change to microsoft fortran 4.10
    +
    14 C> 1989-05-12 | Ralph Jones | Correct order of bytes in date word for pc
    +
    15 C> 1989-08-04 | Ralph Jones | Clean up code, get rid of assign, correction for memory set to indefinite.
    +
    16 C> 1989-10-25 | Ralph Jones | Change to cray cft77 fortran
    +
    17 C> 1995-11-15 | Ralph Jones | Add save statement
    +
    18 C> 2002-10-15 | Boi Vuong | Replaced function ichar with mova2i
    +
    19 C>
    +
    20 C> @param[in] IDATE Packed binary date/time as follows:
    +
    21 C> Byte | Variable | Range
    +
    22 C> -----|----------|------
    +
    23 C> Byte 1 | is year of century | 00-99
    +
    24 C> Byte 2 | is month | 01-12
    +
    25 C> Byte 3 | is day of month | 01-31
    +
    26 C> Byte 4 | is hour | 00-23
    +
    27 C> Subroutine takes advantage of fortran address passing, IDATE and NDATE may
    +
    28 C> be a character*1 array of four, the left 32 bits of 64 bit integer word.
    +
    29 C> An office note 85 label can be stored in 4 integer words. If integer the
    +
    30 C> 2nd word is used. Output is stored in left 32 bits. for a office note 84
    +
    31 C> label the 7th word is in the 4th cray 64 bit integer, the left 32 bits.
    +
    32 C> @param[in] JTAU Number of hours to update (if positive) or backdate (if negative)
    +
    33 C> @param[out] NDATE New date/time word returned in the same format as 'IDATE'.
    +
    34 C> 'NDATE' and 'IDATE' may be the same variable.
    +
    35 C>
    +
    36 C> @note This routine is valid only for the 20th century.
    +
    37 C>
    +
    38 C> @note The format of the date/time word is the same as the seventh word of
    +
    39 C> the packed data field label (see o.n. 84) and the third word of a binary
    +
    40 C> data set label (see o.n. 85).
    +
    41 C>
    +
    42 C> Exit states: An error found by out of range tests on the given date/time
    +
    43 C> information will be indicated by returning a binary zero word in 'NDATE'.
    +
    44 C>
    +
    45 C> @author Ralph Jones @date 1987-02-09
    +
    46  SUBROUTINE w3fs15(IDATE,JTAU,NDATE)
    +
    47 C
    +
    48  INTEGER ITABYR(13)
    +
    49  INTEGER LPTB(13)
    +
    50  INTEGER NOLPTB(13)
    +
    51 C
    +
    52  CHARACTER*1 IDATE(4)
    +
    53  CHARACTER*1 NDATE(4)
    +
    54 C
    +
    55  SAVE
    +
    56 C
    +
    57  DATA lptb /0000,0744,1440,2184,2904,3648,4368,5112,
    +
    58  & 5856,6576,7320,8040,8784/
    +
    59  DATA nolptb/0000,0744,1416,2160,2880,3624,4344,5088,
    +
    60  & 5832,6552,7296,8016,8760/
    +
    61  DATA icenty/1900/
    +
    62 C
    +
    63 C ...WHERE ICENTY IS FOR THE 20TH CENTURY ASSUMED FOR THE GIVEN
    +
    64 C ... YEAR WITHIN THE CENTURY
    +
    65 C
    +
    66  iyr = mova2i(idate(1))
    +
    67  imonth = mova2i(idate(2))
    +
    68  iday = mova2i(idate(3))
    +
    69  ihour = mova2i(idate(4))
    +
    70 C
    +
    71  IF (iyr .GT. 99) GO TO 1600
    +
    72  IF (imonth .LE. 0) GO TO 1600
    +
    73  IF (imonth .GT. 12) GO TO 1600
    +
    74  IF (iday .LE. 0) GO TO 1600
    +
    75  IF (iday .GT. 31) GO TO 1600
    +
    76  IF (ihour .LT. 0) GO TO 1600
    +
    77  IF (ihour .GT. 24) GO TO 1600
    +
    78  IF (jtau .NE. 0) GO TO 100
    +
    79 C
    +
    80  ndate(1) = idate(1)
    +
    81  ndate(2) = idate(2)
    +
    82  ndate(3) = idate(3)
    +
    83  ndate(4) = idate(4)
    +
    84  RETURN
    +
    85 C
    +
    86  100 CONTINUE
    +
    87  jahr = iyr + icenty
    +
    88  kabul = 1
    +
    89  GO TO 900
    +
    90 C
    +
    91 C ...WHERE 900 IS SUBROUTINE TO INITIALIZE ITABYR
    +
    92 C ...AND RETURN THRU KABUL
    +
    93 C
    +
    94  200 CONTINUE
    +
    95  ihryr = ihour + 24 * (iday - 1) + itabyr(imonth)
    +
    96  ihryr2 = ihryr + jtau
    +
    97 C
    +
    98 C ...TO TEST FOR BACKDATED INTO PREVIOUS YEAR...
    +
    99 C
    +
    100  300 CONTINUE
    +
    101  IF (ihryr2 .LT. 0) GO TO 700
    +
    102 C
    +
    103  DO 400 m = 2,13
    +
    104  IF (ihryr2 .LT. itabyr(m)) GO TO 600
    +
    105  400 CONTINUE
    +
    106 C
    +
    107 C ...IF IT FALLS THRU LOOP TO HERE, IT IS INTO NEXT YEAR...
    +
    108 C
    +
    109  jahr = jahr + 1
    +
    110  ihryr2 = ihryr2 - itabyr(13)
    +
    111  kabul = 2
    +
    112  GO TO 900
    +
    113 C
    +
    114  600 CONTINUE
    +
    115  monat = m - 1
    +
    116  ihrmo = ihryr2 - itabyr(monat)
    +
    117  nodays = ihrmo / 24
    +
    118  itag = nodays + 1
    +
    119  iuhr = ihrmo - nodays * 24
    +
    120  GO TO 1500
    +
    121 C
    +
    122 C ...ALL FINISHED. RETURN TO CALLING PROGRAM.......................
    +
    123 C ...COMES TO 700 IF NEG TOTAL HRS. BACK UP INTO PREVIOUS YEAR
    +
    124 C
    +
    125  700 CONTINUE
    +
    126  jahr = jahr - 1
    +
    127  kabul = 3
    +
    128  GO TO 900
    +
    129 C
    +
    130 C ...WHICH IS CALL TO INITIALIZE ITABYR AND RETURN THRU KABUL
    +
    131 C
    +
    132  800 CONTINUE
    +
    133  ihryr2 = itabyr(13) + ihryr2
    +
    134  GO TO 300
    +
    135 C
    +
    136 C ...SUBROUTINE INITYR...
    +
    137 C ...CALLED BY GO TO 900 AFTER ASSIGNING RETURN NO. TO KABUL...
    +
    138 C ...ITABYR HAS MONTHLY ACCUMULATING TOTAL HRS REL TO BEGIN OF YR.
    +
    139 C ...DEPENDS ON WHETHER JAHR IS LEAP YEAR OR NOT.
    +
    140 C
    +
    141  900 CONTINUE
    +
    142  iquot = jahr / 4
    +
    143  irmndr = jahr - 4 * iquot
    +
    144  IF (irmndr .NE. 0) GO TO 1000
    +
    145 C
    +
    146 C ...WAS MODULO 4, SO MOST LIKELY A LEAP YEAR,
    +
    147 C
    +
    148  iquot = jahr / 100
    +
    149  irmndr = jahr - 100 * iquot
    +
    150  IF (irmndr .NE. 0) GO TO 1200
    +
    151 C
    +
    152 C ...COMES THIS WAY IF A CENTURY YEAR...
    +
    153 C
    +
    154  iquot = jahr / 400
    +
    155  irmndr = jahr - 400 * iquot
    +
    156  IF (irmndr .EQ. 0) GO TO 1200
    +
    157 C
    +
    158 C ...COMES TO 1000 IF NOT A LEAP YEAR...
    +
    159 C
    +
    160  1000 CONTINUE
    +
    161  DO 1100 i = 1,13
    +
    162  itabyr(i) = nolptb(i)
    +
    163  1100 CONTINUE
    +
    164  GO TO 1400
    +
    165 C
    +
    166 C ...COMES TO 1200 IF LEAP YEAR
    +
    167 C
    +
    168  1200 CONTINUE
    +
    169  DO 1300 i = 1,13
    +
    170  itabyr(i) = lptb(i)
    +
    171  1300 CONTINUE
    +
    172 C
    +
    173  1400 CONTINUE
    +
    174  GO TO (200,300,800) kabul
    +
    175 C
    +
    176  1500 CONTINUE
    +
    177  jahr = mod(jahr,100)
    +
    178  ndate(1) = char(jahr)
    +
    179  ndate(2) = char(monat)
    +
    180  ndate(3) = char(itag)
    +
    181  ndate(4) = char(iuhr)
    +
    182  RETURN
    +
    183 C
    +
    184  1600 CONTINUE
    +
    185  ndate(1) = char(0)
    +
    186  ndate(2) = char(0)
    +
    187  ndate(3) = char(0)
    +
    188  ndate(4) = char(0)
    +
    189 C
    +
    190 C ...WHICH FLAGS AN ERROR CONDITION ...
    +
    191 C
    +
    192  RETURN
    +
    193  END
    +
    +
    +
    w3fs15
    subroutine w3fs15(IDATE, JTAU, NDATE)
    Updates or backdates a fullword date/time word (o.n.
    Definition: w3fs15.f:47
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    + + + + diff --git a/ver-2.10.0/w3fs21_8f.html b/ver-2.10.0/w3fs21_8f.html new file mode 100644 index 00000000..89215eff --- /dev/null +++ b/ver-2.10.0/w3fs21_8f.html @@ -0,0 +1,175 @@ + + + + + + + +NCEPLIBS-w3emc: w3fs21.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fs21.f File Reference
    +
    +
    + +

    Number of minutes since jan 1, 1978. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fs21 (IDATE, NMIN)
     Calculates the number of minutes since 0000, 1 January 1978. More...
     
    +

    Detailed Description

    +

    Number of minutes since jan 1, 1978.

    +
    Author
    A. Desmarais
    +
    Date
    1984-06-21
    + +

    Definition in file w3fs21.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fs21()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3fs21 (integer, dimension(5) IDATE,
    integer NMIN 
    )
    +
    + +

    Calculates the number of minutes since 0000, 1 January 1978.

    +

    +Program History Log:

    + + + + + + + + + +
    Date Programmer Comments
    1984-06-21 A. Desmarais Initial.
    1989-07-14 Ralph Jones Convert to cyber 205 fortran 200, change logic so it will work in 21 century.
    1989-11-02 Ralph Jones Convert to cray cft77 fortran.
    +
    Parameters
    + + + +
    [in]IDATE(INTEGER Size 5) Array containing year of century, month, day, hour and minute. IDATE(1) may be a two digit year or 4. If 2 digits and GE than 78 1900 is added to it. If LT 78 then 2000 is added to it. If 4 digits the subroutine will work correctly to the year 3300 A.D.
    [out]NMIN(INTEGER) Number of minutes since 1 January 1978.
    +
    +
    +
    Author
    A. Desmarais
    +
    Date
    1984-06-21
    + +

    Definition at line 22 of file w3fs21.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fs21_8f.js b/ver-2.10.0/w3fs21_8f.js new file mode 100644 index 00000000..32661925 --- /dev/null +++ b/ver-2.10.0/w3fs21_8f.js @@ -0,0 +1,4 @@ +var w3fs21_8f = +[ + [ "w3fs21", "w3fs21_8f.html#a337c53a535dd6a8066f313eb9889201c", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fs21_8f_source.html b/ver-2.10.0/w3fs21_8f_source.html new file mode 100644 index 00000000..3c56058f --- /dev/null +++ b/ver-2.10.0/w3fs21_8f_source.html @@ -0,0 +1,164 @@ + + + + + + + +NCEPLIBS-w3emc: w3fs21.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fs21.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Number of minutes since jan 1, 1978
    +
    3 C> @author A. Desmarais @date 1984-06-21
    +
    4 
    +
    5 C> Calculates the number of minutes since 0000, 1 January 1978.
    +
    6 C>
    +
    7 C> ### Program History Log:
    +
    8 C> Date | Programmer | Comments
    +
    9 C> -----|------------|---------
    +
    10 C> 1984-06-21 | A. Desmarais | Initial.
    +
    11 C> 1989-07-14 | Ralph Jones | Convert to cyber 205 fortran 200, change logic so it will work in 21 century.
    +
    12 C> 1989-11-02 | Ralph Jones | Convert to cray cft77 fortran.
    +
    13 C>
    +
    14 C> @param[in] IDATE (INTEGER Size 5) Array containing year of century, month,
    +
    15 C> day, hour and minute. IDATE(1) may be a two digit year or 4. If 2 digits
    +
    16 c> and GE than 78 1900 is added to it. If LT 78 then 2000 is added to it. If 4
    +
    17 C> digits the subroutine will work correctly to the year 3300 A.D.
    +
    18 C> @param[out] NMIN (INTEGER) Number of minutes since 1 January 1978.
    +
    19 C>
    +
    20 C> @author A. Desmarais @date 1984-06-21
    +
    21  SUBROUTINE w3fs21(IDATE, NMIN)
    +
    22 C
    +
    23  INTEGER IDATE(5)
    +
    24  INTEGER NMIN
    +
    25  INTEGER JDN78
    +
    26 C
    +
    27  DATA jdn78 / 2443510 /
    +
    28 C
    +
    29 C*** IDATE(1) YEAR OF CENTURY
    +
    30 C*** IDATE(2) MONTH OF YEAR
    +
    31 C*** IDATE(3) DAY OF MONTH
    +
    32 C*** IDATE(4) HOUR OF DAY
    +
    33 C*** IDATE(5) MINUTE OF HOUR
    +
    34 C
    +
    35  nmin = 0
    +
    36 C
    +
    37  iyear = idate(1)
    +
    38 C
    +
    39  IF (iyear.LE.99) THEN
    +
    40  IF (iyear.LT.78) THEN
    +
    41  iyear = iyear + 2000
    +
    42  ELSE
    +
    43  iyear = iyear + 1900
    +
    44  ENDIF
    +
    45  ENDIF
    +
    46 C
    +
    47 C COMPUTE JULIAN DAY NUMBER FROM YEAR, MONTH, DAY
    +
    48 C
    +
    49  ijdn = iw3jdn(iyear,idate(2),idate(3))
    +
    50 C
    +
    51 C SUBTRACT JULIAN DAY NUMBER OF JAN 1,1978 TO GET THE
    +
    52 C NUMBER OF DAYS BETWEEN DATES
    +
    53 C
    +
    54  ndays = ijdn - jdn78
    +
    55 C
    +
    56 C*** NUMBER OF MINUTES
    +
    57 C
    +
    58  nmin = ndays * 1440 + idate(4) * 60 + idate(5)
    +
    59 C
    +
    60  RETURN
    +
    61  END
    +
    +
    +
    w3fs21
    subroutine w3fs21(IDATE, NMIN)
    Calculates the number of minutes since 0000, 1 January 1978.
    Definition: w3fs21.f:22
    +
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    + + + + diff --git a/ver-2.10.0/w3fs26_8f.html b/ver-2.10.0/w3fs26_8f.html new file mode 100644 index 00000000..e84c9470 --- /dev/null +++ b/ver-2.10.0/w3fs26_8f.html @@ -0,0 +1,208 @@ + + + + + + + +NCEPLIBS-w3emc: w3fs26.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3fs26.f File Reference
    +
    +
    + +

    Year, month, day from julian day number. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3fs26 (JLDAYN, IYEAR, MONTH, IDAY, IDAYWK, IDAYYR)
     Computes year (4 digits), month, day, day of week, day of year from julian day number. More...
     
    +

    Detailed Description

    +

    Year, month, day from julian day number.

    +
    Author
    Ralph Jones
    +
    Date
    1987-03-29
    + +

    Definition in file w3fs26.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3fs26()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3fs26 ( JLDAYN,
     IYEAR,
     MONTH,
     IDAY,
     IDAYWK,
     IDAYYR 
    )
    +
    + +

    Computes year (4 digits), month, day, day of week, day of year from julian day number.

    +

    this subroutine will work from 1583 a.d. to 3300 a.d.

    +

    +Program History Log:

    +

    Date | Programmer | Comments --—|---------—|------— 1987-03-29 | Ralph Jones | 1989-10-25 | Ralph Jones | Convert to cray cft77 fortran

    +
    Parameters
    + + + + + + + +
    [in]JLDAYN(INT) Julian day number
    [out]IYEAR(INT) Year (4 digits)
    [out]MONTH(INT) Month
    [out]IDAY(INT) Day
    [out]IDAYWK(INT) Day of week (1 is sunday, 7 is sat)
    [out]IDAYYR(INT) Day of year (1 to 366)
    +
    +
    +
    Note
    A julian day number can be computed by using one of the following statement functions. A day of week can be computed from the julian day number. A day of year can be computed from a julian day number and year.
    +

    JDN(IYEAR,MONTH,IDAY) = 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
      • +
    +

    IYR (4 DIGITS) , IDYR(1-366) Day of year

    +

    JULIAN(IYR,IDYR) = -31739 + 1461 * (IYR + 4799) / 4 -3 * ((IYR + 4899) / 100) / 4 + IDYR

    +

    Day of week from julian day number, 1 is sunday, 7 is saturday.

    +

    JDAYWK(JLDAYN) = MOD((JLDAYN + 1),7) + 1

    +

    Day of year from julian day number and 4 digit year.

    +

    JDAYYR(JLDAYN,IYEAR) = JLDAYN - (-31739+1461*(IYEAR+4799)/4-3*((IYEAR+4899)/100)/4)

    +

    The first function was in a letter to the editor communications of the acm volume 11 / number 10 / october, 1968. the 2nd function was derived from the first. This subroutine was also included in the same letter. Julian day number 1 is jan 1,4713 b.c. a julian day number can be used to replace a day of century, this will take care of the date problem in the year 2000, or reduce program changes to one line change of 1900 to 2000. Julian day numbers can be used for finding record numbers in an archive or day of week, or day of year.

    +
    Author
    Ralph Jones
    +
    Date
    1987-03-29
    + +

    Definition at line 56 of file w3fs26.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3fs26_8f.js b/ver-2.10.0/w3fs26_8f.js new file mode 100644 index 00000000..da29fd5f --- /dev/null +++ b/ver-2.10.0/w3fs26_8f.js @@ -0,0 +1,4 @@ +var w3fs26_8f = +[ + [ "w3fs26", "w3fs26_8f.html#ab9c55405126eb6b249eb3d6542c0bb30", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3fs26_8f_source.html b/ver-2.10.0/w3fs26_8f_source.html new file mode 100644 index 00000000..a64c6e41 --- /dev/null +++ b/ver-2.10.0/w3fs26_8f_source.html @@ -0,0 +1,173 @@ + + + + + + + +NCEPLIBS-w3emc: w3fs26.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3fs26.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Year, month, day from julian day number
    +
    3 C> @author Ralph Jones @date 1987-03-29
    +
    4 
    +
    5 C> Computes year (4 digits), month, day, day of week, day of year from julian
    +
    6 C> day number. this subroutine will work from 1583 a.d. to 3300 a.d.
    +
    7 C>
    +
    8 C> ### Program History Log:
    +
    9 C> Date | Programmer | Comments
    +
    10 C> -----|------------|---------
    +
    11 C> 1987-03-29 | Ralph Jones |
    +
    12 C> 1989-10-25 | Ralph Jones | Convert to cray cft77 fortran
    +
    13 C>
    +
    14 C> @param[in] JLDAYN (INT) Julian day number
    +
    15 C> @param[out] IYEAR (INT) Year (4 digits)
    +
    16 C> @param[out] MONTH (INT) Month
    +
    17 C> @param[out] IDAY (INT) Day
    +
    18 C> @param[out] IDAYWK (INT) Day of week (1 is sunday, 7 is sat)
    +
    19 C> @param[out] IDAYYR (INT) Day of year (1 to 366)
    +
    20 C>
    +
    21 C> @note A julian day number can be computed by using one of the following
    +
    22 C> statement functions. A day of week can be computed from the julian day
    +
    23 C> number. A day of year can be computed from a julian day number and year.
    +
    24 C>
    +
    25 C> JDN(IYEAR,MONTH,IDAY) = IDAY - 32075
    +
    26 C> + 1461 * (IYEAR + 4800 + (MONTH - 14) / 12) / 4
    +
    27 C> + 367 * (MONTH - 2 - (MONTH -14) / 12 * 12) / 12
    +
    28 C> - 3 * ((IYEAR + 4900 + (MONTH - 14) / 12) / 100) / 4
    +
    29 C>
    +
    30 C> IYR (4 DIGITS) , IDYR(1-366) Day of year
    +
    31 C>
    +
    32 C> JULIAN(IYR,IDYR) = -31739 + 1461 * (IYR + 4799) / 4
    +
    33 C> -3 * ((IYR + 4899) / 100) / 4 + IDYR
    +
    34 C>
    +
    35 C> Day of week from julian day number, 1 is sunday, 7 is saturday.
    +
    36 C>
    +
    37 C> JDAYWK(JLDAYN) = MOD((JLDAYN + 1),7) + 1
    +
    38 C>
    +
    39 C> Day of year from julian day number and 4 digit year.
    +
    40 C>
    +
    41 C> JDAYYR(JLDAYN,IYEAR) = JLDAYN -
    +
    42 C> (-31739+1461*(IYEAR+4799)/4-3*((IYEAR+4899)/100)/4)
    +
    43 C>
    +
    44 C> The first function was in a letter to the editor communications
    +
    45 C> of the acm volume 11 / number 10 / october, 1968. the 2nd
    +
    46 C> function was derived from the first. This subroutine was also
    +
    47 C> included in the same letter. Julian day number 1 is
    +
    48 C> jan 1,4713 b.c. a julian day number can be used to replace a
    +
    49 C> day of century, this will take care of the date problem in
    +
    50 C> the year 2000, or reduce program changes to one line change
    +
    51 C> of 1900 to 2000. Julian day numbers can be used for finding
    +
    52 C> record numbers in an archive or day of week, or day of year.
    +
    53 C>
    +
    54 C> @author Ralph Jones @date 1987-03-29
    +
    55  SUBROUTINE w3fs26(JLDAYN,IYEAR,MONTH,IDAY,IDAYWK,IDAYYR)
    +
    56 C
    +
    57  l = jldayn + 68569
    +
    58  n = 4 * l / 146097
    +
    59  l = l - (146097 * n + 3) / 4
    +
    60  i = 4000 * (l + 1) / 1461001
    +
    61  l = l - 1461 * i / 4 + 31
    +
    62  j = 80 * l / 2447
    +
    63  iday = l - 2447 * j / 80
    +
    64  l = j / 11
    +
    65  month = j + 2 - 12 * l
    +
    66  iyear = 100 * (n - 49) + i + l
    +
    67  idaywk = mod((jldayn + 1),7) + 1
    +
    68  idayyr = jldayn -
    +
    69  & (-31739 +1461 * (iyear+4799) / 4 - 3 * ((iyear+4899)/100)/4)
    +
    70  RETURN
    +
    71  END
    +
    +
    +
    w3fs26
    subroutine w3fs26(JLDAYN, IYEAR, MONTH, IDAY, IDAYWK, IDAYYR)
    Computes year (4 digits), month, day, day of week, day of year from julian day number.
    Definition: w3fs26.f:56
    + + + + diff --git a/ver-2.10.0/w3ft00_8f.html b/ver-2.10.0/w3ft00_8f.html new file mode 100644 index 00000000..c05ed3ef --- /dev/null +++ b/ver-2.10.0/w3ft00_8f.html @@ -0,0 +1,255 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft00.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft00.f File Reference
    +
    +
    + +

    Data field tranformation subroutine. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft00 (FLD, B, IA, JA, IB, JB, CIP, CJP, FIPB, FJPB, SC, ARG, LIN)
     Transforms data contained in a grid array by translation, rotation about a common point and dilatation to a new grid array. More...
     
    +

    Detailed Description

    +

    Data field tranformation subroutine.

    +
    Author
    J. McDonell
    +
    Date
    1974-09-01
    + +

    Definition in file w3ft00.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft00()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft00 (real, dimension(ia,ja) FLD,
    real, dimension(ib,jb) B,
     IA,
     JA,
     IB,
     JB,
     CIP,
     CJP,
     FIPB,
     FJPB,
     SC,
     ARG,
     LIN 
    )
    +
    + +

    Transforms data contained in a grid array by translation, rotation about a common point and dilatation to a new grid array.

    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comments
    1974-09-01 J. McDonell Initial.
    1984-06-27 Ralph Jones Change to ibm vs fortran.
    +
    Parameters
    + + + + + + + + + + + + + + +
    [in]IA(Integer) i-dimension of the input array fa
    [in]JA(Integer) j-dimension of the input array fa
    [in]IB(Integer) i-dimension of the output array fb
    [in]JB(Integer) j-dimension of the output array fb
    [in]SC(Real) Scale change (dilation) expressed as a ratio of the transformed to the origional field.
    [in]ARG(Real) Degree measure of the angle required to rotate the j-row of the origional grid into coincidence with the new grid. (+ counter- clockwise, - clockwise)
    [in]LIN(Integer) Interpolation method switch
      +
    • .eq. 1 bilinear interpolation
      • +
    • .ne. 1 biquadratic interpolation
      • +
    +
    FLD
    B
    CIP
    CJP
    FIPB
    FJPB
    +
    +
    +
    Remarks
    In general 'fa' and 'fb' cannot be equivalenced although there are situations in which it would be safe to do so. care should be taken that all of the new grid points lie within the origional grid, no error checks are made.
    +
    Author
    J. McDonell
    +
    Date
    1974-09-01
    + +

    Definition at line 40 of file w3ft00.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft00_8f.js b/ver-2.10.0/w3ft00_8f.js new file mode 100644 index 00000000..7b28a9ec --- /dev/null +++ b/ver-2.10.0/w3ft00_8f.js @@ -0,0 +1,4 @@ +var w3ft00_8f = +[ + [ "w3ft00", "w3ft00_8f.html#a0df888e118ff615726dfe75f1f268c21", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft00_8f_source.html b/ver-2.10.0/w3ft00_8f_source.html new file mode 100644 index 00000000..63e20c37 --- /dev/null +++ b/ver-2.10.0/w3ft00_8f_source.html @@ -0,0 +1,248 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft00.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft00.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Data field tranformation subroutine.
    +
    3 C> @author J. McDonell @date 1974-09-01
    +
    4 
    +
    5 C> Transforms data contained in a grid array by translation, rotation about a
    +
    6 C> common point and dilatation to a new grid array.
    +
    7 C>
    +
    8 C> ### Program History Log:
    +
    9 C> Date | Programmer | Comments
    +
    10 C> -----|------------|---------
    +
    11 C> 1974-09-01 | J. McDonell | Initial.
    +
    12 C> 1984-06-27 | Ralph Jones | Change to ibm vs fortran.
    +
    13 C>
    +
    14 C> @param[in] IA (Integer) i-dimension of the input array fa
    +
    15 C> @param[in] JA (Integer) j-dimension of the input array fa
    +
    16 C> @param[in] IB (Integer) i-dimension of the output array fb
    +
    17 C> @param[in] JB (Integer) j-dimension of the output array fb
    +
    18 C> @param[in] SC (Real) Scale change (dilation) expressed as a ratio of the
    +
    19 C> transformed to the origional field.
    +
    20 C> @param[in] ARG (Real) Degree measure of the angle required to rotate the
    +
    21 C> j-row of the origional grid into coincidence with the new grid. (+ counter-
    +
    22 C> clockwise, - clockwise)
    +
    23 C> @param[in] LIN (Integer) Interpolation method switch
    +
    24 C> - .eq. 1 bilinear interpolation
    +
    25 C> - .ne. 1 biquadratic interpolation
    +
    26 C> @param FLD
    +
    27 C> @param B
    +
    28 C> @param CIP
    +
    29 C> @param CJP
    +
    30 C> @param FIPB
    +
    31 C> @param FJPB
    +
    32 C>
    +
    33 C> @remark In general 'fa' and 'fb' cannot be equivalenced although there are
    +
    34 C> situations in which it would be safe to do so. care should be taken that
    +
    35 C> all of the new grid points lie within the origional grid, no error checks
    +
    36 C> are made.
    +
    37 C>
    +
    38 C> @author J. McDonell @date 1974-09-01
    +
    39  SUBROUTINE w3ft00(FLD,B,IA,JA,IB,JB,CIP,CJP,FIPB,FJPB,SC,ARG,LIN)
    +
    40 C
    +
    41  REAL B(IB,JB)
    +
    42  REAL ERAS(4)
    +
    43  REAL FLD(IA,JA)
    +
    44 C
    +
    45  equivalence(ci,sti), (cj,stj)
    +
    46 C
    +
    47  theta = arg * (3.14159 / 180.0)
    +
    48  sint = sin(theta)
    +
    49  cost = cos(theta)
    +
    50 C
    +
    51  DO 180 jn = 1,jb
    +
    52  fjn = jn
    +
    53  fj = fjn - fjpb
    +
    54  DO 180 in = 1,ib
    +
    55  fin = in
    +
    56  fi = fin - fipb
    +
    57  ioff = 0
    +
    58  joff = 0
    +
    59  kquad = 0
    +
    60  ci = cip + sc * (fi * cost - fj * sint)
    +
    61  cj = cjp + sc * (fi * sint + fj * cost)
    +
    62  im = ci
    +
    63  jm = cj
    +
    64  IF ((im - 1).GT.0) GO TO 20
    +
    65  IF ((im - 1).EQ.0) GO TO 40
    +
    66  ii = 1
    +
    67  ioff = 1
    +
    68  GO TO 50
    +
    69 C
    +
    70  20 CONTINUE
    +
    71  IF ((ia - im - 1).GT.0) GO TO 50
    +
    72  IF ((ia - im - 1).EQ.0) GO TO 40
    +
    73  ii = ia
    +
    74  ioff = 1
    +
    75  GO TO 50
    +
    76 C
    +
    77  40 CONTINUE
    +
    78  kquad = 5
    +
    79 C
    +
    80  50 CONTINUE
    +
    81  IF ((jm - 1).GT.0) GO TO 70
    +
    82  IF ((jm - 1).EQ.0) GO TO 90
    +
    83  jj = 1
    +
    84  joff = 1
    +
    85  GO TO 100
    +
    86 C
    +
    87  70 CONTINUE
    +
    88  IF ((ja - jm - 1).GT.0) GO TO 100
    +
    89  IF ((ja - jm - 1).EQ.0) GO TO 90
    +
    90  jj = ja
    +
    91  joff = 1
    +
    92  GO TO 100
    +
    93 C
    +
    94  90 CONTINUE
    +
    95  kquad = 5
    +
    96 C
    +
    97  100 CONTINUE
    +
    98  IF ((ioff + joff) .EQ. 0) GO TO 120
    +
    99  IF ((ioff + joff) .EQ. 2) GO TO 110
    +
    100  IF (ioff .EQ. 1) jj = cj
    +
    101  IF (joff .EQ. 1) ii = ci
    +
    102 C
    +
    103  110 CONTINUE
    +
    104  b(in,jn) = fld(ii,jj)
    +
    105  GO TO 180
    +
    106 C
    +
    107  120 CONTINUE
    +
    108  i = sti
    +
    109  j = stj
    +
    110  fix = i
    +
    111  xdeli = sti - fix
    +
    112  fjx = j
    +
    113  xdelj = stj - fjx
    +
    114  IF ((kquad - 5).EQ.0) GO TO 140
    +
    115 C
    +
    116  IF ((lin-1).NE.0) GO TO 150
    +
    117 C
    +
    118  140 CONTINUE
    +
    119  eras(1) = fld(i,j)
    +
    120  eras(4) = fld(i,j+1)
    +
    121  eras(2) = eras(1) + (fld(i+1,j) - eras(1)) * xdeli
    +
    122  eras(3) = eras(4) + (fld(i+1,j+1) - eras(4)) * xdeli
    +
    123  di = eras(2) + (eras(3) - eras(2)) * xdelj
    +
    124  GO TO 170
    +
    125 C
    +
    126  150 CONTINUE
    +
    127  xi2tm = xdeli * (xdeli - 1.0) * 0.25
    +
    128  xj2tm = xdelj * (xdelj - 1.0) * 0.25
    +
    129  j1 = j - 1
    +
    130 C
    +
    131  DO 160 k = 1,4
    +
    132  eras(k) = (fld(i+1,j1) - fld(i,j1)) * xdeli + fld(i,j1) +
    +
    133  & (fld(i-1,j1) - fld(i,j1) - fld(i+1,j1) + fld(i+2,j1)) * xi2tm
    +
    134  j1 = j1 + 1
    +
    135  160 CONTINUE
    +
    136 C
    +
    137  di = eras(2) + (eras(3) - eras(2)) * xdelj + (eras(1) -
    +
    138  & eras(2) - eras(3) + eras(4)) * xj2tm
    +
    139 C
    +
    140  170 CONTINUE
    +
    141  b(in,jn) = di
    +
    142 C
    +
    143  180 CONTINUE
    +
    144 C
    +
    145  RETURN
    +
    146  END
    +
    +
    +
    w3ft00
    subroutine w3ft00(FLD, B, IA, JA, IB, JB, CIP, CJP, FIPB, FJPB, SC, ARG, LIN)
    Transforms data contained in a grid array by translation, rotation about a common point and dilatatio...
    Definition: w3ft00.f:40
    + + + + diff --git a/ver-2.10.0/w3ft01_8f.html b/ver-2.10.0/w3ft01_8f.html new file mode 100644 index 00000000..5f5a717d --- /dev/null +++ b/ver-2.10.0/w3ft01_8f.html @@ -0,0 +1,225 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft01.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft01.f File Reference
    +
    +
    + +

    Interpolate values in a data field. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft01 (STI, STJ, FLD, HI, II, JJ, NCYCLK, LIN)
     For a given grid coordinate in a data array, estimates a data value for that point using either a linear or quadratic interpolation method. More...
     
    +

    Detailed Description

    +

    Interpolate values in a data field.

    +
    Author
    James McDonell
    +
    Date
    1984-06-27
    + +

    Definition in file w3ft01.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft01()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft01 ( STI,
     STJ,
    real, dimension(ii,jj) FLD,
     HI,
     II,
     JJ,
     NCYCLK,
     LIN 
    )
    +
    + +

    For a given grid coordinate in a data array, estimates a data value for that point using either a linear or quadratic interpolation method.

    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Commment
    1984-06-27 James McDonell Initial
    1989-11-01 Ralph Jones Change to cray cft77 fortran
    +
    Parameters
    + + + + + + + + + +
    [in]STIReal*4 i grid coordinate of the point for which an interpolated value is desired.
    [in]STJReal*4 j grid coordinate of the point for which an interpolated value is desired.
    [in]FLDReal*4 size(ii,jj) data field.
    [in]IIInteger*4 number of columns in 'fld'.
    [in]JJInteger*4 number of rows in 'fld'.
    [in]NCYCLKInteger*4 code to specify if grid is cyclic or not:
      +
    • = 0 Non-cyclic in ii, non-cyclic in jj
      • +
    • = 1 Cyclic in ii, non-cyclic in jj
      • +
    • = 2 Cyclic in jj, non-cyclic in ii
      • +
    • = 3 Cyclic in ii, cyclic in jj
      • +
    +
    [in]LINInteger*4 code specifying interpolation method:
      +
    • = 1 Linear interpolation
      • +
    • .NE.1 Quadratic interpolation
      • +
    +
    [out]HIReal*4 data field value at (sti,stj) obtained by interpolation.
    +
    +
    +
    Author
    James McDonell
    +
    Date
    1984-06-27
    + +

    Definition at line 36 of file w3ft01.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft01_8f.js b/ver-2.10.0/w3ft01_8f.js new file mode 100644 index 00000000..d9a2ee1b --- /dev/null +++ b/ver-2.10.0/w3ft01_8f.js @@ -0,0 +1,4 @@ +var w3ft01_8f = +[ + [ "w3ft01", "w3ft01_8f.html#a5712b189cf471fffe9b1529a75949729", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft01_8f_source.html b/ver-2.10.0/w3ft01_8f_source.html new file mode 100644 index 00000000..ed78d3f0 --- /dev/null +++ b/ver-2.10.0/w3ft01_8f_source.html @@ -0,0 +1,266 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft01.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft01.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Interpolate values in a data field.
    +
    3 C> @author James McDonell @date 1984-06-27
    +
    4 
    +
    5 C> For a given grid coordinate in a data array, estimates
    +
    6 C> a data value for that point using either a linear or quadratic
    +
    7 C> interpolation method.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Commment
    +
    11 C> -----|------------|---------
    +
    12 C> 1984-06-27 | James McDonell | Initial
    +
    13 C> 1989-11-01 | Ralph Jones | Change to cray cft77 fortran
    +
    14 C>
    +
    15 C> @param[in] STI Real*4 i grid coordinate of the point for which
    +
    16 C> an interpolated value is desired.
    +
    17 C> @param[in] STJ Real*4 j grid coordinate of the point for which
    +
    18 C> an interpolated value is desired.
    +
    19 C> @param[in] FLD Real*4 size(ii,jj) data field.
    +
    20 C> @param[in] II Integer*4 number of columns in 'fld'.
    +
    21 C> @param[in] JJ Integer*4 number of rows in 'fld'.
    +
    22 C> @param[in] NCYCLK Integer*4 code to specify if grid is cyclic or
    +
    23 C> not:
    +
    24 C> - = 0 Non-cyclic in ii, non-cyclic in jj
    +
    25 C> - = 1 Cyclic in ii, non-cyclic in jj
    +
    26 C> - = 2 Cyclic in jj, non-cyclic in ii
    +
    27 C> - = 3 Cyclic in ii, cyclic in jj
    +
    28 C> @param[in] LIN Integer*4 code specifying interpolation method:
    +
    29 C> - = 1 Linear interpolation
    +
    30 C> - .NE.1 Quadratic interpolation
    +
    31 C> @param[out] HI Real*4 data field value at (sti,stj) obtained
    +
    32 C> by interpolation.
    +
    33 C>
    +
    34 C> @author James McDonell @date 1984-06-27
    +
    35  SUBROUTINE w3ft01(STI,STJ,FLD,HI,II,JJ,NCYCLK,LIN)
    +
    36 C
    +
    37  REAL ERAS(4)
    +
    38  REAL FLD(II,JJ)
    +
    39  REAL JY(4)
    +
    40 C
    +
    41  i = sti
    +
    42  j = stj
    +
    43  fi = i
    +
    44  fj = j
    +
    45  xdeli = sti - fi
    +
    46  xdelj = stj - fj
    +
    47  ip2 = i + 2
    +
    48  im1 = i - 1
    +
    49  ip1 = i + 1
    +
    50  jy(4) = j + 2
    +
    51  jy(1) = j - 1
    +
    52  jy(3) = j + 1
    +
    53  jy(2) = j
    +
    54  xi2tm = 0.0
    +
    55  xj2tm = 0.0
    +
    56  IF (lin.NE.1) THEN
    +
    57  xi2tm = xdeli * (xdeli - 1.0) * 0.25
    +
    58  xj2tm = xdelj * (xdelj - 1.0) * 0.25
    +
    59  ENDIF
    +
    60  IF ((i.LT.2).OR.(j.LT.2)) GO TO 10
    +
    61  IF ((i.GT.ii-3).OR.(j.GT.jj-3)) GO TO 10
    +
    62 C
    +
    63 C QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 170
    +
    64 C
    +
    65  GO TO 170
    +
    66 C
    +
    67  10 CONTINUE
    +
    68  icyclk = 0
    +
    69  jcyclk = 0
    +
    70  IF (ncyclk) 20,120,20
    +
    71 C
    +
    72  20 CONTINUE
    +
    73  IF (ncyclk / 2 .NE. 0) jcyclk = 1
    +
    74  IF (ncyclk .NE. 2) icyclk = 1
    +
    75  IF (icyclk) 30,70,30
    +
    76 C
    +
    77  30 CONTINUE
    +
    78  IF (i.EQ.1) GO TO 40
    +
    79  IF (i.EQ.(ii-1)) GO TO 50
    +
    80  ip2 = i + 2
    +
    81  im1 = i - 1
    +
    82  GO TO 60
    +
    83 C
    +
    84  40 CONTINUE
    +
    85  ip2 = 3
    +
    86  im1 = ii - 1
    +
    87  GO TO 60
    +
    88 C
    +
    89  50 CONTINUE
    +
    90  ip2 = 2
    +
    91  im1 = ii - 2
    +
    92 C
    +
    93  60 CONTINUE
    +
    94  ip1 = i + 1
    +
    95 C
    +
    96  70 CONTINUE
    +
    97  IF (jcyclk) 80,120,80
    +
    98 C
    +
    99  80 CONTINUE
    +
    100  IF (j.EQ.1) GO TO 90
    +
    101  IF (j.EQ.(jj-1)) GO TO 100
    +
    102  jy(4) = j + 2
    +
    103  jy(1) = j - 1
    +
    104  GO TO 110
    +
    105 C
    +
    106  90 CONTINUE
    +
    107  jy(4) = 3
    +
    108  jy(1) = jj - 1
    +
    109  GO TO 110
    +
    110 C
    +
    111  100 CONTINUE
    +
    112  jy(4) = 2
    +
    113  jy(1) = jj - 2
    +
    114 C
    +
    115  110 CONTINUE
    +
    116  jy(3) = j + 1
    +
    117  jy(2) = j
    +
    118 C
    +
    119  120 CONTINUE
    +
    120  IF (lin.EQ.1) GO TO 160
    +
    121  IF (icyclk) 140,130,140
    +
    122 C
    +
    123  130 CONTINUE
    +
    124  IF ((i.LT.2).OR.(i.GE.(ii-1))) xi2tm = 0.0
    +
    125 C
    +
    126  140 CONTINUE
    +
    127  IF (jcyclk) 160,150,160
    +
    128 C
    +
    129  150 CONTINUE
    +
    130  IF ((j.LT.2).OR.(j.GE.(jj-1))) xj2tm = 0.0
    +
    131 C
    +
    132  160 CONTINUE
    +
    133 C
    +
    134 C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
    +
    135 C
    +
    136  IF (i.LT.1) i = 1
    +
    137  IF (ip1.LT.1) ip1 = 1
    +
    138  IF (ip2.LT.1) ip2 = 1
    +
    139  IF (im1.LT.1) im1 = 1
    +
    140 C
    +
    141 C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
    +
    142 C
    +
    143  IF (i.GT.ii) i = ii
    +
    144  IF (ip1.GT.ii) ip1 = ii
    +
    145  IF (ip2.GT.ii) ip2 = ii
    +
    146  IF (im1.GT.ii) im1 = ii
    +
    147 C
    +
    148  170 CONTINUE
    +
    149  DO 180 k = 1,4
    +
    150  j1 = jy(k)
    +
    151 C
    +
    152 C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
    +
    153 C
    +
    154  IF (j1.LT.1) j1 = 1
    +
    155  IF (j1.GT.jj) j1 = jj
    +
    156  eras(k) = (fld(ip1,j1) - fld(i,j1)) * xdeli + fld(i,j1) +
    +
    157  & (fld(im1,j1) - fld(i,j1) - fld(ip1,j1) + fld(ip2,j1)) * xi2tm
    +
    158  180 CONTINUE
    +
    159 C
    +
    160  hi = eras(2) + (eras(3) - eras(2)) * xdelj + (eras(1) -
    +
    161  & eras(2) - eras(3) + eras(4)) * xj2tm
    +
    162 C
    +
    163  RETURN
    +
    164  END
    +
    +
    +
    w3ft01
    subroutine w3ft01(STI, STJ, FLD, HI, II, JJ, NCYCLK, LIN)
    For a given grid coordinate in a data array, estimates a data value for that point using either a lin...
    Definition: w3ft01.f:36
    + + + + diff --git a/ver-2.10.0/w3ft02_8f.html b/ver-2.10.0/w3ft02_8f.html new file mode 100644 index 00000000..0de6d134 --- /dev/null +++ b/ver-2.10.0/w3ft02_8f.html @@ -0,0 +1,202 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft02.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft02.f File Reference
    +
    +
    + +

    Interpolate precipitation to specific point. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft02 (RAIN, IMAX, JMAX, PI, PJ, AMOUNT)
     Interpolate, using a fancy non-linear method, gridded quantitative precipitation forecasts to a specific interior point. More...
     
    +

    Detailed Description

    +

    Interpolate precipitation to specific point.

    +
    Author
    Robert Hirano
    +
    Date
    1979-08-05
    + +

    Definition in file w3ft02.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft02()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft02 (real, dimension(imax,jmax) RAIN,
     IMAX,
     JMAX,
     PI,
     PJ,
     AMOUNT 
    )
    +
    + +

    Interpolate, using a fancy non-linear method, gridded quantitative precipitation forecasts to a specific interior point.

    +

    One point (e.g. an observation station) per call to w3ft02().

    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    1979-08-05 Robert Hirano Initial.
    1996-06-23 Farley Converted to cray fortran 77
    +
    Parameters
    + + + + + + + +
    [in]RAINReal*4 grid field of (forecast) precipitation.
    [in]IMAXInteger*4 i-dimension of rain field.
    [in]JMAXInteger *4 j-dimension of rain field.
    [in]PIReal*4 i-coordinate of interpolation point.
    [in]PJReal*4 j-coordinate of interpolation point.
    [out]AMOUNTReal*4 amount of precip interpolated to pi,pj.
    +
    +
    +
    Author
    Robert Hirano
    +
    Date
    1979-08-05
    + +

    Definition at line 25 of file w3ft02.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft02_8f.js b/ver-2.10.0/w3ft02_8f.js new file mode 100644 index 00000000..3df492fb --- /dev/null +++ b/ver-2.10.0/w3ft02_8f.js @@ -0,0 +1,4 @@ +var w3ft02_8f = +[ + [ "w3ft02", "w3ft02_8f.html#ab2829ffb3ea29d17638612b1e6f4bcdf", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft02_8f_source.html b/ver-2.10.0/w3ft02_8f_source.html new file mode 100644 index 00000000..54db2fb7 --- /dev/null +++ b/ver-2.10.0/w3ft02_8f_source.html @@ -0,0 +1,300 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft02.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft02.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Interpolate precipitation to specific point.
    +
    3 C> @author Robert Hirano @date 1979-08-05
    +
    4 
    +
    5 C> Interpolate, using a fancy non-linear method,
    +
    6 C> gridded quantitative precipitation forecasts to a specific
    +
    7 C> interior point. One point (e.g. an observation station)
    +
    8 C> per call to w3ft02().
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comment
    +
    12 C> -----|------------|--------
    +
    13 C> 1979-08-05 | Robert Hirano | Initial.
    +
    14 C> 1996-06-23 | Farley | Converted to cray fortran 77
    +
    15 C>
    +
    16 C> @param[in] RAIN Real*4 grid field of (forecast) precipitation.
    +
    17 C> @param[in] IMAX Integer*4 i-dimension of rain field.
    +
    18 C> @param[in] JMAX Integer *4 j-dimension of rain field.
    +
    19 C> @param[in] PI Real*4 i-coordinate of interpolation point.
    +
    20 C> @param[in] PJ Real*4 j-coordinate of interpolation point.
    +
    21 C> @param[out] AMOUNT Real*4 amount of precip interpolated to pi,pj.
    +
    22 C>
    +
    23 C> @author Robert Hirano @date 1979-08-05
    +
    24  SUBROUTINE w3ft02 (RAIN, IMAX, JMAX, PI, PJ, AMOUNT)
    +
    25 C
    +
    26 C INTERPOLATE PRECIPITATION FROM RAIN FIELD
    +
    27 C TO INTERNAL POINT (PI,PJ). RESULT IN AMOUNT
    +
    28 C
    +
    29  real RAIN(IMAX,JMAX)
    +
    30 C
    +
    31 C CHECK FOR INTERPOLATION POINT OUTSIDE GRID
    +
    32 C
    +
    33  amount = 0.
    +
    34  IF(pi.LE.1.OR.pi.GE.imax) GO TO 150
    +
    35  IF(pj.LE.1.OR.pj.GE.jmax) GO TO 150
    +
    36 C
    +
    37 C SET UP RAIN AMMOUNTS AT CORNERS OF BOX SURROUNDING POINT (PI,PJ
    +
    38 C
    +
    39 C R2 R4
    +
    40 C
    +
    41 C (PI,PJ)
    +
    42 C
    +
    43 C R1 R3
    +
    44 C
    +
    45  i=pi
    +
    46  j=pj
    +
    47  r1=rain(i ,j )
    +
    48  r2=rain(i ,j+1)
    +
    49  r3=rain(i+1,j )
    +
    50  r4=rain(i+1,j+1)
    +
    51 C
    +
    52 C CHECK FOR NO RAIN AT ALL
    +
    53 C
    +
    54  IF(amax1(r1,r2,r3,r4).LE.0.) GO TO 150
    +
    55 C
    +
    56 C GOT SOME -- FIND APPROPRIATE SECTOR AND SECTION
    +
    57 C OF THE GRID BOX IN WHICH THE STATION IS LOCATED
    +
    58 C
    +
    59  ai = pi-i
    +
    60  aj=pj-j
    +
    61  x = 0.5
    +
    62 C
    +
    63 C MEANINOF IC FOR SECTORS (K=1) OR SECTIONS (K=2)
    +
    64 C
    +
    65 C 2 4
    +
    66 C
    +
    67 C 1 3
    +
    68 C
    +
    69 C ALSO REFERENCED AS
    +
    70 C
    +
    71 C TOP DIAGONAL / T D
    +
    72 C /
    +
    73 C NEAR RIGHT / N R
    +
    74 C
    +
    75  DO 1 k=1,2
    +
    76  IF(ai.GT.x) GO TO 2
    +
    77  IF(aj.GT.x) GO TO 4
    +
    78  ic = 1
    +
    79  GO TO 10
    +
    80  4 CONTINUE
    +
    81  ic = 2
    +
    82  GO TO 10
    +
    83  2 CONTINUE
    +
    84  IF(aj.GT.x) GO TO 6
    +
    85  ic = 3
    +
    86  GO TO 10
    +
    87  6 CONTINUE
    +
    88  ic = 4
    +
    89  10 CONTINUE
    +
    90  IF(k.NE.1) GO TO 16
    +
    91 C
    +
    92 C SET UP SECTORS THIS BUSINESS IN EFFECT ROTATES THE SECTORS
    +
    93 C FOR CONVENIENCE IN LATER INTERPOLATIONS
    +
    94 C
    +
    95  GO TO (11, 12, 13, 14), ic
    +
    96  11 CONTINUE
    +
    97  r = r1
    +
    98  rt = r2
    +
    99  rr = r3
    +
    100  rd = r4
    +
    101  GO TO 15
    +
    102  12 CONTINUE
    +
    103  r = r2
    +
    104  rt = r1
    +
    105  rr = r4
    +
    106  rd = r3
    +
    107  aj = 1. - aj
    +
    108  GO TO 15
    +
    109  13 CONTINUE
    +
    110  r = r3
    +
    111  rt = r4
    +
    112  rr = r1
    +
    113  rd = r2
    +
    114  ai = 1. - ai
    +
    115  GO TO 15
    +
    116  14 CONTINUE
    +
    117  r = r4
    +
    118  rt = r3
    +
    119  rr = r2
    +
    120  rd = r1
    +
    121  ai = 1. - ai
    +
    122  aj = 1. - aj
    +
    123  15 CONTINUE
    +
    124 C
    +
    125 C IF NO RAIN IN CORNER SECTTOR WHERE STATION IS - QUIT
    +
    126 C
    +
    127  IF(r.LE.0.) GO TO 150
    +
    128  x = 0.5 * x
    +
    129  16 CONTINUE
    +
    130  1 CONTINUE
    +
    131 C
    +
    132 C INTERPOLATE TO STATION IN EASY (NON-CORNER) SECTIONS
    +
    133 C
    +
    134  GO TO (21, 22, 23, 24), ic
    +
    135  21 CONTINUE
    +
    136  amount = r
    +
    137  GO TO 150
    +
    138  22 CONTINUE
    +
    139  rc = rt
    +
    140  rx = aj
    +
    141  GO TO 120
    +
    142  23 CONTINUE
    +
    143  rc = rr
    +
    144  rx = ai
    +
    145  120 CONTINUE
    +
    146  IF(rc.GT. 0.) GO TO 130
    +
    147  amount = r - r*(rx-x)/x
    +
    148  GO TO 150
    +
    149  130 CONTINUE
    +
    150  amount = r + (0.5*(r+rc)-r)*(rx-x)/x
    +
    151  GO TO 150
    +
    152  24 CONTINUE
    +
    153 C
    +
    154 C CORNER (CENTER OF BOX) SECTION
    +
    155 C
    +
    156  aa = amax1(rr, rt, rd)
    +
    157  IF(aa.GT.0.) GO TO 30
    +
    158  rs = 0.
    +
    159  ru = 0.
    +
    160  rd = 0.
    +
    161  GO TO 37
    +
    162  30 CONTINUE
    +
    163  IF(rr.GT.0.) GO TO 32
    +
    164  rs = 0.
    +
    165  rrd = 0.
    +
    166  33 CONTINUE
    +
    167  IF(rt.GT.0.) GO TO 34
    +
    168  ru = 0.
    +
    169  rtd = 0.
    +
    170  GO TO 35
    +
    171  34 CONTINUE
    +
    172  ru = 0.5 * (r+rt)
    +
    173  IF(rd.GT.0.) GO TO 36
    +
    174  rtd = 0.
    +
    175  GO TO 35
    +
    176  36 CONTINUE
    +
    177  rtd = 0.5 * (rt + rd)
    +
    178  GO TO 35
    +
    179  32 CONTINUE
    +
    180  rs = 0.5 * (r+rr)
    +
    181  IF(rd.GT.0.) GO TO 38
    +
    182  rrd = 0.
    +
    183  GO TO 33
    +
    184  38 CONTINUE
    +
    185  rrd = 0.5 * (rd + rr)
    +
    186  GO TO 33
    +
    187  35 CONTINUE
    +
    188  rd = 0.25 * (rs + ru + rtd + rrd)
    +
    189  IF(rs.LE.0. .AND. rtd.LE.0.) rd = 0.
    +
    190  IF(ru.LE.0..AND.rrd.LE.0.) rd=0.
    +
    191  ru = ru + (rd-ru) * (ai-x)/x
    +
    192  37 CONTINUE
    +
    193  r = r + (rs-r) * (ai-x)/x
    +
    194  amount = r + (ru-r) * (aj-x)/x
    +
    195  150 CONTINUE
    +
    196  RETURN
    +
    197 C
    +
    198  END
    +
    +
    +
    w3ft02
    subroutine w3ft02(RAIN, IMAX, JMAX, PI, PJ, AMOUNT)
    Interpolate, using a fancy non-linear method, gridded quantitative precipitation forecasts to a speci...
    Definition: w3ft02.f:25
    + + + + diff --git a/ver-2.10.0/w3ft03_8f.html b/ver-2.10.0/w3ft03_8f.html new file mode 100644 index 00000000..dae8c50c --- /dev/null +++ b/ver-2.10.0/w3ft03_8f.html @@ -0,0 +1,217 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft03.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft03.f File Reference
    +
    +
    + +

    A point interpolater. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft03 (FL, HI, STI, STJ, MAXI, MAXJ, ITYPE)
     Do either bilinear or biquadratic interpolation for a point within a two-dimensional data array. More...
     
    +

    Detailed Description

    +

    A point interpolater.

    +
    Author
    James Howcroft
    +
    Date
    1979-02-15
    + +

    Definition in file w3ft03.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft03()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft03 (real, dimension(maxi,maxj) FL,
     HI,
     STI,
     STJ,
     MAXI,
     MAXJ,
     ITYPE 
    )
    +
    + +

    Do either bilinear or biquadratic interpolation for a point within a two-dimensional data array.

    +

    +Program History Log:

    + + + + + + + + + + + + + + + +
    Date Programmer Comment
    1979-02-15 James Howcroft Initial.
    1989-01-25 Ralph Jones Change to microsoft fortran 4.10.
    1990-06-12 Ralph Jones Change to sun fortran 1.3.
    1991-03-30 Ralph Jones Convert to silicongraphics fortran.
    1993-03-29 Ralph Jones Add save statement.
    1996-07-01 Ralph Jones Compile on cray.
    +
    Parameters
    + + + + + + + + +
    [in]FLReal*4 two-dimensional cartesian array of data.
    [in]MAXIInteger*4 i-dimension of fl.
    [in]MAXJInteger*4 j-dimension of fl.
    [in]STIReal*4 i-coordinate to which a value is to be interpolated.
    [in]STJReal*4 j-coordinate to which a value is to be interpolated.
    ITYPE
    [out]HIReal*4 interpolated output value.
    +
    +
    +
    Remarks
    No error checks are made. it is left for the user to determine that the point for which interpolation is desired lies within the grid.
    +
    Author
    James Howcroft
    +
    Date
    1979-02-15
    + +

    Definition at line 34 of file w3ft03.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft03_8f.js b/ver-2.10.0/w3ft03_8f.js new file mode 100644 index 00000000..23682383 --- /dev/null +++ b/ver-2.10.0/w3ft03_8f.js @@ -0,0 +1,4 @@ +var w3ft03_8f = +[ + [ "w3ft03", "w3ft03_8f.html#a86672f0df93a525a9c2f295bf3e9de0b", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft03_8f_source.html b/ver-2.10.0/w3ft03_8f_source.html new file mode 100644 index 00000000..6f05ddc9 --- /dev/null +++ b/ver-2.10.0/w3ft03_8f_source.html @@ -0,0 +1,180 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft03.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft03.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief A point interpolater.
    +
    3 C> @author James Howcroft @date 1979-02-15
    +
    4 
    +
    5 C> Do either bilinear or biquadratic interpolation for a
    +
    6 C> point within a two-dimensional data array.
    +
    7 C>
    +
    8 C> ### Program History Log:
    +
    9 C> Date | Programmer | Comment
    +
    10 C> -----|------------|--------
    +
    11 C> 1979-02-15 | James Howcroft | Initial.
    +
    12 C> 1989-01-25 | Ralph Jones | Change to microsoft fortran 4.10.
    +
    13 C> 1990-06-12 | Ralph Jones | Change to sun fortran 1.3.
    +
    14 C> 1991-03-30 | Ralph Jones | Convert to silicongraphics fortran.
    +
    15 C> 1993-03-29 | Ralph Jones | Add save statement.
    +
    16 C> 1996-07-01 | Ralph Jones | Compile on cray.
    +
    17 C>
    +
    18 C> @param[in] FL Real*4 two-dimensional cartesian array of data.
    +
    19 C> @param[in] MAXI Integer*4 i-dimension of fl.
    +
    20 C> @param[in] MAXJ Integer*4 j-dimension of fl.
    +
    21 C> @param[in] STI Real*4 i-coordinate to which a value is to be
    +
    22 C> interpolated.
    +
    23 C> @param[in] STJ Real*4 j-coordinate to which a value is to be
    +
    24 C> interpolated.
    +
    25 C> @param ITYPE
    +
    26 C> @param[out] HI Real*4 interpolated output value.
    +
    27 C>
    +
    28 C> @remark No error checks are made. it is left for the user to
    +
    29 C> determine that the point for which interpolation is desired
    +
    30 C> lies within the grid.
    +
    31 C>
    +
    32 C> @author James Howcroft @date 1979-02-15
    +
    33  SUBROUTINE w3ft03(FL,HI,STI,STJ,MAXI,MAXJ,ITYPE)
    +
    34 C
    +
    35  REAL FL(MAXI,MAXJ)
    +
    36  REAL E (4)
    +
    37 C
    +
    38  SAVE
    +
    39 C
    +
    40  i = sti
    +
    41  j = stj
    +
    42  di = i
    +
    43  dj = j
    +
    44  di = sti - di
    +
    45  dj = stj - dj
    +
    46 C
    +
    47  hi = 0.
    +
    48 C TEST FOR POINT OFF GRID.
    +
    49  IF (i.LT.1 .OR. i.GT.maxi) GO TO 300
    +
    50  IF (j.LT.1 .OR. j.GT.maxj) GO TO 300
    +
    51  IF (itype .NE. 2) GO TO 100
    +
    52 C DO BILINEAR IF POINT IS BETWEEN ULTIMATE AND
    +
    53 C PENULTIMATE ROWS, WHERE BIQUAD NOT POSSIBLE.
    +
    54  IF (i.LT.2 .OR. i.GT.(maxi-1)) GO TO 100
    +
    55  IF (j.LT.2 .OR. j.GT.(maxj-1)) GO TO 100
    +
    56  GO TO 200
    +
    57 C
    +
    58 C BILINEAR.
    +
    59  100 CONTINUE
    +
    60  hi = fl(i ,j )*(1.-di)*(1.-dj) + fl(i+1,j )*di*(1.-dj)
    +
    61  & + fl(i ,j+1)*(1.-di)*dj + fl(i+1,j+1)*di*dj
    +
    62  GO TO 300
    +
    63 C
    +
    64  200 CONTINUE
    +
    65 C BIQUADRATIC.
    +
    66  di2 = di*(di-1.)*.25
    +
    67  dj2 = dj*(dj-1.)*.25
    +
    68  j1 = j - 1
    +
    69  DO 250 k=1,4
    +
    70  e(k) = fl(i ,j1)*(1.-di-di2) + fl(i+1,j1)*(di-di2)
    +
    71  & + (fl(i-1,j1) + fl(i+2,j1))*di2
    +
    72  j1 = j1 + 1
    +
    73  250 CONTINUE
    +
    74  hi = e(2)*(1.-dj-dj2) + e(3)*(dj-dj2) + (e(1) + e(4))*dj2
    +
    75 C
    +
    76  300 CONTINUE
    +
    77  RETURN
    +
    78  END
    +
    +
    +
    w3ft03
    subroutine w3ft03(FL, HI, STI, STJ, MAXI, MAXJ, ITYPE)
    Do either bilinear or biquadratic interpolation for a point within a two-dimensional data array.
    Definition: w3ft03.f:34
    + + + + diff --git a/ver-2.10.0/w3ft05_8f.html b/ver-2.10.0/w3ft05_8f.html new file mode 100644 index 00000000..065061d6 --- /dev/null +++ b/ver-2.10.0/w3ft05_8f.html @@ -0,0 +1,204 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft05.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft05.f File Reference
    +
    +
    + +

    Convert (145,37) to (65,65) n. hemi. grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft05 (ALOLA, APOLA, W1, W2, LINEAR)
     Convert a northern hemisphere 2.5 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (145,37) to (65,65) n. hemi. grid.

    +
    Author
    Ralph Jones
    +
    Date
    1985-04-08
    + +

    Definition in file w3ft05.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft05()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft05 (real, dimension(145,37) ALOLA,
    real, dimension(4225) APOLA,
    real, dimension(4225) W1,
    real, dimension(4225) W2,
     LINEAR 
    )
    +
    + +

    Convert a northern hemisphere 2.5 degree lat.,lon.

    +

    145 by 37 grid to a polar stereographic 65 by 65 grid. The polar stereographic map projection is true at 60 deg. n. , The mesh length is 381 km. and the oriention is 80 deg. w.

    +

    +Program History Log:

    + + + + + + + + + +
    Date Programmer Comment
    1985-04-08 Ralph Jones Initial.
    1991-07-30 Ralph Jones convert to cray cft77 fortran.
    1992-05-02 Ralph Jones add save.
    +
    Parameters
    + + + + + + +
    [in]ALOLA145*37 grid 2.5 lat,lon grid n. hemi. 5365 point grid is type 29 or 1d hex o.n. 84
    [in]LINEAR1 linear interpolation , ne.1 biquadratic
    [out]APOLA65*65 grid of northern hemi. 4225 point grid is type 27 or 1b hex o.n. 84
    [out]W165*65 scratch field
    [out]W265*65 scratch field
    +
    +
    +
    Remarks
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine. If they are over written by the user, a warning message will be printed and w1 and w2 will be recomputed.
      • +
    • 2. Wind components are not rotated to the 65*65 grid orientation after interpolation. You may use w3fc08() to do this.
      • +
    • 3. The grid points values on the equator have been extrapolated outward to all the grid points outside the equator on the 65*65 grid (about 1100 points).
      • +
    • 4. You should use the cray vectorized version w3ft05v on the cray it has 3 parameters in the call, runs about 10 times faster. Uses more memory.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1985-04-08
    + +

    Definition at line 41 of file w3ft05.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft05_8f.js b/ver-2.10.0/w3ft05_8f.js new file mode 100644 index 00000000..a3afe657 --- /dev/null +++ b/ver-2.10.0/w3ft05_8f.js @@ -0,0 +1,4 @@ +var w3ft05_8f = +[ + [ "w3ft05", "w3ft05_8f.html#a752b36aee00d233764c2d4fc9aa83d48", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft05_8f_source.html b/ver-2.10.0/w3ft05_8f_source.html new file mode 100644 index 00000000..aac59579 --- /dev/null +++ b/ver-2.10.0/w3ft05_8f_source.html @@ -0,0 +1,329 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft05.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft05.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (145,37) to (65,65) n. hemi. grid
    +
    3 C> @author Ralph Jones @date 1985-04-08
    +
    4 
    +
    5 C> Convert a northern hemisphere 2.5 degree lat.,lon. 145 by
    +
    6 C> 37 grid to a polar stereographic 65 by 65 grid. The polar
    +
    7 C> stereographic map projection is true at 60 deg. n. , The mesh
    +
    8 C> length is 381 km. and the oriention is 80 deg. w.
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comment
    +
    12 C> -----|------------|--------
    +
    13 C> 1985-04-08 | Ralph Jones | Initial.
    +
    14 C> 1991-07-30 | Ralph Jones | convert to cray cft77 fortran.
    +
    15 C> 1992-05-02 | Ralph Jones | add save.
    +
    16 C>
    +
    17 C> @param[in] ALOLA 145*37 grid 2.5 lat,lon grid n. hemi.
    +
    18 C> 5365 point grid is type 29 or 1d hex o.n. 84
    +
    19 C> @param[in] LINEAR 1 linear interpolation , ne.1 biquadratic
    +
    20 C> @param[out] APOLA 65*65 grid of northern hemi.
    +
    21 C> 4225 point grid is type 27 or 1b hex o.n. 84
    +
    22 C> @param[out] W1 65*65 scratch field
    +
    23 C> @param[out] W2 65*65 scratch field
    +
    24 C>
    +
    25 C> @remark
    +
    26 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    27 C> reusable for repeated calls to the subroutine. If they are
    +
    28 C> over written by the user, a warning message will be printed
    +
    29 C> and w1 and w2 will be recomputed.
    +
    30 C> - 2. Wind components are not rotated to the 65*65 grid orientation
    +
    31 C> after interpolation. You may use w3fc08() to do this.
    +
    32 C> - 3. The grid points values on the equator have been extrapolated
    +
    33 C> outward to all the grid points outside the equator on the 65*65
    +
    34 C> grid (about 1100 points).
    +
    35 C> - 4. You should use the cray vectorized version w3ft05v on the cray
    +
    36 C> it has 3 parameters in the call, runs about 10 times faster. Uses
    +
    37 C> more memory.
    +
    38 C>
    +
    39 C> @author Ralph Jones @date 1985-04-08
    +
    40  SUBROUTINE w3ft05(ALOLA,APOLA,W1,W2,LINEAR)
    +
    41 C
    +
    42  REAL ALOLA(145,37)
    +
    43  REAL APOLA(4225)
    +
    44  REAL ERAS(4)
    +
    45  REAL SAVEW1(10)
    +
    46  REAL SAVEW2(10)
    +
    47  REAL W1(4225)
    +
    48  REAL W2(4225)
    +
    49 C
    +
    50  INTEGER JY(4)
    +
    51  INTEGER OUT
    +
    52 C
    +
    53  LOGICAL LIN
    +
    54 C
    +
    55  SAVE
    +
    56 C
    +
    57  DATA degprd/57.2957795/
    +
    58  DATA earthr/6371.2/
    +
    59  DATA iswt /0/
    +
    60  DATA out /6/
    +
    61 C
    +
    62  4000 FORMAT ( 52h *** warning , w1 or w2 scratch files over written ,,
    +
    63  & 43h i will restore them , burning up cpu time,,
    +
    64  & 14h in w3ft05 ***)
    +
    65 C
    +
    66  lin = .false.
    +
    67  IF (linear.EQ.1) lin = .true.
    +
    68 C
    +
    69  IF (iswt.EQ.0) GO TO 300
    +
    70 C
    +
    71 C TEST W1 AND W2 TO SEE IF THEY WERE WRITTEN OVER
    +
    72 C
    +
    73  DO 100 kk=1,10
    +
    74  IF (savew1(kk).NE.w1(kk)) GO TO 200
    +
    75  IF (savew2(kk).NE.w2(kk)) GO TO 200
    +
    76  100 CONTINUE
    +
    77  GOTO 1000
    +
    78 C
    +
    79  200 CONTINUE
    +
    80  WRITE (out,4000)
    +
    81 C
    +
    82  300 CONTINUE
    +
    83  deg = 2.5
    +
    84  nn = 0
    +
    85  xmesh = 381.0
    +
    86  gi2 = (1.86603*earthr) / xmesh
    +
    87  gi2 = gi2 * gi2
    +
    88 C
    +
    89 C DO LOOP 800 PUTS SUBROUTINE W3FB01 IN LINE
    +
    90 C
    +
    91  DO 800 j = 1,65
    +
    92  xj = j - 33
    +
    93  xj2 = xj * xj
    +
    94  DO 800 i=1,65
    +
    95  xi = i - 33
    +
    96  r2 = xi*xi + xj2
    +
    97  IF (r2.NE.0.0) GO TO 400
    +
    98  wlon = 0.0
    +
    99  xlat = 90.0
    +
    100  GO TO 700
    +
    101  400 CONTINUE
    +
    102  xlong = degprd * atan2(xj,xi)
    +
    103  IF (xlong.GE.0.0) GO TO 500
    +
    104  wlon = -10.0 - xlong
    +
    105  IF (wlon.LT.0.0) wlon = wlon + 360.0
    +
    106  GO TO 600
    +
    107 C
    +
    108  500 CONTINUE
    +
    109  wlon = 350.0 - xlong
    +
    110  600 CONTINUE
    +
    111  xlat = asin((gi2-r2)/(gi2+r2))*degprd
    +
    112  700 CONTINUE
    +
    113  IF (wlon.GT.360.0) wlon = wlon - 360.0
    +
    114  IF (wlon.LT.0.0) wlon = wlon + 360.0
    +
    115  nn = nn + 1
    +
    116  w1(nn) = ( 360.0 - wlon ) / deg + 1.0
    +
    117  w2(nn) = xlat / deg + 1.0
    +
    118  800 CONTINUE
    +
    119 C
    +
    120  DO 900 kk = 1,10
    +
    121  savew1(kk) = w1(kk)
    +
    122  savew2(kk) = w2(kk)
    +
    123  900 CONTINUE
    +
    124 C
    +
    125  iswt = 1
    +
    126 C
    +
    127  1000 CONTINUE
    +
    128 C
    +
    129  DO 2100 kk = 1,4225
    +
    130  i = w1(kk)
    +
    131  j = w2(kk)
    +
    132  fi = i
    +
    133  fj = j
    +
    134  xdeli = w1(kk) - fi
    +
    135  xdelj = w2(kk) - fj
    +
    136  ip1 = i + 1
    +
    137  jy(3) = j + 1
    +
    138  jy(2) = j
    +
    139  IF (lin) GO TO 1100
    +
    140  ip2 = i + 2
    +
    141  im1 = i - 1
    +
    142  jy(4) = j + 2
    +
    143  jy(1) = j - 1
    +
    144  xi2tm = xdeli * (xdeli-1.) * 0.25
    +
    145  xj2tm = xdelj * (xdelj-1.) * 0.25
    +
    146 C
    +
    147  1100 CONTINUE
    +
    148  IF ((i.LT.2).OR.(j.LT.2)) GO TO 1200
    +
    149  IF ((i.GT.142).OR.(j.GT.34)) GO TO 1200
    +
    150 C
    +
    151 C QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 1700
    +
    152 C
    +
    153  GO TO 1700
    +
    154 C
    +
    155  1200 CONTINUE
    +
    156  IF (i.EQ.1) GO TO 1300
    +
    157  IF (i.EQ.144) GO TO 1400
    +
    158  ip2 = i + 2
    +
    159  im1 = i - 1
    +
    160  GO TO 1500
    +
    161 C
    +
    162  1300 CONTINUE
    +
    163  ip2 = 3
    +
    164  im1 = 144
    +
    165  GO TO 1500
    +
    166 C
    +
    167  1400 CONTINUE
    +
    168  ip2 = 2
    +
    169  im1 = 143
    +
    170 C
    +
    171  1500 CONTINUE
    +
    172  ip1 = i + 1
    +
    173  IF (lin) GO TO 1600
    +
    174  IF ((j.LT.2).OR.(j.GE.36)) xj2tm=0.
    +
    175 C.....DO NOT ALLOW POINT OFF GRID
    +
    176  IF (ip2.LT.1) ip2 = 1
    +
    177  IF (im1.LT.1) im1 = 1
    +
    178  IF (ip2.GT.145) ip2 = 145
    +
    179  IF (im1.GT.145) im1 = 145
    +
    180 C
    +
    181  1600 CONTINUE
    +
    182 C.....DO NOT ALLOW POINT OFF GRID
    +
    183  IF (i.LT.1) i = 1
    +
    184  IF (ip1.LT.1) ip1 = 1
    +
    185  IF (i.GT.145) i = 145
    +
    186  IF (ip1.GT.145) ip1 = 145
    +
    187 C
    +
    188  1700 CONTINUE
    +
    189  IF (.NOT.lin) GO TO 1900
    +
    190 C
    +
    191 C LINEAR INTERPLOATION
    +
    192 C
    +
    193  DO 1800 k = 2,3
    +
    194  j1 = jy(k)
    +
    195  IF (j1.LT.1) j1 = 1
    +
    196  IF (j1.GT.37) j1 = 37
    +
    197  eras(k) = (alola(ip1,j1) - alola(i,j1)) * xdeli + alola(i,j1)
    +
    198  1800 CONTINUE
    +
    199 C
    +
    200  apola(kk) = eras(2) + (eras(3) - eras(2)) * xdelj
    +
    201  GO TO 2100
    +
    202 C
    +
    203  1900 CONTINUE
    +
    204 C
    +
    205 C QUADRATIC INTERPOLATION
    +
    206 C
    +
    207  DO 2000 k = 1,4
    +
    208  j1 = jy(k)
    +
    209 C.....DO NOT ALLOW POINT OFF GRID
    +
    210  IF (j1.LT.1) j1 = 1
    +
    211  IF (j1.GT.37) j1 = 37
    +
    212  eras(k) = (alola(ip1,j1)-alola(i,j1))*xdeli+alola(i,j1)+
    +
    213  & (alola(im1,j1)-alola(i,j1)-alola(ip1,j1)+
    +
    214  & alola(ip2,j1))*xi2tm
    +
    215  2000 CONTINUE
    +
    216 C
    +
    217  apola(kk) = eras(2)+(eras(3)-eras(2))*xdelj+(eras(1)-
    +
    218  & eras(2)-eras(3)+eras(4)) * xj2tm
    +
    219 C
    +
    220  2100 CONTINUE
    +
    221 C
    +
    222 C SET POLE POINT , WMO STANDARD FOR U OR V
    +
    223 C
    +
    224  apola(2113) = alola(73,37)
    +
    225 C
    +
    226  RETURN
    +
    227  END
    +
    +
    +
    w3ft05
    subroutine w3ft05(ALOLA, APOLA, W1, W2, LINEAR)
    Convert a northern hemisphere 2.5 degree lat.,lon.
    Definition: w3ft05.f:41
    + + + + diff --git a/ver-2.10.0/w3ft05v_8f.html b/ver-2.10.0/w3ft05v_8f.html new file mode 100644 index 00000000..46114fbf --- /dev/null +++ b/ver-2.10.0/w3ft05v_8f.html @@ -0,0 +1,189 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft05v.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft05v.f File Reference
    +
    +
    + +

    Convert (145,37) grid to (65,65) n. hemi. grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft05v (ALOLA, APOLA, INTERP)
     Convert a northern hemisphere 2.5 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (145,37) grid to (65,65) n. hemi. grid.

    +
    Author
    Ralph Jones
    +
    Date
    1985-04-10
    + +

    Definition in file w3ft05v.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft05v()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft05v (real, dimension(145,37) ALOLA,
    real, dimension(4225) APOLA,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 2.5 degree lat.,lon.

    +

    145 by 37 grid to a polar stereographic 65 by 65 grid. The polar stereographic map projection is true at 60 deg. n. , The mesh length is 381 km. and the oriention is 80 deg. w.

    +

    +Program History Log:

    + + + + + + + + + +
    Date Programmer Comment
    1985-04-10 Ralph Jones Vectorized version of w3ft05().
    1989-10-21 Ralph Jones Changes to increase speed.
    1991-07-25 Ralph Jones Change to cray cft77 fortran.
    +
    Parameters
    + + + + +
    [in]ALOLA145*37 gid 2.5 lat,lon grid n. hemisphere 5365 point grid is o.n. 84 type 29 or 1d hex interp - 1 linear interpolation , ne.1 biquadratic
    [out]APOLA65*65 grid of northern hemisphere 4225 point grid is o.n.84 type 27 or 1b hex.
    INTERP
    +
    +
    +
    Remarks
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine.
      • +
    • 2. Wind components are not rotated to the 65*65 grid orientation after interpolation. you may use w3fc08 to do this.
      • +
    • 3. The grid points values on the equator have been extrapolated outward to all the grid points outside the equator on the 65*65 grid (about 1100 points).
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1985-04-10
    + +

    Definition at line 34 of file w3ft05v.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft05v_8f.js b/ver-2.10.0/w3ft05v_8f.js new file mode 100644 index 00000000..22a87013 --- /dev/null +++ b/ver-2.10.0/w3ft05v_8f.js @@ -0,0 +1,4 @@ +var w3ft05v_8f = +[ + [ "w3ft05v", "w3ft05v_8f.html#a77ae0ff42d73bc3e901c84d6fae74d60", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft05v_8f_source.html b/ver-2.10.0/w3ft05v_8f_source.html new file mode 100644 index 00000000..d07c3a7a --- /dev/null +++ b/ver-2.10.0/w3ft05v_8f_source.html @@ -0,0 +1,355 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft05v.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft05v.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (145,37) grid to (65,65) n. hemi. grid
    +
    3 C> @author Ralph Jones @date 1985-04-10
    +
    4 
    +
    5 C> Convert a northern hemisphere 2.5 degree lat.,lon. 145 by
    +
    6 C> 37 grid to a polar stereographic 65 by 65 grid. The polar
    +
    7 C> stereographic map projection is true at 60 deg. n. , The mesh
    +
    8 C> length is 381 km. and the oriention is 80 deg. w.
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comment
    +
    12 C> -----|------------|--------
    +
    13 C> 1985-04-10 | Ralph Jones | Vectorized version of w3ft05().
    +
    14 C> 1989-10-21 | Ralph Jones | Changes to increase speed.
    +
    15 C> 1991-07-25 | Ralph Jones | Change to cray cft77 fortran.
    +
    16 C>
    +
    17 C> @param[in] ALOLA 145*37 gid 2.5 lat,lon grid n. hemisphere
    +
    18 C> 5365 point grid is o.n. 84 type 29 or 1d hex
    +
    19 C> interp - 1 linear interpolation , ne.1 biquadratic
    +
    20 C> @param[out] APOLA 65*65 grid of northern hemisphere
    +
    21 C> 4225 point grid is o.n.84 type 27 or 1b hex.
    +
    22 C> @param INTERP
    +
    23 C> @remark
    +
    24 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    25 C> reusable for repeated calls to the subroutine.
    +
    26 C> - 2. Wind components are not rotated to the 65*65 grid orientation
    +
    27 C> after interpolation. you may use w3fc08 to do this.
    +
    28 C> - 3. The grid points values on the equator have been extrapolated
    +
    29 C> outward to all the grid points outside the equator on the 65*65
    +
    30 C> grid (about 1100 points).
    +
    31 C>
    +
    32 C> @author Ralph Jones @date 1985-04-10
    +
    33  SUBROUTINE w3ft05v(ALOLA,APOLA,INTERP)
    +
    34 C
    +
    35  REAL R2(4225), WLON(4225)
    +
    36  REAL XLAT(4225), XI(65,65), XJ(65,65)
    +
    37  REAL XII(4225), XJJ(4225), ANGLE(4225)
    +
    38  REAL ALOLA(145,37), APOLA(4225), ERAS(4225,4)
    +
    39  REAL W1(4225), W2(4225)
    +
    40  REAL XDELI(4225), XDELJ(4225)
    +
    41  REAL XI2TM(4225), XJ2TM(4225)
    +
    42 C
    +
    43  INTEGER IV(4225), JV(4225), JY(4225,4)
    +
    44  INTEGER IM1(4225), IP1(4225), IP2(4225)
    +
    45 C
    +
    46  LOGICAL LIN
    +
    47 C
    +
    48  SAVE
    +
    49 C
    +
    50  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    51 C
    +
    52  DATA degprd/57.2957795/
    +
    53  DATA earthr/6371.2/
    +
    54  DATA intrpo/99/
    +
    55  DATA iswt /0/
    +
    56 C
    +
    57  lin = .false.
    +
    58  IF (interp.EQ.1) lin = .true.
    +
    59 C
    +
    60  IF (iswt.EQ.1) GO TO 900
    +
    61 C
    +
    62  orient = 80.0
    +
    63  deg = 2.5
    +
    64  xmesh = 381.0
    +
    65  gi2 = (1.86603 * earthr) / xmesh
    +
    66  gi2 = gi2 * gi2
    +
    67 C
    +
    68 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE
    +
    69 C
    +
    70  DO 100 j = 1,65
    +
    71  xj1 = j - 33
    +
    72  DO 100 i = 1,65
    +
    73  xi(i,j) = i - 33
    +
    74  xj(i,j) = xj1
    +
    75  100 CONTINUE
    +
    76 C
    +
    77  DO 200 kk = 1,4225
    +
    78  r2(kk) = xjj(kk) * xjj(kk) + xii(kk) * xii(kk)
    +
    79  xlat(kk) = degprd *
    +
    80  & asin((gi2 - r2(kk)) / (gi2 + r2(kk)))
    +
    81  200 CONTINUE
    +
    82 C
    +
    83  xii(2113) = 1.0
    +
    84  DO 300 kk = 1,4225
    +
    85  angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    86  300 CONTINUE
    +
    87 C
    +
    88  DO 400 kk = 1,4225
    +
    89  IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    90  400 CONTINUE
    +
    91 C
    +
    92  DO 500 kk = 1,4225
    +
    93  wlon(kk) = 270.0 + orient - angle(kk)
    +
    94  500 CONTINUE
    +
    95 C
    +
    96  DO 600 kk = 1,4225
    +
    97  IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    98  600 CONTINUE
    +
    99 C
    +
    100  DO 700 kk = 1,4225
    +
    101  IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    102  700 CONTINUE
    +
    103 C
    +
    104  xlat(2113) = 90.0
    +
    105  wlon(2113) = 0.0
    +
    106 C
    +
    107  DO 800 kk = 1,4225
    +
    108  w1(kk) = (360.0 - wlon(kk)) / deg + 1.0
    +
    109  w2(kk) = xlat(kk) / deg + 1.0
    +
    110  800 CONTINUE
    +
    111 C
    +
    112  iswt = 1
    +
    113  intrpo = interp
    +
    114  GO TO 1000
    +
    115 C
    +
    116 C AFTER THE 1ST CALL TO W3FT05V TEST INTERP, IF IT HAS
    +
    117 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    118 C
    +
    119  900 CONTINUE
    +
    120  IF (interp.EQ.intrpo) GO TO 2100
    +
    121  intrpo = interp
    +
    122 C
    +
    123  1000 CONTINUE
    +
    124  DO 1100 k = 1,4225
    +
    125  iv(k) = w1(k)
    +
    126  jv(k) = w2(k)
    +
    127  xdeli(k) = w1(k) - iv(k)
    +
    128  xdelj(k) = w2(k) - jv(k)
    +
    129  ip1(k) = iv(k) + 1
    +
    130  jy(k,3) = jv(k) + 1
    +
    131  jy(k,2) = jv(k)
    +
    132  1100 CONTINUE
    +
    133 C
    +
    134  IF (lin) GO TO 1400
    +
    135 C
    +
    136  DO 1200 k = 1,4225
    +
    137  ip2(k) = iv(k) + 2
    +
    138  im1(k) = iv(k) - 1
    +
    139  jy(k,1) = jv(k) - 1
    +
    140  jy(k,4) = jv(k) + 2
    +
    141  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    142  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    143  1200 CONTINUE
    +
    144 C
    +
    145  DO 1300 kk = 1,4225
    +
    146  IF (iv(kk).EQ.1) THEN
    +
    147  ip2(kk) = 3
    +
    148  im1(kk) = 144
    +
    149  ELSE IF (iv(kk).EQ.144) THEN
    +
    150  ip2(kk) = 2
    +
    151  im1(kk) = 143
    +
    152  ENDIF
    +
    153  1300 CONTINUE
    +
    154 C
    +
    155  1400 CONTINUE
    +
    156 C
    +
    157  IF (lin) GO TO 1700
    +
    158 C
    +
    159  DO 1500 kk = 1,4225
    +
    160  IF (jv(kk).LT.2.OR.jv(kk).GT.35) xj2tm(kk) = 0.0
    +
    161  1500 CONTINUE
    +
    162 C
    +
    163  DO 1600 kk = 1,4225
    +
    164  IF (ip2(kk).LT.1) ip2(kk) = 1
    +
    165  IF (im1(kk).LT.1) im1(kk) = 1
    +
    166  IF (ip2(kk).GT.145) ip2(kk) = 145
    +
    167  IF (im1(kk).GT.145) im1(kk) = 145
    +
    168  1600 CONTINUE
    +
    169 C
    +
    170  1700 CONTINUE
    +
    171  DO 1800 kk = 1,4225
    +
    172  IF (iv(kk).LT.1) iv(kk) = 1
    +
    173  IF (ip1(kk).LT.1) ip1(kk) = 1
    +
    174  IF (iv(kk).GT.145) iv(kk) = 145
    +
    175  IF (ip1(kk).GT.145) ip1(kk) = 145
    +
    176  1800 CONTINUE
    +
    177 C
    +
    178 C LINEAR INTERPOLATION
    +
    179 C
    +
    180  DO 1900 kk = 1,4225
    +
    181  IF (jy(kk,2).LT.1) jy(kk,2) = 1
    +
    182  IF (jy(kk,2).GT.37) jy(kk,2) = 37
    +
    183  IF (jy(kk,3).LT.1) jy(kk,3) = 1
    +
    184  IF (jy(kk,3).GT.37) jy(kk,3) = 37
    +
    185  1900 CONTINUE
    +
    186 C
    +
    187  IF (.NOT.lin) THEN
    +
    188  DO 2000 kk = 1,4225
    +
    189  IF (jy(kk,1).LT.1) jy(kk,1) = 1
    +
    190  IF (jy(kk,1).GT.37) jy(kk,1) = 37
    +
    191  IF (jy(kk,4).LT.1) jy(kk,4) = 1
    +
    192  IF (jy(kk,4).GT.37) jy(kk,4) = 37
    +
    193  2000 CONTINUE
    +
    194  ENDIF
    +
    195 C
    +
    196  2100 CONTINUE
    +
    197  IF (lin) THEN
    +
    198 C
    +
    199 C LINEAR INTERPOLATION
    +
    200 C
    +
    201  DO 2200 kk = 1,4225
    +
    202  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    203  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    204  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    205  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    206  2200 CONTINUE
    +
    207 C
    +
    208  DO 2300 kk = 1,4225
    +
    209  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    210  & * xdelj(kk)
    +
    211  2300 CONTINUE
    +
    212 C
    +
    213  ELSE
    +
    214 C
    +
    215 C QUADRATIC INTERPOLATION
    +
    216 C
    +
    217  DO 2400 kk = 1,4225
    +
    218  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    219  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    220  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    221  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    222  & * xi2tm(kk)
    +
    223  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    224  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    225  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    226  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    227  & * xi2tm(kk)
    +
    228  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    229  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    230  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    231  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    232  & * xi2tm(kk)
    +
    233  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    234  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    235  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    236  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    237  & * xi2tm(kk)
    +
    238  2400 CONTINUE
    +
    239 C
    +
    240  DO 2500 kk = 1,4225
    +
    241  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    242  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    243  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    244  2500 CONTINUE
    +
    245 C
    +
    246  ENDIF
    +
    247 C
    +
    248 C SET POLE POINT , WMO STANDARD FOR U OR V
    +
    249 C
    +
    250  apola(2113) = alola(73,37)
    +
    251 C
    +
    252  RETURN
    +
    253  END
    +
    +
    +
    w3ft05v
    subroutine w3ft05v(ALOLA, APOLA, INTERP)
    Convert a northern hemisphere 2.5 degree lat.,lon.
    Definition: w3ft05v.f:34
    + + + + diff --git a/ver-2.10.0/w3ft06_8f.html b/ver-2.10.0/w3ft06_8f.html new file mode 100644 index 00000000..4dbac890 --- /dev/null +++ b/ver-2.10.0/w3ft06_8f.html @@ -0,0 +1,204 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft06.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft06.f File Reference
    +
    +
    + +

    Convert (145,37) to (65,65) s. hemi. grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft06 (ALOLA, APOLA, W1, W2, LINEAR)
     Convert a southern hemisphere 2.5 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (145,37) to (65,65) s. hemi. grid.

    +
    Author
    Ralph Jones
    +
    Date
    1984-06-18
    + +

    Definition in file w3ft06.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft06()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft06 (real, dimension(145,37) ALOLA,
    real, dimension(4225) APOLA,
    real, dimension(4225) W1,
    real, dimension(4225) W2,
     LINEAR 
    )
    +
    + +

    Convert a southern hemisphere 2.5 degree lat.,lon.

    +

    145 by 37 grid to a polar stereographic 65 by 65 grid. The polar stereographic map projection is true at 60 deg. s.; The mesh length is 381 km. and the oriention is 260 deg. w.(100e).

    +

    +Program History Log:

    + + + + + + + + + +
    Date Programmer Comment
    1984-06-18 Ralph Jones Initial.
    1991-07-30 Ralph Jones Convert to cray cft77 fortran.
    1992-05-02 Ralph Jones Add save.
    +
    Parameters
    + + + + + + +
    [in]ALOLA145*37 deg 2.5 lat,lon grid s. hemi. 5365 point grid is type 30 or 1e hex o.n. 84.
    [in]LINEAR1 linear interpolation , ne.1 biquadratic.
    [out]APOLA65*65 grid of southern hemi. 4225 point grid is type 28 or 1c hex o.n. 84.
    [out]W165*65 scratch field.
    [out]W265*65 scratch field. FT06F001 Error message
    +
    +
    +
    Remarks
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine. If they are over written by the user, a warning message will be printed and w1 and w2 will be recomputed.
      • +
    • 2. Wind components are not rotated to the 65*65 grid orientation after interpolation. You may use w3fc10() to do this.
      • +
    • 3. The grid points values on the equator have been extrapolated outward to all the grid points outside the equator on the 65*65 grid (about 1100 points).
      • +
    • 4. You should use the cray vectorized verion w3ft06v() on the cray it has 3 parameters in the call, runs about times faster, uses more memory.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1984-06-18
    + +

    Definition at line 41 of file w3ft06.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft06_8f.js b/ver-2.10.0/w3ft06_8f.js new file mode 100644 index 00000000..db53290f --- /dev/null +++ b/ver-2.10.0/w3ft06_8f.js @@ -0,0 +1,4 @@ +var w3ft06_8f = +[ + [ "w3ft06", "w3ft06_8f.html#a251b117d0bb18aa51a81c14180fda635", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft06_8f_source.html b/ver-2.10.0/w3ft06_8f_source.html new file mode 100644 index 00000000..bf1e2011 --- /dev/null +++ b/ver-2.10.0/w3ft06_8f_source.html @@ -0,0 +1,322 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft06.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft06.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (145,37) to (65,65) s. hemi. grid.
    +
    3 C> @author Ralph Jones @date 1984-06-18
    +
    4 
    +
    5 C> Convert a southern hemisphere 2.5 degree lat.,lon. 145 by
    +
    6 C> 37 grid to a polar stereographic 65 by 65 grid. The polar
    +
    7 C> stereographic map projection is true at 60 deg. s.; The mesh
    +
    8 C> length is 381 km. and the oriention is 260 deg. w.(100e).
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comment
    +
    12 C> -----|------------|--------
    +
    13 C> 1984-06-18 | Ralph Jones | Initial.
    +
    14 C> 1991-07-30 | Ralph Jones | Convert to cray cft77 fortran.
    +
    15 C> 1992-05-02 | Ralph Jones | Add save.
    +
    16 C>
    +
    17 C> @param[in] ALOLA 145*37 deg 2.5 lat,lon grid s. hemi.
    +
    18 C> 5365 point grid is type 30 or 1e hex o.n. 84.
    +
    19 C> @param[in] LINEAR 1 linear interpolation , ne.1 biquadratic.
    +
    20 C> @param[out] APOLA 65*65 grid of southern hemi.
    +
    21 C> 4225 point grid is type 28 or 1c hex o.n. 84.
    +
    22 C> @param[out] W1 65*65 scratch field.
    +
    23 C> @param[out] W2 65*65 scratch field. FT06F001 Error message
    +
    24 C>
    +
    25 C> @remark
    +
    26 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    27 C> reusable for repeated calls to the subroutine. If they are
    +
    28 C> over written by the user, a warning message will be printed
    +
    29 C> and w1 and w2 will be recomputed.
    +
    30 C> - 2. Wind components are not rotated to the 65*65 grid orientation
    +
    31 C> after interpolation. You may use w3fc10() to do this.
    +
    32 C> - 3. The grid points values on the equator have been extrapolated
    +
    33 C> outward to all the grid points outside the equator on the 65*65
    +
    34 C> grid (about 1100 points).
    +
    35 C> - 4. You should use the cray vectorized verion w3ft06v() on the cray
    +
    36 C> it has 3 parameters in the call, runs about times faster, uses
    +
    37 C> more memory.
    +
    38 C>
    +
    39 C> @author Ralph Jones @date 1984-06-18
    +
    40  SUBROUTINE w3ft06(ALOLA,APOLA,W1,W2,LINEAR)
    +
    41 C
    +
    42  REAL ALOLA(145,37)
    +
    43  REAL APOLA(4225)
    +
    44  REAL ERAS(4)
    +
    45  REAL SAVEW1(10)
    +
    46  REAL SAVEW2(10)
    +
    47  REAL W1(4225)
    +
    48  REAL W2(4225)
    +
    49 C
    +
    50  INTEGER JY(4)
    +
    51  INTEGER OUT
    +
    52 C
    +
    53  LOGICAL LIN
    +
    54 C
    +
    55  SAVE
    +
    56 C
    +
    57  DATA degprd/57.2957795/
    +
    58  DATA earthr/6371.2/
    +
    59  DATA iswt /0/
    +
    60  DATA out /6/
    +
    61 C
    +
    62  4000 FORMAT ( 52h *** warning , w1 or w2 scratch files over written ,,
    +
    63  & 43h i will restore them , burning up cpu time,,
    +
    64  & 14h in w3ft06 ***)
    +
    65 C
    +
    66  lin = .false.
    +
    67  IF (linear.EQ.1) lin = .true.
    +
    68  IF (iswt.EQ.0) GO TO 300
    +
    69 C
    +
    70 C TEST TO SEE IF W1 OR W2 WAS WRITTEN OVER
    +
    71 C
    +
    72  DO 100 kk=1,10
    +
    73  IF (savew1(kk).NE.w1(kk)) GO TO 200
    +
    74  IF (savew2(kk).NE.w2(kk)) GO TO 200
    +
    75  100 CONTINUE
    +
    76  GO TO 800
    +
    77 C
    +
    78  200 CONTINUE
    +
    79  WRITE (out,4000)
    +
    80 C
    +
    81  300 CONTINUE
    +
    82  deg = 2.5
    +
    83  nn = 0
    +
    84  xmesh = 381.0
    +
    85  gi2 = (1.86603*earthr) / xmesh
    +
    86  gi2 = gi2 * gi2
    +
    87 C
    +
    88 C DO LOOP 600 PUTS SUBROUTINE W3FB03 IN LINE
    +
    89 C
    +
    90  DO 600 j=1,65
    +
    91  xj = j - 33
    +
    92  xj2 = xj * xj
    +
    93  DO 600 i=1,65
    +
    94  xi = i - 33
    +
    95  r2 = xi*xi + xj2
    +
    96  IF (r2.NE.0.0) GO TO 400
    +
    97  wlon = 0.0
    +
    98  xlat = -90.0
    +
    99  GO TO 500
    +
    100  400 CONTINUE
    +
    101  xlong = degprd * atan2(xj,xi)
    +
    102  wlon = xlong -10.0
    +
    103  IF (wlon.LT.0.0) wlon = wlon + 360.0
    +
    104  xlat = asin((gi2-r2)/(gi2+r2))*degprd
    +
    105  xlat = -xlat
    +
    106  500 CONTINUE
    +
    107  xlat = xlat + 90.0
    +
    108  IF (wlon.GT.360.0) wlon = wlon - 360.0
    +
    109  IF (wlon.LT.0.0) wlon = wlon + 360.0
    +
    110  nn = nn + 1
    +
    111  w1(nn) = ( 360.0 - wlon ) / deg + 1.0
    +
    112  w2(nn) = xlat / deg + 1.0
    +
    113  600 CONTINUE
    +
    114 C
    +
    115  DO 700 kk=1,10
    +
    116  savew1(kk)=w1(kk)
    +
    117  savew2(kk)=w2(kk)
    +
    118  700 CONTINUE
    +
    119 C
    +
    120  iswt = 1
    +
    121 C
    +
    122  800 CONTINUE
    +
    123 C
    +
    124  DO 1900 kk=1,4225
    +
    125  i = w1(kk)
    +
    126  j = w2(kk)
    +
    127  fi = i
    +
    128  fj = j
    +
    129  xdeli = w1(kk) - fi
    +
    130  xdelj = w2(kk) - fj
    +
    131  ip1 = i + 1
    +
    132  jy(3) = j + 1
    +
    133  jy(2) = j
    +
    134  IF (lin) GO TO 900
    +
    135  ip2 = i + 2
    +
    136  im1 = i - 1
    +
    137  jy(4) = j + 2
    +
    138  jy(1) = j - 1
    +
    139  xi2tm = xdeli*(xdeli-1.)*.25
    +
    140  xj2tm = xdelj*(xdelj-1.)*.25
    +
    141  900 CONTINUE
    +
    142  IF ((i.LT.2).OR.(j.LT.2)) GO TO 1000
    +
    143  IF ((i.GT.142).OR.(j.GT.34)) GO TO 1000
    +
    144 C QUADRATIC (LINEAR TOO) OK W/O FURTHER ADO SO GO TO 1500
    +
    145  GO TO 1500
    +
    146 C
    +
    147  1000 CONTINUE
    +
    148  IF (i.EQ.1) GO TO 1100
    +
    149  IF (i.EQ.144) GO TO 1200
    +
    150  ip2 = i+2
    +
    151  im1 = i-1
    +
    152  GO TO 1300
    +
    153 C
    +
    154  1100 CONTINUE
    +
    155  ip2 = 3
    +
    156  im1 = 144
    +
    157  GO TO 1300
    +
    158 C
    +
    159  1200 CONTINUE
    +
    160  ip2 = 2
    +
    161  im1 = 143
    +
    162 C
    +
    163  1300 CONTINUE
    +
    164  ip1 = i + 1
    +
    165  IF (lin) GO TO 1400
    +
    166  IF ((j.LT.2).OR.(j.GE.36)) xj2tm=0.
    +
    167 C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
    +
    168  IF (ip2.LT.1) ip2 = 1
    +
    169  IF (im1.LT.1) im1 = 1
    +
    170  IF (ip2.GT.145) ip2 = 145
    +
    171  IF (im1.GT.145) im1 = 145
    +
    172 C
    +
    173  1400 CONTINUE
    +
    174 C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
    +
    175  IF (i.LT.1) i = 1
    +
    176  IF (ip1.LT.1) ip1 = 1
    +
    177  IF (i.GT.145) i = 145
    +
    178  IF (ip1.GT.145) ip1 = 145
    +
    179 C
    +
    180  1500 CONTINUE
    +
    181 C
    +
    182  IF (.NOT.lin) GO TO 1700
    +
    183 C
    +
    184 C LINEAR INTERPOLATION
    +
    185 C
    +
    186  DO 1600 k = 2,3
    +
    187  j1 = jy(k)
    +
    188  IF (j1.LT.1) j1=1
    +
    189  IF (j1.GT.37) j1=37
    +
    190  eras(k) = (alola(ip1,j1) - alola(i,j1)) * xdeli + alola(i,j1)
    +
    191  1600 CONTINUE
    +
    192 C
    +
    193  apola(kk) = eras(2) + (eras(3) - eras(2)) * xdelj
    +
    194  GO TO 1900
    +
    195 C
    +
    196  1700 CONTINUE
    +
    197 C
    +
    198 C QUADRATIC INTERPOLATION
    +
    199 C
    +
    200  DO 1800 k = 1,4
    +
    201  j1 = jy(k)
    +
    202 C.....DO NOT ALLOW POINT OFF GRID,CYCLIC OR NOT
    +
    203  IF (j1.LT.1) j1=1
    +
    204  IF (j1.GT.37) j1=37
    +
    205  eras(k)=(alola(ip1,j1)-alola(i,j1))*xdeli+alola(i,j1)+
    +
    206  & (alola(im1,j1)-alola(i,j1)-alola(ip1,j1)+
    +
    207  & alola(ip2,j1))*xi2tm
    +
    208  1800 CONTINUE
    +
    209 C
    +
    210  apola(kk) = eras(2)+(eras(3)-eras(2))*xdelj+(eras(1)-
    +
    211  & eras(2)-eras(3)+eras(4))*xj2tm
    +
    212 C
    +
    213  1900 CONTINUE
    +
    214 C
    +
    215 C SET POLE POINT, WMO STANDARD FOR U OR V
    +
    216 C
    +
    217  apola(2113) = alola(73,1)
    +
    218 C
    +
    219  RETURN
    +
    220  END
    +
    +
    +
    w3ft06
    subroutine w3ft06(ALOLA, APOLA, W1, W2, LINEAR)
    Convert a southern hemisphere 2.5 degree lat.,lon.
    Definition: w3ft06.f:41
    + + + + diff --git a/ver-2.10.0/w3ft06v_8f.html b/ver-2.10.0/w3ft06v_8f.html new file mode 100644 index 00000000..2f739b09 --- /dev/null +++ b/ver-2.10.0/w3ft06v_8f.html @@ -0,0 +1,191 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft06v.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft06v.f File Reference
    +
    +
    + +

    Convert (145,37) grid to (65,65) s. hemi. grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft06v (ALOLA, APOLA, INTERP)
     Convert a southern hemisphere 2.5 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (145,37) grid to (65,65) s. hemi. grid.

    +
    Author
    Ralph Jones
    +
    Date
    1985-04-10
    + +

    Definition in file w3ft06v.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft06v()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft06v (real, dimension(145,37) ALOLA,
    real, dimension(4225) APOLA,
     INTERP 
    )
    +
    + +

    Convert a southern hemisphere 2.5 degree lat.,lon.

    +

    145 by 37 grid to a polar stereographic 65 by 65 grid. The polar stereographic map projection is true at 60 deg. s.; The mesh length is 381 km. and the oriention is 260 deg. w.

    +

    +Program History Log:

    + + + + + + + + + + + +
    Date Programmer Comment
    1985-04-10 Ralph Jones Vectorized version of w3ft05.
    1989-10-21 Ralph Jones Changes to increase speed.
    1991-07-24 Ralph Jones Change to cray cft77 fortran.
    1993-05-31 Ralph Jones Recompile so linear interpolation works.
    +
    Parameters
    + + + + +
    [in]ALOLA- 145*37 gid 2.5 lat,lon grid s. hemishere. 5365 point grid is o.n.84 type 30 or 1e hex.
    [in]INTERP- 1 linear interpolation , ne.1 biquadratic.
    [out]APOLA- 65*65 grid of northern hemi. 4225 point grid is o.n. 84 type 28 or 1c hex.
    +
    +
    +
    Remarks
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine.
      • +
    • 2. Wind components are not rotated to the 65*65 grid orientation after interpolation. You may use w3fc10 to do this.
      • +
    • 3. The grid points values on the equator have been extrapolated outward to all the grid points outside the equator on the 65*65 grid (about 1100 points).
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1985-04-10
    + +

    Definition at line 35 of file w3ft06v.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft06v_8f.js b/ver-2.10.0/w3ft06v_8f.js new file mode 100644 index 00000000..fb2d867f --- /dev/null +++ b/ver-2.10.0/w3ft06v_8f.js @@ -0,0 +1,4 @@ +var w3ft06v_8f = +[ + [ "w3ft06v", "w3ft06v_8f.html#a02340fb38509abdb031c638362609844", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft06v_8f_source.html b/ver-2.10.0/w3ft06v_8f_source.html new file mode 100644 index 00000000..d183a956 --- /dev/null +++ b/ver-2.10.0/w3ft06v_8f_source.html @@ -0,0 +1,355 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft06v.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft06v.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (145,37) grid to (65,65) s. hemi. grid.
    +
    3 C> @author Ralph Jones @date 1985-04-10
    +
    4 
    +
    5 C> Convert a southern hemisphere 2.5 degree lat.,lon. 145 by
    +
    6 C> 37 grid to a polar stereographic 65 by 65 grid. The polar
    +
    7 C> stereographic map projection is true at 60 deg. s.; The mesh
    +
    8 C> length is 381 km. and the oriention is 260 deg. w.
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comment
    +
    12 C> -----|------------|--------
    +
    13 C> 1985-04-10 | Ralph Jones | Vectorized version of w3ft05.
    +
    14 C> 1989-10-21 | Ralph Jones | Changes to increase speed.
    +
    15 C> 1991-07-24 | Ralph Jones | Change to cray cft77 fortran.
    +
    16 C> 1993-05-31 | Ralph Jones | Recompile so linear interpolation works.
    +
    17 C>
    +
    18 C> @param[in] ALOLA - 145*37 gid 2.5 lat,lon grid s. hemishere. 5365 point
    +
    19 C> grid is o.n.84 type 30 or 1e hex.
    +
    20 C> @param[in] INTERP - 1 linear interpolation , ne.1 biquadratic.
    +
    21 C> @param[out] APOLA - 65*65 grid of northern hemi. 4225 point grid is o.n. 84
    +
    22 C> type 28 or 1c hex.
    +
    23 C>
    +
    24 C> @remark
    +
    25 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    26 C> reusable for repeated calls to the subroutine.
    +
    27 C> - 2. Wind components are not rotated to the 65*65 grid orientation
    +
    28 C> after interpolation. You may use w3fc10 to do this.
    +
    29 C> - 3. The grid points values on the equator have been extrapolated
    +
    30 C> outward to all the grid points outside the equator on the 65*65
    +
    31 C> grid (about 1100 points).
    +
    32 C>
    +
    33 C> @author Ralph Jones @date 1985-04-10
    +
    34  SUBROUTINE w3ft06v(ALOLA,APOLA,INTERP)
    +
    35 C
    +
    36  REAL R2(4225), WLON(4225)
    +
    37  REAL XLAT(4225), XI(65,65), XJ(65,65)
    +
    38  REAL XII(4225), XJJ(4225), ANGLE(4225)
    +
    39  REAL ALOLA(145,37), APOLA(4225), ERAS(4225,4)
    +
    40  REAL W1(4225), W2(4225)
    +
    41  REAL XDELI(4225), XDELJ(4225)
    +
    42  REAL XI2TM(4225), XJ2TM(4225)
    +
    43 C
    +
    44  INTEGER IV(4225), JV(4225), JY(4225,4)
    +
    45  INTEGER IM1(4225), IP1(4225), IP2(4225)
    +
    46 C
    +
    47  LOGICAL LIN
    +
    48 C
    +
    49  SAVE
    +
    50 C
    +
    51  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    52 C
    +
    53  DATA degprd/57.2957795/
    +
    54  DATA earthr/6371.2/
    +
    55  DATA intrpo/99/
    +
    56  DATA iswt /0/
    +
    57 C
    +
    58  lin = .false.
    +
    59  IF (interp.EQ.1) lin = .true.
    +
    60  IF (iswt.EQ.1) GO TO 900
    +
    61 C
    +
    62  orient = 260.0
    +
    63  deg = 2.5
    +
    64  xmesh = 381.0
    +
    65  gi2 = (1.86603 * earthr) / xmesh
    +
    66  gi2 = gi2 * gi2
    +
    67 C
    +
    68 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB03 IN LINE
    +
    69 C
    +
    70  DO 100 j = 1,65
    +
    71  xj1 = j - 33
    +
    72  DO 100 i = 1,65
    +
    73  xi(i,j) = i - 33
    +
    74  xj(i,j) = xj1
    +
    75  100 CONTINUE
    +
    76 C
    +
    77  DO 200 kk = 1,4225
    +
    78  r2(kk) = xjj(kk) * xjj(kk) + xii(kk) * xii(kk)
    +
    79  xlat(kk) = -degprd *
    +
    80  & asin((gi2 - r2(kk)) / (gi2 + r2(kk)))
    +
    81  200 CONTINUE
    +
    82 C
    +
    83  xii(2113) = 1.0
    +
    84  DO 300 kk = 1,4225
    +
    85  angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    86  300 CONTINUE
    +
    87 C
    +
    88  DO 400 kk = 1,4225
    +
    89  IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    90  400 CONTINUE
    +
    91 C
    +
    92  DO 500 kk = 1,4225
    +
    93  wlon(kk) = angle(kk) + orient - 270.0
    +
    94  500 CONTINUE
    +
    95 C
    +
    96  DO 600 kk = 1,4225
    +
    97  IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    98  600 CONTINUE
    +
    99 C
    +
    100  DO 700 kk = 1,4225
    +
    101  IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    102  700 CONTINUE
    +
    103 C
    +
    104  xlat(2113) = -90.0
    +
    105  wlon(2113) = 0.0
    +
    106 C
    +
    107  DO 800 kk = 1,4225
    +
    108  w1(kk) = (360.0 - wlon(kk)) / deg + 1.0
    +
    109  w2(kk) = (xlat(kk) + 90.0) / deg + 1.0
    +
    110  800 CONTINUE
    +
    111 C
    +
    112  iswt = 1
    +
    113  intrpo = interp
    +
    114  GO TO 1000
    +
    115 C
    +
    116 C AFTER THE 1ST CALL TO W3FT05 TEST INTERP, IF IT HAS
    +
    117 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    118 C
    +
    119  900 CONTINUE
    +
    120  IF (interp.EQ.intrpo) GO TO 2100
    +
    121  intrpo = interp
    +
    122 C
    +
    123  1000 CONTINUE
    +
    124  DO 1100 k = 1,4225
    +
    125  iv(k) = w1(k)
    +
    126  jv(k) = w2(k)
    +
    127  xdeli(k) = w1(k) - iv(k)
    +
    128  xdelj(k) = w2(k) - jv(k)
    +
    129  ip1(k) = iv(k) + 1
    +
    130  jy(k,3) = jv(k) + 1
    +
    131  jy(k,2) = jv(k)
    +
    132  1100 CONTINUE
    +
    133 C
    +
    134  IF (lin) GO TO 1400
    +
    135 C
    +
    136  DO 1200 k = 1,4225
    +
    137  ip2(k) = iv(k) + 2
    +
    138  im1(k) = iv(k) - 1
    +
    139  jy(k,1) = jv(k) - 1
    +
    140  jy(k,4) = jv(k) + 2
    +
    141  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    142  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    143  1200 CONTINUE
    +
    144 C
    +
    145  DO 1300 kk = 1,4225
    +
    146  IF (iv(kk).EQ.1) THEN
    +
    147  ip2(kk) = 3
    +
    148  im1(kk) = 144
    +
    149  ELSE IF (iv(kk).EQ.144) THEN
    +
    150  ip2(kk) = 2
    +
    151  im1(kk) = 143
    +
    152  ENDIF
    +
    153  1300 CONTINUE
    +
    154 C
    +
    155  1400 CONTINUE
    +
    156 C
    +
    157  IF (lin) GO TO 1700
    +
    158 C
    +
    159  DO 1500 kk = 1,4225
    +
    160  IF (jv(kk).LT.2.OR.jv(kk).GT.35) xj2tm(kk) = 0.0
    +
    161  1500 CONTINUE
    +
    162 C
    +
    163  DO 1600 kk = 1,4225
    +
    164  IF (ip2(kk).LT.1) ip2(kk) = 1
    +
    165  IF (im1(kk).LT.1) im1(kk) = 1
    +
    166  IF (ip2(kk).GT.145) ip2(kk) = 145
    +
    167  IF (im1(kk).GT.145) im1(kk) = 145
    +
    168  1600 CONTINUE
    +
    169 C
    +
    170  1700 CONTINUE
    +
    171  DO 1800 kk = 1,4225
    +
    172  IF (iv(kk).LT.1) iv(kk) = 1
    +
    173  IF (ip1(kk).LT.1) ip1(kk) = 1
    +
    174  IF (iv(kk).GT.145) iv(kk) = 145
    +
    175  IF (ip1(kk).GT.145) ip1(kk) = 145
    +
    176  1800 CONTINUE
    +
    177 C
    +
    178 C LINEAR INTERPOLATION
    +
    179 C
    +
    180  DO 1900 kk = 1,4225
    +
    181  IF (jy(kk,2).LT.1) jy(kk,2) = 1
    +
    182  IF (jy(kk,2).GT.37) jy(kk,2) = 37
    +
    183  IF (jy(kk,3).LT.1) jy(kk,3) = 1
    +
    184  IF (jy(kk,3).GT.37) jy(kk,3) = 37
    +
    185  1900 CONTINUE
    +
    186 C
    +
    187  IF (.NOT.lin) THEN
    +
    188  DO 2000 kk = 1,4225
    +
    189  IF (jy(kk,1).LT.1) jy(kk,1) = 1
    +
    190  IF (jy(kk,1).GT.37) jy(kk,1) = 37
    +
    191  IF (jy(kk,4).LT.1) jy(kk,4) = 1
    +
    192  IF (jy(kk,4).GT.37) jy(kk,4) = 37
    +
    193  2000 CONTINUE
    +
    194  ENDIF
    +
    195 C
    +
    196  2100 CONTINUE
    +
    197  IF (lin) THEN
    +
    198 C
    +
    199 C LINEAR INTERPOLATION
    +
    200 C
    +
    201  DO 2200 kk = 1,4225
    +
    202  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    203  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    204  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    205  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    206  2200 CONTINUE
    +
    207 C
    +
    208  DO 2300 kk = 1,4225
    +
    209  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    210  & * xdelj(kk)
    +
    211  2300 CONTINUE
    +
    212 C
    +
    213  ELSE
    +
    214 C
    +
    215 C QUADRATIC INTERPOLATION
    +
    216 C
    +
    217  DO 2400 kk = 1,4225
    +
    218  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    219  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    220  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    221  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    222  & * xi2tm(kk)
    +
    223  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    224  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    225  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    226  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    227  & * xi2tm(kk)
    +
    228  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    229  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    230  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    231  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    232  & * xi2tm(kk)
    +
    233  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    234  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    235  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    236  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    237  & * xi2tm(kk)
    +
    238  2400 CONTINUE
    +
    239 C
    +
    240  DO 2500 kk = 1,4225
    +
    241  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    242  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    243  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    244  2500 CONTINUE
    +
    245 C
    +
    246  ENDIF
    +
    247 C
    +
    248 C SET POLE POINT , WMO STANDARD FOR U OR V
    +
    249 C
    +
    250  apola(2113) = alola(73,1)
    +
    251 C
    +
    252  RETURN
    +
    253  END
    +
    +
    +
    w3ft06v
    subroutine w3ft06v(ALOLA, APOLA, INTERP)
    Convert a southern hemisphere 2.5 degree lat.,lon.
    Definition: w3ft06v.f:35
    + + + + diff --git a/ver-2.10.0/w3ft07_8f.html b/ver-2.10.0/w3ft07_8f.html new file mode 100644 index 00000000..a1b39ba0 --- /dev/null +++ b/ver-2.10.0/w3ft07_8f.html @@ -0,0 +1,276 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft07.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft07.f File Reference
    +
    +
    + +

    Transform gridpoint fld by interpolation. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft07 (FLDA, IA, JA, AIPOLE, AJPOLE, BIPOLE, BJPOLE, DSCALE, ANGLE, LINEAR, LDEFQQ, DEFALT, FLDB, IB, JB)
     Transforms data contained in a given grid array by translation, rotation about a common point and dilatation in order to create a new grid array according to specs. More...
     
    +

    Detailed Description

    +

    Transform gridpoint fld by interpolation.

    +
    Author
    McDonell & Howcroft
    +
    Date
    1974-09-01
    + +

    Definition in file w3ft07.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft07()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft07 (real, dimension(ia,ja) FLDA,
     IA,
     JA,
    real AIPOLE,
    real AJPOLE,
    real BIPOLE,
    real BJPOLE,
    real DSCALE,
    real ANGLE,
    logical LINEAR,
    logical LDEFQQ,
    real DEFALT,
    real, dimension(ib,jb) FLDB,
     IB,
     JB 
    )
    +
    + +

    Transforms data contained in a given grid array by translation, rotation about a common point and dilatation in order to create a new grid array according to specs.

    +

    +Program History Log:

    + + + + + + + + + + + + + +
    Date Programmer Comment
    1974-09-01 J. McDonell, J.Howcroft Initial.
    1984-06-27 Ralph Jones Change to ibm vs fortran
    1989-01-24 Ralph Jones Change to microsoft fortran 4.10
    1989-03-31 Ralph Jones Change to vax-11 fortran
    1993-03-16 D. Shimomura Renamed from w3ft00() to w3ft07()
    +

    in order to make minor mods while doing f77. Changes to call sequence; changes to vrbl names; added comments.

    +
    Parameters
    + + + + + + + + + + + + + + + + +
    [in]FLDAReal*4 original source grid-point data field
    [in]IA(Input for FLDA)
    [in]JA(Input for FLDA)
    [in]FLDBReal*4 original source grid-point data field
    [in]IB(Input for FLDB)
    [in]JB(Input for FLDB)
    [in]AIPOLEReal*4 common point i-coordinates of the original field, assuming a right-hand cartesian coordinate system. the point need not be inside the bounds of either grid
    [in]AJPOLEReal*4 common point j-coordinates of the original field, assuming a right-hand cartesian coordinate system. the point need not be inside the bounds of either grid and can have fractional values. Common point about which to rotate the gridpoints.
    [in]BIPOLE- Real*4 common point i-coordinates for transformed destination grid
    [in]BJPOLE- Real*4 common point j-coordinates for transformed destination grid
    [in]DSCALE- Real*4 scale-change (dilation) expressed as a ratio of the transformed field to the original field dscale = grdlenkm(destination) / grdlenkm(source)
    [in]ANGLE- Real*4 degree measure of the angle required to rotate the j-row of the original grid into coincidence with the new grid. (+ counter- clockwise, - clockwise) angle = vertlonw(source) - vertlonw(destination)
    [in]LINEAR- Logical*4 interpolation-method selection switch:
      +
    • .TRUE. Bi-linear interpolation.
      • +
    • .FALSE. Bi-quadratic interpolation.
      • +
    +
    [in]LDEFQQ- Logical*4 default-value switch: if .true. then use default-value for destination point out-of-bounds of given grid; else extrapolate coarsely from nearby bndry point
    [in]DEFALT- Real*4 the default-value to use if ldefqq = .true.
    +
    +
    +
    Remarks
    List caveats, other helpful hints or information in general 'FLDA' and 'FLDB' cannot be equivalenced although there are situations in which it would be safe to do so. Care should be taken that all of the new grid points lie within the original grid, no error checks are made.
    +
    Author
    McDonell & Howcroft
    +
    Date
    1974-09-01
    + +

    Definition at line 66 of file w3ft07.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft07_8f.js b/ver-2.10.0/w3ft07_8f.js new file mode 100644 index 00000000..a137f12e --- /dev/null +++ b/ver-2.10.0/w3ft07_8f.js @@ -0,0 +1,4 @@ +var w3ft07_8f = +[ + [ "w3ft07", "w3ft07_8f.html#a226490ee379923e202ba1f7d0d14102a", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft07_8f_source.html b/ver-2.10.0/w3ft07_8f_source.html new file mode 100644 index 00000000..bdbd1382 --- /dev/null +++ b/ver-2.10.0/w3ft07_8f_source.html @@ -0,0 +1,324 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft07.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft07.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Transform gridpoint fld by interpolation.
    +
    3 C> @author McDonell & Howcroft @date 1974-09-01
    +
    4 
    +
    5 C> Transforms data contained in a given grid array
    +
    6 C> by translation, rotation about a common point and dilatation
    +
    7 C> in order to create a new grid array according to specs.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1974-09-01 | J. McDonell, J.Howcroft | Initial.
    +
    13 C> 1984-06-27 | Ralph Jones | Change to ibm vs fortran
    +
    14 C> 1989-01-24 | Ralph Jones | Change to microsoft fortran 4.10
    +
    15 C> 1989-03-31 | Ralph Jones | Change to vax-11 fortran
    +
    16 C> 1993-03-16 | D. Shimomura | Renamed from w3ft00() to w3ft07()
    +
    17 C> in order to make minor mods while doing f77. Changes to call sequence;
    +
    18 C> changes to vrbl names; added comments.
    +
    19 C>
    +
    20 C> @param[in] FLDA Real*4 original source grid-point data field
    +
    21 C> @param[in] IA (Input for FLDA)
    +
    22 C> @param[in] JA (Input for FLDA)
    +
    23 C> @param[in] FLDB Real*4 original source grid-point data field
    +
    24 C> @param[in] IB (Input for FLDB)
    +
    25 C> @param[in] JB (Input for FLDB)
    +
    26 C> @param[in] AIPOLE Real*4 common point i-coordinates of the
    +
    27 C> original field, assuming a right-hand cartesian
    +
    28 C> coordinate system. the point need not be inside the bounds of either grid
    +
    29 C> @param[in] AJPOLE Real*4 common point j-coordinates of the
    +
    30 C> original field, assuming a right-hand cartesian
    +
    31 C> coordinate system. the point need not be inside the bounds of either grid
    +
    32 C> and can have fractional values. Common point about which to rotate the gridpoints.
    +
    33 C> @param[in] BIPOLE - Real*4 common point i-coordinates for
    +
    34 C> transformed destination grid
    +
    35 C> @param[in] BJPOLE - Real*4 common point j-coordinates for
    +
    36 C> transformed destination grid
    +
    37 C> @param[in] DSCALE - Real*4 scale-change (dilation) expressed as
    +
    38 C> a ratio of the transformed field to the original field
    +
    39 C> dscale = grdlenkm(destination) / grdlenkm(source)
    +
    40 C> @param[in] ANGLE - Real*4 degree measure of the angle required to
    +
    41 C> rotate the j-row of the original grid into
    +
    42 C> coincidence with the new grid. (+ counter-
    +
    43 C> clockwise, - clockwise)
    +
    44 C> angle = vertlonw(source) - vertlonw(destination)
    +
    45 C>
    +
    46 C> @param[in] LINEAR - Logical*4 interpolation-method selection switch:
    +
    47 C> - .TRUE. Bi-linear interpolation.
    +
    48 C> - .FALSE. Bi-quadratic interpolation.
    +
    49 C> @param[in] LDEFQQ - Logical*4 default-value switch:
    +
    50 C> if .true. then
    +
    51 C> use default-value for destination point
    +
    52 C> out-of-bounds of given grid;
    +
    53 C> else
    +
    54 C> extrapolate coarsely from nearby bndry point
    +
    55 C> @param[in] DEFALT - Real*4 the default-value to use if ldefqq = .true.
    +
    56 C>
    +
    57 C> @remark List caveats, other helpful hints or information
    +
    58 C> in general 'FLDA' and 'FLDB' cannot be equivalenced
    +
    59 C> although there are situations in which it would be safe to do
    +
    60 C> so. Care should be taken that all of the new grid points lie
    +
    61 C> within the original grid, no error checks are made.
    +
    62 C>
    +
    63 C> @author McDonell & Howcroft @date 1974-09-01
    +
    64  SUBROUTINE w3ft07(FLDA,IA,JA,AIPOLE,AJPOLE,BIPOLE,BJPOLE,
    +
    65  A DSCALE,ANGLE,LINEAR,LDEFQQ,DEFALT,FLDB,IB,JB)
    +
    66 C
    +
    67  REAL FLDA(IA,JA)
    +
    68  REAL AIPOLE,AJPOLE
    +
    69  REAL BIPOLE,BJPOLE
    +
    70  REAL DSCALE
    +
    71  REAL ANGLE
    +
    72  REAL DEFALT
    +
    73  REAL FLDB(IB,JB)
    +
    74  REAL ERAS(4)
    +
    75  REAL TINY
    +
    76 C
    +
    77  LOGICAL LINEAR
    +
    78  LOGICAL LDEFQQ
    +
    79 C
    +
    80  SAVE
    +
    81 C
    +
    82  DATA tiny / 0.001 /
    +
    83 C
    +
    84 C ... WHERE TINY IS IN UNITS OF 1.0 = 1 GRID INTERVAL
    +
    85 C
    +
    86 C . . . . . S T A R T . . . . . . . . . . . . . . . . . . .
    +
    87 C
    +
    88  theta = angle * (3.14159/180.)
    +
    89  sint = sin(theta)
    +
    90  cost = cos(theta)
    +
    91 C
    +
    92 C ... WE WILL SCAN ALONG THE J-ROW OF THE DESTINATION GRID ...
    +
    93  DO 288 jn = 1,jb
    +
    94  brelj = float(jn) - bjpole
    +
    95 C
    +
    96  DO 277 in = 1,ib
    +
    97  breli = float(in) - bipole
    +
    98  sti = aipole + dscale*(breli*cost - brelj*sint)
    +
    99  stj = ajpole + dscale*(breli*sint + brelj*cost)
    +
    100  im = sti
    +
    101  jm = stj
    +
    102 C
    +
    103 C ... THE PT(STI,STJ) IS THE LOCATION OF THE FLDB(IN,JN)
    +
    104 C ... IN FLDA,S COORDINATE SYSTEM
    +
    105 C ... IS THIS POINT LOCATED OUTSIDE FLDA?
    +
    106 C ... ON THE BOUNDARY LINE OF FLDA?
    +
    107 C ... ON THE FIRST INTERIOR GRIDPOINT OF FLDA?
    +
    108 C ... GOOD INSIDER, AT LEAST 2 INTERIOR GRIDS INSIDE?
    +
    109  ioff = 0
    +
    110  joff = 0
    +
    111  kquad = 0
    +
    112 C
    +
    113  IF (im .LT. 1) THEN
    +
    114 C ... LOCATED OUTSIDE OF FLDA, OFF LEFT SIDE ...
    +
    115  ii = 1
    +
    116  ioff = 1
    +
    117  ELSE IF (im .EQ. 1) THEN
    +
    118 C ... LOCATED ON BOUNDARY OF FLDA, ON LEFT EDGE ...
    +
    119  kquad = 5
    +
    120  ELSE
    +
    121 C ...( IM .GT. 1) ... LOCATED TO RIGHT OF LEFT-EDGE ...
    +
    122  IF ((ia-im) .LT. 1) THEN
    +
    123 C ... LOCATED OUTSIDE OF OR EXACTLY ON RIGHT EDGE OF FLDA ..
    +
    124  ii = ia
    +
    125  ioff = 1
    +
    126  ELSE IF ((ia-im) .EQ. 1) THEN
    +
    127 C ... LOCATED ON FIRST INTERIOR PT WITHIN RIGHT EDGE OF FLDA
    +
    128  kquad = 5
    +
    129  ELSE
    +
    130 C ... (IA-IM) IS .GT. 1) ...GOOD INTERIOR, AT LEAST 2 INSIDE
    +
    131  ENDIF
    +
    132  ENDIF
    +
    133 C
    +
    134 C . . . . . . . . . . . . . . .
    +
    135 C
    +
    136  IF (jm .LT. 1) THEN
    +
    137 C ... LOCATED OUTSIDE OF FLDA, OFF BOTTOM ...
    +
    138  jj = 1
    +
    139  joff = 1
    +
    140  ELSE IF (jm .EQ. 1) THEN
    +
    141 C ... LOCATED ON BOUNDARY OF FLDA, ON BOTTOM EDGE ...
    +
    142  kquad = 5
    +
    143  ELSE
    +
    144 C ...( JM .GT. 1) ... LOCATED ABOVE BOTTOM EDGE ...
    +
    145  IF ((ja-jm) .LT. 1) THEN
    +
    146 C ... LOCATED OUTSIDE OF OR EXACTLY ON TOP EDGE OF FLDA ..
    +
    147  jj = ja
    +
    148  joff = 1
    +
    149  ELSE IF ((ja-jm) .EQ. 1) THEN
    +
    150 C ... LOCATED ON FIRST INTERIOR PT WITHIN TOP EDGE OF FLDA
    +
    151  kquad = 5
    +
    152  ELSE
    +
    153 C ... ((JA-JM) .GT. 1) ...GOOD INTERIOR, AT LEAST 2 INSIDE
    +
    154  ENDIF
    +
    155  ENDIF
    +
    156 C
    +
    157  IF ((ioff + joff) .EQ. 0) THEN
    +
    158  GO TO 244
    +
    159  ELSE IF ((ioff + joff) .EQ. 2) THEN
    +
    160  GO TO 233
    +
    161  ENDIF
    +
    162 C
    +
    163  IF (ioff .EQ. 1) THEN
    +
    164  jj = stj
    +
    165  ENDIF
    +
    166  IF (joff .EQ. 1) THEN
    +
    167  ii = sti
    +
    168  ENDIF
    +
    169  233 CONTINUE
    +
    170  IF (ldefqq) THEN
    +
    171  fldb(in,jn) = defalt
    +
    172  ELSE
    +
    173  fldb(in,jn) = flda(ii,jj)
    +
    174  ENDIF
    +
    175  GO TO 277
    +
    176 C
    +
    177 C . . . . . . . . . . . . .
    +
    178 C
    +
    179  244 CONTINUE
    +
    180  i = sti
    +
    181  j = stj
    +
    182  xdeli = sti - float(i)
    +
    183  xdelj = stj - float(j)
    +
    184 C
    +
    185  IF ((abs(xdeli) .LT. tiny) .AND. (abs(xdelj) .LT. tiny)) THEN
    +
    186 C ... THIS POINT IS RIGHT AT A GRIDPOINT. NO INTERP NECESSARY
    +
    187  fldb(in,jn) = flda(i,j)
    +
    188  GO TO 277
    +
    189  ENDIF
    +
    190 C
    +
    191  IF ((kquad .EQ. 5) .OR. (linear)) THEN
    +
    192 C ... PERFORM BI-LINEAR INTERP ...
    +
    193  eras(1) = flda(i,j)
    +
    194  eras(4) = flda(i,j+1)
    +
    195  eras(2) = eras(1) + xdeli*(flda(i+1,j) - eras(1))
    +
    196  eras(3) = eras(4) + xdeli*(flda(i+1,j+1) - eras(4))
    +
    197  di = eras(2) + xdelj*(eras(3) - eras(2))
    +
    198  GO TO 266
    +
    199 C
    +
    200  ELSE
    +
    201 C ... PERFORM BI-QUADRATIC INTERP ...
    +
    202  xi2tm = xdeli * (xdeli-1.) * 0.25
    +
    203  xj2tm = xdelj * (xdelj-1.) * 0.25
    +
    204  j1 = j - 1
    +
    205  DO 255 k=1,4
    +
    206  eras(k)=(flda(i+1,j1)-flda(i,j1))*xdeli+flda(i,j1)+
    +
    207  a (flda(i-1,j1)-flda(i,j1)-flda(i+1,j1)+flda(i+2,j1))*xi2tm
    +
    208  j1 = j1 + 1
    +
    209  255 CONTINUE
    +
    210 C
    +
    211  di = eras(2) + xdelj*(eras(3)-eras(2)) +
    +
    212  a xj2tm*(eras(4)-eras(3)-eras(2)+eras(1))
    +
    213  GO TO 266
    +
    214  ENDIF
    +
    215 C
    +
    216  266 CONTINUE
    +
    217  fldb(in,jn) = di
    +
    218  277 CONTINUE
    +
    219  288 CONTINUE
    +
    220 C
    +
    221  RETURN
    +
    222  END
    +
    +
    +
    w3ft07
    subroutine w3ft07(FLDA, IA, JA, AIPOLE, AJPOLE, BIPOLE, BJPOLE, DSCALE, ANGLE, LINEAR, LDEFQQ, DEFALT, FLDB, IB, JB)
    Transforms data contained in a given grid array by translation, rotation about a common point and dil...
    Definition: w3ft07.f:66
    + + + + diff --git a/ver-2.10.0/w3ft08_8f.html b/ver-2.10.0/w3ft08_8f.html new file mode 100644 index 00000000..e4ce625b --- /dev/null +++ b/ver-2.10.0/w3ft08_8f.html @@ -0,0 +1,218 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft08.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft08.f File Reference
    +
    +
    + +

    Computes 2.5 x 2.5 n. hemi. grid-scaler. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft08 (FLN, GN, PLN, EPS, FL, WORK, TRIGS)
     Computes 2.5 x 2.5 n. More...
     
    +

    Detailed Description

    +

    Computes 2.5 x 2.5 n. hemi. grid-scaler.

    +
    Author
    Joe Sela
    +
    Date
    1988-06-20
    + +

    Definition in file w3ft08.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft08()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft08 (complex, dimension( 31 , 31 ) FLN,
    real, dimension(145,37) GN,
    real, dimension( 32 , 31 ) PLN,
    real, dimension(992) EPS,
    complex, dimension( 31 ) FL,
    real, dimension(144) WORK,
    real, dimension(216) TRIGS 
    )
    +
    + +

    Computes 2.5 x 2.5 n.

    +

    hemi. grid of 145 x 37 points from spectral coefficients in a rhomboidal 30 resolution representing a scaler field.

    +

    +Program History Log:

    + + + + + + + + + + + + + + + +
    Date Programmer Comment
    1988-06-20 Joe Sela Initial.
    1988-06-20 Ralph Jones Change to microsoft fortran 4.10.
    1990-06-12 Ralph Jones Change to sun fortran 1.3.
    1991-03-30 Ralph Jones Convert to silicongraphics fortran.
    1993-03-29 Ralph Jones Add save statement.
    1993-07-22 Ralph Jones Change double precision to real for cray.
    +
    Parameters
    + + + + + + + + +
    [in]FLN961 complex coeff.
    [in]PLN992 real space for legendre polynomials.
    [in]EPS992 real space for coeffs. used in computing pln.
    [in]FL31 complex space for fourier coeff.
    [in]WORK144 real work space for subr. w3ft12()
    [in]TRIGS216 precomputed trig funcs. used in w3ft12(), computed by w3fa13()
    [out]GN(145,37) grid values. 5365 point grid is type 29 or 1d hex o.n. 84
    +
    +
    +
    Note
    This subroutine was optimized to run in a small amount of memory, it is not optimized for speed, 70 percent of the time is used by subroutine w3fa12 computing the legendre polynomials. since the legendre polynomials are constant they need to be computed only once in a program. By moving w3fa12() to the main program and computing pln as a (32,31,37) array and changing this subroutine to use pln as a three dimension array you can cut the running time 70 percent. w3ft38() has these improvements.
    +
    Author
    Joe Sela
    +
    Date
    1988-06-20
    + +

    Definition at line 41 of file w3ft08.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft08_8f.js b/ver-2.10.0/w3ft08_8f.js new file mode 100644 index 00000000..6524186b --- /dev/null +++ b/ver-2.10.0/w3ft08_8f.js @@ -0,0 +1,4 @@ +var w3ft08_8f = +[ + [ "w3ft08", "w3ft08_8f.html#ae48a19283d690c37fe8c3dc355e8e609", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft08_8f_source.html b/ver-2.10.0/w3ft08_8f_source.html new file mode 100644 index 00000000..482c33f1 --- /dev/null +++ b/ver-2.10.0/w3ft08_8f_source.html @@ -0,0 +1,183 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft08.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft08.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes 2.5 x 2.5 n. hemi. grid-scaler.
    +
    3 C> @author Joe Sela @date 1988-06-20
    +
    4 
    +
    5 C> Computes 2.5 x 2.5 n. hemi. grid of 145 x 37 points
    +
    6 C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7 C> representing a scaler field.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1988-06-20 | Joe Sela | Initial.
    +
    13 C> 1988-06-20 | Ralph Jones | Change to microsoft fortran 4.10.
    +
    14 C> 1990-06-12 | Ralph Jones | Change to sun fortran 1.3.
    +
    15 C> 1991-03-30 | Ralph Jones | Convert to silicongraphics fortran.
    +
    16 C> 1993-03-29 | Ralph Jones | Add save statement.
    +
    17 C> 1993-07-22 | Ralph Jones | Change double precision to real for cray.
    +
    18 C>
    +
    19 C> @param[in] FLN 961 complex coeff.
    +
    20 C> @param[in] PLN 992 real space for legendre polynomials.
    +
    21 C> @param[in] EPS 992 real space for
    +
    22 C> coeffs. used in computing pln.
    +
    23 C> @param[in] FL 31 complex space for fourier coeff.
    +
    24 C> @param[in] WORK 144 real work space for subr. w3ft12()
    +
    25 C> @param[in] TRIGS 216 precomputed trig funcs. used
    +
    26 C> in w3ft12(), computed by w3fa13()
    +
    27 C> @param[out] GN (145,37) grid values. 5365 point grid is type 29 or
    +
    28 C> 1d hex o.n. 84
    +
    29 C>
    +
    30 C> @note This subroutine was optimized to run in a small amount of
    +
    31 C> memory, it is not optimized for speed, 70 percent of the time is
    +
    32 C> used by subroutine w3fa12 computing the legendre polynomials. since
    +
    33 C> the legendre polynomials are constant they need to be computed
    +
    34 C> only once in a program. By moving w3fa12() to the main program and
    +
    35 C> computing pln as a (32,31,37) array and changing this subroutine
    +
    36 C> to use pln as a three dimension array you can cut the running time
    +
    37 C> 70 percent. w3ft38() has these improvements.
    +
    38 C>
    +
    39 C> @author Joe Sela @date 1988-06-20
    +
    40  SUBROUTINE w3ft08(FLN,GN,PLN,EPS,FL,WORK,TRIGS)
    +
    41 C
    +
    42  COMPLEX FL( 31 )
    +
    43  COMPLEX FLN( 31 , 31 )
    +
    44 C
    +
    45  REAL COLRA
    +
    46  REAL EPS(992)
    +
    47  REAL GN(145,37)
    +
    48  REAL PLN( 32 , 31 )
    +
    49  REAL TRIGS(216)
    +
    50  REAL WORK(144)
    +
    51 C
    +
    52  SAVE
    +
    53 C
    +
    54  DATA pi /3.14159265/
    +
    55 C
    +
    56  drad = 2.5 * pi / 180.0
    +
    57 C
    +
    58  DO 400 lat = 1,37
    +
    59  latn = 38 - lat
    +
    60  colra = (lat - 1) * drad
    +
    61  CALL w3fa12(pln,colra, 30 ,eps)
    +
    62 C
    +
    63  DO 100 l = 1, 31
    +
    64  fl(l) = (0.,0.)
    +
    65  100 CONTINUE
    +
    66 C
    +
    67  DO 300 l = 1, 31
    +
    68  DO 200 i = 1, 31
    +
    69  fl(l) = fl(l) + cmplx(pln(i,l) * real(fln(i,l)) ,
    +
    70  & pln(i,l) * aimag(fln(i,l)) )
    +
    71  200 CONTINUE
    +
    72 C
    +
    73  300 CONTINUE
    +
    74 C
    +
    75  CALL w3ft12(fl,work,gn(1,latn),trigs)
    +
    76 C
    +
    77  400 CONTINUE
    +
    78 C
    +
    79  RETURN
    +
    80  END
    +
    +
    +
    w3ft12
    subroutine w3ft12(COEF, WORK, GRID, TRIGS)
    Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients.
    Definition: w3ft12.f:25
    +
    w3ft08
    subroutine w3ft08(FLN, GN, PLN, EPS, FL, WORK, TRIGS)
    Computes 2.5 x 2.5 n.
    Definition: w3ft08.f:41
    + + + + diff --git a/ver-2.10.0/w3ft09_8f.html b/ver-2.10.0/w3ft09_8f.html new file mode 100644 index 00000000..5832de6d --- /dev/null +++ b/ver-2.10.0/w3ft09_8f.html @@ -0,0 +1,227 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft09.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft09.f File Reference
    +
    +
    + +

    Computes 2.5x2.5 n. hemi. grid-vector. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft09 (VLN, GN, PLN, EPS, FL, WORK, TRIGS, RCOS)
     Computes 2.5 x 2.5 n. More...
     
    +

    Detailed Description

    +

    Computes 2.5x2.5 n. hemi. grid-vector.

    +
    Author
    Joe Sela
    +
    Date
    1980-10-21
    + +

    Definition in file w3ft09.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft09()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft09 (complex, dimension( 32 , 31 ) VLN,
    real, dimension(145,37) GN,
    real, dimension( 32 , 31 ) PLN,
    real, dimension(992) EPS,
    complex, dimension( 31 ) FL,
    real, dimension(144) WORK,
    real, dimension(216) TRIGS,
    real, dimension(37) RCOS 
    )
    +
    + +

    Computes 2.5 x 2.5 n.

    +

    hemi. grid of 145 x 37 points from spectral coefficients in a rhomboidal 30 resolution representing a vector field.

    +

    +Program History Log:

    + + + + + + + + + + + + + + + + + +
    Date Programmer Comment
    1980-10-21 JOE SELA Initial.
    1981-06-15 Ralph Jones Add doc block, clean up source.
    1989-01-25 Ralph Jones Change to microsoft fortran 4.10.
    1990-06-12 Ralph Jones Change to sun fortran 1.3.
    1991-03-30 Ralph Jones Convert to silicongraphics fortran.
    1993-03-29 Ralph Jones Add save statement.
    1993-07-22 Ralph Jones Change double precision to real for cray.
    +
    Parameters
    + + + + + + + + + +
    [in]VLN992 complex coeff.
    [in]PLN992 space for legendre polynomials.
    [in]EPS992 real space for coeffs. used in computing pln.
    [in]FL31 complex space for fourier coeff.
    [in]WORK144 work space for subr. w3ft12
    [in]TRIGS216 precomputed trig funcs. Used in w3ft12(), computed by w3fa13()
    [in]RCOS37 reciprocal cosine latitudes of 2.5 x 2.5 grid must be computed before first call to w3ft11() using sr w3fa13.
    [out]GN(145,37) grid values. 5365 point grid is type 29 or 1d o.n. 84
    +
    +
    +
    Note
    This subroutine was optimized to run in a small amount of memory, it is not optimized for speed, 70 percent of the time is used by subroutine w3fa12() computing the legendre polynomials. since the legendre polynomials are constant they need to be computed only once in a program. By moving w3fa12() to the main program and computing pln as a (32,31,37) array and changing this subroutine to use pln as a three dimension array you can cut the running time 70 percent.
    +
    Author
    Joe Sela
    +
    Date
    1980-10-21
    + +

    Definition at line 41 of file w3ft09.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft09_8f.js b/ver-2.10.0/w3ft09_8f.js new file mode 100644 index 00000000..447c7a21 --- /dev/null +++ b/ver-2.10.0/w3ft09_8f.js @@ -0,0 +1,4 @@ +var w3ft09_8f = +[ + [ "w3ft09", "w3ft09_8f.html#ac50128472db184365bc4c2dfb1ea1a47", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft09_8f_source.html b/ver-2.10.0/w3ft09_8f_source.html new file mode 100644 index 00000000..117b086e --- /dev/null +++ b/ver-2.10.0/w3ft09_8f_source.html @@ -0,0 +1,192 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft09.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft09.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes 2.5x2.5 n. hemi. grid-vector
    +
    3 C> @author Joe Sela @date 1980-10-21
    +
    4 
    +
    5 C> Computes 2.5 x 2.5 n. hemi. grid of 145 x 37 points
    +
    6 C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7 C> representing a vector field.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1980-10-21 | JOE SELA | Initial.
    +
    13 C> 1981-06-15 | Ralph Jones | Add doc block, clean up source.
    +
    14 C> 1989-01-25 | Ralph Jones | Change to microsoft fortran 4.10.
    +
    15 C> 1990-06-12 | Ralph Jones | Change to sun fortran 1.3.
    +
    16 C> 1991-03-30 | Ralph Jones | Convert to silicongraphics fortran.
    +
    17 C> 1993-03-29 | Ralph Jones | Add save statement.
    +
    18 C> 1993-07-22 | Ralph Jones | Change double precision to real for cray.
    +
    19 C>
    +
    20 C> @param[in] VLN 992 complex coeff.
    +
    21 C> @param[in] PLN 992 space for legendre polynomials.
    +
    22 C> @param[in] EPS 992 real space for coeffs. used in computing pln.
    +
    23 C> @param[in] FL 31 complex space for fourier coeff.
    +
    24 C> @param[in] WORK 144 work space for subr. w3ft12
    +
    25 C> @param[in] TRIGS 216 precomputed trig funcs. Used in w3ft12(), computed by w3fa13()
    +
    26 C> @param[in] RCOS 37 reciprocal cosine latitudes of 2.5 x 2.5 grid must be
    +
    27 C> computed before first call to w3ft11() using sr w3fa13.
    +
    28 C> @param[out] GN (145,37) grid values. 5365 point grid is type 29 or 1d o.n. 84
    +
    29 C>
    +
    30 C> @note This subroutine was optimized to run in a small amount of
    +
    31 C> memory, it is not optimized for speed, 70 percent of the time is
    +
    32 C> used by subroutine w3fa12() computing the legendre polynomials. since
    +
    33 C> the legendre polynomials are constant they need to be computed
    +
    34 C> only once in a program. By moving w3fa12() to the main program and
    +
    35 C> computing pln as a (32,31,37) array and changing this subroutine
    +
    36 C> to use pln as a three dimension array you can cut the running time
    +
    37 C> 70 percent.
    +
    38 C>
    +
    39 C> @author Joe Sela @date 1980-10-21
    +
    40  SUBROUTINE w3ft09(VLN,GN,PLN,EPS,FL,WORK,TRIGS,RCOS)
    +
    41 C
    +
    42  COMPLEX FL( 31 )
    +
    43  COMPLEX VLN( 32 , 31 )
    +
    44 C
    +
    45  REAL COLRA
    +
    46  REAL EPS(992)
    +
    47  REAL GN(145,37)
    +
    48  REAL PLN( 32 , 31 )
    +
    49  REAL RCOS(37)
    +
    50  REAL TRIGS(216)
    +
    51  REAL WORK(144)
    +
    52 C
    +
    53  SAVE
    +
    54 C
    +
    55  DATA pi /3.14159265/
    +
    56 C
    +
    57  drad = 2.5 * pi / 180.0
    +
    58 C
    +
    59  DO 400 lat = 2,37
    +
    60  latn = 38 - lat
    +
    61  colra = (lat - 1) * drad
    +
    62  CALL w3fa12(pln,colra, 30 ,eps)
    +
    63 C
    +
    64  DO 100 l = 1, 31
    +
    65  fl(l) = (0.,0.)
    +
    66  100 CONTINUE
    +
    67 C
    +
    68  DO 300 l = 1, 31
    +
    69 C
    +
    70  DO 200 i = 1, 32
    +
    71  fl(l) = fl(l) + cmplx(pln(i,l) * real(vln(i,l)),
    +
    72  & pln(i,l) * aimag(vln(i,l)) )
    +
    73  200 CONTINUE
    +
    74 C
    +
    75  fl(l)=cmplx(real(fl(l))*rcos(lat),aimag(fl(l))*rcos(lat))
    +
    76  300 CONTINUE
    +
    77 C
    +
    78  CALL w3ft12(fl,work,gn(1,latn),trigs)
    +
    79 C
    +
    80  400 CONTINUE
    +
    81 C
    +
    82 C*** POLE ROW=CLOSEST LATITUDE ROW
    +
    83 C
    +
    84  DO 500 i = 1,145
    +
    85  gn(i,37) = gn(i,36)
    +
    86  500 CONTINUE
    +
    87 C
    +
    88  RETURN
    +
    89  END
    +
    +
    +
    w3ft09
    subroutine w3ft09(VLN, GN, PLN, EPS, FL, WORK, TRIGS, RCOS)
    Computes 2.5 x 2.5 n.
    Definition: w3ft09.f:41
    +
    w3ft12
    subroutine w3ft12(COEF, WORK, GRID, TRIGS)
    Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients.
    Definition: w3ft12.f:25
    + + + + diff --git a/ver-2.10.0/w3ft10_8f.html b/ver-2.10.0/w3ft10_8f.html new file mode 100644 index 00000000..e6b680aa --- /dev/null +++ b/ver-2.10.0/w3ft10_8f.html @@ -0,0 +1,220 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft10.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft10.f File Reference
    +
    +
    + +

    Computes 2.5 x 2.5 s. hemi. grid-scaler. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft10 (FLN, GN, PLN, EPS, FL, WORK, TRIGS)
     Computes 2.5 x 2.5 s. More...
     
    +

    Detailed Description

    +

    Computes 2.5 x 2.5 s. hemi. grid-scaler.

    +
    Author
    Joe Sela
    +
    Date
    1980-10-21
    + +

    Definition in file w3ft10.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft10()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft10 (complex, dimension( 31 , 31 ) FLN,
    real, dimension(145,37) GN,
    real, dimension( 32 , 31 ) PLN,
    real, dimension( 992) EPS,
    complex, dimension( 31 ) FL,
    real, dimension(144) WORK,
    real, dimension(216) TRIGS 
    )
    +
    + +

    Computes 2.5 x 2.5 s.

    +

    hemi. grid of 145 x 37 points from spectral coefficients in a rhomboidal 30 resolution representing a scaler field.

    +

    +Program History Log:

    + + + + + + + + + + + + + + + + + +
    Date Programmer Comment
    1980-10-21 Joe Sela Initial.
    1984-06-28 Ralph Jones Change to ibm vs fortran.
    1989-01-25 Ralph Jones Change to microsoft fortran 4.10.
    1990-06-12 Ralph Jones Change to sun fortran 1.3.
    1991-03-30 Ralph Jones Convert to silicongraphics fortran.
    1993-03-29 Ralph Jones Add save statement.
    1993-07-22 Ralph Jones Change double precision to real for cray.
    +
    Parameters
    + + + + + + + + +
    [in]FLN961 complex coeff.
    [in]PLN992 real space for legendre polynomials.
    [in]EPS992 real space for coeffs. used in computing pln.
    [in]FL31 complex space for fourier coeff.
    [in]WORK144 real work space for subr. w3ft12()
    [in]TRIGS216 precomputed trig funcs. used in w3ft12(), computed by w3fa13()
    [out]GN(145,37) grid values. 5365 point grid is type 30 or 1e o.n. 84
    +
    +
    +
    Note
    This subroutine was optimized to run in a small amount of memory, it is not optimized for speed, 70 percent of the time is used by subroutine w3fa12() computing the legendre polynomials. Since the legendre polynomials are constant they need to be computed only once in a program. By moving w3fa12() to the main program and computing pln as a (32,31,37) array and changing this subroutine to use pln as a three dimension array you can cut the running time 70 percent.
    +
    Author
    Joe Sela
    +
    Date
    1980-10-21
    + +

    Definition at line 39 of file w3ft10.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft10_8f.js b/ver-2.10.0/w3ft10_8f.js new file mode 100644 index 00000000..0a6f13ab --- /dev/null +++ b/ver-2.10.0/w3ft10_8f.js @@ -0,0 +1,4 @@ +var w3ft10_8f = +[ + [ "w3ft10", "w3ft10_8f.html#a17871a93f588bd482470dd30d88f6b8c", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft10_8f_source.html b/ver-2.10.0/w3ft10_8f_source.html new file mode 100644 index 00000000..7e926e16 --- /dev/null +++ b/ver-2.10.0/w3ft10_8f_source.html @@ -0,0 +1,185 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft10.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft10.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes 2.5 x 2.5 s. hemi. grid-scaler.
    +
    3 C> @author Joe Sela @date 1980-10-21
    +
    4 
    +
    5 C> Computes 2.5 x 2.5 s. hemi. grid of 145 x 37 points
    +
    6 C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7 C> representing a scaler field.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1980-10-21 | Joe Sela | Initial.
    +
    13 C> 1984-06-28 | Ralph Jones | Change to ibm vs fortran.
    +
    14 C> 1989-01-25 | Ralph Jones | Change to microsoft fortran 4.10.
    +
    15 C> 1990-06-12 | Ralph Jones | Change to sun fortran 1.3.
    +
    16 C> 1991-03-30 | Ralph Jones | Convert to silicongraphics fortran.
    +
    17 C> 1993-03-29 | Ralph Jones | Add save statement.
    +
    18 C> 1993-07-22 | Ralph Jones | Change double precision to real for cray.
    +
    19 C>
    +
    20 C> @param[in] FLN 961 complex coeff.
    +
    21 C> @param[in] PLN 992 real space for legendre polynomials.
    +
    22 C> @param[in] EPS 992 real space for coeffs. used in computing pln.
    +
    23 C> @param[in] FL 31 complex space for fourier coeff.
    +
    24 C> @param[in] WORK 144 real work space for subr. w3ft12()
    +
    25 C> @param[in] TRIGS 216 precomputed trig funcs. used in w3ft12(), computed by w3fa13()
    +
    26 C> @param[out] GN (145,37) grid values. 5365 point grid is type 30 or 1e o.n. 84
    +
    27 C>
    +
    28 C> @note This subroutine was optimized to run in a small amount of
    +
    29 C> memory, it is not optimized for speed, 70 percent of the time is
    +
    30 C> used by subroutine w3fa12() computing the legendre polynomials. Since
    +
    31 C> the legendre polynomials are constant they need to be computed
    +
    32 C> only once in a program. By moving w3fa12() to the main program and
    +
    33 C> computing pln as a (32,31,37) array and changing this subroutine
    +
    34 C> to use pln as a three dimension array you can cut the running time
    +
    35 C> 70 percent.
    +
    36 C>
    +
    37 C> @author Joe Sela @date 1980-10-21
    +
    38  SUBROUTINE w3ft10(FLN,GN,PLN,EPS,FL,WORK,TRIGS)
    +
    39 C
    +
    40  COMPLEX FL( 31 )
    +
    41  COMPLEX FLN( 31 , 31 )
    +
    42 C
    +
    43  REAL COLRA
    +
    44  REAL EPS( 992)
    +
    45  REAL GN(145,37)
    +
    46  REAL PLN( 32 , 31 )
    +
    47  REAL TRIGS(216)
    +
    48  REAL WORK(144)
    +
    49 C
    +
    50  SAVE
    +
    51 C
    +
    52  DATA pi /3.14159265/
    +
    53 C
    +
    54  drad = 2.5 * pi / 180.0
    +
    55 C
    +
    56  DO 400 lat = 1,37
    +
    57  colra = (lat-1) * drad
    +
    58  CALL w3fa12(pln,colra, 30 ,eps)
    +
    59 C
    +
    60  DO 100 l = 1, 31
    +
    61  fl(l) = (0.,0.)
    +
    62  100 CONTINUE
    +
    63 C
    +
    64  DO 300 l = 1, 31
    +
    65  i = 1
    +
    66  fl(l) = fl(l)+cmplx(pln(i,l) * real(fln(i,l)) ,
    +
    67  & pln(i,l) * aimag(fln(i,l)) )
    +
    68 C
    +
    69  DO 200 i = 2, 30 ,2
    +
    70  fl(l) = fl(l)-cmplx(pln(i,l) * real(fln(i,l)) ,
    +
    71  & pln(i,l) * aimag(fln(i,l)) )
    +
    72  fl(l) = fl(l)+cmplx(pln(i+1,l) * real(fln(i+1,l)),
    +
    73  & pln(i+1,l) * aimag(fln(i+1,l)))
    +
    74  200 CONTINUE
    +
    75 C
    +
    76  300 CONTINUE
    +
    77 C
    +
    78  CALL w3ft12(fl,work,gn(1,lat ),trigs)
    +
    79  400 CONTINUE
    +
    80 C
    +
    81  RETURN
    +
    82  END
    +
    +
    +
    w3ft12
    subroutine w3ft12(COEF, WORK, GRID, TRIGS)
    Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients.
    Definition: w3ft12.f:25
    +
    w3ft10
    subroutine w3ft10(FLN, GN, PLN, EPS, FL, WORK, TRIGS)
    Computes 2.5 x 2.5 s.
    Definition: w3ft10.f:39
    + + + + diff --git a/ver-2.10.0/w3ft11_8f.html b/ver-2.10.0/w3ft11_8f.html new file mode 100644 index 00000000..a8d0860f --- /dev/null +++ b/ver-2.10.0/w3ft11_8f.html @@ -0,0 +1,227 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft11.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft11.f File Reference
    +
    +
    + +

    Computes 2.5x2.5 s. hemi. grid vector. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft11 (VLN, GN, PLN, EPS, FL, WORK, TRIGS, RCOS)
     Computes 2.5 x 2.5 s. More...
     
    +

    Detailed Description

    +

    Computes 2.5x2.5 s. hemi. grid vector.

    +
    Author
    Joe Sela
    +
    Date
    1980-11-20
    + +

    Definition in file w3ft11.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft11()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft11 (complex, dimension( 32 , 31 ) VLN,
    real, dimension(145,37) GN,
    real, dimension( 32 , 31 ) PLN,
    real, dimension( 992 ) EPS,
    complex, dimension( 31 ) FL,
    real, dimension(144) WORK,
    real, dimension(216) TRIGS,
    real, dimension(37) RCOS 
    )
    +
    + +

    Computes 2.5 x 2.5 s.

    +

    hemi. grid of 145 x 37 points from spectral coefficients in a rhomboidal 30 resolution representing a vector field.

    +

    +Program History Log:

    + + + + + + + + + + + + + + + + + +
    Date Programmer Comment
    1980-11-20 Joe Sela Initial.
    1984-06-15 Ralph Jones Change to ibm vs fortran.
    1989-01-25 Ralph Jones Change to microsoft fortran 4.10.
    1990-06-12 Ralph Jones Change to sun fortran 1.3.
    1991-03-30 Ralph Jones Convert to silicongraphics fortran.
    1993-03-29 Ralph Jones Add save statement.
    1993-07-22 Ralph Jones Change double precision to real for cray.
    +
    Parameters
    + + + + + + + + + +
    [in]VLN992 complex coeff.
    [in]PLN992 real space for legendre polynomials.
    [in]EPS992 real space for coeffs. used in computing pln.
    [in]FL31 complex space for fourier coeff.
    [in]WORK144 real work space for subr. w3ft12()
    [in]TRIGS216 precomputed trig funcs. used in w3ft12(), computed by w3fa13()
    [in]RCOS37 reciprocal cosine latitudes of 2.5 x 2.5 grid must be computed before first call to w3ft11 using subr. w3fa13()
    [out]GN(145,37) grid values. 5365 point grid is type 30 or 1e hex o.n. 84
    +
    +
    +
    Note
    This subroutine was optimized to run in a small amount of memory, it is not optimized for speed, 70 percent of the time is used by subroutine w3fa12() computing the legendre polynomials. Since the legendre polynomials are constant they need to be computed only once in a program. by moving w3fa12() to the main program and computing pln as a (32,31,37) array and changing this subroutine to use pln as a three dimension array you can cut the running time 70 percent.
    +
    Author
    Joe Sela
    +
    Date
    1980-11-20
    + +

    Definition at line 41 of file w3ft11.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft11_8f.js b/ver-2.10.0/w3ft11_8f.js new file mode 100644 index 00000000..5fe18e20 --- /dev/null +++ b/ver-2.10.0/w3ft11_8f.js @@ -0,0 +1,4 @@ +var w3ft11_8f = +[ + [ "w3ft11", "w3ft11_8f.html#af60fd501521a85612c264e601718bb68", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft11_8f_source.html b/ver-2.10.0/w3ft11_8f_source.html new file mode 100644 index 00000000..4d5f2e5a --- /dev/null +++ b/ver-2.10.0/w3ft11_8f_source.html @@ -0,0 +1,193 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft11.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft11.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes 2.5x2.5 s. hemi. grid vector.
    +
    3 C> @author Joe Sela @date 1980-11-20
    +
    4 
    +
    5 C> Computes 2.5 x 2.5 s. hemi. grid of 145 x 37 points
    +
    6 C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7 C> representing a vector field.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1980-11-20 | Joe Sela | Initial.
    +
    13 C> 1984-06-15 | Ralph Jones | Change to ibm vs fortran.
    +
    14 C> 1989-01-25 | Ralph Jones | Change to microsoft fortran 4.10.
    +
    15 C> 1990-06-12 | Ralph Jones | Change to sun fortran 1.3.
    +
    16 C> 1991-03-30 | Ralph Jones | Convert to silicongraphics fortran.
    +
    17 C> 1993-03-29 | Ralph Jones | Add save statement.
    +
    18 C> 1993-07-22 | Ralph Jones | Change double precision to real for cray.
    +
    19 C>
    +
    20 C> @param[in] VLN 992 complex coeff.
    +
    21 C> @param[in] PLN 992 real space for legendre polynomials.
    +
    22 C> @param[in] EPS 992 real space for coeffs. used in computing pln.
    +
    23 C> @param[in] FL 31 complex space for fourier coeff.
    +
    24 C> @param[in] WORK 144 real work space for subr. w3ft12()
    +
    25 C> @param[in] TRIGS 216 precomputed trig funcs. used in w3ft12(), computed by w3fa13()
    +
    26 C> @param[in] RCOS 37 reciprocal cosine latitudes of 2.5 x 2.5 grid must be
    +
    27 C> computed before first call to w3ft11 using subr. w3fa13()
    +
    28 C> @param[out] GN (145,37) grid values. 5365 point grid is type 30 or 1e hex o.n. 84
    +
    29 C>
    +
    30 C> @note This subroutine was optimized to run in a small amount of
    +
    31 C> memory, it is not optimized for speed, 70 percent of the time is
    +
    32 C> used by subroutine w3fa12() computing the legendre polynomials. Since
    +
    33 C> the legendre polynomials are constant they need to be computed
    +
    34 C> only once in a program. by moving w3fa12() to the main program and
    +
    35 C> computing pln as a (32,31,37) array and changing this subroutine
    +
    36 C> to use pln as a three dimension array you can cut the running time
    +
    37 C> 70 percent.
    +
    38 C>
    +
    39 C> @author Joe Sela @date 1980-11-20
    +
    40  SUBROUTINE w3ft11(VLN,GN,PLN,EPS,FL,WORK,TRIGS,RCOS)
    +
    41 C
    +
    42  COMPLEX FL( 31 )
    +
    43  COMPLEX VLN( 32 , 31 )
    +
    44 C
    +
    45  REAL COLRA
    +
    46  REAL EPS( 992 )
    +
    47  REAL GN(145,37)
    +
    48  REAL PLN( 32 , 31 )
    +
    49  REAL RCOS(37)
    +
    50  REAL TRIGS(216)
    +
    51  REAL WORK(144)
    +
    52 C
    +
    53  SAVE
    +
    54 C
    +
    55  DATA pi /3.14159265/
    +
    56 C
    +
    57  drad = 2.5 * pi / 180.0
    +
    58 C
    +
    59  DO 400 lat = 2,37
    +
    60  colra = (lat-1) * drad
    +
    61  CALL w3fa12(pln,colra, 30 ,eps)
    +
    62 C
    +
    63  DO 100 l = 1, 31
    +
    64  fl(l) = (0.,0.)
    +
    65  100 CONTINUE
    +
    66 C
    +
    67  DO 300 l = 1, 31
    +
    68 C
    +
    69  DO 200 i = 1, 31 ,2
    +
    70  fl(l) = fl(l)+cmplx(pln(i,l) * real(vln(i,l)) ,
    +
    71  & pln(i,l) * aimag(vln(i,l)) )
    +
    72  fl(l) = fl(l)-cmplx(pln(i+1,l) * real(vln(i+1,l)),
    +
    73  & pln(i+1,l) * aimag(vln(i+1,l)))
    +
    74  200 CONTINUE
    +
    75 C
    +
    76  fl(l) = cmplx(real(fl(l))*rcos(lat),aimag(fl(l))*rcos(lat))
    +
    77 C
    +
    78  300 CONTINUE
    +
    79 C
    +
    80  CALL w3ft12(fl,work,gn(1,lat ),trigs)
    +
    81 C
    +
    82  400 CONTINUE
    +
    83 C
    +
    84 C*** POLE ROW = CLOSEST LATITUDE ROW
    +
    85 C
    +
    86  DO 500 i = 1,145
    +
    87  gn(i,1) = gn(i,2)
    +
    88  500 CONTINUE
    +
    89  RETURN
    +
    90  END
    +
    +
    +
    w3ft11
    subroutine w3ft11(VLN, GN, PLN, EPS, FL, WORK, TRIGS, RCOS)
    Computes 2.5 x 2.5 s.
    Definition: w3ft11.f:41
    +
    w3ft12
    subroutine w3ft12(COEF, WORK, GRID, TRIGS)
    Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients.
    Definition: w3ft12.f:25
    + + + + diff --git a/ver-2.10.0/w3ft12_8f.html b/ver-2.10.0/w3ft12_8f.html new file mode 100644 index 00000000..316814e7 --- /dev/null +++ b/ver-2.10.0/w3ft12_8f.html @@ -0,0 +1,190 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft12.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft12.f File Reference
    +
    +
    + +

    Fast fourier for 2.5 degree grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft12 (COEF, WORK, GRID, TRIGS)
     Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients. More...
     
    +

    Detailed Description

    +

    Fast fourier for 2.5 degree grid.

    +
    Author
    Joe Sela
    +
    Date
    1980-11-21
    + +

    Definition in file w3ft12.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft12()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft12 (real, dimension( 62 ) COEF,
    real, dimension(144) WORK,
    real, dimension(145) GRID,
    real, dimension(216) TRIGS 
    )
    +
    + +

    Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients.

    +

    This subroutine is special purpose for converting coefficients to a 2.5 degree lat,lon grid.

    +

    +Program History Log:

    + + + + + + + + + +
    Date Programmer Comment
    1980-11-21 Joe Sela Initial.
    1984-06-21 Ralph Jones Change to ibm vs fortran.
    1993-04-12 Ralph Jones Change to cray cft77 fortran.
    +
    Parameters
    + + + + + +
    [in]COEF31 complex fourier coefficients.
    [in]TRIGS216 trig functions assumed precomputed by w3fa13() before first call to w3ft12().
    [in]WORK144 real work space
    [out]GRID145 grid values, grid(1)=grid(145)
    +
    +
    +
    Author
    Joe Sela
    +
    Date
    1980-11-21
    + +

    Definition at line 25 of file w3ft12.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft12_8f.js b/ver-2.10.0/w3ft12_8f.js new file mode 100644 index 00000000..128b9848 --- /dev/null +++ b/ver-2.10.0/w3ft12_8f.js @@ -0,0 +1,4 @@ +var w3ft12_8f = +[ + [ "w3ft12", "w3ft12_8f.html#afb994008cf891b44e3fe4a25c0b46157", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft12_8f_source.html b/ver-2.10.0/w3ft12_8f_source.html new file mode 100644 index 00000000..9fa74bfe --- /dev/null +++ b/ver-2.10.0/w3ft12_8f_source.html @@ -0,0 +1,327 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft12.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft12.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Fast fourier for 2.5 degree grid.
    +
    3 C> @author Joe Sela @date 1980-11-21
    +
    4 
    +
    5 C> Fast fourier to compute 145 grid values at desired
    +
    6 C> latitude from 31 complex fourier coefficients. This subroutine
    +
    7 C> is special purpose for converting coefficients to a 2.5 degree
    +
    8 C> lat,lon grid.
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comment
    +
    12 C> -----|------------|--------
    +
    13 C> 1980-11-21 | Joe Sela | Initial.
    +
    14 C> 1984-06-21 | Ralph Jones | Change to ibm vs fortran.
    +
    15 C> 1993-04-12 | Ralph Jones | Change to cray cft77 fortran.
    +
    16 C>
    +
    17 C> @param[in] COEF 31 complex fourier coefficients.
    +
    18 C> @param[in] TRIGS 216 trig functions assumed precomputed by w3fa13() before
    +
    19 C> first call to w3ft12().
    +
    20 C> @param[in] WORK 144 real work space
    +
    21 C> @param[out] GRID 145 grid values, grid(1)=grid(145)
    +
    22 C>
    +
    23 C> @author Joe Sela @date 1980-11-21
    +
    24  SUBROUTINE w3ft12(COEF,WORK,GRID,TRIGS)
    +
    25  REAL COEF( 62 )
    +
    26  REAL GRID(145)
    +
    27  REAL TRIGS(216)
    +
    28  REAL WORK(144)
    +
    29 C
    +
    30  SAVE
    +
    31 C
    +
    32  DATA sin60/0.866025403784437/
    +
    33 C
    +
    34  grid(1) = coef(1)
    +
    35  grid(2) = coef(1)
    +
    36  k = 147
    +
    37  j = 143
    +
    38  DO 100 i=3, 61 ,2
    +
    39  temp = coef(i)*trigs(k+1) - coef(i+1)*trigs(k)
    +
    40  grid(i) = coef(i) - temp
    +
    41  grid(j) = coef(i) + temp
    +
    42  temp = coef(i)*trigs(k) + coef(i+1)*trigs(k+1)
    +
    43  grid(i+1) = temp - coef(i+1)
    +
    44  grid(j+1) = temp + coef(i+1)
    +
    45  k = k + 2
    +
    46  j = j - 2
    +
    47 100 CONTINUE
    +
    48  DO 110 i= 63 , 84
    +
    49  grid(i) = 0.0
    +
    50 110 CONTINUE
    +
    51 C
    +
    52  a0 = grid(1) + grid(73)
    +
    53  a2 = grid(1) - grid(73)
    +
    54  b0 = grid(2) + grid(74)
    +
    55  b2 = grid(2) - grid(74)
    +
    56  a1 = grid(37) + grid(109)
    +
    57  a3 = grid(37) - grid(109)
    +
    58  b1 = grid(38) + grid(110)
    +
    59  b3 = grid(38) - grid(110)
    +
    60  work(1) = a0 + a1
    +
    61  work(5) = a0 - a1
    +
    62  work(2) = b0 + b1
    +
    63  work(6) = b0 - b1
    +
    64  work(3) = a2 - b3
    +
    65  work(7) = a2 + b3
    +
    66  work(4) = b2 + a3
    +
    67  work(8) = b2 - a3
    +
    68  kb = 3
    +
    69  kc = 5
    +
    70  kd = 7
    +
    71  j = 75
    +
    72  k = 39
    +
    73  l = 111
    +
    74  m = 9
    +
    75  DO 300 i=3,35,2
    +
    76  a0 = grid(i) + grid(j)
    +
    77  a2 = grid(i) - grid(j)
    +
    78  b0 = grid(i+1) + grid(j+1)
    +
    79  b2 = grid(i+1) - grid(j+1)
    +
    80  a1 = grid(k) + grid(l)
    +
    81  a3 = grid(k) - grid(l)
    +
    82  b1 = grid(k+1) + grid(l+1)
    +
    83  b3 = grid(k+1) - grid(l+1)
    +
    84  work(m ) = a0 + a1
    +
    85  work(m+4) = a0 - a1
    +
    86  work(m+1) = b0 + b1
    +
    87  work(m+5) = b0 - b1
    +
    88  work(m+2) = a2 - b3
    +
    89  work(m+6) = a2 + b3
    +
    90  work(m+3) = b2 + a3
    +
    91  work(m+7) = b2 - a3
    +
    92  temp = work(m+2)*trigs(kb) - work(m+3)*trigs(kb+1)
    +
    93  work(m+3) = work(m+2)*trigs(kb+1) + work(m+3)*trigs(kb)
    +
    94  work(m+2) = temp
    +
    95  temp = work(m+4)*trigs(kc) - work(m+5)*trigs(kc+1)
    +
    96  work(m+5) = work(m+4)*trigs(kc+1) + work(m+5)*trigs(kc)
    +
    97  work(m+4) = temp
    +
    98  temp = work(m+6)*trigs(kd) - work(m+7)*trigs(kd+1)
    +
    99  work(m+7) = work(m+6)*trigs(kd+1) + work(m+7)*trigs(kd)
    +
    100  work(m+6) = temp
    +
    101  j = j + 2
    +
    102  k = k + 2
    +
    103  l = l + 2
    +
    104  kb = kb + 2
    +
    105  kc = kc + 4
    +
    106  kd = kd + 6
    +
    107  m = m + 8
    +
    108 300 CONTINUE
    +
    109 C
    +
    110  i = 1
    +
    111  j = 1
    +
    112  k = 73
    +
    113  DO 440 l=1,4
    +
    114  grid(i) = work(j) + work(k)
    +
    115  grid(i+8) = work(j) - work(k)
    +
    116  grid(i+1) = work(j+1) + work(k+1)
    +
    117  grid(i+9) = work(j+1) - work(k+1)
    +
    118  i = i + 2
    +
    119  j = j + 2
    +
    120  k = k + 2
    +
    121 440 CONTINUE
    +
    122  DO 500 kb=9,65,8
    +
    123  i = i + 8
    +
    124  DO 460 l=1,4
    +
    125  grid(i) = work(j) + work(k)
    +
    126  grid(i+8) = work(j) - work(k)
    +
    127  grid(i+1) = work(j+1) + work(k+1)
    +
    128  grid(i+9) = work(j+1) - work(k+1)
    +
    129  temp = grid(i+8)*trigs(kb) - grid(i+9)*trigs(kb+1)
    +
    130  grid(i+9) = grid(i+8)*trigs(kb+1) + grid(i+9)*trigs(kb)
    +
    131  grid(i+8) = temp
    +
    132  i = i + 2
    +
    133  j = j + 2
    +
    134  k = k + 2
    +
    135 460 CONTINUE
    +
    136 500 CONTINUE
    +
    137 C
    +
    138  i = 1
    +
    139  l = 1
    +
    140  kc = 1
    +
    141  j = 49
    +
    142  k = 97
    +
    143  m = 17
    +
    144  n = 33
    +
    145  DO 660 ll=1,8
    +
    146  a1 = grid(j) + grid(k)
    +
    147  a3 = sin60*(grid(j)-grid(k))
    +
    148  b1 = grid(j+1) + grid(k+1)
    +
    149  b3 = sin60*(grid(j+1)-grid(k+1))
    +
    150  work(l) = grid(i) + a1
    +
    151  a2 = grid(i) - 0.5*a1
    +
    152  work(l+1) = grid(i+1) + b1
    +
    153  b2 = grid(i+1) - 0.5*b1
    +
    154  work(n) = a2 + b3
    +
    155  work(m) = a2 - b3
    +
    156  work(m+1) = b2 + a3
    +
    157  work(n+1) = b2 - a3
    +
    158  i = i + 2
    +
    159  j = j + 2
    +
    160  k = k + 2
    +
    161  l = l + 2
    +
    162  m = m + 2
    +
    163  n = n + 2
    +
    164 660 CONTINUE
    +
    165  DO 700 kb=17,33,16
    +
    166  l = l + 32
    +
    167  m = m + 32
    +
    168  n = n + 32
    +
    169  kc = kc + 32
    +
    170  DO 680 ll=1,8
    +
    171  a1 = grid(j) + grid(k)
    +
    172  a3 = sin60*(grid(j)-grid(k))
    +
    173  b1 = grid(j+1) + grid(k+1)
    +
    174  b3 = sin60*(grid(j+1)-grid(k+1))
    +
    175  work(l) = grid(i) + a1
    +
    176  a2 = grid(i) - 0.5*a1
    +
    177  work(l+1) = grid(i+1) + b1
    +
    178  b2 = grid(i+1) - 0.5*b1
    +
    179  work(n) = a2 + b3
    +
    180  work(m) = a2 - b3
    +
    181  work(m+1) = b2 + a3
    +
    182  work(n+1) = b2 - a3
    +
    183  temp = work(m)*trigs(kb) - work(m+1)*trigs(kb+1)
    +
    184  work(m+1) = work(m)*trigs(kb+1) + work(m+1)*trigs(kb)
    +
    185  work(m) = temp
    +
    186  temp = work(n)*trigs(kc) - work(n+1)*trigs(kc+1)
    +
    187  work(n+1) = work(n)*trigs(kc+1) + work(n+1)*trigs(kc)
    +
    188  work(n) = temp
    +
    189  i = i + 2
    +
    190  j = j + 2
    +
    191  k = k + 2
    +
    192  l = l + 2
    +
    193  m = m + 2
    +
    194  n = n + 2
    +
    195 680 CONTINUE
    +
    196 700 CONTINUE
    +
    197 C
    +
    198  j = 49
    +
    199  k = 97
    +
    200  l = 144
    +
    201  m = 96
    +
    202  n = 48
    +
    203  DO 900 i=1,47,2
    +
    204  a1 = work(j) + work(k)
    +
    205  a3 = sin60 * (work(j)-work(k))
    +
    206  b3 = sin60 * (work(j+1)-work(k+1))
    +
    207  b1 = work(j+1) + work(k+1)
    +
    208  grid(l+1) = work(i) + a1
    +
    209  a2 = work(i) - 0.5*a1
    +
    210  b2 = work(i+1) - 0.5*b1
    +
    211  grid(l) = work(i+1) + b1
    +
    212  grid(n+1) = a2 + b3
    +
    213  grid(m+1) = a2 - b3
    +
    214  grid(m) = b2 + a3
    +
    215  grid(n) = b2 - a3
    +
    216  j = j + 2
    +
    217  k = k + 2
    +
    218  l = l - 2
    +
    219  m = m - 2
    +
    220  n = n - 2
    +
    221 900 CONTINUE
    +
    222  grid(1) = grid(145)
    +
    223 C
    +
    224  RETURN
    +
    225  END
    +
    +
    +
    w3ft12
    subroutine w3ft12(COEF, WORK, GRID, TRIGS)
    Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients.
    Definition: w3ft12.f:25
    + + + + diff --git a/ver-2.10.0/w3ft16_8f.html b/ver-2.10.0/w3ft16_8f.html new file mode 100644 index 00000000..c95b7b98 --- /dev/null +++ b/ver-2.10.0/w3ft16_8f.html @@ -0,0 +1,183 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft16.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft16.f File Reference
    +
    +
    + +

    Convert (95,91) grid to (3447) grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft16 (ALOLA, BTHIN, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (95,91) grid to (3447) grid.

    +
    Author
    Ralph Jones
    +
    Date
    1994-05-03
    + +

    Definition in file w3ft16.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft16()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft16 (real, dimension(95,91) ALOLA,
    real, dimension(npts) BTHIN,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    95 by 91 grid to a wafs 1.25 degree thinned 3447 point grid.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1994-05-03 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA95 * 91 grid 1.0 deg. lat,lon grid northern hemisphere 8645 point grid.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]BTHIN3447 point thinned grid of n. hemispere 3447 grid is for grib grids 37-40.
    +
    +
    +
    Note
      +
    • W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine. 10 other arrays are saved and reused on the next call.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1994-05-03
    + +

    Definition at line 24 of file w3ft16.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft16_8f.js b/ver-2.10.0/w3ft16_8f.js new file mode 100644 index 00000000..5ed303b6 --- /dev/null +++ b/ver-2.10.0/w3ft16_8f.js @@ -0,0 +1,4 @@ +var w3ft16_8f = +[ + [ "w3ft16", "w3ft16_8f.html#a3eb1bcdeb5163086f4e319d036fa9b8f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft16_8f_source.html b/ver-2.10.0/w3ft16_8f_source.html new file mode 100644 index 00000000..dafc4613 --- /dev/null +++ b/ver-2.10.0/w3ft16_8f_source.html @@ -0,0 +1,303 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft16.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft16.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (95,91) grid to (3447) grid
    +
    3 C> @author Ralph Jones @date 1994-05-03
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 95 by
    +
    6 C> 91 grid to a wafs 1.25 degree thinned 3447 point grid.
    +
    7 C>
    +
    8 C> ### Program History Log:
    +
    9 C> Date | Programmer | Comment
    +
    10 C> -----|------------|--------
    +
    11 C> 1994-05-03 | Ralph Jones | Initial.
    +
    12 C>
    +
    13 C> @param[in] ALOLA 95 * 91 grid 1.0 deg. lat,lon grid northern hemisphere 8645 point grid.
    +
    14 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    15 C> @param[out] BTHIN 3447 point thinned grid of n. hemispere 3447 grid is for grib grids 37-40.
    +
    16 C>
    +
    17 C> @note
    +
    18 C> - W1 and w2 are used to store sets of constants which are
    +
    19 C> reusable for repeated calls to the subroutine. 10 other arrays
    +
    20 C> are saved and reused on the next call.
    +
    21 C>
    +
    22 C> @author Ralph Jones @date 1994-05-03
    +
    23  SUBROUTINE w3ft16(ALOLA,BTHIN,INTERP)
    +
    24 C
    +
    25  parameter(npts=3447)
    +
    26 C
    +
    27  REAL SEP(73)
    +
    28  REAL ALOLA(95,91), BTHIN(NPTS), ERAS(NPTS,4)
    +
    29  REAL W1(NPTS), W2(NPTS)
    +
    30  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    31  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    32 C
    +
    33  INTEGER NPT(73)
    +
    34  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    35  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    36 C
    +
    37  LOGICAL LIN
    +
    38 C
    +
    39  SAVE
    +
    40 C
    +
    41  DATA intrpo/99/
    +
    42  DATA iswt /0/
    +
    43 C
    +
    44 C GRID POINT SEPARATION
    +
    45 C
    +
    46  DATA sep /1.250, 1.250, 1.250, 1.250, 1.250, 1.250,
    +
    47  & 1.250, 1.250, 1.268, 1.268, 1.268, 1.286,
    +
    48  & 1.286, 1.286, 1.304, 1.304, 1.324, 1.324,
    +
    49  & 1.343, 1.364, 1.364, 1.385, 1.406, 1.406,
    +
    50  & 1.429, 1.452, 1.475, 1.500, 1.525, 1.525,
    +
    51  & 1.552, 1.579, 1.607, 1.636, 1.667, 1.698,
    +
    52  & 1.765, 1.800, 1.837, 1.875, 1.915, 1.957,
    +
    53  & 2.045, 2.093, 2.143, 2.195, 2.308, 2.368,
    +
    54  & 2.432, 2.571, 2.647, 2.813, 2.903, 3.103,
    +
    55  & 3.214, 3.333, 3.600, 3.750, 4.091, 4.286,
    +
    56  & 4.737, 5.000, 5.625, 6.000, 6.923, 8.182,
    +
    57  & 9.000,11.250,12.857,18.000,22.500,45.000,
    +
    58  & 90.000/
    +
    59 C
    +
    60 C NUMBER OF POINTS ALONG LAT CIRCLE FOR ONE OCTANT
    +
    61 C
    +
    62  DATA npt / 73, 73, 73, 73, 73, 73,
    +
    63  & 73, 73, 72, 72, 72, 71,
    +
    64  & 71, 71, 70, 70, 69, 69,
    +
    65  & 68, 67, 67, 66, 65, 65,
    +
    66  & 64, 63, 62, 61, 60, 60,
    +
    67  & 59, 58, 57, 56, 55, 54,
    +
    68  & 52, 51, 50, 49, 48, 47,
    +
    69  & 45, 44, 43, 42, 40, 39,
    +
    70  & 38, 36, 35, 33, 32, 30,
    +
    71  & 29, 28, 26, 25, 23, 22,
    +
    72  & 20, 19, 17, 16, 14, 12,
    +
    73  & 11, 9, 8, 6, 5, 3,
    +
    74  & 2/
    +
    75 C
    +
    76  lin = .false.
    +
    77  IF (interp.EQ.1) lin = .true.
    +
    78 C
    +
    79  IF (iswt.EQ.1) GO TO 900
    +
    80 C
    +
    81  ijout = 0
    +
    82  DO 200 j = 1,73
    +
    83  xjou = (j-1) * 1.25 + 1.0
    +
    84  ii = npt(j)
    +
    85  rdglat = sep(j)
    +
    86  DO 100 i = 1,ii
    +
    87  ijout = ijout + 1
    +
    88  w1(ijout) = (i-1) * rdglat + 3.0
    +
    89  w2(ijout) = xjou
    +
    90  100 CONTINUE
    +
    91  200 CONTINUE
    +
    92 C
    +
    93  iswt = 1
    +
    94  intrpo = interp
    +
    95  GO TO 1000
    +
    96 C
    +
    97 C AFTER THE 1ST CALL TO W3FT16 TEST INTERP, IF IT HAS
    +
    98 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    99 C
    +
    100  900 CONTINUE
    +
    101  IF (interp.EQ.intrpo) GO TO 2100
    +
    102  intrpo = interp
    +
    103 C
    +
    104  1000 CONTINUE
    +
    105  DO 1100 k = 1,npts
    +
    106  iv(k) = w1(k)
    +
    107  jv(k) = w2(k)
    +
    108  xdeli(k) = w1(k) - iv(k)
    +
    109  xdelj(k) = w2(k) - jv(k)
    +
    110  ip1(k) = iv(k) + 1
    +
    111  jy(k,3) = jv(k) + 1
    +
    112  jy(k,2) = jv(k)
    +
    113  1100 CONTINUE
    +
    114 C
    +
    115  IF (lin) GO TO 1400
    +
    116 C
    +
    117  DO 1200 k = 1,npts
    +
    118  ip2(k) = iv(k) + 2
    +
    119  im1(k) = iv(k) - 1
    +
    120  jy(k,1) = jv(k) - 1
    +
    121  jy(k,4) = jv(k) + 2
    +
    122  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    123  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    124  1200 CONTINUE
    +
    125 C
    +
    126  1400 CONTINUE
    +
    127 C
    +
    128  IF (lin) GO TO 1700
    +
    129 C
    +
    130  DO 1500 kk = 1,npts
    +
    131  IF (jv(kk).LT.2.OR.jv(kk).GE.90) xj2tm(kk) = 0.0
    +
    132  1500 CONTINUE
    +
    133 C
    +
    134 C LINEAR INTERPOLATION
    +
    135 C
    +
    136  1700 CONTINUE
    +
    137  DO 1900 kk = 1,npts
    +
    138  IF (jy(kk,3).GT.91) jy(kk,3) = 91
    +
    139  1900 CONTINUE
    +
    140 C
    +
    141  IF (.NOT.lin) THEN
    +
    142  DO 2000 kk = 1,npts
    +
    143  IF (jy(kk,1).LT.1) jy(kk,1) = 1
    +
    144  IF (jy(kk,4).GT.91) jy(kk,4) = 91
    +
    145  2000 CONTINUE
    +
    146  ENDIF
    +
    147 C
    +
    148  2100 CONTINUE
    +
    149  IF (lin) THEN
    +
    150 C
    +
    151 C LINEAR INTERPOLATION
    +
    152 C
    +
    153  DO 2200 kk = 1,npts
    +
    154  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    155  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    156  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    157  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    158  2200 CONTINUE
    +
    159 C
    +
    160  DO 2300 kk = 1,npts
    +
    161  bthin(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    162  & * xdelj(kk)
    +
    163  2300 CONTINUE
    +
    164 C
    +
    165  ELSE
    +
    166 C
    +
    167 C QUADRATIC INTERPOLATION
    +
    168 C
    +
    169  DO 2400 kk = 1,npts
    +
    170  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    171  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    172  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    173  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    174  & * xi2tm(kk)
    +
    175  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    176  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    177  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    178  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    179  & * xi2tm(kk)
    +
    180  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    181  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    182  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    183  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    184  & * xi2tm(kk)
    +
    185  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    186  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    187  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    188  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    189  & * xi2tm(kk)
    +
    190  2400 CONTINUE
    +
    191 C
    +
    192  DO 2500 kk = 1,npts
    +
    193  bthin(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    194  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    195  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    196  2500 CONTINUE
    +
    197 C
    +
    198  ENDIF
    +
    199 C
    +
    200  RETURN
    +
    201  END
    +
    +
    +
    w3ft16
    subroutine w3ft16(ALOLA, BTHIN, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft16.f:24
    + + + + diff --git a/ver-2.10.0/w3ft17_8f.html b/ver-2.10.0/w3ft17_8f.html new file mode 100644 index 00000000..bb4b2c6b --- /dev/null +++ b/ver-2.10.0/w3ft17_8f.html @@ -0,0 +1,183 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft17.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft17.f File Reference
    +
    +
    + +

    Convert (95,91) grid to (3447) grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft17 (ALOLA, BTHIN, INTERP)
     Convert a southern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (95,91) grid to (3447) grid.

    +
    Author
    Ralph Jones
    +
    Date
    1994-05-03
    + +

    Definition in file w3ft17.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft17()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft17 (real, dimension(95,91) ALOLA,
    real, dimension(npts) BTHIN,
     INTERP 
    )
    +
    + +

    Convert a southern hemisphere 1.0 degree lat.,lon.

    +

    95 by 91 grid to a wafs 1.25 degree thinned 3447 point grid.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1994-05-03 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA95 * 91 grid 1.0 deg. lat,lon grid southern hemisphere 8645 point grid.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]BTHIN3447 point thinned grid of s. hemispere 3447 grid is for grib grids 41-44.
    +
    +
    +
    Note
      +
    • w1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine. 10 other arrays are saved and reused on the next call.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1994-05-03
    + +

    Definition at line 24 of file w3ft17.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft17_8f.js b/ver-2.10.0/w3ft17_8f.js new file mode 100644 index 00000000..cb2c7641 --- /dev/null +++ b/ver-2.10.0/w3ft17_8f.js @@ -0,0 +1,4 @@ +var w3ft17_8f = +[ + [ "w3ft17", "w3ft17_8f.html#ac26d2dfc790515275a019ab4588f0751", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft17_8f_source.html b/ver-2.10.0/w3ft17_8f_source.html new file mode 100644 index 00000000..2bca66ba --- /dev/null +++ b/ver-2.10.0/w3ft17_8f_source.html @@ -0,0 +1,304 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft17.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft17.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (95,91) grid to (3447) grid
    +
    3 C> @author Ralph Jones @date 1994-05-03
    +
    4 
    +
    5 C> Convert a southern hemisphere 1.0 degree lat.,lon. 95 by
    +
    6 C> 91 grid to a wafs 1.25 degree thinned 3447 point grid.
    +
    7 C>
    +
    8 C> ### Program History Log:
    +
    9 C> Date | Programmer | Comment
    +
    10 C> -----|------------|--------
    +
    11 C> 1994-05-03 | Ralph Jones | Initial.
    +
    12 C>
    +
    13 C> @param[in] ALOLA 95 * 91 grid 1.0 deg. lat,lon grid southern hemisphere 8645 point grid.
    +
    14 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    15 C> @param[out] BTHIN 3447 point thinned grid of s. hemispere 3447 grid is for grib grids 41-44.
    +
    16 C>
    +
    17 C> @note
    +
    18 C> - w1 and w2 are used to store sets of constants which are
    +
    19 C> reusable for repeated calls to the subroutine. 10 other arrays
    +
    20 C> are saved and reused on the next call.
    +
    21 C>
    +
    22 C> @author Ralph Jones @date 1994-05-03
    +
    23  SUBROUTINE w3ft17(ALOLA,BTHIN,INTERP)
    +
    24 C
    +
    25  parameter(npts=3447)
    +
    26 C
    +
    27  REAL SEP(73)
    +
    28  REAL ALOLA(95,91), BTHIN(NPTS), ERAS(NPTS,4)
    +
    29  REAL W1(NPTS), W2(NPTS)
    +
    30  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    31  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    32 C
    +
    33  INTEGER NPT(73)
    +
    34  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    35  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    36 C
    +
    37  LOGICAL LIN
    +
    38 C
    +
    39  SAVE
    +
    40 C
    +
    41  DATA intrpo/99/
    +
    42  DATA iswt /0/
    +
    43 C
    +
    44 C GRID POINT SEPARATION
    +
    45 C
    +
    46  DATA sep /1.250, 1.250, 1.250, 1.250, 1.250, 1.250,
    +
    47  & 1.250, 1.250, 1.268, 1.268, 1.268, 1.286,
    +
    48  & 1.286, 1.286, 1.304, 1.304, 1.324, 1.324,
    +
    49  & 1.343, 1.364, 1.364, 1.385, 1.406, 1.406,
    +
    50  & 1.429, 1.452, 1.475, 1.500, 1.525, 1.525,
    +
    51  & 1.552, 1.579, 1.607, 1.636, 1.667, 1.698,
    +
    52  & 1.765, 1.800, 1.837, 1.875, 1.915, 1.957,
    +
    53  & 2.045, 2.093, 2.143, 2.195, 2.308, 2.368,
    +
    54  & 2.432, 2.571, 2.647, 2.813, 2.903, 3.103,
    +
    55  & 3.214, 3.333, 3.600, 3.750, 4.091, 4.286,
    +
    56  & 4.737, 5.000, 5.625, 6.000, 6.923, 8.182,
    +
    57  & 9.000,11.250,12.857,18.000,22.500,45.000,
    +
    58  & 90.000/
    +
    59 C
    +
    60 C NUMBER OF POINTS ALONG LAT CIRCLE FOR ONE OCTANT
    +
    61 C
    +
    62  DATA npt / 73, 73, 73, 73, 73, 73,
    +
    63  & 73, 73, 72, 72, 72, 71,
    +
    64  & 71, 71, 70, 70, 69, 69,
    +
    65  & 68, 67, 67, 66, 65, 65,
    +
    66  & 64, 63, 62, 61, 60, 60,
    +
    67  & 59, 58, 57, 56, 55, 54,
    +
    68  & 52, 51, 50, 49, 48, 47,
    +
    69  & 45, 44, 43, 42, 40, 39,
    +
    70  & 38, 36, 35, 33, 32, 30,
    +
    71  & 29, 28, 26, 25, 23, 22,
    +
    72  & 20, 19, 17, 16, 14, 12,
    +
    73  & 11, 9, 8, 6, 5, 3,
    +
    74  & 2/
    +
    75 C
    +
    76  lin = .false.
    +
    77  IF (interp.EQ.1) lin = .true.
    +
    78 C
    +
    79  IF (iswt.EQ.1) GO TO 900
    +
    80 C
    +
    81  ijout = 0
    +
    82  DO 200 j = 1,73
    +
    83  xjou = (j-1) * 1.25 + 1.0
    +
    84  ii = npt(74-j)
    +
    85  rdglat = sep(74-j)
    +
    86  DO 100 i = 1,ii
    +
    87  ijout = ijout + 1
    +
    88  w1(ijout) = (i-1) * rdglat + 3.0
    +
    89  w2(ijout) = xjou
    +
    90  100 CONTINUE
    +
    91  200 CONTINUE
    +
    92 C
    +
    93  iswt = 1
    +
    94  intrpo = interp
    +
    95  GO TO 1000
    +
    96 C
    +
    97 C AFTER THE 1ST CALL TO W3FT17 TEST INTERP, IF IT HAS
    +
    98 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    99 C
    +
    100  900 CONTINUE
    +
    101  IF (interp.EQ.intrpo) GO TO 2100
    +
    102  intrpo = interp
    +
    103 C
    +
    104  1000 CONTINUE
    +
    105  DO 1100 k = 1,npts
    +
    106  iv(k) = w1(k)
    +
    107  jv(k) = w2(k)
    +
    108  xdeli(k) = w1(k) - iv(k)
    +
    109  xdelj(k) = w2(k) - jv(k)
    +
    110  ip1(k) = iv(k) + 1
    +
    111  jy(k,3) = jv(k) + 1
    +
    112  jy(k,2) = jv(k)
    +
    113  1100 CONTINUE
    +
    114 C
    +
    115  IF (lin) GO TO 1400
    +
    116 C
    +
    117  DO 1200 k = 1,npts
    +
    118  ip2(k) = iv(k) + 2
    +
    119  im1(k) = iv(k) - 1
    +
    120  jy(k,1) = jv(k) - 1
    +
    121  jy(k,4) = jv(k) + 2
    +
    122  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    123  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    124  1200 CONTINUE
    +
    125 C
    +
    126  1400 CONTINUE
    +
    127 C
    +
    128  IF (lin) GO TO 1700
    +
    129 C
    +
    130  DO 1500 kk = 1,npts
    +
    131  IF (jv(kk).LT.2.OR.jv(kk).GE.90) xj2tm(kk) = 0.0
    +
    132  1500 CONTINUE
    +
    133 C
    +
    134  1700 CONTINUE
    +
    135 C
    +
    136 C LINEAR INTERPOLATION
    +
    137 C
    +
    138  DO 1900 kk = 1,npts
    +
    139  IF (jy(kk,3).GT.91) jy(kk,3) = 91
    +
    140  1900 CONTINUE
    +
    141 C
    +
    142  IF (.NOT.lin) THEN
    +
    143  DO 2000 kk = 1,npts
    +
    144  IF (jy(kk,1).LT.1) jy(kk,1) = 1
    +
    145  IF (jy(kk,4).GT.91) jy(kk,4) = 91
    +
    146  2000 CONTINUE
    +
    147  ENDIF
    +
    148 C
    +
    149  2100 CONTINUE
    +
    150  IF (lin) THEN
    +
    151 C
    +
    152 C LINEAR INTERPOLATION
    +
    153 C
    +
    154  DO 2200 kk = 1,npts
    +
    155  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    156  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    157  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    158  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    159  2200 CONTINUE
    +
    160 C
    +
    161  DO 2300 kk = 1,npts
    +
    162  bthin(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    163  & * xdelj(kk)
    +
    164  2300 CONTINUE
    +
    165 C
    +
    166  ELSE
    +
    167 C
    +
    168 C QUADRATIC INTERPOLATION
    +
    169 C
    +
    170  DO 2400 kk = 1,npts
    +
    171  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    172  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    173  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    174  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    175  & * xi2tm(kk)
    +
    176  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    177  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    178  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    179  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    180  & * xi2tm(kk)
    +
    181  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    182  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    183  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    184  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    185  & * xi2tm(kk)
    +
    186  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    187  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    188  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    189  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    190  & * xi2tm(kk)
    +
    191  2400 CONTINUE
    +
    192 C
    +
    193  DO 2500 kk = 1,npts
    +
    194  bthin(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    195  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    196  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    197  2500 CONTINUE
    +
    198 C
    +
    199  ENDIF
    +
    200 C
    +
    201  RETURN
    +
    202  END
    +
    +
    +
    w3ft17
    subroutine w3ft17(ALOLA, BTHIN, INTERP)
    Convert a southern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft17.f:24
    + + + + diff --git a/ver-2.10.0/w3ft201_8f.html b/ver-2.10.0/w3ft201_8f.html new file mode 100644 index 00000000..d0045223 --- /dev/null +++ b/ver-2.10.0/w3ft201_8f.html @@ -0,0 +1,185 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft201.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft201.f File Reference
    +
    +
    + +

    Convert (361,181) grid to (65,65) n. hemi. grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft201 (ALOLA, APOLA, INTERP)
     Convert a global 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,181) grid to (65,65) n. hemi. grid.

    +
    Author
    Ralph Jones
    +
    Date
    1993-03-29
    + +

    Definition in file w3ft201.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft201()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft201 (real, dimension(361,181) ALOLA,
    real, dimension(npts) APOLA,
     INTERP 
    )
    +
    + +

    Convert a global 1.0 degree lat.,lon.

    +

    361 by 181 grid to a polar stereographic 65 by 65 grid. The polar stereographic map projection is true at 60 deg. n. , the mesh length is 381 km. and the oriention is 105 deg. w. This is the same as w3ft43v() except the oriention is 105 deg. w.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1993-03-29 Ralph Jones Add save statement.
    +
    Parameters
    + + + + +
    [in]ALOLA361*181 grid 1.0 deg. lat,lon grid 65341 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to right side to make 361 * 181.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]APOLA65*65 grid of northern hemisphere. 4225 point grid is awips grid type 201
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine.
      • +
    • 2. Wind components are not rotated to the 65*65 grid orientation after interpolation. You may use w3fc08() to do this.
      • +
    • 3. All points below equator are on this grid.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1993-03-29
    + +

    Definition at line 32 of file w3ft201.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft201_8f.js b/ver-2.10.0/w3ft201_8f.js new file mode 100644 index 00000000..7215b09e --- /dev/null +++ b/ver-2.10.0/w3ft201_8f.js @@ -0,0 +1,4 @@ +var w3ft201_8f = +[ + [ "w3ft201", "w3ft201_8f.html#adf01350dac0812280321527151e91c76", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft201_8f_source.html b/ver-2.10.0/w3ft201_8f_source.html new file mode 100644 index 00000000..d4587766 --- /dev/null +++ b/ver-2.10.0/w3ft201_8f_source.html @@ -0,0 +1,351 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft201.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft201.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,181) grid to (65,65) n. hemi. grid
    +
    3 C> @author Ralph Jones @date 1993-03-29
    +
    4 
    +
    5 C> Convert a global 1.0 degree lat.,lon. 361 by
    +
    6 C> 181 grid to a polar stereographic 65 by 65 grid. The polar
    +
    7 C> stereographic map projection is true at 60 deg. n. , the mesh
    +
    8 C> length is 381 km. and the oriention is 105 deg. w. This is the
    +
    9 C> same as w3ft43v() except the oriention is 105 deg. w.
    +
    10 C>
    +
    11 C> ### Program History Log:
    +
    12 C> Date | Programmer | Comment
    +
    13 C> -----|------------|--------
    +
    14 C> 1993-03-29 | Ralph Jones | Add save statement.
    +
    15 C>
    +
    16 C> @param[in] ALOLA 361*181 grid 1.0 deg. lat,lon grid
    +
    17 C> 65341 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    18 C> to right side to make 361 * 181.
    +
    19 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    20 C> @param[out] APOLA 65*65 grid of northern hemisphere. 4225 point grid is
    +
    21 C> awips grid type 201
    +
    22 C>
    +
    23 C> @note
    +
    24 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    25 C> reusable for repeated calls to the subroutine.
    +
    26 C> - 2. Wind components are not rotated to the 65*65 grid orientation
    +
    27 C> after interpolation. You may use w3fc08() to do this.
    +
    28 C> - 3. All points below equator are on this grid.
    +
    29 C>
    +
    30 C> @author Ralph Jones @date 1993-03-29
    +
    31  SUBROUTINE w3ft201(ALOLA,APOLA,INTERP)
    +
    32 C
    +
    33  parameter(npts=4225,ii=65,jj=65)
    +
    34  parameter(orient=105.0,ipole=33,jpole=33)
    +
    35  parameter(xmesh=381.0)
    +
    36 C
    +
    37  REAL R2(NPTS), WLON(NPTS)
    +
    38  REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ)
    +
    39  REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS)
    +
    40  REAL ALOLA(361,181), APOLA(NPTS), ERAS(NPTS,4)
    +
    41  REAL W1(NPTS), W2(NPTS)
    +
    42  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    43  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    44 C
    +
    45  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    46  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    47 C
    +
    48  LOGICAL LIN
    +
    49 C
    +
    50  SAVE
    +
    51 C
    +
    52  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    53 C
    +
    54  DATA degprd/57.2957795/
    +
    55  DATA earthr/6371.2/
    +
    56  DATA intrpo/99/
    +
    57  DATA iswt /0/
    +
    58 C
    +
    59  lin = .false.
    +
    60  IF (interp.EQ.1) lin = .true.
    +
    61 C
    +
    62  IF (iswt.EQ.1) GO TO 900
    +
    63 C
    +
    64  deg = 1.0
    +
    65  gi2 = (1.86603 * earthr) / xmesh
    +
    66  gi2 = gi2 * gi2
    +
    67 C
    +
    68 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE
    +
    69 C
    +
    70  DO 100 j = 1,jj
    +
    71  xj1 = j - jpole
    +
    72  DO 100 i = 1,ii
    +
    73  xi(i,j) = i - ipole
    +
    74  xj(i,j) = xj1
    +
    75  100 CONTINUE
    +
    76 C
    +
    77  DO 200 kk = 1,npts
    +
    78  r2(kk) = xjj(kk) * xjj(kk) + xii(kk) * xii(kk)
    +
    79  xlat(kk) = degprd *
    +
    80  & asin((gi2 - r2(kk)) / (gi2 + r2(kk)))
    +
    81  200 CONTINUE
    +
    82 C
    +
    83  xii(2113) = 1.0
    +
    84  DO 300 kk = 1,npts
    +
    85  angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    86  300 CONTINUE
    +
    87 C
    +
    88  DO 400 kk = 1,npts
    +
    89  IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    90  400 CONTINUE
    +
    91 C
    +
    92  DO 500 kk = 1,npts
    +
    93  wlon(kk) = 270.0 + orient - angle(kk)
    +
    94  500 CONTINUE
    +
    95 C
    +
    96  DO 600 kk = 1,npts
    +
    97  IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    98  600 CONTINUE
    +
    99 C
    +
    100  DO 700 kk = 1,npts
    +
    101  IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    102  700 CONTINUE
    +
    103 C
    +
    104  xlat(2113) = 90.0
    +
    105  wlon(2113) = 0.0
    +
    106 C
    +
    107  DO 800 kk = 1,npts
    +
    108  w1(kk) = (360.0 - wlon(kk)) / deg + 1.0
    +
    109  w2(kk) = xlat(kk) / deg + 91.0
    +
    110  800 CONTINUE
    +
    111 C
    +
    112  iswt = 1
    +
    113  intrpo = interp
    +
    114  GO TO 1000
    +
    115 C
    +
    116 C AFTER THE 1ST CALL TO W3FT201 TEST INTERP, IF IT HAS
    +
    117 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    118 C
    +
    119  900 CONTINUE
    +
    120  IF (interp.EQ.intrpo) GO TO 2100
    +
    121  intrpo = interp
    +
    122 C
    +
    123  1000 CONTINUE
    +
    124  DO 1100 k = 1,npts
    +
    125  iv(k) = w1(k)
    +
    126  jv(k) = w2(k)
    +
    127  xdeli(k) = w1(k) - iv(k)
    +
    128  xdelj(k) = w2(k) - jv(k)
    +
    129  ip1(k) = iv(k) + 1
    +
    130  jy(k,3) = jv(k) + 1
    +
    131  jy(k,2) = jv(k)
    +
    132  1100 CONTINUE
    +
    133 C
    +
    134  IF (lin) GO TO 1400
    +
    135 C
    +
    136  DO 1200 k = 1,npts
    +
    137  ip2(k) = iv(k) + 2
    +
    138  im1(k) = iv(k) - 1
    +
    139  jy(k,1) = jv(k) - 1
    +
    140  jy(k,4) = jv(k) + 2
    +
    141  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    142  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    143  1200 CONTINUE
    +
    144 C
    +
    145  DO 1300 kk = 1,npts
    +
    146  IF (iv(kk).EQ.1) THEN
    +
    147  ip2(kk) = 3
    +
    148  im1(kk) = 360
    +
    149  ELSE IF (iv(kk).EQ.360) THEN
    +
    150  ip2(kk) = 2
    +
    151  im1(kk) = 359
    +
    152  ENDIF
    +
    153  1300 CONTINUE
    +
    154 C
    +
    155  1400 CONTINUE
    +
    156 C
    +
    157  IF (lin) GO TO 1700
    +
    158 C
    +
    159  DO 1500 kk = 1,npts
    +
    160  IF (jv(kk).GE.180) xj2tm(kk) = 0.0
    +
    161  1500 CONTINUE
    +
    162 C
    +
    163  DO 1600 kk = 1,npts
    +
    164  IF (ip2(kk).LT.1) ip2(kk) = 1
    +
    165  IF (im1(kk).LT.1) im1(kk) = 1
    +
    166  IF (ip2(kk).GT.361) ip2(kk) = 361
    +
    167  IF (im1(kk).GT.361) im1(kk) = 361
    +
    168  1600 CONTINUE
    +
    169 C
    +
    170  1700 CONTINUE
    +
    171  DO 1800 kk = 1,npts
    +
    172  IF (iv(kk).LT.1) iv(kk) = 1
    +
    173  IF (ip1(kk).LT.1) ip1(kk) = 1
    +
    174  IF (iv(kk).GT.361) iv(kk) = 361
    +
    175  IF (ip1(kk).GT.361) ip1(kk) = 361
    +
    176  1800 CONTINUE
    +
    177 C
    +
    178 C LINEAR INTERPOLATION
    +
    179 C
    +
    180  DO 1900 kk = 1,npts
    +
    181  IF (jy(kk,2).GT.181) jy(kk,2) = 181
    +
    182  IF (jy(kk,3).GT.181) jy(kk,3) = 181
    +
    183  1900 CONTINUE
    +
    184 C
    +
    185  IF (.NOT.lin) THEN
    +
    186  DO 2000 kk = 1,npts
    +
    187  IF (jy(kk,1).GT.181) jy(kk,1) = 181
    +
    188  IF (jy(kk,4).GT.181) jy(kk,4) = 181
    +
    189  2000 CONTINUE
    +
    190  ENDIF
    +
    191 C
    +
    192  2100 CONTINUE
    +
    193  IF (lin) THEN
    +
    194 C
    +
    195 C LINEAR INTERPOLATION
    +
    196 C
    +
    197  DO 2200 kk = 1,npts
    +
    198  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    199  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    200  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    201  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    202  2200 CONTINUE
    +
    203 C
    +
    204  DO 2300 kk = 1,npts
    +
    205  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    206  & * xdelj(kk)
    +
    207  2300 CONTINUE
    +
    208 C
    +
    209  ELSE
    +
    210 C
    +
    211 C QUADRATIC INTERPOLATION
    +
    212 C
    +
    213  DO 2400 kk = 1,npts
    +
    214  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    215  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    216  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    217  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    218  & * xi2tm(kk)
    +
    219  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    220  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    221  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    222  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    223  & * xi2tm(kk)
    +
    224  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    225  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    226  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    227  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    228  & * xi2tm(kk)
    +
    229  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    230  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    231  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    232  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    233  & * xi2tm(kk)
    +
    234  2400 CONTINUE
    +
    235 C
    +
    236  DO 2500 kk = 1,npts
    +
    237  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    238  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    239  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    240  2500 CONTINUE
    +
    241 C
    +
    242  ENDIF
    +
    243 C
    +
    244 C SET POLE POINT , WMO STANDARD FOR U OR V
    +
    245 C
    +
    246  apola(2113) = alola(181,181)
    +
    247 C
    +
    248  RETURN
    +
    249  END
    +
    +
    +
    w3ft201
    subroutine w3ft201(ALOLA, APOLA, INTERP)
    Convert a global 1.0 degree lat.,lon.
    Definition: w3ft201.f:32
    + + + + diff --git a/ver-2.10.0/w3ft202_8f.html b/ver-2.10.0/w3ft202_8f.html new file mode 100644 index 00000000..87597d35 --- /dev/null +++ b/ver-2.10.0/w3ft202_8f.html @@ -0,0 +1,185 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft202.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft202.f File Reference
    +
    +
    + +

    Convert (361,91) grid to (65,43) n. hemi. grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft202 (ALOLA, APOLA, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,91) grid to (65,43) n. hemi. grid.

    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition in file w3ft202.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft202()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft202 (real, dimension(361,91) ALOLA,
    real, dimension(npts) APOLA,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    361 by 91 grid to a polar stereographic 65 by 43 grid. The polar stereographic map projection is true at 60 deg. n. , The mesh length is 190.5 km. and the oriention is 105 deg. w.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1994-05-18 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA361*91 grid 1.0 lat,lon grid n. hemisphere 32851 point grid is o.n. 84 type ?? or ?? hex
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]APOLA65*43 grid of northern hemisphere. 2795 point grid is awips grid type 202
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine.
      • +
    • 2. Wind components are not rotated to the 65*43 grid orientation after interpolation. You may use w3fc08() to do this.
      • +
    • 3. The grid points values on the equator have been extrapolated outward to all the grid points outside the equator on the 65*43 grid (about 1100 points).
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition at line 32 of file w3ft202.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft202_8f.js b/ver-2.10.0/w3ft202_8f.js new file mode 100644 index 00000000..3299147c --- /dev/null +++ b/ver-2.10.0/w3ft202_8f.js @@ -0,0 +1,4 @@ +var w3ft202_8f = +[ + [ "w3ft202", "w3ft202_8f.html#a250a1c3e5855f0481b17a3bf264cb2cd", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft202_8f_source.html b/ver-2.10.0/w3ft202_8f_source.html new file mode 100644 index 00000000..351caeb3 --- /dev/null +++ b/ver-2.10.0/w3ft202_8f_source.html @@ -0,0 +1,296 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft202.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft202.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,91) grid to (65,43) n. hemi. grid
    +
    3 C> @author Ralph Jones @date 1994-05-18
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 91 grid to a polar stereographic 65 by 43 grid. The polar
    +
    7 C> stereographic map projection is true at 60 deg. n. , The mesh
    +
    8 C> length is 190.5 km. and the oriention is 105 deg. w.
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comment
    +
    12 C> -----|------------|--------
    +
    13 C> 1994-05-18 | Ralph Jones | Initial.
    +
    14 C>
    +
    15 C> @param[in] ALOLA 361*91 grid 1.0 lat,lon grid n. hemisphere 32851 point
    +
    16 C> grid is o.n. 84 type ?? or ?? hex
    +
    17 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    18 C> @param[out] APOLA 65*43 grid of northern hemisphere. 2795 point grid is
    +
    19 C> awips grid type 202
    +
    20 C>
    +
    21 C> @note
    +
    22 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    23 C> reusable for repeated calls to the subroutine.
    +
    24 C> - 2. Wind components are not rotated to the 65*43 grid orientation
    +
    25 C> after interpolation. You may use w3fc08() to do this.
    +
    26 C> - 3. The grid points values on the equator have been extrapolated
    +
    27 C> outward to all the grid points outside the equator on the 65*43
    +
    28 C> grid (about 1100 points).
    +
    29 C>
    +
    30 C> @author Ralph Jones @date 1994-05-18
    +
    31  SUBROUTINE w3ft202(ALOLA,APOLA,INTERP)
    +
    32 C
    +
    33  parameter(npts=2795,ii=65,jj=43)
    +
    34  parameter(orient=105.0,ipole=33,jpole=45)
    +
    35  parameter(xmesh=190.5)
    +
    36 C
    +
    37  REAL R2(NPTS), WLON(NPTS)
    +
    38  REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ)
    +
    39  REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS)
    +
    40  REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4)
    +
    41  REAL W1(NPTS), W2(NPTS)
    +
    42  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    43  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    44 C
    +
    45  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    46  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    47 C
    +
    48  LOGICAL LIN
    +
    49 C
    +
    50  SAVE
    +
    51 C
    +
    52  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    53 C
    +
    54  DATA degprd/57.2957795/
    +
    55  DATA earthr/6371.2/
    +
    56  DATA intrpo/99/
    +
    57  DATA iswt /0/
    +
    58 C
    +
    59  lin = .false.
    +
    60  IF (interp.EQ.1) lin = .true.
    +
    61 C
    +
    62  IF (iswt.EQ.1) GO TO 900
    +
    63 C
    +
    64  deg = 1.0
    +
    65  gi2 = (1.86603 * earthr) / xmesh
    +
    66  gi2 = gi2 * gi2
    +
    67 C
    +
    68 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE
    +
    69 C
    +
    70  DO 100 j = 1,jj
    +
    71  xj1 = j - jpole
    +
    72  DO 100 i = 1,ii
    +
    73  xi(i,j) = i - ipole
    +
    74  xj(i,j) = xj1
    +
    75  100 CONTINUE
    +
    76 C
    +
    77  DO 200 kk = 1,npts
    +
    78  r2(kk) = xjj(kk) * xjj(kk) + xii(kk) * xii(kk)
    +
    79  xlat(kk) = degprd *
    +
    80  & asin((gi2 - r2(kk)) / (gi2 + r2(kk)))
    +
    81  200 CONTINUE
    +
    82 C
    +
    83  DO 300 kk = 1,npts
    +
    84  angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    85  300 CONTINUE
    +
    86 C
    +
    87  DO 400 kk = 1,npts
    +
    88  IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    89  400 CONTINUE
    +
    90 C
    +
    91  DO 500 kk = 1,npts
    +
    92  wlon(kk) = 270.0 + orient - angle(kk)
    +
    93  500 CONTINUE
    +
    94 C
    +
    95  DO 600 kk = 1,npts
    +
    96  IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    97  600 CONTINUE
    +
    98 C
    +
    99  DO 700 kk = 1,npts
    +
    100  IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    101  700 CONTINUE
    +
    102 C
    +
    103  DO 800 kk = 1,npts
    +
    104  w1(kk) = (360.0 - wlon(kk)) / deg + 1.0
    +
    105  w2(kk) = xlat(kk) / deg + 1.0
    +
    106  800 CONTINUE
    +
    107 C
    +
    108  iswt = 1
    +
    109  intrpo = interp
    +
    110  GO TO 1000
    +
    111 C
    +
    112 C AFTER THE 1ST CALL TO W3FT202 TEST INTERP, IF IT HAS
    +
    113 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    114 C
    +
    115  900 CONTINUE
    +
    116  IF (interp.EQ.intrpo) GO TO 2100
    +
    117  intrpo = interp
    +
    118 C
    +
    119  1000 CONTINUE
    +
    120  DO 1100 k = 1,npts
    +
    121  iv(k) = w1(k)
    +
    122  jv(k) = w2(k)
    +
    123  xdeli(k) = w1(k) - iv(k)
    +
    124  xdelj(k) = w2(k) - jv(k)
    +
    125  ip1(k) = iv(k) + 1
    +
    126  jy(k,3) = jv(k) + 1
    +
    127  jy(k,2) = jv(k)
    +
    128  1100 CONTINUE
    +
    129 C
    +
    130  IF (lin) GO TO 2100
    +
    131 C
    +
    132  DO 1200 k = 1,npts
    +
    133  ip2(k) = iv(k) + 2
    +
    134  im1(k) = iv(k) - 1
    +
    135  jy(k,1) = jv(k) - 1
    +
    136  jy(k,4) = jv(k) + 2
    +
    137  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    138  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    139  1200 CONTINUE
    +
    140 C
    +
    141  2100 CONTINUE
    +
    142  IF (lin) THEN
    +
    143 C
    +
    144 C LINEAR INTERPOLATION
    +
    145 C
    +
    146  DO 2200 kk = 1,npts
    +
    147  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    148  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    149  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    150  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    151  2200 CONTINUE
    +
    152 C
    +
    153  DO 2300 kk = 1,npts
    +
    154  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    155  & * xdelj(kk)
    +
    156  2300 CONTINUE
    +
    157 C
    +
    158  ELSE
    +
    159 C
    +
    160 C QUADRATIC INTERPOLATION
    +
    161 C
    +
    162  DO 2400 kk = 1,npts
    +
    163  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    164  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    165  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    166  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    167  & * xi2tm(kk)
    +
    168  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    169  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    170  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    171  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    172  & * xi2tm(kk)
    +
    173  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    174  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    175  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    176  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    177  & * xi2tm(kk)
    +
    178  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    179  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    180  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    181  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    182  & * xi2tm(kk)
    +
    183  2400 CONTINUE
    +
    184 C
    +
    185  DO 2500 kk = 1,npts
    +
    186  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    187  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    188  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    189  2500 CONTINUE
    +
    190 C
    +
    191  ENDIF
    +
    192 C
    +
    193  RETURN
    +
    194  END
    +
    +
    +
    w3ft202
    subroutine w3ft202(ALOLA, APOLA, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft202.f:32
    + + + + diff --git a/ver-2.10.0/w3ft203_8f.html b/ver-2.10.0/w3ft203_8f.html new file mode 100644 index 00000000..91441714 --- /dev/null +++ b/ver-2.10.0/w3ft203_8f.html @@ -0,0 +1,184 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft203.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft203.f File Reference
    +
    +
    + +

    Convert (361,91) grid to (45,39) n. hemi. grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft203 (ALOLA, APOLA, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,91) grid to (45,39) n. hemi. grid.

    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition in file w3ft203.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft203()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft203 (real, dimension(361,91) ALOLA,
    real, dimension(npts) APOLA,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    361 by 91 grid to a polar stereographic 45 by 39 grid. The polar stereographic map projection is true at 60 deg. n. , The mesh length is 190.5 km. and the oriention is 150 deg. w.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1994-05-18 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA361*91 grid 1.0 lat,lon grid n. hemisphere 32851 point grid is o.n. 84 type ?? or ?? hex
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]APOLA45*39 grid of northern hemisphere. 1755 point grid is awips grid type 203
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine.
      • +
    • 2. Wind components are not rotated to the 45*39 grid orientation after interpolation. You may use w3fc08() to do this.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition at line 29 of file w3ft203.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft203_8f.js b/ver-2.10.0/w3ft203_8f.js new file mode 100644 index 00000000..6d72b5fc --- /dev/null +++ b/ver-2.10.0/w3ft203_8f.js @@ -0,0 +1,4 @@ +var w3ft203_8f = +[ + [ "w3ft203", "w3ft203_8f.html#ac0fba620647d28d2dfd0424c2d3543e8", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft203_8f_source.html b/ver-2.10.0/w3ft203_8f_source.html new file mode 100644 index 00000000..491f4a6b --- /dev/null +++ b/ver-2.10.0/w3ft203_8f_source.html @@ -0,0 +1,352 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft203.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft203.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,91) grid to (45,39) n. hemi. grid
    +
    3 C> @author Ralph Jones @date 1994-05-18
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 91 grid to a polar stereographic 45 by 39 grid. The polar
    +
    7 C> stereographic map projection is true at 60 deg. n. , The mesh
    +
    8 C> length is 190.5 km. and the oriention is 150 deg. w.
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comment
    +
    12 C> -----|------------|--------
    +
    13 C> 1994-05-18 | Ralph Jones | Initial.
    +
    14 C>
    +
    15 C> @param[in] ALOLA 361*91 grid 1.0 lat,lon grid n. hemisphere
    +
    16 C> 32851 point grid is o.n. 84 type ?? or ?? hex
    +
    17 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    18 C> @param[out] APOLA 45*39 grid of northern hemisphere. 1755 point grid is
    +
    19 C> awips grid type 203
    +
    20 C>
    +
    21 C> @note
    +
    22 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    23 C> reusable for repeated calls to the subroutine.
    +
    24 C> - 2. Wind components are not rotated to the 45*39 grid orientation
    +
    25 C> after interpolation. You may use w3fc08() to do this.
    +
    26 C>
    +
    27 C> @author Ralph Jones @date 1994-05-18
    +
    28  SUBROUTINE w3ft203(ALOLA,APOLA,INTERP)
    +
    29 C
    +
    30  parameter(npts=1755,ii=45,jj=39)
    +
    31  parameter(orient=150.0,ipole=27,jpole=37)
    +
    32  parameter(xmesh=190.5)
    +
    33 C
    +
    34  REAL R2(NPTS), WLON(NPTS)
    +
    35  REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ)
    +
    36  REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS)
    +
    37  REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4)
    +
    38  REAL W1(NPTS), W2(NPTS)
    +
    39  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    40  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    41 C
    +
    42  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    43  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    44 C
    +
    45  LOGICAL LIN
    +
    46 C
    +
    47  SAVE
    +
    48 C
    +
    49  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    50 C
    +
    51  DATA degprd/57.2957795/
    +
    52  DATA earthr/6371.2/
    +
    53  DATA intrpo/99/
    +
    54  DATA iswt /0/
    +
    55 C
    +
    56  lin = .false.
    +
    57  IF (interp.EQ.1) lin = .true.
    +
    58 C
    +
    59  IF (iswt.EQ.1) GO TO 900
    +
    60 C
    +
    61  deg = 1.0
    +
    62  gi2 = (1.86603 * earthr) / xmesh
    +
    63  gi2 = gi2 * gi2
    +
    64 C
    +
    65 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB01 IN LINE
    +
    66 C
    +
    67  DO 100 j = 1,jj
    +
    68  xj1 = j - jpole
    +
    69  DO 100 i = 1,ii
    +
    70  xi(i,j) = i - ipole
    +
    71  xj(i,j) = xj1
    +
    72  100 CONTINUE
    +
    73 C
    +
    74  DO 200 kk = 1,npts
    +
    75  r2(kk) = xjj(kk) * xjj(kk) + xii(kk) * xii(kk)
    +
    76  xlat(kk) = degprd *
    +
    77  & asin((gi2 - r2(kk)) / (gi2 + r2(kk)))
    +
    78  200 CONTINUE
    +
    79 C
    +
    80  xii(1647) = 1.0
    +
    81  DO 300 kk = 1,npts
    +
    82  angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    83  300 CONTINUE
    +
    84 C
    +
    85  DO 400 kk = 1,npts
    +
    86  IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    87  400 CONTINUE
    +
    88 C
    +
    89  DO 500 kk = 1,npts
    +
    90  wlon(kk) = 270.0 + orient - angle(kk)
    +
    91  500 CONTINUE
    +
    92 C
    +
    93  DO 600 kk = 1,npts
    +
    94  IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    95  600 CONTINUE
    +
    96 C
    +
    97  DO 700 kk = 1,npts
    +
    98  IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    99  700 CONTINUE
    +
    100 C
    +
    101  xlat(1647) = 90.0
    +
    102  wlon(1647) = 0.0
    +
    103 C
    +
    104  DO 800 kk = 1,npts
    +
    105  w1(kk) = (360.0 - wlon(kk)) / deg + 1.0
    +
    106  w2(kk) = xlat(kk) / deg + 1.0
    +
    107  800 CONTINUE
    +
    108 C
    +
    109  iswt = 1
    +
    110  intrpo = interp
    +
    111  GO TO 1000
    +
    112 C
    +
    113 C AFTER THE 1ST CALL TO W3FT203 TEST INTERP, IF IT HAS
    +
    114 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    115 C
    +
    116  900 CONTINUE
    +
    117  IF (interp.EQ.intrpo) GO TO 2100
    +
    118  intrpo = interp
    +
    119 C
    +
    120  1000 CONTINUE
    +
    121  DO 1100 k = 1,npts
    +
    122  iv(k) = w1(k)
    +
    123  jv(k) = w2(k)
    +
    124  xdeli(k) = w1(k) - iv(k)
    +
    125  xdelj(k) = w2(k) - jv(k)
    +
    126  ip1(k) = iv(k) + 1
    +
    127  jy(k,3) = jv(k) + 1
    +
    128  jy(k,2) = jv(k)
    +
    129  1100 CONTINUE
    +
    130 C
    +
    131  IF (lin) GO TO 1400
    +
    132 C
    +
    133  DO 1200 k = 1,npts
    +
    134  ip2(k) = iv(k) + 2
    +
    135  im1(k) = iv(k) - 1
    +
    136  jy(k,1) = jv(k) - 1
    +
    137  jy(k,4) = jv(k) + 2
    +
    138  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    139  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    140  1200 CONTINUE
    +
    141 C
    +
    142  DO 1300 kk = 1,npts
    +
    143  IF (iv(kk).EQ.1) THEN
    +
    144  ip2(kk) = 3
    +
    145  im1(kk) = 360
    +
    146  ELSE IF (iv(kk).EQ.360) THEN
    +
    147  ip2(kk) = 2
    +
    148  im1(kk) = 359
    +
    149  ENDIF
    +
    150  1300 CONTINUE
    +
    151 C
    +
    152  1400 CONTINUE
    +
    153 C
    +
    154  IF (lin) GO TO 1700
    +
    155 C
    +
    156  DO 1500 kk = 1,npts
    +
    157  IF (jv(kk).LT.2.OR.jv(kk).GT.89) xj2tm(kk) = 0.0
    +
    158  1500 CONTINUE
    +
    159 C
    +
    160  DO 1600 kk = 1,npts
    +
    161  IF (ip2(kk).LT.1) ip2(kk) = 1
    +
    162  IF (im1(kk).LT.1) im1(kk) = 1
    +
    163  IF (ip2(kk).GT.361) ip2(kk) = 361
    +
    164  IF (im1(kk).GT.361) im1(kk) = 361
    +
    165  1600 CONTINUE
    +
    166 C
    +
    167  1700 CONTINUE
    +
    168  DO 1800 kk = 1,npts
    +
    169  IF (iv(kk).LT.1) iv(kk) = 1
    +
    170  IF (ip1(kk).LT.1) ip1(kk) = 1
    +
    171  IF (iv(kk).GT.361) iv(kk) = 361
    +
    172  IF (ip1(kk).GT.361) ip1(kk) = 361
    +
    173  1800 CONTINUE
    +
    174 C
    +
    175 C LINEAR INTERPOLATION
    +
    176 C
    +
    177  DO 1900 kk = 1,npts
    +
    178  IF (jy(kk,2).LT.1) jy(kk,2) = 1
    +
    179  IF (jy(kk,2).GT.91) jy(kk,2) = 91
    +
    180  IF (jy(kk,3).LT.1) jy(kk,3) = 1
    +
    181  IF (jy(kk,3).GT.91) jy(kk,3) = 91
    +
    182  1900 CONTINUE
    +
    183 C
    +
    184  IF (.NOT.lin) THEN
    +
    185  DO 2000 kk = 1,npts
    +
    186  IF (jy(kk,1).LT.1) jy(kk,1) = 1
    +
    187  IF (jy(kk,1).GT.91) jy(kk,1) = 91
    +
    188  IF (jy(kk,4).LT.1) jy(kk,4) = 1
    +
    189  IF (jy(kk,4).GT.91) jy(kk,4) = 91
    +
    190  2000 CONTINUE
    +
    191  ENDIF
    +
    192 C
    +
    193  2100 CONTINUE
    +
    194  IF (lin) THEN
    +
    195 C
    +
    196 C LINEAR INTERPOLATION
    +
    197 C
    +
    198  DO 2200 kk = 1,npts
    +
    199  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    200  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    201  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    202  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    203  2200 CONTINUE
    +
    204 C
    +
    205  DO 2300 kk = 1,npts
    +
    206  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    207  & * xdelj(kk)
    +
    208  2300 CONTINUE
    +
    209 C
    +
    210  ELSE
    +
    211 C
    +
    212 C QUADRATIC INTERPOLATION
    +
    213 C
    +
    214  DO 2400 kk = 1,npts
    +
    215  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    216  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    217  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    218  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    219  & * xi2tm(kk)
    +
    220  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    221  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    222  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    223  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    224  & * xi2tm(kk)
    +
    225  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    226  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    227  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    228  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    229  & * xi2tm(kk)
    +
    230  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    231  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    232  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    233  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    234  & * xi2tm(kk)
    +
    235  2400 CONTINUE
    +
    236 C
    +
    237  DO 2500 kk = 1,npts
    +
    238  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    239  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    240  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    241  2500 CONTINUE
    +
    242 C
    +
    243 C SET POLE POINT , WMO STANDARD FOR U OR V
    +
    244 C
    +
    245  apola(1647) = alola(181,91)
    +
    246 C
    +
    247  ENDIF
    +
    248 C
    +
    249  RETURN
    +
    250  END
    +
    +
    +
    w3ft203
    subroutine w3ft203(ALOLA, APOLA, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft203.f:29
    + + + + diff --git a/ver-2.10.0/w3ft204_8f.html b/ver-2.10.0/w3ft204_8f.html new file mode 100644 index 00000000..a8061542 --- /dev/null +++ b/ver-2.10.0/w3ft204_8f.html @@ -0,0 +1,183 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft204.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft204.f File Reference
    +
    +
    + +

    Convert (361,181) grid to (93,68) mercator grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft204 (ALOLA, AMERC, INTERP)
     Convert a n. More...
     
    +

    Detailed Description

    +

    Convert (361,181) grid to (93,68) mercator grid.

    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition in file w3ft204.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft204()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft204 (real, dimension(361,181) ALOLA,
    real, dimension(npts) AMERC,
     INTERP 
    )
    +
    + +

    Convert a n.

    +

    s. hemisphere 1.0 degree lat.,lon. 361 by 181 grid to a national - hawaii (mercator) 93*68 awips 204 grid.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1994-05-18 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA361*181 grid 1.0 deg. lat,lon grid n. hemi. 65341 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to right side.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]AMERC93*68 grid national - hawaii (mercator) 6324 point grid is awips grid type 204
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine. 20 other array are saved and reused on the next call.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition at line 27 of file w3ft204.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft204_8f.js b/ver-2.10.0/w3ft204_8f.js new file mode 100644 index 00000000..f42e57fa --- /dev/null +++ b/ver-2.10.0/w3ft204_8f.js @@ -0,0 +1,4 @@ +var w3ft204_8f = +[ + [ "w3ft204", "w3ft204_8f.html#abb78410bc09aaf18f345e4a90c7cff9f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft204_8f_source.html b/ver-2.10.0/w3ft204_8f_source.html new file mode 100644 index 00000000..88a38f73 --- /dev/null +++ b/ver-2.10.0/w3ft204_8f_source.html @@ -0,0 +1,280 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft204.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft204.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,181) grid to (93,68) mercator grid.
    +
    3 C> @author Ralph Jones @date 1994-05-18
    +
    4 
    +
    5 C> Convert a n. s. hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 181 grid to a national - hawaii (mercator) 93*68 awips 204
    +
    7 C> grid.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1994-05-18 | Ralph Jones | Initial.
    +
    13 C>
    +
    14 C> @param[in] ALOLA 361*181 grid 1.0 deg. lat,lon grid n. hemi.
    +
    15 C> 65341 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    16 C> to right side.
    +
    17 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    18 C> @param[out] AMERC 93*68 grid national - hawaii (mercator) 6324 point grid
    +
    19 C> is awips grid type 204
    +
    20 C> @note
    +
    21 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    22 C> reusable for repeated calls to the subroutine. 20 other array
    +
    23 C> are saved and reused on the next call.
    +
    24 C>
    +
    25 C> @author Ralph Jones @date 1994-05-18
    +
    26  SUBROUTINE w3ft204(ALOLA,AMERC,INTERP)
    +
    27 C
    +
    28  parameter(npts=6324,ii=93,jj=68)
    +
    29  parameter(alatin=20.000)
    +
    30  parameter(pi=3.1416)
    +
    31  parameter(dx=160000.0)
    +
    32  parameter(alat1=-25.000)
    +
    33  parameter(alon1=110.000)
    +
    34 C
    +
    35  REAL WLON(NPTS), XLAT(NPTS)
    +
    36  REAL XI(II,JJ), XJ(II,JJ)
    +
    37  REAL XII(NPTS), XJJ(NPTS)
    +
    38  REAL ALOLA(361,181), AMERC(NPTS), ERAS(NPTS,4)
    +
    39  REAL W1(NPTS), W2(NPTS)
    +
    40  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    41  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    42 C
    +
    43  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    44  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    45 C
    +
    46  LOGICAL LIN
    +
    47 C
    +
    48  SAVE
    +
    49 C
    +
    50  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    51 C
    +
    52 C DATA DEGPR /57.2957795/
    +
    53  DATA rerth /6.3712e+6/
    +
    54  DATA intrpo/99/
    +
    55  DATA iswt /0/
    +
    56 C
    +
    57  radpd = pi / 180.0
    +
    58  degpr = 180.0 / pi
    +
    59  clain = cos(radpd * alatin)
    +
    60  dellon = dx / (rerth * clain)
    +
    61  djeo = (alog(tan(0.5*((alat1+90.0)*radpd))))/dellon
    +
    62 C
    +
    63  lin = .false.
    +
    64  IF (interp.EQ.1) lin = .true.
    +
    65 C
    +
    66  IF (iswt.EQ.1) GO TO 900
    +
    67 C
    +
    68  deg = 1.0
    +
    69 C
    +
    70 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB09 IN LINE
    +
    71 C
    +
    72  DO 100 j = 1,jj
    +
    73  DO 100 i = 1,ii
    +
    74  xi(i,j) = i
    +
    75  xj(i,j) = j
    +
    76  100 CONTINUE
    +
    77 C
    +
    78  DO 200 kk = 1,npts
    +
    79  xlat(kk) = 2.0*atan(exp(dellon*(djeo + xjj(kk)-1.)))
    +
    80  & * degpr - 90.0
    +
    81  200 CONTINUE
    +
    82 C
    +
    83  DO 300 kk = 1,npts
    +
    84  wlon(kk) = (xii(kk) -1.0) * dellon * degpr + alon1
    +
    85  300 CONTINUE
    +
    86 C
    +
    87  DO 400 kk = 1,npts
    +
    88  w1(kk) = wlon(kk) + 1.0
    +
    89  w2(kk) = xlat(kk) + 91.0
    +
    90  400 CONTINUE
    +
    91 C
    +
    92  iswt = 1
    +
    93  intrpo = interp
    +
    94  GO TO 1000
    +
    95 C
    +
    96 C AFTER THE 1ST CALL TO W3FT204 TEST INTERP, IF IT HAS
    +
    97 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    98 C
    +
    99  900 CONTINUE
    +
    100  IF (interp.EQ.intrpo) GO TO 2100
    +
    101  intrpo = interp
    +
    102 C
    +
    103  1000 CONTINUE
    +
    104  DO 1100 k = 1,npts
    +
    105  iv(k) = w1(k)
    +
    106  jv(k) = w2(k)
    +
    107  xdeli(k) = w1(k) - iv(k)
    +
    108  xdelj(k) = w2(k) - jv(k)
    +
    109  ip1(k) = iv(k) + 1
    +
    110  jy(k,3) = jv(k) + 1
    +
    111  jy(k,2) = jv(k)
    +
    112  1100 CONTINUE
    +
    113 C
    +
    114  IF (lin) GO TO 2100
    +
    115 C
    +
    116  DO 1200 k = 1,npts
    +
    117  ip2(k) = iv(k) + 2
    +
    118  im1(k) = iv(k) - 1
    +
    119  jy(k,1) = jv(k) - 1
    +
    120  jy(k,4) = jv(k) + 2
    +
    121  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    122  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    123  1200 CONTINUE
    +
    124 C
    +
    125  2100 CONTINUE
    +
    126  IF (lin) THEN
    +
    127 C
    +
    128 C LINEAR INTERPOLATION
    +
    129 C
    +
    130  DO 2200 kk = 1,npts
    +
    131  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    132  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    133  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    134  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    135  2200 CONTINUE
    +
    136 C
    +
    137  DO 2300 kk = 1,npts
    +
    138  amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    139  & * xdelj(kk)
    +
    140  2300 CONTINUE
    +
    141 C
    +
    142  ELSE
    +
    143 C
    +
    144 C QUADRATIC INTERPOLATION
    +
    145 C
    +
    146  DO 2400 kk = 1,npts
    +
    147  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    148  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    149  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    150  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    151  & * xi2tm(kk)
    +
    152  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    153  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    154  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    155  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    156  & * xi2tm(kk)
    +
    157  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    158  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    159  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    160  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    161  & * xi2tm(kk)
    +
    162  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    163  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    164  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    165  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    166  & * xi2tm(kk)
    +
    167  2400 CONTINUE
    +
    168 C
    +
    169  DO 2500 kk = 1,npts
    +
    170  amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    171  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    172  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    173  2500 CONTINUE
    +
    174 C
    +
    175  ENDIF
    +
    176 C
    +
    177  RETURN
    +
    178  END
    +
    +
    +
    w3ft204
    subroutine w3ft204(ALOLA, AMERC, INTERP)
    Convert a n.
    Definition: w3ft204.f:27
    + + + + diff --git a/ver-2.10.0/w3ft205_8f.html b/ver-2.10.0/w3ft205_8f.html new file mode 100644 index 00000000..bb555c90 --- /dev/null +++ b/ver-2.10.0/w3ft205_8f.html @@ -0,0 +1,184 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft205.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft205.f File Reference
    +
    +
    + +

    Convert (361,91) grid to (45,39) n. hemi. grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft205 (ALOLA, APOLA, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,91) grid to (45,39) n. hemi. grid.

    +
    Author
    Ralph Jones
    +
    Date
    1993-10-19
    + +

    Definition in file w3ft205.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft205()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft205 (real, dimension(361,91) ALOLA,
    real, dimension(npts) APOLA,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    361 by 91 grid to a polar stereographic 45 by 39 grid. The polar stereographic map projection is true at 60 deg. n. , The mesh length is 190.5 km. and the oriention is 60 deg. w. pole point is at (i,j) = (27,57). new map is awips map 205.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1993-10-19 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA361*91 grid 1.0 lat,lon grid n. hemisphere 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to righ side and cut to 361 * 91.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]APOLA45*39 grid of northern hemisphere. 1755 point grid is awips grid type 205
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine.
      • +
    • 2. Wind components are not rotated to the 45*39 grid orientation after interpolation. You may use w3fc08() to do this.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1993-10-19
    + +

    Definition at line 31 of file w3ft205.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft205_8f.js b/ver-2.10.0/w3ft205_8f.js new file mode 100644 index 00000000..5aa9658e --- /dev/null +++ b/ver-2.10.0/w3ft205_8f.js @@ -0,0 +1,4 @@ +var w3ft205_8f = +[ + [ "w3ft205", "w3ft205_8f.html#ad9a3463156cbb99e97f7f3c2f9e0bc26", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft205_8f_source.html b/ver-2.10.0/w3ft205_8f_source.html new file mode 100644 index 00000000..666922fb --- /dev/null +++ b/ver-2.10.0/w3ft205_8f_source.html @@ -0,0 +1,314 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft205.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft205.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,91) grid to (45,39) n. hemi. grid.
    +
    3 C> @author Ralph Jones @date 1993-10-19
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 91 grid to a polar stereographic 45 by 39 grid. The polar
    +
    7 C> stereographic map projection is true at 60 deg. n. , The mesh
    +
    8 C> length is 190.5 km. and the oriention is 60 deg. w. pole
    +
    9 C> point is at (i,j) = (27,57). new map is awips map 205.
    +
    10 C>
    +
    11 C> ### Program History Log:
    +
    12 C> Date | Programmer | Comment
    +
    13 C> -----|------------|--------
    +
    14 C> 1993-10-19 | Ralph Jones | Initial.
    +
    15 C>
    +
    16 C> @param[in] ALOLA 361*91 grid 1.0 lat,lon grid n. hemisphere
    +
    17 C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    18 C> to righ side and cut to 361 * 91.
    +
    19 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    20 C> @param[out] APOLA 45*39 grid of northern hemisphere. 1755 point grid is
    +
    21 C> awips grid type 205
    +
    22 C>
    +
    23 C> @note
    +
    24 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    25 C> reusable for repeated calls to the subroutine.
    +
    26 C> - 2. Wind components are not rotated to the 45*39 grid orientation
    +
    27 C> after interpolation. You may use w3fc08() to do this.
    +
    28 C>
    +
    29 C> @author Ralph Jones @date 1993-10-19
    +
    30  SUBROUTINE w3ft205(ALOLA,APOLA,INTERP)
    +
    31 C
    +
    32  parameter(npts=1755,ii=45,jj=39)
    +
    33  parameter(orient=60.0,ipole=27,jpole=57)
    +
    34  parameter(xmesh=190.5)
    +
    35 C
    +
    36  REAL R2(NPTS), WLON(NPTS)
    +
    37  REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ)
    +
    38  REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS)
    +
    39  REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4)
    +
    40  REAL W1(NPTS), W2(NPTS)
    +
    41  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    42  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    43 C
    +
    44  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    45  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    46 C
    +
    47  LOGICAL LIN
    +
    48 C
    +
    49  SAVE
    +
    50 C
    +
    51  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    52 C
    +
    53  DATA degprd/57.2957795/
    +
    54  DATA earthr/6371.2/
    +
    55  DATA intrpo/99/
    +
    56  DATA iswt /0/
    +
    57 C
    +
    58  lin = .false.
    +
    59  IF (interp.EQ.1) lin = .true.
    +
    60 C
    +
    61  IF (iswt.EQ.1) GO TO 900
    +
    62 C
    +
    63  deg = 1.0
    +
    64  gi2 = (1.86603 * earthr) / xmesh
    +
    65  gi2 = gi2 * gi2
    +
    66 C
    +
    67 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE
    +
    68 C
    +
    69  DO 100 j = 1,jj
    +
    70  xj1 = j - jpole
    +
    71  DO 100 i = 1,ii
    +
    72  xi(i,j) = i - ipole
    +
    73  xj(i,j) = xj1
    +
    74  100 CONTINUE
    +
    75 C
    +
    76  DO 200 kk = 1,npts
    +
    77  r2(kk) = xjj(kk) * xjj(kk) + xii(kk) * xii(kk)
    +
    78  xlat(kk) = degprd *
    +
    79  & asin((gi2 - r2(kk)) / (gi2 + r2(kk)))
    +
    80  200 CONTINUE
    +
    81 C
    +
    82  xii(1647) = 1.0
    +
    83  DO 300 kk = 1,npts
    +
    84  angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    85  300 CONTINUE
    +
    86 C
    +
    87  DO 400 kk = 1,npts
    +
    88  IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    89  400 CONTINUE
    +
    90 C
    +
    91  DO 500 kk = 1,npts
    +
    92  wlon(kk) = 270.0 + orient - angle(kk)
    +
    93  500 CONTINUE
    +
    94 C
    +
    95  DO 600 kk = 1,npts
    +
    96  IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    97  600 CONTINUE
    +
    98 C
    +
    99  DO 700 kk = 1,npts
    +
    100  IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    101  700 CONTINUE
    +
    102 C
    +
    103  DO 800 kk = 1,npts
    +
    104  w1(kk) = (360.0 - wlon(kk)) / deg + 1.0
    +
    105  w2(kk) = xlat(kk) / deg + 1.0
    +
    106  800 CONTINUE
    +
    107 C
    +
    108  iswt = 1
    +
    109  intrpo = interp
    +
    110  GO TO 1000
    +
    111 C
    +
    112 C AFTER THE 1ST CALL TO W3FT203 TEST INTERP, IF IT HAS
    +
    113 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    114 C
    +
    115  900 CONTINUE
    +
    116  IF (interp.EQ.intrpo) GO TO 2100
    +
    117  intrpo = interp
    +
    118 C
    +
    119  1000 CONTINUE
    +
    120  DO 1100 k = 1,npts
    +
    121  iv(k) = w1(k)
    +
    122  jv(k) = w2(k)
    +
    123  xdeli(k) = w1(k) - iv(k)
    +
    124  xdelj(k) = w2(k) - jv(k)
    +
    125  ip1(k) = iv(k) + 1
    +
    126  jy(k,3) = jv(k) + 1
    +
    127  jy(k,2) = jv(k)
    +
    128  1100 CONTINUE
    +
    129 C
    +
    130  IF (lin) GO TO 1400
    +
    131 C
    +
    132  DO 1200 k = 1,npts
    +
    133  ip2(k) = iv(k) + 2
    +
    134  im1(k) = iv(k) - 1
    +
    135  jy(k,1) = jv(k) - 1
    +
    136  jy(k,4) = jv(k) + 2
    +
    137  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    138  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    139  1200 CONTINUE
    +
    140 C
    +
    141  1400 CONTINUE
    +
    142 C
    +
    143  IF (lin) GO TO 1700
    +
    144 C
    +
    145  DO 1500 kk = 1,npts
    +
    146  IF (jv(kk).LT.2.OR.jv(kk).GT.89) xj2tm(kk) = 0.0
    +
    147  1500 CONTINUE
    +
    148 C
    +
    149  1700 CONTINUE
    +
    150 C
    +
    151  IF (.NOT.lin) THEN
    +
    152  DO 2000 kk = 1,npts
    +
    153  IF (jy(kk,1).LT.1) jy(kk,1) = 1
    +
    154  2000 CONTINUE
    +
    155  ENDIF
    +
    156 C
    +
    157  2100 CONTINUE
    +
    158  IF (lin) THEN
    +
    159 C
    +
    160 C LINEAR INTERPOLATION
    +
    161 C
    +
    162  DO 2200 kk = 1,npts
    +
    163  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    164  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    165  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    166  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    167  2200 CONTINUE
    +
    168 C
    +
    169  DO 2300 kk = 1,npts
    +
    170  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    171  & * xdelj(kk)
    +
    172  2300 CONTINUE
    +
    173 C
    +
    174  ELSE
    +
    175 C
    +
    176 C QUADRATIC INTERPOLATION
    +
    177 C
    +
    178  DO 2400 kk = 1,npts
    +
    179  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    180  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    181  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    182  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    183  & * xi2tm(kk)
    +
    184  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    185  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    186  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    187  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    188  & * xi2tm(kk)
    +
    189  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    190  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    191  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    192  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    193  & * xi2tm(kk)
    +
    194  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    195  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    196  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    197  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    198  & * xi2tm(kk)
    +
    199  2400 CONTINUE
    +
    200 C
    +
    201  DO 2500 kk = 1,npts
    +
    202  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    203  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    204  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    205  2500 CONTINUE
    +
    206 C
    +
    207 C NO POLE POINT
    +
    208 C
    +
    209  ENDIF
    +
    210 C
    +
    211  RETURN
    +
    212  END
    +
    +
    +
    w3ft205
    subroutine w3ft205(ALOLA, APOLA, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft205.f:31
    + + + + diff --git a/ver-2.10.0/w3ft206_8f.html b/ver-2.10.0/w3ft206_8f.html new file mode 100644 index 00000000..b1bc251d --- /dev/null +++ b/ver-2.10.0/w3ft206_8f.html @@ -0,0 +1,184 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft206.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft206.f File Reference
    +
    +
    + +

    Convert (361,91) grid to (51,41) lambert grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft206 (ALOLA, ALAMB, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,91) grid to (51,41) lambert grid.

    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition in file w3ft206.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft206()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft206 (real, dimension(iii,jjj) ALOLA,
    real, dimension(npts) ALAMB,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    361 by 91 grid to a lambert conformal 51 by 41 awips grib 206.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1994-05-18 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA361*91 grid 1.0 deg. lat,lon grid n. hemi. 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to right side and cut to 361 * 91.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]ALAMB51*41 regional - central us mard (lambert conformal). 2091 point grid is awips grid type 206
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine. 11 other array are saved and reused on the next call.
      • +
    • 2. Wind components are not rotated to the 51*41 grid orientation after interpolation. You may use w3fc08() to do this.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition at line 29 of file w3ft206.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft206_8f.js b/ver-2.10.0/w3ft206_8f.js new file mode 100644 index 00000000..da5f9ac8 --- /dev/null +++ b/ver-2.10.0/w3ft206_8f.js @@ -0,0 +1,4 @@ +var w3ft206_8f = +[ + [ "w3ft206", "w3ft206_8f.html#a8a2d9d2de5ecb622756c8138eab5377c", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft206_8f_source.html b/ver-2.10.0/w3ft206_8f_source.html new file mode 100644 index 00000000..ba8ee75c --- /dev/null +++ b/ver-2.10.0/w3ft206_8f_source.html @@ -0,0 +1,262 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft206.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft206.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,91) grid to (51,41) lambert grid
    +
    3 C> @author Ralph Jones @date 1994-05-18
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 91 grid to a lambert conformal 51 by 41 awips grib 206.
    +
    7 C>
    +
    8 C> ### Program History Log:
    +
    9 C> Date | Programmer | Comment
    +
    10 C> -----|------------|--------
    +
    11 C> 1994-05-18 | Ralph Jones | Initial.
    +
    12 C>
    +
    13 C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    14 C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    15 C> to right side and cut to 361 * 91.
    +
    16 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    17 C> @param[out] ALAMB 51*41 regional - central us mard
    +
    18 C> (lambert conformal). 2091 point grid is awips grid type 206
    +
    19 C>
    +
    20 C> @note
    +
    21 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    22 C> reusable for repeated calls to the subroutine. 11 other array
    +
    23 C> are saved and reused on the next call.
    +
    24 C> - 2. Wind components are not rotated to the 51*41 grid orientation
    +
    25 C> after interpolation. You may use w3fc08() to do this.
    +
    26 C>
    +
    27 C> @author Ralph Jones @date 1994-05-18
    +
    28  SUBROUTINE w3ft206(ALOLA,ALAMB,INTERP)
    +
    29 C
    +
    30  parameter(npts=2091,ii=51,jj=41)
    +
    31  parameter(alatan=25.000)
    +
    32  parameter(pi=3.1416)
    +
    33  parameter(dx=81270.500)
    +
    34  parameter(alat1=22.289)
    +
    35  parameter(elon1=242.00962)
    +
    36  parameter(elonv=265.000)
    +
    37  parameter(iii=361,jjj=91)
    +
    38 C
    +
    39  REAL ALOLA(III,JJJ)
    +
    40  REAL ALAMB(NPTS)
    +
    41  REAL W1(NPTS), W2(NPTS), ERAS(NPTS,4)
    +
    42  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    43  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    44 C
    +
    45  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    46  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    47 C
    +
    48  LOGICAL LIN
    +
    49 C
    +
    50  SAVE
    +
    51 C
    +
    52  DATA iswt /0/
    +
    53  DATA intrpo/99/
    +
    54 C
    +
    55  lin = .false.
    +
    56  IF (interp.EQ.1) lin = .true.
    +
    57 C
    +
    58  IF (iswt.EQ.1) GO TO 900
    +
    59 c print *,'iswt = ',iswt
    +
    60  n = 0
    +
    61  DO j = 1,jj
    +
    62  DO i = 1,ii
    +
    63  xj = j
    +
    64  xi = i
    +
    65  CALL w3fb12(xi,xj,alat1,elon1,dx,elonv,alatan,alat,
    +
    66  & elon,ierr)
    +
    67  n = n + 1
    +
    68  w1(n) = elon + 1.0
    +
    69  w2(n) = alat + 1.0
    +
    70  END DO
    +
    71  END DO
    +
    72 C
    +
    73  iswt = 1
    +
    74  intrpo = interp
    +
    75  GO TO 1000
    +
    76 C
    +
    77 C AFTER THE 1ST CALL TO W3FT206 TEST INTERP, IF IT HAS
    +
    78 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    79 C
    +
    80  900 CONTINUE
    +
    81  IF (interp.EQ.intrpo) GO TO 2100
    +
    82  intrpo = interp
    +
    83 C
    +
    84  1000 CONTINUE
    +
    85  DO 1100 k = 1,npts
    +
    86  iv(k) = w1(k)
    +
    87  jv(k) = w2(k)
    +
    88  xdeli(k) = w1(k) - iv(k)
    +
    89  xdelj(k) = w2(k) - jv(k)
    +
    90  ip1(k) = iv(k) + 1
    +
    91  jy(k,3) = jv(k) + 1
    +
    92  jy(k,2) = jv(k)
    +
    93  1100 CONTINUE
    +
    94 C
    +
    95  IF (lin) GO TO 2100
    +
    96 C
    +
    97  DO 1200 k = 1,npts
    +
    98  ip2(k) = iv(k) + 2
    +
    99  im1(k) = iv(k) - 1
    +
    100  jy(k,1) = jv(k) - 1
    +
    101  jy(k,4) = jv(k) + 2
    +
    102  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    103  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    104  1200 CONTINUE
    +
    105 C
    +
    106  2100 CONTINUE
    +
    107  IF (lin) THEN
    +
    108 C
    +
    109 C LINEAR INTERPOLATION
    +
    110 C
    +
    111  DO 2200 kk = 1,npts
    +
    112  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    113  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    114  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    115  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    116  2200 CONTINUE
    +
    117 C
    +
    118  DO 2300 kk = 1,npts
    +
    119  alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    120  & * xdelj(kk)
    +
    121  2300 CONTINUE
    +
    122 C
    +
    123  ELSE
    +
    124 C
    +
    125 C QUADRATIC INTERPOLATION
    +
    126 C
    +
    127  DO 2400 kk = 1,npts
    +
    128  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    129  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    130  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    131  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    132  & * xi2tm(kk)
    +
    133  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    134  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    135  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    136  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    137  & * xi2tm(kk)
    +
    138  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    139  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    140  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    141  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    142  & * xi2tm(kk)
    +
    143  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    144  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    145  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    146  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    147  & * xi2tm(kk)
    +
    148  2400 CONTINUE
    +
    149 C
    +
    150  DO 2500 kk = 1,npts
    +
    151  alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    152  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    153  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    154  2500 CONTINUE
    +
    155 C
    +
    156  ENDIF
    +
    157 C
    +
    158  RETURN
    +
    159  END
    +
    +
    +
    w3ft206
    subroutine w3ft206(ALOLA, ALAMB, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft206.f:29
    +
    w3fb12
    subroutine w3fb12(XI, XJ, ALAT1, ELON1, DX, ELONV, ALATAN, ALAT, ELON, IERR)
    Converts the coordinates of a location on Earth given in a grid coordinate system overlaid on a lambe...
    Definition: w3fb12.f:53
    + + + + diff --git a/ver-2.10.0/w3ft207_8f.html b/ver-2.10.0/w3ft207_8f.html new file mode 100644 index 00000000..58ec549f --- /dev/null +++ b/ver-2.10.0/w3ft207_8f.html @@ -0,0 +1,184 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft207.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft207.f File Reference
    +
    +
    + +

    Convert (361,91) grid to (49,35) n. hemi. grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft207 (ALOLA, APOLA, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,91) grid to (49,35) n. hemi. grid.

    +
    Author
    Ralph Jones
    +
    Date
    1993-10-19
    + +

    Definition in file w3ft207.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft207()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft207 (real, dimension(361,91) ALOLA,
    real, dimension(npts) APOLA,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    361 by 91 grid to a polar stereographic 49 by 35 grid. The polar stereographic map projection is true at 60 deg. n. , The mesh length is 95.25 km. and the oriention is 150 deg. w. awips grid 207 regional - alaska.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1993-10-19 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA361*91 grid 1.0 deg. lat,lon grid n. hemi. 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to right side and cut to 361 * 91.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]APOLA49*35 grid of northern hemisphere. 1715 point grid is awips grid type 207
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine.
      • +
    • 2. Wind components are not rotated to the 49*35 grid orientation after interpolation. You may use w3fc08() to do this.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1993-10-19
    + +

    Definition at line 31 of file w3ft207.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft207_8f.js b/ver-2.10.0/w3ft207_8f.js new file mode 100644 index 00000000..561bb4e2 --- /dev/null +++ b/ver-2.10.0/w3ft207_8f.js @@ -0,0 +1,4 @@ +var w3ft207_8f = +[ + [ "w3ft207", "w3ft207_8f.html#aa4de7ddd4f65373756f6cd70b3fd6fec", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft207_8f_source.html b/ver-2.10.0/w3ft207_8f_source.html new file mode 100644 index 00000000..36d382bb --- /dev/null +++ b/ver-2.10.0/w3ft207_8f_source.html @@ -0,0 +1,346 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft207.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft207.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,91) grid to (49,35) n. hemi. grid
    +
    3 C> @author Ralph Jones @date 1993-10-19
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 91 grid to a polar stereographic 49 by 35 grid. The polar
    +
    7 C> stereographic map projection is true at 60 deg. n. , The mesh
    +
    8 C> length is 95.25 km. and the oriention is 150 deg. w.
    +
    9 C> awips grid 207 regional - alaska.
    +
    10 C>
    +
    11 C> ### Program History Log:
    +
    12 C> Date | Programmer | Comment
    +
    13 C> -----|------------|--------
    +
    14 C> 1993-10-19 | Ralph Jones | Initial.
    +
    15 C>
    +
    16 C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    17 C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    18 C> to right side and cut to 361 * 91.
    +
    19 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    20 C> @param[out] APOLA 49*35 grid of northern hemisphere. 1715 point grid is
    +
    21 C> awips grid type 207
    +
    22 C>
    +
    23 C> @note
    +
    24 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    25 C> reusable for repeated calls to the subroutine.
    +
    26 C> - 2. Wind components are not rotated to the 49*35 grid orientation
    +
    27 C> after interpolation. You may use w3fc08() to do this.
    +
    28 C>
    +
    29 C> @author Ralph Jones @date 1993-10-19
    +
    30  SUBROUTINE w3ft207(ALOLA,APOLA,INTERP)
    +
    31 C
    +
    32  parameter(npts=1715,ii=49,jj=35)
    +
    33  parameter(orient=150.0,ipole=25,jpole=51)
    +
    34  parameter(xmesh=95.250)
    +
    35 C
    +
    36  REAL R2(NPTS), WLON(NPTS)
    +
    37  REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ)
    +
    38  REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS)
    +
    39  REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4)
    +
    40  REAL W1(NPTS), W2(NPTS)
    +
    41  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    42  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    43 C
    +
    44  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    45  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    46 C
    +
    47  LOGICAL LIN
    +
    48 C
    +
    49  SAVE
    +
    50 C
    +
    51  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    52 C
    +
    53  DATA degprd/57.2957795/
    +
    54  DATA earthr/6371.2/
    +
    55  DATA intrpo/99/
    +
    56  DATA iswt /0/
    +
    57 C
    +
    58  lin = .false.
    +
    59  IF (interp.EQ.1) lin = .true.
    +
    60 C
    +
    61  IF (iswt.EQ.1) GO TO 900
    +
    62 C
    +
    63  deg = 1.0
    +
    64  gi2 = (1.86603 * earthr) / xmesh
    +
    65  gi2 = gi2 * gi2
    +
    66 C
    +
    67 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE
    +
    68 C
    +
    69  DO 100 j = 1,jj
    +
    70  xj1 = j - jpole
    +
    71  DO 100 i = 1,ii
    +
    72  xi(i,j) = i - ipole
    +
    73  xj(i,j) = xj1
    +
    74  100 CONTINUE
    +
    75 C
    +
    76  DO 200 kk = 1,npts
    +
    77  r2(kk) = xjj(kk) * xjj(kk) + xii(kk) * xii(kk)
    +
    78  xlat(kk) = degprd *
    +
    79  & asin((gi2 - r2(kk)) / (gi2 + r2(kk)))
    +
    80  200 CONTINUE
    +
    81 C
    +
    82  DO 300 kk = 1,npts
    +
    83  angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    84  300 CONTINUE
    +
    85 C
    +
    86  DO 400 kk = 1,npts
    +
    87  IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    88  400 CONTINUE
    +
    89 C
    +
    90  DO 500 kk = 1,npts
    +
    91  wlon(kk) = 270.0 + orient - angle(kk)
    +
    92  500 CONTINUE
    +
    93 C
    +
    94  DO 600 kk = 1,npts
    +
    95  IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    96  600 CONTINUE
    +
    97 C
    +
    98  DO 700 kk = 1,npts
    +
    99  IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    100  700 CONTINUE
    +
    101 C
    +
    102  DO 800 kk = 1,npts
    +
    103  w1(kk) = (360.0 - wlon(kk)) / deg + 1.0
    +
    104  w2(kk) = xlat(kk) / deg + 1.0
    +
    105  800 CONTINUE
    +
    106 C
    +
    107  iswt = 1
    +
    108  intrpo = interp
    +
    109  GO TO 1000
    +
    110 C
    +
    111 C AFTER THE 1ST CALL TO W3FT207 TEST INTERP, IF IT HAS
    +
    112 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    113 C
    +
    114  900 CONTINUE
    +
    115  IF (interp.EQ.intrpo) GO TO 2100
    +
    116  intrpo = interp
    +
    117 C
    +
    118  1000 CONTINUE
    +
    119  DO 1100 k = 1,npts
    +
    120  iv(k) = w1(k)
    +
    121  jv(k) = w2(k)
    +
    122  xdeli(k) = w1(k) - iv(k)
    +
    123  xdelj(k) = w2(k) - jv(k)
    +
    124  ip1(k) = iv(k) + 1
    +
    125  jy(k,3) = jv(k) + 1
    +
    126  jy(k,2) = jv(k)
    +
    127  1100 CONTINUE
    +
    128 C
    +
    129  IF (lin) GO TO 1400
    +
    130 C
    +
    131  DO 1200 k = 1,npts
    +
    132  ip2(k) = iv(k) + 2
    +
    133  im1(k) = iv(k) - 1
    +
    134  jy(k,1) = jv(k) - 1
    +
    135  jy(k,4) = jv(k) + 2
    +
    136  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    137  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    138  1200 CONTINUE
    +
    139 C
    +
    140  DO 1300 kk = 1,npts
    +
    141  IF (iv(kk).EQ.1) THEN
    +
    142  ip2(kk) = 3
    +
    143  im1(kk) = 360
    +
    144  ELSE IF (iv(kk).EQ.360) THEN
    +
    145  ip2(kk) = 2
    +
    146  im1(kk) = 359
    +
    147  ENDIF
    +
    148  1300 CONTINUE
    +
    149 C
    +
    150  1400 CONTINUE
    +
    151 C
    +
    152  IF (lin) GO TO 1700
    +
    153 C
    +
    154  DO 1500 kk = 1,npts
    +
    155  IF (jv(kk).LT.2.OR.jv(kk).GT.89) xj2tm(kk) = 0.0
    +
    156  1500 CONTINUE
    +
    157 C
    +
    158  DO 1600 kk = 1,npts
    +
    159  IF (ip2(kk).LT.1) ip2(kk) = 1
    +
    160  IF (im1(kk).LT.1) im1(kk) = 1
    +
    161  IF (ip2(kk).GT.361) ip2(kk) = 361
    +
    162  IF (im1(kk).GT.361) im1(kk) = 361
    +
    163  1600 CONTINUE
    +
    164 C
    +
    165  1700 CONTINUE
    +
    166  DO 1800 kk = 1,npts
    +
    167  IF (iv(kk).LT.1) iv(kk) = 1
    +
    168  IF (ip1(kk).LT.1) ip1(kk) = 1
    +
    169  IF (iv(kk).GT.361) iv(kk) = 361
    +
    170  IF (ip1(kk).GT.361) ip1(kk) = 361
    +
    171  1800 CONTINUE
    +
    172 C
    +
    173 C LINEAR INTERPOLATION
    +
    174 C
    +
    175  DO 1900 kk = 1,npts
    +
    176  IF (jy(kk,2).LT.1) jy(kk,2) = 1
    +
    177  IF (jy(kk,2).GT.91) jy(kk,2) = 91
    +
    178  IF (jy(kk,3).LT.1) jy(kk,3) = 1
    +
    179  IF (jy(kk,3).GT.91) jy(kk,3) = 91
    +
    180  1900 CONTINUE
    +
    181 C
    +
    182  IF (.NOT.lin) THEN
    +
    183  DO 2000 kk = 1,npts
    +
    184  IF (jy(kk,1).LT.1) jy(kk,1) = 1
    +
    185  IF (jy(kk,1).GT.91) jy(kk,1) = 91
    +
    186  IF (jy(kk,4).LT.1) jy(kk,4) = 1
    +
    187  IF (jy(kk,4).GT.91) jy(kk,4) = 91
    +
    188  2000 CONTINUE
    +
    189  ENDIF
    +
    190 C
    +
    191  2100 CONTINUE
    +
    192  IF (lin) THEN
    +
    193 C
    +
    194 C LINEAR INTERPOLATION
    +
    195 C
    +
    196  DO 2200 kk = 1,npts
    +
    197  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    198  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    199  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    200  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    201  2200 CONTINUE
    +
    202 C
    +
    203  DO 2300 kk = 1,npts
    +
    204  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    205  & * xdelj(kk)
    +
    206  2300 CONTINUE
    +
    207 C
    +
    208  ELSE
    +
    209 C
    +
    210 C QUADRATIC INTERPOLATION
    +
    211 C
    +
    212  DO 2400 kk = 1,npts
    +
    213  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    214  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    215  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    216  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    217  & * xi2tm(kk)
    +
    218  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    219  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    220  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    221  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    222  & * xi2tm(kk)
    +
    223  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    224  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    225  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    226  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    227  & * xi2tm(kk)
    +
    228  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    229  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    230  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    231  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    232  & * xi2tm(kk)
    +
    233  2400 CONTINUE
    +
    234 C
    +
    235  DO 2500 kk = 1,npts
    +
    236  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    237  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    238  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    239  2500 CONTINUE
    +
    240 C
    +
    241  ENDIF
    +
    242 C
    +
    243  RETURN
    +
    244  END
    +
    +
    +
    w3ft207
    subroutine w3ft207(ALOLA, APOLA, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft207.f:31
    + + + + diff --git a/ver-2.10.0/w3ft208_8f.html b/ver-2.10.0/w3ft208_8f.html new file mode 100644 index 00000000..03cb85a6 --- /dev/null +++ b/ver-2.10.0/w3ft208_8f.html @@ -0,0 +1,183 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft208.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft208.f File Reference
    +
    +
    + +

    Convert (361,91) grid to (29,27) mercator grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft208 (ALOLA, AMERC, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,91) grid to (29,27) mercator grid.

    +
    Author
    Ralph Jones
    +
    Date
    1993-10-19
    + +

    Definition in file w3ft208.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft208()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft208 (real, dimension(361,91) ALOLA,
    real, dimension(npts) AMERC,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    361 by 91 grid to a regional - hawaii (mercator) 29*27 awips 208 grid.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1993-10-19 Ralph Jones Initial
    +
    Parameters
    + + + + +
    [in]ALOLA361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI. 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to right side and cut to 361 * 91.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]AMERC29*27 grid of northern mercator 783 point grid is awips grid type 208
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine. 20 other array are saved and reused on the next call.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1993-10-19
    + +

    Definition at line 28 of file w3ft208.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft208_8f.js b/ver-2.10.0/w3ft208_8f.js new file mode 100644 index 00000000..9fff508d --- /dev/null +++ b/ver-2.10.0/w3ft208_8f.js @@ -0,0 +1,4 @@ +var w3ft208_8f = +[ + [ "w3ft208", "w3ft208_8f.html#ab3380c5bf59fbd57210787bb91f5584f", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft208_8f_source.html b/ver-2.10.0/w3ft208_8f_source.html new file mode 100644 index 00000000..786f60e9 --- /dev/null +++ b/ver-2.10.0/w3ft208_8f_source.html @@ -0,0 +1,281 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft208.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft208.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,91) grid to (29,27) mercator grid.
    +
    3 C> @author Ralph Jones @date 1993-10-19
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 91 grid to a regional - hawaii (mercator) 29*27 awips 208
    +
    7 C> grid.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1993-10-19 | Ralph Jones | Initial
    +
    13 C>
    +
    14 C> @param[in] ALOLA 361*91 GRID 1.0 DEG. LAT,LON GRID N. HEMI.
    +
    15 C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    16 C> to right side and cut to 361 * 91.
    +
    17 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    18 C> @param[out] AMERC 29*27 grid of northern mercator 783 point grid is awips
    +
    19 C> grid type 208
    +
    20 C>
    +
    21 C> @note
    +
    22 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    23 C> reusable for repeated calls to the subroutine. 20 other array
    +
    24 C> are saved and reused on the next call.
    +
    25 C>
    +
    26 C> @author Ralph Jones @date 1993-10-19
    +
    27  SUBROUTINE w3ft208(ALOLA,AMERC,INTERP)
    +
    28 C
    +
    29  parameter(npts=783,ii=29,jj=27)
    +
    30  parameter(alatin=20.000)
    +
    31  parameter(pi=3.1416)
    +
    32  parameter(dx=80000.0)
    +
    33  parameter(alat1=9.343)
    +
    34  parameter(alon1=192.685)
    +
    35 C
    +
    36  REAL WLON(NPTS), XLAT(NPTS)
    +
    37  REAL XI(II,JJ), XJ(II,JJ)
    +
    38  REAL XII(NPTS), XJJ(NPTS)
    +
    39  REAL ALOLA(361,91), AMERC(NPTS), ERAS(NPTS,4)
    +
    40  REAL W1(NPTS), W2(NPTS)
    +
    41  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    42  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    43 C
    +
    44  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    45  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    46 C
    +
    47  LOGICAL LIN
    +
    48 C
    +
    49  SAVE
    +
    50 C
    +
    51  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    52 C
    +
    53 C DATA DEGPR /57.2957795/
    +
    54  DATA rerth /6.3712e+6/
    +
    55  DATA intrpo/99/
    +
    56  DATA iswt /0/
    +
    57 C
    +
    58  degpr = 180.0 / pi
    +
    59  radpd = pi / 180.0
    +
    60  clain = cos(radpd * alatin)
    +
    61  dellon = dx / (rerth * clain)
    +
    62  djeo = (alog(tan(0.5*((alat1+90.0)*radpd))))/dellon
    +
    63 C
    +
    64  lin = .false.
    +
    65  IF (interp.EQ.1) lin = .true.
    +
    66 C
    +
    67  IF (iswt.EQ.1) GO TO 900
    +
    68 C
    +
    69  deg = 1.0
    +
    70 C
    +
    71 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB09 IN LINE
    +
    72 C
    +
    73  DO 100 j = 1,jj
    +
    74  DO 100 i = 1,ii
    +
    75  xi(i,j) = i
    +
    76  xj(i,j) = j
    +
    77  100 CONTINUE
    +
    78 C
    +
    79  DO 200 kk = 1,npts
    +
    80  xlat(kk) = 2.0*atan(exp(dellon*(djeo + xjj(kk)-1.)))
    +
    81  & * degpr - 90.0
    +
    82  200 CONTINUE
    +
    83 C
    +
    84  DO 300 kk = 1,npts
    +
    85  wlon(kk) = (xii(kk) -1.0) * dellon * degpr + alon1
    +
    86  300 CONTINUE
    +
    87 C
    +
    88  DO 400 kk = 1,npts
    +
    89  w1(kk) = wlon(kk) + 1.0
    +
    90  w2(kk) = xlat(kk) + 1.0
    +
    91  400 CONTINUE
    +
    92 C
    +
    93  iswt = 1
    +
    94  intrpo = interp
    +
    95  GO TO 1000
    +
    96 C
    +
    97 C AFTER THE 1ST CALL TO W3FT208 TEST INTERP, IF IT HAS
    +
    98 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    99 C
    +
    100  900 CONTINUE
    +
    101  IF (interp.EQ.intrpo) GO TO 2100
    +
    102  intrpo = interp
    +
    103 C
    +
    104  1000 CONTINUE
    +
    105  DO 1100 k = 1,npts
    +
    106  iv(k) = w1(k)
    +
    107  jv(k) = w2(k)
    +
    108  xdeli(k) = w1(k) - iv(k)
    +
    109  xdelj(k) = w2(k) - jv(k)
    +
    110  ip1(k) = iv(k) + 1
    +
    111  jy(k,3) = jv(k) + 1
    +
    112  jy(k,2) = jv(k)
    +
    113  1100 CONTINUE
    +
    114 C
    +
    115  IF (.NOT.lin) THEN
    +
    116  DO 1200 k = 1,npts
    +
    117  ip2(k) = iv(k) + 2
    +
    118  im1(k) = iv(k) - 1
    +
    119  jy(k,1) = jv(k) - 1
    +
    120  jy(k,4) = jv(k) + 2
    +
    121  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    122  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    123  1200 CONTINUE
    +
    124  END IF
    +
    125 C
    +
    126  2100 CONTINUE
    +
    127  IF (lin) THEN
    +
    128 C
    +
    129 C LINEAR INTERPOLATION
    +
    130 C
    +
    131  DO 2200 kk = 1,npts
    +
    132  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    133  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    134  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    135  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    136  2200 CONTINUE
    +
    137 C
    +
    138  DO 2300 kk = 1,npts
    +
    139  amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    140  & * xdelj(kk)
    +
    141  2300 CONTINUE
    +
    142 C
    +
    143  ELSE
    +
    144 C
    +
    145 C BI-QUADRATIC INTERPOLATION
    +
    146 C
    +
    147  DO 2400 kk = 1,npts
    +
    148  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    149  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    150  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    151  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    152  & * xi2tm(kk)
    +
    153  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    154  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    155  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    156  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    157  & * xi2tm(kk)
    +
    158  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    159  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    160  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    161  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    162  & * xi2tm(kk)
    +
    163  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    164  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    165  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    166  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    167  & * xi2tm(kk)
    +
    168  2400 CONTINUE
    +
    169 C
    +
    170  DO 2500 kk = 1,npts
    +
    171  amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    172  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    173  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    174  2500 CONTINUE
    +
    175 C
    +
    176  ENDIF
    +
    177 C
    +
    178  RETURN
    +
    179  END
    +
    +
    +
    w3ft208
    subroutine w3ft208(ALOLA, AMERC, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft208.f:28
    + + + + diff --git a/ver-2.10.0/w3ft209_8f.html b/ver-2.10.0/w3ft209_8f.html new file mode 100644 index 00000000..b2052ee6 --- /dev/null +++ b/ver-2.10.0/w3ft209_8f.html @@ -0,0 +1,184 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft209.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft209.f File Reference
    +
    +
    + +

    Convert (361,91) grid to (101,81) lambert grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft209 (ALOLA, ALAMB, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,91) grid to (101,81) lambert grid.

    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition in file w3ft209.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft209()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft209 (real, dimension(iii,jjj) ALOLA,
    real, dimension(npts) ALAMB,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    361 by 91 grid to a lambert conformal 101 by 81 awips grib 209.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1994-05-18 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA361*91 grid 1.0 deg. lat,lon grid n. hemi. 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to right side and cut to 361 * 91.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]ALAMB101*81 regional - central us mard double res. (lambert conformal). 8181 point grid is awips grid type 209
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine. 11 other array are saved and reused on the next call.
      • +
    • 2. Wind components are not rotated to the 101*81 grid orientation after interpolation. You may use w3fc08() to do this.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition at line 30 of file w3ft209.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft209_8f.js b/ver-2.10.0/w3ft209_8f.js new file mode 100644 index 00000000..6ecab450 --- /dev/null +++ b/ver-2.10.0/w3ft209_8f.js @@ -0,0 +1,4 @@ +var w3ft209_8f = +[ + [ "w3ft209", "w3ft209_8f.html#a8d2adf2c3f2603ed6555c88d77f0b51b", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft209_8f_source.html b/ver-2.10.0/w3ft209_8f_source.html new file mode 100644 index 00000000..93e09ba5 --- /dev/null +++ b/ver-2.10.0/w3ft209_8f_source.html @@ -0,0 +1,264 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft209.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft209.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,91) grid to (101,81) lambert grid.
    +
    3 C> @author Ralph Jones @date 1994-05-18
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 91 grid to a lambert conformal 101 by 81 awips grib 209.
    +
    7 C>
    +
    8 C> ### Program History Log:
    +
    9 C> Date | Programmer | Comment
    +
    10 C> -----|------------|--------
    +
    11 C> 1994-05-18 | Ralph Jones | Initial.
    +
    12 C>
    +
    13 C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    14 C> 32851 point grid. 360 * 181 one degree
    +
    15 C> grib grid 3 was flipped, greenwish added
    +
    16 C> to right side and cut to 361 * 91.
    +
    17 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    18 C> @param[out] ALAMB 101*81 regional - central us mard double res.
    +
    19 C> (lambert conformal). 8181 point grid is awips grid type 209
    +
    20 C>
    +
    21 C> @note
    +
    22 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    23 C> reusable for repeated calls to the subroutine. 11 other array
    +
    24 C> are saved and reused on the next call.
    +
    25 C> - 2. Wind components are not rotated to the 101*81 grid orientation
    +
    26 C> after interpolation. You may use w3fc08() to do this.
    +
    27 C>
    +
    28 C> @author Ralph Jones @date 1994-05-18
    +
    29  SUBROUTINE w3ft209(ALOLA,ALAMB,INTERP)
    +
    30 C
    +
    31 C
    +
    32  parameter(npts=8181,ii=101,jj=81)
    +
    33  parameter(alatan=25.000)
    +
    34  parameter(pi=3.1416)
    +
    35  parameter(dx=40635.250)
    +
    36  parameter(alat1=22.289)
    +
    37  parameter(elon1=242.00962)
    +
    38  parameter(elonv=265.000)
    +
    39  parameter(iii=361,jjj=91)
    +
    40 C
    +
    41  REAL ALOLA(III,JJJ)
    +
    42  REAL ALAMB(NPTS)
    +
    43  REAL W1(NPTS), W2(NPTS), ERAS(NPTS,4)
    +
    44  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    45  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    46 C
    +
    47  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    48  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    49 C
    +
    50  LOGICAL LIN
    +
    51 C
    +
    52  SAVE
    +
    53 C
    +
    54  DATA iswt /0/
    +
    55  DATA intrpo/99/
    +
    56 C
    +
    57  lin = .false.
    +
    58  IF (interp.EQ.1) lin = .true.
    +
    59 C
    +
    60  IF (iswt.EQ.1) GO TO 900
    +
    61 c print *,'iswt = ',iswt
    +
    62  n = 0
    +
    63  DO j = 1,jj
    +
    64  DO i = 1,ii
    +
    65  xj = j
    +
    66  xi = i
    +
    67  CALL w3fb12(xi,xj,alat1,elon1,dx,elonv,alatan,alat,
    +
    68  & elon,ierr)
    +
    69  n = n + 1
    +
    70  w1(n) = elon + 1.0
    +
    71  w2(n) = alat + 1.0
    +
    72  END DO
    +
    73  END DO
    +
    74 C
    +
    75  iswt = 1
    +
    76  intrpo = interp
    +
    77  GO TO 1000
    +
    78 C
    +
    79 C AFTER THE 1ST CALL TO W3FT209 TEST INTERP, IF IT HAS
    +
    80 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    81 C
    +
    82  900 CONTINUE
    +
    83  IF (interp.EQ.intrpo) GO TO 2100
    +
    84  intrpo = interp
    +
    85 C
    +
    86  1000 CONTINUE
    +
    87  DO 1100 k = 1,npts
    +
    88  iv(k) = w1(k)
    +
    89  jv(k) = w2(k)
    +
    90  xdeli(k) = w1(k) - iv(k)
    +
    91  xdelj(k) = w2(k) - jv(k)
    +
    92  ip1(k) = iv(k) + 1
    +
    93  jy(k,3) = jv(k) + 1
    +
    94  jy(k,2) = jv(k)
    +
    95  1100 CONTINUE
    +
    96 C
    +
    97  IF (lin) GO TO 2100
    +
    98 C
    +
    99  DO 1200 k = 1,npts
    +
    100  ip2(k) = iv(k) + 2
    +
    101  im1(k) = iv(k) - 1
    +
    102  jy(k,1) = jv(k) - 1
    +
    103  jy(k,4) = jv(k) + 2
    +
    104  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    105  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    106  1200 CONTINUE
    +
    107 C
    +
    108  2100 CONTINUE
    +
    109  IF (lin) THEN
    +
    110 C
    +
    111 C LINEAR INTERPOLATION
    +
    112 C
    +
    113  DO 2200 kk = 1,npts
    +
    114  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    115  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    116  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    117  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    118  2200 CONTINUE
    +
    119 C
    +
    120  DO 2300 kk = 1,npts
    +
    121  alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    122  & * xdelj(kk)
    +
    123  2300 CONTINUE
    +
    124 C
    +
    125  ELSE
    +
    126 C
    +
    127 C QUADRATIC INTERPOLATION
    +
    128 C
    +
    129  DO 2400 kk = 1,npts
    +
    130  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    131  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    132  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    133  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    134  & * xi2tm(kk)
    +
    135  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    136  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    137  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    138  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    139  & * xi2tm(kk)
    +
    140  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    141  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    142  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    143  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    144  & * xi2tm(kk)
    +
    145  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    146  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    147  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    148  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    149  & * xi2tm(kk)
    +
    150  2400 CONTINUE
    +
    151 C
    +
    152  DO 2500 kk = 1,npts
    +
    153  alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    154  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    155  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    156  2500 CONTINUE
    +
    157 C
    +
    158  ENDIF
    +
    159 C
    +
    160  RETURN
    +
    161  END
    +
    +
    +
    w3ft209
    subroutine w3ft209(ALOLA, ALAMB, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft209.f:30
    +
    w3fb12
    subroutine w3fb12(XI, XJ, ALAT1, ELON1, DX, ELONV, ALATAN, ALAT, ELON, IERR)
    Converts the coordinates of a location on Earth given in a grid coordinate system overlaid on a lambe...
    Definition: w3fb12.f:53
    + + + + diff --git a/ver-2.10.0/w3ft210_8f.html b/ver-2.10.0/w3ft210_8f.html new file mode 100644 index 00000000..dacf1ed1 --- /dev/null +++ b/ver-2.10.0/w3ft210_8f.html @@ -0,0 +1,183 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft210.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft210.f File Reference
    +
    +
    + +

    Convert (361,91) grid to (25,25) mercator grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft210 (ALOLA, AMERC, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,91) grid to (25,25) mercator grid.

    +
    Author
    Ralph Jones
    +
    Date
    1993-10-19
    + +

    Definition in file w3ft210.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft210()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft210 (real, dimension(361,91) ALOLA,
    real, dimension(npts) AMERC,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    361 by 91 grid to a regional - puerto rico (mercator) 25*25 awips 210 grid.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1993-10-19 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA361*91 grid 1.0 deg. lat,lon grid n. hemi. 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to right side and cut to 361 * 91.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]AMERC25*25 grid of northern mercator 625 point grid is awips grid type 210
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine. 20 other array are saved and reused on the next call.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1993-10-19
    + +

    Definition at line 27 of file w3ft210.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft210_8f.js b/ver-2.10.0/w3ft210_8f.js new file mode 100644 index 00000000..6f5f0798 --- /dev/null +++ b/ver-2.10.0/w3ft210_8f.js @@ -0,0 +1,4 @@ +var w3ft210_8f = +[ + [ "w3ft210", "w3ft210_8f.html#a3803de9cbf2932eb2aa3b36ed8fef355", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft210_8f_source.html b/ver-2.10.0/w3ft210_8f_source.html new file mode 100644 index 00000000..dd3ddeae --- /dev/null +++ b/ver-2.10.0/w3ft210_8f_source.html @@ -0,0 +1,279 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft210.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft210.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,91) grid to (25,25) mercator grid.
    +
    3 C> @author Ralph Jones @date 1993-10-19
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 91 grid to a regional - puerto rico (mercator) 25*25 awips 210
    +
    7 C> grid.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1993-10-19 | Ralph Jones | Initial.
    +
    13 
    +
    14 C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    15 C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    16 C> to right side and cut to 361 * 91.
    +
    17 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    18 C> @param[out] AMERC 25*25 grid of northern mercator 625 point grid is awips grid type 210
    +
    19 C>
    +
    20 C> @note
    +
    21 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    22 C> reusable for repeated calls to the subroutine. 20 other array
    +
    23 C> are saved and reused on the next call.
    +
    24 C>
    +
    25 C> @author Ralph Jones @date 1993-10-19
    +
    26  SUBROUTINE w3ft210(ALOLA,AMERC,INTERP)
    +
    27 C
    +
    28  parameter(npts=625,ii=25,jj=25)
    +
    29  parameter(alatin=20.000)
    +
    30  parameter(pi=3.1416)
    +
    31  parameter(dx=80000.0)
    +
    32  parameter(alat1=9.000)
    +
    33  parameter(alon1=283.000)
    +
    34 C
    +
    35  REAL R2(NPTS), WLON(NPTS)
    +
    36  REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ)
    +
    37  REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS)
    +
    38  REAL ALOLA(361,91), AMERC(NPTS), ERAS(NPTS,4)
    +
    39  REAL W1(NPTS), W2(NPTS)
    +
    40  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    41  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    42 C
    +
    43  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    44  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    45 C
    +
    46  LOGICAL LIN
    +
    47 C
    +
    48  SAVE
    +
    49 C
    +
    50  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    51 C
    +
    52 C DATA DEGPR /57.2957795/
    +
    53  DATA rerth /6.3712e+6/
    +
    54  DATA intrpo/99/
    +
    55  DATA iswt /0/
    +
    56 C
    +
    57  degpr = 180.0 / pi
    +
    58  radpd = pi / 180.0
    +
    59  clain = cos(radpd * alatin)
    +
    60  dellon = dx / (rerth * clain)
    +
    61  djeo = (alog(tan(0.5*((alat1+90.0)*radpd))))/dellon
    +
    62  lin = .false.
    +
    63  IF (interp.EQ.1) lin = .true.
    +
    64 C
    +
    65  IF (iswt.EQ.1) GO TO 900
    +
    66 C
    +
    67  deg = 1.0
    +
    68 C
    +
    69 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB09 IN LINE
    +
    70 C
    +
    71  DO 100 j = 1,jj
    +
    72  DO 100 i = 1,ii
    +
    73  xi(i,j) = i
    +
    74  xj(i,j) = j
    +
    75  100 CONTINUE
    +
    76 C
    +
    77  DO 200 kk = 1,npts
    +
    78  xlat(kk) = 2.0*atan(exp(dellon*(djeo + xjj(kk)-1.)))
    +
    79  & * degpr - 90.0
    +
    80  200 CONTINUE
    +
    81 C
    +
    82  DO 300 kk = 1,npts
    +
    83  wlon(kk) = (xii(kk) -1.0) * dellon * degpr + alon1
    +
    84  300 CONTINUE
    +
    85 C
    +
    86  DO 400 kk = 1,npts
    +
    87  w1(kk) = wlon(kk) + 1.0
    +
    88  w2(kk) = xlat(kk) + 1.0
    +
    89  400 CONTINUE
    +
    90 C
    +
    91  iswt = 1
    +
    92  intrpo = interp
    +
    93  GO TO 1000
    +
    94 C
    +
    95 C AFTER THE 1ST CALL TO W3FT210 TEST INTERP, IF IT HAS
    +
    96 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    97 C
    +
    98  900 CONTINUE
    +
    99  IF (interp.EQ.intrpo) GO TO 2100
    +
    100  intrpo = interp
    +
    101 C
    +
    102  1000 CONTINUE
    +
    103  DO 1100 k = 1,npts
    +
    104  iv(k) = w1(k)
    +
    105  jv(k) = w2(k)
    +
    106  xdeli(k) = w1(k) - iv(k)
    +
    107  xdelj(k) = w2(k) - jv(k)
    +
    108  ip1(k) = iv(k) + 1
    +
    109  jy(k,3) = jv(k) + 1
    +
    110  jy(k,2) = jv(k)
    +
    111  1100 CONTINUE
    +
    112 C
    +
    113  IF (.NOT.lin) THEN
    +
    114  DO 1200 k = 1,npts
    +
    115  ip2(k) = iv(k) + 2
    +
    116  im1(k) = iv(k) - 1
    +
    117  jy(k,1) = jv(k) - 1
    +
    118  jy(k,4) = jv(k) + 2
    +
    119  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    120  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    121  1200 CONTINUE
    +
    122  END IF
    +
    123 C
    +
    124  2100 CONTINUE
    +
    125  IF (lin) THEN
    +
    126 C
    +
    127 C LINEAR INTERPOLATION
    +
    128 C
    +
    129  DO 2200 kk = 1,npts
    +
    130  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    131  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    132  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    133  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    134  2200 CONTINUE
    +
    135 C
    +
    136  DO 2300 kk = 1,npts
    +
    137  amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    138  & * xdelj(kk)
    +
    139  2300 CONTINUE
    +
    140 C
    +
    141  ELSE
    +
    142 C
    +
    143 C QUADRATIC INTERPOLATION
    +
    144 C
    +
    145  DO 2400 kk = 1,npts
    +
    146  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    147  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    148  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    149  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    150  & * xi2tm(kk)
    +
    151  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    152  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    153  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    154  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    155  & * xi2tm(kk)
    +
    156  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    157  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    158  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    159  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    160  & * xi2tm(kk)
    +
    161  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    162  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    163  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    164  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    165  & * xi2tm(kk)
    +
    166  2400 CONTINUE
    +
    167 C
    +
    168  DO 2500 kk = 1,npts
    +
    169  amerc(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    170  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    171  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    172  2500 CONTINUE
    +
    173 C
    +
    174  ENDIF
    +
    175 C
    +
    176  RETURN
    +
    177  END
    +
    +
    +
    w3ft210
    subroutine w3ft210(ALOLA, AMERC, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft210.f:27
    + + + + diff --git a/ver-2.10.0/w3ft211_8f.html b/ver-2.10.0/w3ft211_8f.html new file mode 100644 index 00000000..2d83b03d --- /dev/null +++ b/ver-2.10.0/w3ft211_8f.html @@ -0,0 +1,182 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft211.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft211.f File Reference
    +
    +
    + +

    Convert (361,91) grid to (93,65) lambert grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft211 (ALOLA, ALAMB, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,91) grid to (93,65) lambert grid.

    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition in file w3ft211.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft211()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft211 (real, dimension(iii,jjj) ALOLA,
    real, dimension(npts) ALAMB,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    361 by 91 grid to a lambert conformal 93 by 65 awips grib 211.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1994-05-18 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA361*91 grid 1.0 deg. lat,lon grid n. hemi. 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to right side and cut to 361 * 91.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]ALAMB93*65 regional - conus (lambert conformal). 6045 point grid is awips grid type 211
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine. 11 other array are saved and reused on the next call.
      • +
    • 2. Wind components are not rotated to the 93*65 grid orientation after interpolation. You may use w3fc08() to do this.
      • +
    +
    + +

    Definition at line 28 of file w3ft211.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft211_8f.js b/ver-2.10.0/w3ft211_8f.js new file mode 100644 index 00000000..299f570c --- /dev/null +++ b/ver-2.10.0/w3ft211_8f.js @@ -0,0 +1,4 @@ +var w3ft211_8f = +[ + [ "w3ft211", "w3ft211_8f.html#a353f8903a8cbe06aa931ab815e317708", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft211_8f_source.html b/ver-2.10.0/w3ft211_8f_source.html new file mode 100644 index 00000000..570e53d4 --- /dev/null +++ b/ver-2.10.0/w3ft211_8f_source.html @@ -0,0 +1,262 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft211.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft211.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,91) grid to (93,65) lambert grid.
    +
    3 C> @author Ralph Jones @date 1994-05-18
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 91 grid to a lambert conformal 93 by 65 awips grib 211.
    +
    7 C>
    +
    8 C> ### Program History Log:
    +
    9 C> Date | Programmer | Comment
    +
    10 C> -----|------------|--------
    +
    11 C> 1994-05-18 | Ralph Jones | Initial.
    +
    12 C>
    +
    13 C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    14 C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    15 C> to right side and cut to 361 * 91.
    +
    16 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    17 C> @param[out] ALAMB 93*65 regional - conus (lambert conformal). 6045 point grid
    +
    18 C> is awips grid type 211
    +
    19 C>
    +
    20 C> @note
    +
    21 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    22 C> reusable for repeated calls to the subroutine. 11 other array
    +
    23 C> are saved and reused on the next call.
    +
    24 C> - 2. Wind components are not rotated to the 93*65 grid orientation
    +
    25 C> after interpolation. You may use w3fc08() to do this.
    +
    26 C>
    +
    27  SUBROUTINE w3ft211(ALOLA,ALAMB,INTERP)
    +
    28 C
    +
    29 C
    +
    30  parameter(npts=6045,ii=93,jj=65)
    +
    31  parameter(alatan=25.000)
    +
    32  parameter(pi=3.1416)
    +
    33  parameter(dx=81270.500)
    +
    34  parameter(alat1=12.190)
    +
    35  parameter(elon1=226.541)
    +
    36  parameter(elonv=265.000)
    +
    37  parameter(iii=361,jjj=91)
    +
    38 C
    +
    39  REAL ALOLA(III,JJJ)
    +
    40  REAL ALAMB(NPTS)
    +
    41  REAL W1(NPTS), W2(NPTS), ERAS(NPTS,4)
    +
    42  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    43  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    44 C
    +
    45  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    46  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    47 C
    +
    48  LOGICAL LIN
    +
    49 C
    +
    50  SAVE
    +
    51 C
    +
    52  DATA iswt /0/
    +
    53  DATA intrpo/99/
    +
    54 C
    +
    55  lin = .false.
    +
    56  IF (interp.EQ.1) lin = .true.
    +
    57 C
    +
    58  IF (iswt.EQ.1) GO TO 900
    +
    59 c print *,'iswt = ',iswt
    +
    60  n = 0
    +
    61  DO j = 1,jj
    +
    62  DO i = 1,ii
    +
    63  xj = j
    +
    64  xi = i
    +
    65  CALL w3fb12(xi,xj,alat1,elon1,dx,elonv,alatan,alat,
    +
    66  & elon,ierr)
    +
    67  n = n + 1
    +
    68  w1(n) = elon + 1.0
    +
    69  w2(n) = alat + 1.0
    +
    70  END DO
    +
    71  END DO
    +
    72 C
    +
    73  iswt = 1
    +
    74  intrpo = interp
    +
    75  GO TO 1000
    +
    76 C
    +
    77 C AFTER THE 1ST CALL TO W3FT211 TEST INTERP, IF IT HAS
    +
    78 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    79 C
    +
    80  900 CONTINUE
    +
    81  IF (interp.EQ.intrpo) GO TO 2100
    +
    82  intrpo = interp
    +
    83 C
    +
    84  1000 CONTINUE
    +
    85  DO 1100 k = 1,npts
    +
    86  iv(k) = w1(k)
    +
    87  jv(k) = w2(k)
    +
    88  xdeli(k) = w1(k) - iv(k)
    +
    89  xdelj(k) = w2(k) - jv(k)
    +
    90  ip1(k) = iv(k) + 1
    +
    91  jy(k,3) = jv(k) + 1
    +
    92  jy(k,2) = jv(k)
    +
    93  1100 CONTINUE
    +
    94 C
    +
    95  IF (lin) GO TO 2100
    +
    96 C
    +
    97  DO 1200 k = 1,npts
    +
    98  ip2(k) = iv(k) + 2
    +
    99  im1(k) = iv(k) - 1
    +
    100  jy(k,1) = jv(k) - 1
    +
    101  jy(k,4) = jv(k) + 2
    +
    102  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    103  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    104  1200 CONTINUE
    +
    105 C
    +
    106  2100 CONTINUE
    +
    107  IF (lin) THEN
    +
    108 C
    +
    109 C LINEAR INTERPOLATION
    +
    110 C
    +
    111  DO 2200 kk = 1,npts
    +
    112  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    113  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    114  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    115  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    116  2200 CONTINUE
    +
    117 C
    +
    118  DO 2300 kk = 1,npts
    +
    119  alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    120  & * xdelj(kk)
    +
    121  2300 CONTINUE
    +
    122 C
    +
    123  ELSE
    +
    124 C
    +
    125 C QUADRATIC INTERPOLATION
    +
    126 C
    +
    127  DO 2400 kk = 1,npts
    +
    128  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    129  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    130  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    131  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    132  & * xi2tm(kk)
    +
    133  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    134  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    135  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    136  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    137  & * xi2tm(kk)
    +
    138  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    139  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    140  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    141  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    142  & * xi2tm(kk)
    +
    143  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    144  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    145  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    146  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    147  & * xi2tm(kk)
    +
    148  2400 CONTINUE
    +
    149 C
    +
    150  DO 2500 kk = 1,npts
    +
    151  alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    152  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    153  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    154  2500 CONTINUE
    +
    155 C
    +
    156  ENDIF
    +
    157 C
    +
    158  RETURN
    +
    159  END
    +
    +
    +
    w3ft211
    subroutine w3ft211(ALOLA, ALAMB, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft211.f:28
    +
    w3fb12
    subroutine w3fb12(XI, XJ, ALAT1, ELON1, DX, ELONV, ALATAN, ALAT, ELON, IERR)
    Converts the coordinates of a location on Earth given in a grid coordinate system overlaid on a lambe...
    Definition: w3fb12.f:53
    + + + + diff --git a/ver-2.10.0/w3ft212_8f.html b/ver-2.10.0/w3ft212_8f.html new file mode 100644 index 00000000..064fea5c --- /dev/null +++ b/ver-2.10.0/w3ft212_8f.html @@ -0,0 +1,184 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft212.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft212.f File Reference
    +
    +
    + +

    Convert (361,91) grid to (185,129) lambert grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft212 (ALOLA, ALAMB, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,91) grid to (185,129) lambert grid.

    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition in file w3ft212.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft212()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft212 (real, dimension(iii,jjj) ALOLA,
    real, dimension(npts) ALAMB,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    361 by 91 grid to a lambert conformal 185 by 129 awips grib 212.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1994-05-18 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA361*91 grid 1.0 deg. lat,lon grid n. hemi. 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to right side and cut to 361 * 91.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]ALAMB185*129 regional - conus double resolution (lambert conformal). 23865 point grid is awips grid type 212
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine. 11 other array are saved and reused on the next call.
      • +
    • 2. Wind components are not rotated to the 185*129 grid orientation after interpolation. You may use w3fc08() to do this.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1994-05-18
    + +

    Definition at line 29 of file w3ft212.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft212_8f.js b/ver-2.10.0/w3ft212_8f.js new file mode 100644 index 00000000..81a9bacf --- /dev/null +++ b/ver-2.10.0/w3ft212_8f.js @@ -0,0 +1,4 @@ +var w3ft212_8f = +[ + [ "w3ft212", "w3ft212_8f.html#a80630575cad8c3e8743fb7b161d2b18e", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft212_8f_source.html b/ver-2.10.0/w3ft212_8f_source.html new file mode 100644 index 00000000..d66e0e2b --- /dev/null +++ b/ver-2.10.0/w3ft212_8f_source.html @@ -0,0 +1,263 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft212.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft212.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,91) grid to (185,129) lambert grid
    +
    3 C> @author Ralph Jones @date 1994-05-18
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 91 grid to a lambert conformal 185 by 129 awips grib 212.
    +
    7 C>
    +
    8 C> ### Program History Log:
    +
    9 C> Date | Programmer | Comment
    +
    10 C> -----|------------|--------
    +
    11 C> 1994-05-18 | Ralph Jones | Initial.
    +
    12 C>
    +
    13 C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    14 C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    15 C> to right side and cut to 361 * 91.
    +
    16 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    17 C> @param[out] ALAMB 185*129 regional - conus double resolution
    +
    18 C> (lambert conformal). 23865 point grid is awips grid type 212
    +
    19 C>
    +
    20 C> @note
    +
    21 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    22 C> reusable for repeated calls to the subroutine. 11 other array
    +
    23 C> are saved and reused on the next call.
    +
    24 C> - 2. Wind components are not rotated to the 185*129 grid orientation
    +
    25 C> after interpolation. You may use w3fc08() to do this.
    +
    26 C>
    +
    27 C> @author Ralph Jones @date 1994-05-18
    +
    28  SUBROUTINE w3ft212(ALOLA,ALAMB,INTERP)
    +
    29 C
    +
    30 C
    +
    31  parameter(npts=23865,ii=185,jj=129)
    +
    32  parameter(alatan=25.000)
    +
    33  parameter(pi=3.1416)
    +
    34  parameter(dx=40635.250)
    +
    35  parameter(alat1=12.190)
    +
    36  parameter(elon1=226.541)
    +
    37  parameter(elonv=265.000)
    +
    38  parameter(iii=361,jjj=91)
    +
    39 C
    +
    40  REAL ALOLA(III,JJJ)
    +
    41  REAL ALAMB(NPTS)
    +
    42  REAL W1(NPTS), W2(NPTS), ERAS(NPTS,4)
    +
    43  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    44  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    45 C
    +
    46  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    47  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    48 C
    +
    49  LOGICAL LIN
    +
    50 C
    +
    51  SAVE
    +
    52 C
    +
    53  DATA iswt /0/
    +
    54  DATA intrpo/99/
    +
    55 C
    +
    56  lin = .false.
    +
    57  IF (interp.EQ.1) lin = .true.
    +
    58 C
    +
    59  IF (iswt.EQ.1) GO TO 900
    +
    60 c print *,'iswt = ',iswt
    +
    61  n = 0
    +
    62  DO j = 1,jj
    +
    63  DO i = 1,ii
    +
    64  xj = j
    +
    65  xi = i
    +
    66  CALL w3fb12(xi,xj,alat1,elon1,dx,elonv,alatan,alat,
    +
    67  & elon,ierr)
    +
    68  n = n + 1
    +
    69  w1(n) = elon + 1.0
    +
    70  w2(n) = alat + 1.0
    +
    71  END DO
    +
    72  END DO
    +
    73 C
    +
    74  iswt = 1
    +
    75  intrpo = interp
    +
    76  GO TO 1000
    +
    77 C
    +
    78 C AFTER THE 1ST CALL TO W3FT212 TEST INTERP, IF IT HAS
    +
    79 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    80 C
    +
    81  900 CONTINUE
    +
    82  IF (interp.EQ.intrpo) GO TO 2100
    +
    83  intrpo = interp
    +
    84 C
    +
    85  1000 CONTINUE
    +
    86  DO 1100 k = 1,npts
    +
    87  iv(k) = w1(k)
    +
    88  jv(k) = w2(k)
    +
    89  xdeli(k) = w1(k) - iv(k)
    +
    90  xdelj(k) = w2(k) - jv(k)
    +
    91  ip1(k) = iv(k) + 1
    +
    92  jy(k,3) = jv(k) + 1
    +
    93  jy(k,2) = jv(k)
    +
    94  1100 CONTINUE
    +
    95 C
    +
    96  IF (lin) GO TO 2100
    +
    97 C
    +
    98  DO 1200 k = 1,npts
    +
    99  ip2(k) = iv(k) + 2
    +
    100  im1(k) = iv(k) - 1
    +
    101  jy(k,1) = jv(k) - 1
    +
    102  jy(k,4) = jv(k) + 2
    +
    103  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    104  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    105  1200 CONTINUE
    +
    106 C
    +
    107  2100 CONTINUE
    +
    108  IF (lin) THEN
    +
    109 C
    +
    110 C LINEAR INTERPOLATION
    +
    111 C
    +
    112  DO 2200 kk = 1,npts
    +
    113  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    114  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    115  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    116  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    117  2200 CONTINUE
    +
    118 C
    +
    119  DO 2300 kk = 1,npts
    +
    120  alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    121  & * xdelj(kk)
    +
    122  2300 CONTINUE
    +
    123 C
    +
    124  ELSE
    +
    125 C
    +
    126 C QUADRATIC INTERPOLATION
    +
    127 C
    +
    128  DO 2400 kk = 1,npts
    +
    129  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    130  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    131  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    132  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    133  & * xi2tm(kk)
    +
    134  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    135  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    136  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    137  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    138  & * xi2tm(kk)
    +
    139  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    140  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    141  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    142  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    143  & * xi2tm(kk)
    +
    144  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    145  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    146  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    147  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    148  & * xi2tm(kk)
    +
    149  2400 CONTINUE
    +
    150 C
    +
    151  DO 2500 kk = 1,npts
    +
    152  alamb(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    153  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    154  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    155  2500 CONTINUE
    +
    156 C
    +
    157  ENDIF
    +
    158 C
    +
    159  RETURN
    +
    160  END
    +
    +
    +
    w3ft212
    subroutine w3ft212(ALOLA, ALAMB, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft212.f:29
    +
    w3fb12
    subroutine w3fb12(XI, XJ, ALAT1, ELON1, DX, ELONV, ALATAN, ALAT, ELON, IERR)
    Converts the coordinates of a location on Earth given in a grid coordinate system overlaid on a lambe...
    Definition: w3fb12.f:53
    + + + + diff --git a/ver-2.10.0/w3ft213_8f.html b/ver-2.10.0/w3ft213_8f.html new file mode 100644 index 00000000..76a2ec3e --- /dev/null +++ b/ver-2.10.0/w3ft213_8f.html @@ -0,0 +1,184 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft213.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft213.f File Reference
    +
    +
    + +

    Convert (361,91) grid to (129,85) n. hemi. grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft213 (ALOLA, APOLA, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,91) grid to (129,85) n. hemi. grid.

    +
    Author
    Ralph Jones
    +
    Date
    1993-10-23
    + +

    Definition in file w3ft213.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft213()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft213 (real, dimension(361,91) ALOLA,
    real, dimension(npts) APOLA,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    361 by 91 grid to a polar stereographic 129 by 85 grid. The polar stereographic map projection is true at 60 deg. n. , The mesh length is 95.25 km. and the oriention is 105 deg. w. awips grid 213 national - conus - double resolution

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1993-10-23 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA361*91 grid 1.0 deg. lat,lon grid n. hemi. 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to right side and cut to 361 * 91.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]APOLA129*85 grid of northern hemisphere. 10965 point grid is awips grid type 213
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine.
      • +
    • 2. Wind components are not rotated to the 129*85 grid orientation after interpolation. You may use w3fc08() to do this.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1993-10-23
    + +

    Definition at line 30 of file w3ft213.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft213_8f.js b/ver-2.10.0/w3ft213_8f.js new file mode 100644 index 00000000..b504601d --- /dev/null +++ b/ver-2.10.0/w3ft213_8f.js @@ -0,0 +1,4 @@ +var w3ft213_8f = +[ + [ "w3ft213", "w3ft213_8f.html#a1de78ace88fde1b28429425c20838344", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft213_8f_source.html b/ver-2.10.0/w3ft213_8f_source.html new file mode 100644 index 00000000..bab5d664 --- /dev/null +++ b/ver-2.10.0/w3ft213_8f_source.html @@ -0,0 +1,345 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft213.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft213.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,91) grid to (129,85) n. hemi. grid
    +
    3 C> @author Ralph Jones @date 1993-10-23
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 91 grid to a polar stereographic 129 by 85 grid. The polar
    +
    7 C> stereographic map projection is true at 60 deg. n. , The mesh
    +
    8 C> length is 95.25 km. and the oriention is 105 deg. w.
    +
    9 C> awips grid 213 national - conus - double resolution
    +
    10 C>
    +
    11 C> ### Program History Log:
    +
    12 C> Date | Programmer | Comment
    +
    13 C> -----|------------|--------
    +
    14 C> 1993-10-23 | Ralph Jones | Initial.
    +
    15 C>
    +
    16 C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    17 C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    18 C> to right side and cut to 361 * 91.
    +
    19 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    20 C> @param[out] APOLA 129*85 grid of northern hemisphere. 10965 point grid is
    +
    21 C> awips grid type 213
    +
    22 C> @note
    +
    23 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    24 C> reusable for repeated calls to the subroutine.
    +
    25 C> - 2. Wind components are not rotated to the 129*85 grid orientation
    +
    26 C> after interpolation. You may use w3fc08() to do this.
    +
    27 C>
    +
    28 C> @author Ralph Jones @date 1993-10-23
    +
    29  SUBROUTINE w3ft213(ALOLA,APOLA,INTERP)
    +
    30 C
    +
    31  parameter(npts=10965,ii=129,jj=85)
    +
    32  parameter(orient=105.0,ipole=65,jpole=89)
    +
    33  parameter(xmesh=95.250)
    +
    34 C
    +
    35  REAL R2(NPTS), WLON(NPTS)
    +
    36  REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ)
    +
    37  REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS)
    +
    38  REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4)
    +
    39  REAL W1(NPTS), W2(NPTS)
    +
    40  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    41  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    42 C
    +
    43  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    44  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    45 C
    +
    46  LOGICAL LIN
    +
    47 C
    +
    48  SAVE
    +
    49 C
    +
    50  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    51 C
    +
    52  DATA degprd/57.2957795/
    +
    53  DATA earthr/6371.2/
    +
    54  DATA intrpo/99/
    +
    55  DATA iswt /0/
    +
    56 C
    +
    57  lin = .false.
    +
    58  IF (interp.EQ.1) lin = .true.
    +
    59 C
    +
    60  IF (iswt.EQ.1) GO TO 900
    +
    61 C
    +
    62  deg = 1.0
    +
    63  gi2 = (1.86603 * earthr) / xmesh
    +
    64  gi2 = gi2 * gi2
    +
    65 C
    +
    66 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE
    +
    67 C
    +
    68  DO 100 j = 1,jj
    +
    69  xj1 = j - jpole
    +
    70  DO 100 i = 1,ii
    +
    71  xi(i,j) = i - ipole
    +
    72  xj(i,j) = xj1
    +
    73  100 CONTINUE
    +
    74 C
    +
    75  DO 200 kk = 1,npts
    +
    76  r2(kk) = xjj(kk) * xjj(kk) + xii(kk) * xii(kk)
    +
    77  xlat(kk) = degprd *
    +
    78  & asin((gi2 - r2(kk)) / (gi2 + r2(kk)))
    +
    79  200 CONTINUE
    +
    80 C
    +
    81  DO 300 kk = 1,npts
    +
    82  angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    83  300 CONTINUE
    +
    84 C
    +
    85  DO 400 kk = 1,npts
    +
    86  IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    87  400 CONTINUE
    +
    88 C
    +
    89  DO 500 kk = 1,npts
    +
    90  wlon(kk) = 270.0 + orient - angle(kk)
    +
    91  500 CONTINUE
    +
    92 C
    +
    93  DO 600 kk = 1,npts
    +
    94  IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    95  600 CONTINUE
    +
    96 C
    +
    97  DO 700 kk = 1,npts
    +
    98  IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    99  700 CONTINUE
    +
    100 C
    +
    101  DO 800 kk = 1,npts
    +
    102  w1(kk) = (360.0 - wlon(kk)) / deg + 1.0
    +
    103  w2(kk) = xlat(kk) / deg + 1.0
    +
    104  800 CONTINUE
    +
    105 C
    +
    106  iswt = 1
    +
    107  intrpo = interp
    +
    108  GO TO 1000
    +
    109 C
    +
    110 C AFTER THE 1ST CALL TO W3FT213 TEST INTERP, IF IT HAS
    +
    111 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    112 C
    +
    113  900 CONTINUE
    +
    114  IF (interp.EQ.intrpo) GO TO 2100
    +
    115  intrpo = interp
    +
    116 C
    +
    117  1000 CONTINUE
    +
    118  DO 1100 k = 1,npts
    +
    119  iv(k) = w1(k)
    +
    120  jv(k) = w2(k)
    +
    121  xdeli(k) = w1(k) - iv(k)
    +
    122  xdelj(k) = w2(k) - jv(k)
    +
    123  ip1(k) = iv(k) + 1
    +
    124  jy(k,3) = jv(k) + 1
    +
    125  jy(k,2) = jv(k)
    +
    126  1100 CONTINUE
    +
    127 C
    +
    128  IF (lin) GO TO 1400
    +
    129 C
    +
    130  DO 1200 k = 1,npts
    +
    131  ip2(k) = iv(k) + 2
    +
    132  im1(k) = iv(k) - 1
    +
    133  jy(k,1) = jv(k) - 1
    +
    134  jy(k,4) = jv(k) + 2
    +
    135  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    136  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    137  1200 CONTINUE
    +
    138 C
    +
    139  DO 1300 kk = 1,npts
    +
    140  IF (iv(kk).EQ.1) THEN
    +
    141  ip2(kk) = 3
    +
    142  im1(kk) = 360
    +
    143  ELSE IF (iv(kk).EQ.360) THEN
    +
    144  ip2(kk) = 2
    +
    145  im1(kk) = 359
    +
    146  ENDIF
    +
    147  1300 CONTINUE
    +
    148 C
    +
    149  1400 CONTINUE
    +
    150 C
    +
    151  IF (lin) GO TO 1700
    +
    152 C
    +
    153  DO 1500 kk = 1,npts
    +
    154  IF (jv(kk).LT.2.OR.jv(kk).GT.89) xj2tm(kk) = 0.0
    +
    155  1500 CONTINUE
    +
    156 C
    +
    157  DO 1600 kk = 1,npts
    +
    158  IF (ip2(kk).LT.1) ip2(kk) = 1
    +
    159  IF (im1(kk).LT.1) im1(kk) = 1
    +
    160  IF (ip2(kk).GT.361) ip2(kk) = 361
    +
    161  IF (im1(kk).GT.361) im1(kk) = 361
    +
    162  1600 CONTINUE
    +
    163 C
    +
    164  1700 CONTINUE
    +
    165  DO 1800 kk = 1,npts
    +
    166  IF (iv(kk).LT.1) iv(kk) = 1
    +
    167  IF (ip1(kk).LT.1) ip1(kk) = 1
    +
    168  IF (iv(kk).GT.361) iv(kk) = 361
    +
    169  IF (ip1(kk).GT.361) ip1(kk) = 361
    +
    170  1800 CONTINUE
    +
    171 C
    +
    172 C LINEAR INTERPOLATION
    +
    173 C
    +
    174  DO 1900 kk = 1,npts
    +
    175  IF (jy(kk,2).LT.1) jy(kk,2) = 1
    +
    176  IF (jy(kk,2).GT.91) jy(kk,2) = 91
    +
    177  IF (jy(kk,3).LT.1) jy(kk,3) = 1
    +
    178  IF (jy(kk,3).GT.91) jy(kk,3) = 91
    +
    179  1900 CONTINUE
    +
    180 C
    +
    181  IF (.NOT.lin) THEN
    +
    182  DO 2000 kk = 1,npts
    +
    183  IF (jy(kk,1).LT.1) jy(kk,1) = 1
    +
    184  IF (jy(kk,1).GT.91) jy(kk,1) = 91
    +
    185  IF (jy(kk,4).LT.1) jy(kk,4) = 1
    +
    186  IF (jy(kk,4).GT.91) jy(kk,4) = 91
    +
    187  2000 CONTINUE
    +
    188  ENDIF
    +
    189 C
    +
    190  2100 CONTINUE
    +
    191  IF (lin) THEN
    +
    192 C
    +
    193 C LINEAR INTERPOLATION
    +
    194 C
    +
    195  DO 2200 kk = 1,npts
    +
    196  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    197  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    198  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    199  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    200  2200 CONTINUE
    +
    201 C
    +
    202  DO 2300 kk = 1,npts
    +
    203  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    204  & * xdelj(kk)
    +
    205  2300 CONTINUE
    +
    206 C
    +
    207  ELSE
    +
    208 C
    +
    209 C QUADRATIC INTERPOLATION
    +
    210 C
    +
    211  DO 2400 kk = 1,npts
    +
    212  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    213  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    214  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    215  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    216  & * xi2tm(kk)
    +
    217  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    218  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    219  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    220  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    221  & * xi2tm(kk)
    +
    222  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    223  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    224  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    225  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    226  & * xi2tm(kk)
    +
    227  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    228  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    229  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    230  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    231  & * xi2tm(kk)
    +
    232  2400 CONTINUE
    +
    233 C
    +
    234  DO 2500 kk = 1,npts
    +
    235  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    236  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    237  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    238  2500 CONTINUE
    +
    239 C
    +
    240  ENDIF
    +
    241 C
    +
    242  RETURN
    +
    243  END
    +
    +
    +
    w3ft213
    subroutine w3ft213(ALOLA, APOLA, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft213.f:30
    + + + + diff --git a/ver-2.10.0/w3ft214_8f.html b/ver-2.10.0/w3ft214_8f.html new file mode 100644 index 00000000..ca770373 --- /dev/null +++ b/ver-2.10.0/w3ft214_8f.html @@ -0,0 +1,184 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft214.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft214.f File Reference
    +
    +
    + +

    Convert (361,91) grid to (97,69) n. hemi. grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft214 (ALOLA, APOLA, INTERP)
     Convert a northern hemisphere 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,91) grid to (97,69) n. hemi. grid.

    +
    Author
    Ralph Jones
    +
    Date
    1993-10-19
    + +

    Definition in file w3ft214.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft214()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft214 (real, dimension(361,91) ALOLA,
    real, dimension(npts) APOLA,
     INTERP 
    )
    +
    + +

    Convert a northern hemisphere 1.0 degree lat.,lon.

    +

    361 by 91 grid to a polar stereographic 97 by 69 grid. The polar stereographic map projection is true at 60 deg. n. , The mesh length is 47.625 km. and the oriention is 150 deg. w. awips grid 214 regional - alaska - double resolution

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1993-10-19 Ralph Jones Initial.
    +
    Parameters
    + + + + +
    [in]ALOLA361*91 grid 1.0 deg. lat,lon grid n. hemi. 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to right side and cut to 361 * 91.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]APOLA97*69 grid of northern hemisphere. 6693 point grid is awips grid type 214
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine.
      • +
    • 2. Wind components are not rotated to the 97*69 grid orientation after interpolation. you may use w3fc08 to do this.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1993-10-19
    + +

    Definition at line 31 of file w3ft214.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft214_8f.js b/ver-2.10.0/w3ft214_8f.js new file mode 100644 index 00000000..463bc1d8 --- /dev/null +++ b/ver-2.10.0/w3ft214_8f.js @@ -0,0 +1,4 @@ +var w3ft214_8f = +[ + [ "w3ft214", "w3ft214_8f.html#a87c1f4b3ef6dccfe37b0a288d2143848", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft214_8f_source.html b/ver-2.10.0/w3ft214_8f_source.html new file mode 100644 index 00000000..2078e7f8 --- /dev/null +++ b/ver-2.10.0/w3ft214_8f_source.html @@ -0,0 +1,346 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft214.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft214.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,91) grid to (97,69) n. hemi. grid
    +
    3 C> @author Ralph Jones @date 1993-10-19
    +
    4 
    +
    5 C> Convert a northern hemisphere 1.0 degree lat.,lon. 361 by
    +
    6 C> 91 grid to a polar stereographic 97 by 69 grid. The polar
    +
    7 C> stereographic map projection is true at 60 deg. n. , The mesh
    +
    8 C> length is 47.625 km. and the oriention is 150 deg. w.
    +
    9 C> awips grid 214 regional - alaska - double resolution
    +
    10 C>
    +
    11 C> ### Program History Log:
    +
    12 C> Date | Programmer | Comment
    +
    13 C> -----|------------|--------
    +
    14 C> 1993-10-19 | Ralph Jones | Initial.
    +
    15 C>
    +
    16 C> @param[in] ALOLA 361*91 grid 1.0 deg. lat,lon grid n. hemi.
    +
    17 C> 32851 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added
    +
    18 C> to right side and cut to 361 * 91.
    +
    19 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    20 C> @param[out] APOLA 97*69 grid of northern hemisphere. 6693 point grid is
    +
    21 C> awips grid type 214
    +
    22 C>
    +
    23 C> @note
    +
    24 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    25 C> reusable for repeated calls to the subroutine.
    +
    26 C> - 2. Wind components are not rotated to the 97*69 grid orientation
    +
    27 C> after interpolation. you may use w3fc08 to do this.
    +
    28 C>
    +
    29 C> @author Ralph Jones @date 1993-10-19
    +
    30  SUBROUTINE w3ft214(ALOLA,APOLA,INTERP)
    +
    31 C
    +
    32  parameter(npts=6693,ii=97,jj=69)
    +
    33  parameter(orient=150.0,ipole=49,jpole=101)
    +
    34  parameter(xmesh=47.625)
    +
    35 C
    +
    36  REAL R2(NPTS), WLON(NPTS)
    +
    37  REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ)
    +
    38  REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS)
    +
    39  REAL ALOLA(361,91), APOLA(NPTS), ERAS(NPTS,4)
    +
    40  REAL W1(NPTS), W2(NPTS)
    +
    41  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    42  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    43 C
    +
    44  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    45  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    46 C
    +
    47  LOGICAL LIN
    +
    48 C
    +
    49  SAVE
    +
    50 C
    +
    51  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    52 C
    +
    53  DATA degprd/57.2957795/
    +
    54  DATA earthr/6371.2/
    +
    55  DATA intrpo/99/
    +
    56  DATA iswt /0/
    +
    57 C
    +
    58  lin = .false.
    +
    59  IF (interp.EQ.1) lin = .true.
    +
    60 C
    +
    61  IF (iswt.EQ.1) GO TO 900
    +
    62 C
    +
    63  deg = 1.0
    +
    64  gi2 = (1.86603 * earthr) / xmesh
    +
    65  gi2 = gi2 * gi2
    +
    66 C
    +
    67 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE
    +
    68 C
    +
    69  DO 100 j = 1,jj
    +
    70  xj1 = j - jpole
    +
    71  DO 100 i = 1,ii
    +
    72  xi(i,j) = i - ipole
    +
    73  xj(i,j) = xj1
    +
    74  100 CONTINUE
    +
    75 C
    +
    76  DO 200 kk = 1,npts
    +
    77  r2(kk) = xjj(kk) * xjj(kk) + xii(kk) * xii(kk)
    +
    78  xlat(kk) = degprd *
    +
    79  & asin((gi2 - r2(kk)) / (gi2 + r2(kk)))
    +
    80  200 CONTINUE
    +
    81 C
    +
    82  DO 300 kk = 1,npts
    +
    83  angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    84  300 CONTINUE
    +
    85 C
    +
    86  DO 400 kk = 1,npts
    +
    87  IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    88  400 CONTINUE
    +
    89 C
    +
    90  DO 500 kk = 1,npts
    +
    91  wlon(kk) = 270.0 + orient - angle(kk)
    +
    92  500 CONTINUE
    +
    93 C
    +
    94  DO 600 kk = 1,npts
    +
    95  IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    96  600 CONTINUE
    +
    97 C
    +
    98  DO 700 kk = 1,npts
    +
    99  IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    100  700 CONTINUE
    +
    101 C
    +
    102  DO 800 kk = 1,npts
    +
    103  w1(kk) = (360.0 - wlon(kk)) / deg + 1.0
    +
    104  w2(kk) = xlat(kk) / deg + 1.0
    +
    105  800 CONTINUE
    +
    106 C
    +
    107  iswt = 1
    +
    108  intrpo = interp
    +
    109  GO TO 1000
    +
    110 C
    +
    111 C AFTER THE 1ST CALL TO W3FT214 TEST INTERP, IF IT HAS
    +
    112 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    113 C
    +
    114  900 CONTINUE
    +
    115  IF (interp.EQ.intrpo) GO TO 2100
    +
    116  intrpo = interp
    +
    117 C
    +
    118  1000 CONTINUE
    +
    119  DO 1100 k = 1,npts
    +
    120  iv(k) = w1(k)
    +
    121  jv(k) = w2(k)
    +
    122  xdeli(k) = w1(k) - iv(k)
    +
    123  xdelj(k) = w2(k) - jv(k)
    +
    124  ip1(k) = iv(k) + 1
    +
    125  jy(k,3) = jv(k) + 1
    +
    126  jy(k,2) = jv(k)
    +
    127  1100 CONTINUE
    +
    128 C
    +
    129  IF (lin) GO TO 1400
    +
    130 C
    +
    131  DO 1200 k = 1,npts
    +
    132  ip2(k) = iv(k) + 2
    +
    133  im1(k) = iv(k) - 1
    +
    134  jy(k,1) = jv(k) - 1
    +
    135  jy(k,4) = jv(k) + 2
    +
    136  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    137  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    138  1200 CONTINUE
    +
    139 C
    +
    140  DO 1300 kk = 1,npts
    +
    141  IF (iv(kk).EQ.1) THEN
    +
    142  ip2(kk) = 3
    +
    143  im1(kk) = 360
    +
    144  ELSE IF (iv(kk).EQ.360) THEN
    +
    145  ip2(kk) = 2
    +
    146  im1(kk) = 359
    +
    147  ENDIF
    +
    148  1300 CONTINUE
    +
    149 C
    +
    150  1400 CONTINUE
    +
    151 C
    +
    152  IF (lin) GO TO 1700
    +
    153 C
    +
    154  DO 1500 kk = 1,npts
    +
    155  IF (jv(kk).LT.2.OR.jv(kk).GT.89) xj2tm(kk) = 0.0
    +
    156  1500 CONTINUE
    +
    157 C
    +
    158  DO 1600 kk = 1,npts
    +
    159  IF (ip2(kk).LT.1) ip2(kk) = 1
    +
    160  IF (im1(kk).LT.1) im1(kk) = 1
    +
    161  IF (ip2(kk).GT.361) ip2(kk) = 361
    +
    162  IF (im1(kk).GT.361) im1(kk) = 361
    +
    163  1600 CONTINUE
    +
    164 C
    +
    165  1700 CONTINUE
    +
    166  DO 1800 kk = 1,npts
    +
    167  IF (iv(kk).LT.1) iv(kk) = 1
    +
    168  IF (ip1(kk).LT.1) ip1(kk) = 1
    +
    169  IF (iv(kk).GT.361) iv(kk) = 361
    +
    170  IF (ip1(kk).GT.361) ip1(kk) = 361
    +
    171  1800 CONTINUE
    +
    172 C
    +
    173 C LINEAR INTERPOLATION
    +
    174 C
    +
    175  DO 1900 kk = 1,npts
    +
    176  IF (jy(kk,2).LT.1) jy(kk,2) = 1
    +
    177  IF (jy(kk,2).GT.91) jy(kk,2) = 91
    +
    178  IF (jy(kk,3).LT.1) jy(kk,3) = 1
    +
    179  IF (jy(kk,3).GT.91) jy(kk,3) = 91
    +
    180  1900 CONTINUE
    +
    181 C
    +
    182  IF (.NOT.lin) THEN
    +
    183  DO 2000 kk = 1,npts
    +
    184  IF (jy(kk,1).LT.1) jy(kk,1) = 1
    +
    185  IF (jy(kk,1).GT.91) jy(kk,1) = 91
    +
    186  IF (jy(kk,4).LT.1) jy(kk,4) = 1
    +
    187  IF (jy(kk,4).GT.91) jy(kk,4) = 91
    +
    188  2000 CONTINUE
    +
    189  ENDIF
    +
    190 C
    +
    191  2100 CONTINUE
    +
    192  IF (lin) THEN
    +
    193 C
    +
    194 C LINEAR INTERPOLATION
    +
    195 C
    +
    196  DO 2200 kk = 1,npts
    +
    197  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    198  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    199  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    200  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    201  2200 CONTINUE
    +
    202 C
    +
    203  DO 2300 kk = 1,npts
    +
    204  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    205  & * xdelj(kk)
    +
    206  2300 CONTINUE
    +
    207 C
    +
    208  ELSE
    +
    209 C
    +
    210 C QUADRATIC INTERPOLATION
    +
    211 C
    +
    212  DO 2400 kk = 1,npts
    +
    213  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    214  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    215  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    216  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    217  & * xi2tm(kk)
    +
    218  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    219  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    220  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    221  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    222  & * xi2tm(kk)
    +
    223  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    224  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    225  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    226  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    227  & * xi2tm(kk)
    +
    228  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    229  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    230  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    231  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    232  & * xi2tm(kk)
    +
    233  2400 CONTINUE
    +
    234 C
    +
    235  DO 2500 kk = 1,npts
    +
    236  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    237  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    238  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    239  2500 CONTINUE
    +
    240 C
    +
    241  ENDIF
    +
    242 C
    +
    243  RETURN
    +
    244  END
    +
    +
    +
    w3ft214
    subroutine w3ft214(ALOLA, APOLA, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft214.f:31
    + + + + diff --git a/ver-2.10.0/w3ft21_8f.html b/ver-2.10.0/w3ft21_8f.html new file mode 100644 index 00000000..cc35a0b9 --- /dev/null +++ b/ver-2.10.0/w3ft21_8f.html @@ -0,0 +1,231 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft21.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft21.f File Reference
    +
    +
    + +

    Computes 2.5 x 2.5 n. hemi. grid-scaler. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft21 (FLN, GN, PLN, EPS, FL, WORK, TRIGS, L1, L2, I2)
     Computes 2.5 x 2.5 n. More...
     
    +

    Detailed Description

    +

    Computes 2.5 x 2.5 n. hemi. grid-scaler.

    +
    Author
    Ralph Jones
    +
    Date
    1981-11-19
    + +

    Definition in file w3ft21.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft21()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft21 (complex, dimension (31,31) FLN,
    real, dimension (145,37) GN,
    real, dimension (32,31) PLN,
    real, dimension (992) EPS,
    complex, dimension (31) FL,
    real, dimension (144) WORK,
    real, dimension (216) TRIGS,
     L1,
     L2,
     I2 
    )
    +
    + +

    Computes 2.5 x 2.5 n.

    +

    hemi. grid of 145 x 37 points from spectral coefficients in a rhomboidal 30 resolution representing a scalar field. Special version of w3ft08() which gives programmer more control of how many waves are summed and how many points in each wave. A programmer can simulate 24-mode, 12-mode, etc.

    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    1981-11-19 Ralph Jones Initial.
    1984-06-01 Ralph Jones Change to ibm vs fortran.
    +
    Parameters
    + + + + + + + + + + + +
    [in]FLN961 complex coeff.
    [in]PLN992 real space for legendre polynomials
    [in]EPS992 real space for coeffs. used in computing pln.
    [in]FL31 complex space for fourier coeff.
    [in]WORK144 real work space for subr. w3ft12()
    [in]TRIGS216 precomputed trig funcs, used in w3ft12(), computed by w3fa13()
    [in]L1Starting wave number
    [in]L2Ending wave number
    [in]I2Mode of spectral coefficients
    [out]GN(145,37) grid values. 5365 point grid is type 29 or 1d hex o.n. 84
    +
    +
    +
    Note
    This subroutine was optimized to run in a small amount of memory, it is not optimized for speed, 70 percent of the time is used by subroutine w3fa12() computing the legendre polynomials. Since the legendre polynomials are constant they need to be computed only once in a program. By moving w3fa12() to the main program and computing pln as a (32,31,37) array and changing this subroutine to use pln as a three dimension array you can cut the running time 70 percent.
    +
    Author
    Ralph Jones
    +
    Date
    1981-11-19
    + +

    Definition at line 41 of file w3ft21.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft21_8f.js b/ver-2.10.0/w3ft21_8f.js new file mode 100644 index 00000000..02b066a4 --- /dev/null +++ b/ver-2.10.0/w3ft21_8f.js @@ -0,0 +1,4 @@ +var w3ft21_8f = +[ + [ "w3ft21", "w3ft21_8f.html#a681f756a8ebbb0bed83c216be180c4ae", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft21_8f_source.html b/ver-2.10.0/w3ft21_8f_source.html new file mode 100644 index 00000000..f16ca726 --- /dev/null +++ b/ver-2.10.0/w3ft21_8f_source.html @@ -0,0 +1,188 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft21.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft21.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes 2.5 x 2.5 n. hemi. grid-scaler.
    +
    3 C> @author Ralph Jones @date 1981-11-19
    +
    4 
    +
    5 C> Computes 2.5 x 2.5 n. hemi. grid of 145 x 37 points
    +
    6 C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7 C> representing a scalar field. Special version of w3ft08() which
    +
    8 C> gives programmer more control of how many waves are summed
    +
    9 C> and how many points in each wave. A programmer can simulate
    +
    10 C> 24-mode, 12-mode, etc.
    +
    11 C>
    +
    12 C> ### Program History Log:
    +
    13 C> Date | Programmer | Comment
    +
    14 C> -----|------------|--------
    +
    15 C> 1981-11-19 | Ralph Jones | Initial.
    +
    16 C> 1984-06-01 | Ralph Jones | Change to ibm vs fortran.
    +
    17 C>
    +
    18 C> @param[in] FLN 961 complex coeff.
    +
    19 C> @param[in] PLN 992 real space for legendre polynomials
    +
    20 C> @param[in] EPS 992 real space for coeffs. used in computing pln.
    +
    21 C> @param[in] FL 31 complex space for fourier coeff.
    +
    22 C> @param[in] WORK 144 real work space for subr. w3ft12()
    +
    23 C> @param[in] TRIGS 216 precomputed trig funcs, used in w3ft12(), computed by
    +
    24 C> w3fa13()
    +
    25 C> @param[in] L1 Starting wave number
    +
    26 C> @param[in] L2 Ending wave number
    +
    27 C> @param[in] I2 Mode of spectral coefficients
    +
    28 C> @param[out] GN (145,37) grid values. 5365 point grid is type 29 or 1d hex o.n. 84
    +
    29 C>
    +
    30 C> @note This subroutine was optimized to run in a small amount of
    +
    31 C> memory, it is not optimized for speed, 70 percent of the time is
    +
    32 C> used by subroutine w3fa12() computing the legendre polynomials. Since
    +
    33 C> the legendre polynomials are constant they need to be computed
    +
    34 C> only once in a program. By moving w3fa12() to the main program and
    +
    35 C> computing pln as a (32,31,37) array and changing this subroutine
    +
    36 C> to use pln as a three dimension array you can cut the running time
    +
    37 C> 70 percent.
    +
    38 C>
    +
    39 C> @author Ralph Jones @date 1981-11-19
    +
    40  SUBROUTINE w3ft21(FLN,GN,PLN,EPS,FL,WORK,TRIGS,L1,L2,I2)
    +
    41 C
    +
    42  COMPLEX FL (31)
    +
    43  COMPLEX FLN (31,31)
    +
    44 C
    +
    45  REAL COLRA
    +
    46  REAL EPS (992)
    +
    47 C
    +
    48  REAL GN (145,37)
    +
    49  REAL PLN (32,31)
    +
    50  REAL TRIGS (216)
    +
    51  REAL WORK (144)
    +
    52 C
    +
    53  SAVE
    +
    54 C
    +
    55  DATA pi /3.14159265/
    +
    56 C
    +
    57  drad = 2.5 * pi / 180.0
    +
    58 C
    +
    59  k1 = l1 + 1
    +
    60  k2 = l2 + 1
    +
    61  m2 = i2 + 1
    +
    62 C
    +
    63  DO 400 lat = 1,37
    +
    64  latn = 38 - lat
    +
    65  colra = (lat-1) * drad
    +
    66  CALL w3fa12 (pln, colra, 30 ,eps)
    +
    67 C
    +
    68  DO 100 l = 1, 31
    +
    69  fl(l) = (0.,0.)
    +
    70  100 CONTINUE
    +
    71 C
    +
    72  DO 300 l = k1 , k2
    +
    73  DO 200 i = 1 , m2
    +
    74  fl(l) = fl(l) + cmplx(pln(i,l) * real(fln(i,l)) ,
    +
    75  & pln(i,l) * aimag(fln(i,l)) )
    +
    76  200 CONTINUE
    +
    77 C
    +
    78  300 CONTINUE
    +
    79 C
    +
    80  CALL w3ft12(fl,work,gn(1,latn),trigs)
    +
    81 C
    +
    82  400 CONTINUE
    +
    83 C
    +
    84  RETURN
    +
    85  END
    +
    +
    +
    w3ft12
    subroutine w3ft12(COEF, WORK, GRID, TRIGS)
    Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients.
    Definition: w3ft12.f:25
    +
    w3ft21
    subroutine w3ft21(FLN, GN, PLN, EPS, FL, WORK, TRIGS, L1, L2, I2)
    Computes 2.5 x 2.5 n.
    Definition: w3ft21.f:41
    + + + + diff --git a/ver-2.10.0/w3ft26_8f.html b/ver-2.10.0/w3ft26_8f.html new file mode 100644 index 00000000..6b5d79c5 --- /dev/null +++ b/ver-2.10.0/w3ft26_8f.html @@ -0,0 +1,196 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft26.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft26.f File Reference
    +
    +
    + +

    Creates wafs 1.25x1.25 thinned grids. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft26 (MAPNUM, FLD, HI, IGPTS, NSTOP)
     Converts a 360x181 1-degree grid into a nh or sh 360x91 1-degree grid. More...
     
    +

    Detailed Description

    +

    Creates wafs 1.25x1.25 thinned grids.

    +
    Author
    Farley
    +
    Date
    1993-04-28
    + +

    Definition in file w3ft26.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft26()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft26 (integer MAPNUM,
    real, dimension (360,181) FLD,
    real, dimension (3447) HI,
    integer IGPTS,
    integer NSTOP 
    )
    +
    + +

    Converts a 360x181 1-degree grid into a nh or sh 360x91 1-degree grid.

    +

    This nh/sh grid is flipped for grib purposes and then converted to the desired 1.25 degree wafs (quadrant) thinned grid.

    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    1993-04-28 FARLEY Original author.
    1994-04-01 Ralph Jones Corrections for 1 deg. displacement of grids and
    +

    error in flipping of southern hemisphere. 1994-05-05 | Ralph Jones | Replace subr. w3ft01() with w3ft16() and w3ft17(). 1994-06-04 | Ralph Jones | Change subroutine name from wfstrp to w3ft26().

    +
    Parameters
    + + + + + + +
    [in]MAPNUMNumber of grid, 37 to 44.
    [in]FLDNorthern or southern hem. spectral field.
    [in]HIInterpolated wafs field (3447 points)
    [in]IGPTSNumber of points in interpolated field
    [in]NSTOP24, when mapnum .ne. 37 thru 44
    +
    +
    +
    Author
    Farley
    +
    Date
    1993-04-28
    + +

    Definition at line 27 of file w3ft26.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft26_8f.js b/ver-2.10.0/w3ft26_8f.js new file mode 100644 index 00000000..531fa1c5 --- /dev/null +++ b/ver-2.10.0/w3ft26_8f.js @@ -0,0 +1,4 @@ +var w3ft26_8f = +[ + [ "w3ft26", "w3ft26_8f.html#a584757389b1cf4707abb4cadb47850ab", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft26_8f_source.html b/ver-2.10.0/w3ft26_8f_source.html new file mode 100644 index 00000000..1532eef8 --- /dev/null +++ b/ver-2.10.0/w3ft26_8f_source.html @@ -0,0 +1,221 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft26.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft26.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Creates wafs 1.25x1.25 thinned grids.
    +
    3 C> @author Farley @date 1993-04-28
    +
    4 
    +
    5 C> Converts a 360x181 1-degree grid into a nh or sh
    +
    6 C> 360x91 1-degree grid. This nh/sh grid is flipped for grib
    +
    7 C> purposes and then converted to the desired 1.25 degree
    +
    8 C> wafs (quadrant) thinned grid.
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comment
    +
    12 C> -----|------------|--------
    +
    13 C> 1993-04-28 | FARLEY | Original author.
    +
    14 C> 1994-04-01 | Ralph Jones | Corrections for 1 deg. displacement of grids and
    +
    15 C> error in flipping of southern hemisphere.
    +
    16 C> 1994-05-05 | Ralph Jones | Replace subr. w3ft01() with w3ft16() and w3ft17().
    +
    17 C> 1994-06-04 | Ralph Jones | Change subroutine name from wfstrp to w3ft26().
    +
    18 C>
    +
    19 C> @param[in] MAPNUM Number of grid, 37 to 44.
    +
    20 C> @param[in] FLD Northern or southern hem. spectral field.
    +
    21 C> @param[in] HI Interpolated wafs field (3447 points)
    +
    22 C> @param[in] IGPTS Number of points in interpolated field
    +
    23 C> @param[in] NSTOP 24, when mapnum .ne. 37 thru 44
    +
    24 C>
    +
    25 C> @author Farley @date 1993-04-28
    +
    26  SUBROUTINE w3ft26 (MAPNUM,FLD,HI,IGPTS,NSTOP)
    +
    27 C
    +
    28  REAL FLD (360,181)
    +
    29  REAL HALF (360,91)
    +
    30  REAL HI (3447)
    +
    31  REAL QUAD (95,91)
    +
    32 C
    +
    33  INTEGER IGPTS
    +
    34  INTEGER MAPNUM
    +
    35  INTEGER NSTOP
    +
    36 C
    +
    37  SAVE
    +
    38 C
    +
    39 C PRINT *,' MADE IT TO W3FT26'
    +
    40  nstop = 0
    +
    41 C
    +
    42 C 1.0 CUT FULL GRID TO DESIRED HEMISPHERE.
    +
    43 C
    +
    44 C 1.1 EXTRACT THE NORTHERN HEMISPHERE AND FLIP IT.
    +
    45 C
    +
    46  IF (mapnum .EQ. 37 .OR. mapnum .EQ. 38 .OR.
    +
    47  & mapnum .EQ. 39 .OR. mapnum .EQ. 40) THEN
    +
    48  DO j=1,91
    +
    49  DO i=1,360
    +
    50  half(i,91-j+1) = fld(i,j)
    +
    51  END DO
    +
    52  END DO
    +
    53 C
    +
    54 C 1.2 EXTRACT THE SOUTHERN HEMISPHERE AND FLIP IT.
    +
    55 C
    +
    56  ELSE IF (mapnum .EQ. 41 .OR. mapnum .EQ. 42 .OR.
    +
    57  & mapnum .EQ. 43 .OR. mapnum .EQ. 44) THEN
    +
    58  DO j=91,181
    +
    59  DO i=1,360
    +
    60  half(i,181-j+1) = fld(i,j)
    +
    61  END DO
    +
    62  END DO
    +
    63  ENDIF
    +
    64 C
    +
    65 C 2.0 SELECT THE QUADRANT DESIRED.
    +
    66 C
    +
    67  IF (mapnum .EQ. 37 .OR. mapnum .EQ. 41) THEN
    +
    68  DO 372 j = 1,91
    +
    69  DO 370 i = 329,360
    +
    70  quad(i-328,j) = half(i,j)
    +
    71  370 CONTINUE
    +
    72  DO 371 i = 1,63
    +
    73  quad(i+32,j) = half(i,j)
    +
    74  371 CONTINUE
    +
    75  372 CONTINUE
    +
    76 C
    +
    77  ELSE IF (mapnum .EQ. 38 .OR. mapnum .EQ. 42) THEN
    +
    78  DO 381 j = 1,91
    +
    79  DO 380 i = 59,153
    +
    80  quad(i-58,j) = half(i,j)
    +
    81  380 CONTINUE
    +
    82  381 CONTINUE
    +
    83 C
    +
    84  ELSE IF (mapnum .EQ. 39 .OR. mapnum .EQ. 43) THEN
    +
    85  DO 391 j = 1,91
    +
    86  DO 390 i = 149,243
    +
    87  quad(i-148,j) = half(i,j)
    +
    88  390 CONTINUE
    +
    89  391 CONTINUE
    +
    90 C
    +
    91  ELSE IF (mapnum .EQ. 40 .OR. mapnum .EQ. 44) THEN
    +
    92  DO 401 j = 1,91
    +
    93  DO 400 i = 239,333
    +
    94  quad(i-238,j) = half(i,j)
    +
    95  400 CONTINUE
    +
    96  401 CONTINUE
    +
    97 C
    +
    98  ELSE
    +
    99  print *,' W3FT26 - MAP NOT TYPE 37-44'
    +
    100  igpts = 0
    +
    101  nstop = 24
    +
    102  RETURN
    +
    103  ENDIF
    +
    104 C
    +
    105  interp = 0
    +
    106 C
    +
    107  IF (mapnum .EQ. 37 .OR. mapnum .EQ. 38 .OR.
    +
    108  & mapnum .EQ. 39 .OR. mapnum .EQ. 40) THEN
    +
    109  CALL w3ft16(quad,hi,interp)
    +
    110  ELSE
    +
    111  CALL w3ft17(quad,hi,interp)
    +
    112  ENDIF
    +
    113 C
    +
    114  igpts = 3447
    +
    115 C
    +
    116  RETURN
    +
    117  END
    +
    +
    +
    w3ft17
    subroutine w3ft17(ALOLA, BTHIN, INTERP)
    Convert a southern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft17.f:24
    +
    w3ft16
    subroutine w3ft16(ALOLA, BTHIN, INTERP)
    Convert a northern hemisphere 1.0 degree lat.,lon.
    Definition: w3ft16.f:24
    +
    w3ft26
    subroutine w3ft26(MAPNUM, FLD, HI, IGPTS, NSTOP)
    Converts a 360x181 1-degree grid into a nh or sh 360x91 1-degree grid.
    Definition: w3ft26.f:27
    + + + + diff --git a/ver-2.10.0/w3ft32_8f.html b/ver-2.10.0/w3ft32_8f.html new file mode 100644 index 00000000..e686dc1c --- /dev/null +++ b/ver-2.10.0/w3ft32_8f.html @@ -0,0 +1,214 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft32.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft32.f File Reference
    +
    +
    + +

    General interpolator between nmc flds. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft32 (FIELD, MAPIN, DATA, MAPOUT, INTERP, IER)
     Interpolate scalar quantity from any given nmc field (in office note 84) to any other field. More...
     
    +

    Detailed Description

    +

    General interpolator between nmc flds.

    +
    Author
    John Stackpole
    +
    Date
    1974-06-15
    + +

    Definition in file w3ft32.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft32()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft32 (real, dimension(*) FIELD,
     MAPIN,
    real, dimension(*) DATA,
     MAPOUT,
     INTERP,
     IER 
    )
    +
    + +

    Interpolate scalar quantity from any given nmc field (in office note 84) to any other field.

    +

    Can do bilinearly or biquadratically. Will not rotate wind components. Input and output fields are real*4 unpacked

    +

    +Program History Log:

    +

    Date | Programmer | Comment --—|---------—|-----— 1974-06-15 | John Stackpole | 1987-07-15 | Bill Cavanaugh | Add grid type 100, 101 to tables. 1990-08-08 | John. Stackpole | Correct rotation error wrt 100, 101 1990-08-31 | Ralph Jones | Change name from polate to w3ft32 1993-01-26 | Dennis Keyser | Added grid types 87, 105, 106, 107 to tables (as both input and output).

    +
    Parameters
    + + + + + + + +
    [in]FIELDREAL*4 Two dimensional array.
    [in]MAPININTEGER*4 Nmc map number (k) for given input field.
    [in]MAPOUTINTEGER*4 Nmc map number (k) for wanted output field.
    [in]INTERPINTEGER*4 Set interpolation method:
      +
    • eq 1 - linear
      • +
    • ne 1 - biquadratic
      • +
    +
    [out]DATAREAL*4 Array to hold output map (unpacked).
    [out]IERINTEGER*4 Completion condition flag
    +
    +
    +

    Return conditions:

      +
    • IER:
        +
      • 0 No difficulties
        • +
      • 1 Mapin not recognized
        • +
      • 2 Mapout not recognized
        • +
      • 3 Particular pola mapout not recognized
        • +
      • 4 Particular lola mapout not recognized
        • +
      • 5 Particular lola mapin not recognized
        • +
      • 6 Particular pola mapout not recognized
        • +
      • 7 Particular lola mapin not recognized
        • +
      • 8 Particular lola mapout not recognized these flags are set at various test locations please refer to the code listing for details
        • +
      +
      • +
    +
    Note
    See comment cards following for more detail including recipes for adding more input and output maps as the need arises.
    +
    Author
    John Stackpole
    +
    Date
    1974-06-15
    + +

    Definition at line 49 of file w3ft32.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft32_8f.js b/ver-2.10.0/w3ft32_8f.js new file mode 100644 index 00000000..0241891e --- /dev/null +++ b/ver-2.10.0/w3ft32_8f.js @@ -0,0 +1,4 @@ +var w3ft32_8f = +[ + [ "w3ft32", "w3ft32_8f.html#acfaec65cdd9e813295e8e83626c176cd", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft32_8f_source.html b/ver-2.10.0/w3ft32_8f_source.html new file mode 100644 index 00000000..d36c9a1f --- /dev/null +++ b/ver-2.10.0/w3ft32_8f_source.html @@ -0,0 +1,1329 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft32.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft32.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief General interpolator between nmc flds.
    +
    3 C> @author John Stackpole @date 1974-06-15
    +
    4 
    +
    5 C> Interpolate scalar quantity from any given nmc
    +
    6 C> field (in office note 84) to any other field. Can do bilinearly
    +
    7 C> or biquadratically. Will not rotate wind components.
    +
    8 C> Input and output fields are real*4 unpacked
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comment
    +
    12 C> -----|------------|--------
    +
    13 C> 1974-06-15 | John Stackpole |
    +
    14 C> 1987-07-15 | Bill Cavanaugh | Add grid type 100, 101 to tables.
    +
    15 C> 1990-08-08 | John. Stackpole | Correct rotation error wrt 100, 101
    +
    16 C> 1990-08-31 | Ralph Jones | Change name from polate to w3ft32
    +
    17 C> 1993-01-26 | Dennis Keyser | Added grid types 87, 105, 106, 107 to
    +
    18 C> tables (as both input and output).
    +
    19 C>
    +
    20 C> @param[in] FIELD REAL*4 Two dimensional array.
    +
    21 C> @param[in] MAPIN INTEGER*4 Nmc map number (k) for given input field.
    +
    22 C> @param[in] MAPOUT INTEGER*4 Nmc map number (k) for wanted output field.
    +
    23 C> @param[in] INTERP INTEGER*4 Set interpolation method:
    +
    24 C> - eq 1 - linear
    +
    25 C> - ne 1 - biquadratic
    +
    26 C> @param[out] DATA REAL*4 Array to hold output map (unpacked).
    +
    27 C> @param[out] IER INTEGER*4 Completion condition flag
    +
    28 C>
    +
    29 C> Return conditions:
    +
    30 C> - IER:
    +
    31 C> - 0 No difficulties
    +
    32 C> - 1 Mapin not recognized
    +
    33 C> - 2 Mapout not recognized
    +
    34 C> - 3 Particular pola mapout not recognized
    +
    35 C> - 4 Particular lola mapout not recognized
    +
    36 C> - 5 Particular lola mapin not recognized
    +
    37 C> - 6 Particular pola mapout not recognized
    +
    38 C> - 7 Particular lola mapin not recognized
    +
    39 C> - 8 Particular lola mapout not recognized
    +
    40 C> these flags are set at various test locations
    +
    41 C> please refer to the code listing for details
    +
    42 C>
    +
    43 C> @note See comment cards following for more detail
    +
    44 C> including recipes for adding more input and
    +
    45 C> output maps as the need arises.
    +
    46 C>
    +
    47 C> @author John Stackpole @date 1974-06-15
    +
    48  SUBROUTINE w3ft32(FIELD, MAPIN, DATA, MAPOUT, INTERP, IER)
    +
    49 C
    +
    50 C INTERPOLATE INFORMATION FROM FIELD (MAP TYPE K = MAPIN)
    +
    51 C TO DATA (MAP TYPE K = MAPOUT)
    +
    52 C INTERP SETS INTERPOLATION METHOD
    +
    53 C = 1 BILINEAR, OTHERWISE BIQUADRATIC
    +
    54 C
    +
    55  REAL DATA(*), FIELD(*)
    +
    56 C
    +
    57 C RESTRICTION AND RULES:
    +
    58 C
    +
    59 C AT PRESENT W3FT32 WILL ACCEPT ONLY THE FOLLOWING TYPES
    +
    60 C POLAR STEREOGRAPHIC
    +
    61 C K = 5 & 26 (LFM ANL & FCST RESPECTIVELY)
    +
    62 C 27 & 28 (65X65)
    +
    63 C 25 (53X57 SOUTHERN HEMISPHERE)
    +
    64 C 49 (129X129 NH; 190.5 KM)
    +
    65 C 50 (129X129 SH; 190.5 KM)
    +
    66 C 55 (87X71 NH; LFM ORIENT; 254 KM)
    +
    67 C 56 (87X71 NA; LFM ORIENT; 174 KM)
    +
    68 C 60 (57X57 ENLARGED LFM 'VLFM')
    +
    69 C 87 (81X62 MAPS ANAL/FCST GRID; 68.153 KM)
    +
    70 C 100 (83X83 NGM C-GRID; 91.452)
    +
    71 C 101 (113X91 NGM BIG C-GRID; 91.452)
    +
    72 C 105 (83X83 NGM SUPER C-GRID SUBSET; 90.75464 KM)
    +
    73 C 106 (165X117 HI RESOLUTION GRID; 45.37732 KM)
    +
    74 C 107 (120X92 HI RESOLUTION GRID SUBSET; 45.37732 KM)
    +
    75 C
    +
    76 C LONGITUDE/LATITUDE: ('LOLA')
    +
    77 C K = 29 & 30 (145X37)
    +
    78 C 33 & 34 (181X46)
    +
    79 C 45 & 46 (97X25 - 3.75 DEG LOLA)
    +
    80 C 21 & 22 (73X19 - 5 DEG LOLA)
    +
    81 C 21 & 22 (73X19 - 5 DEG LOLA)
    +
    82 C
    +
    83 C WILL OUTPUT:
    +
    84 C POLAR STEREO:
    +
    85 C K = 5 (53X57) LFM
    +
    86 C 25 (53X57 SOUTH HEMISPHERE)
    +
    87 C 26 (53X45) LFM
    +
    88 C 27 & 28 (65X65)
    +
    89 C 49 (129X129 NH POLA) (1/2 BEDIENT MESH;ORIENTED 80W)
    +
    90 C 50 (129X129 SH POLA) (1/2 BEDIENT MESH;ORINETED 80W)
    +
    91 C 51 (129X129 NH POLA) (SAME MESHL; ORIENTED AT 105W)
    +
    92 C 55 (NH 87X71 254 KM, LFM ORIENT)
    +
    93 C 56 (NA 87X71 127 KM, LFM ORIENT)
    +
    94 C 60 (57X57 ENLARGED LFM 'VLFM')
    +
    95 C 87 (81X62 MAPS ANAL/FCST GRID; 68.153 KM)
    +
    96 C 100 (83X83 NGM C-GRID)
    +
    97 C 101 (113X91 NGM BIG C-GRID)
    +
    98 C 105 (83X83 NGM SUPER C-GRID SUBSET; 90.75464 KM)
    +
    99 C 106 (165X117 HI RESOLUTION GRID; 45.37732 KM)
    +
    100 C 107 (120X92 HI RESOLUTION GRID SUBSET; 45.37732 KM)
    +
    101 C 400 (39X39 1:40MIL 80 DEG VERTICAL POLA)
    +
    102 C 401 (25X35 1:20MIL U.S. SECTION ROTATED)
    +
    103 C 402 (97X97 1-20MIL N.H. POLA ROTATED TO 105W VERT)
    +
    104 C 403 (97X97 1-20MIL S.H. POLA UNROTATED 80W TOP VERT)
    +
    105 C LOLA:
    +
    106 C K = 29 & 30 (145X37)
    +
    107 C 33 & 34 (181X46)
    +
    108 C 45 & 46 (97X25 - 3.75 DEG LOLA)
    +
    109 C 500 & 501 US SECTIONAL NEP 36 & 45
    +
    110 C
    +
    111 C FEEL FREE, GENTLE READER, TO AUGMENT THE LIST AS YOU WISH
    +
    112 C AND HERE IS A RECIPE FOR ADDING A NEW OUTPUT GRID
    +
    113 C (POLA IN THIS CASE, BUT I AM SURE YOU CAN DRAW THE ANALOGY)
    +
    114 C STEP1
    +
    115 C PUT NEW NUMBER IN COMMENT ABOVE
    +
    116 C STEP 2
    +
    117 C ADD IT TO MAPOUT LIST NEAR STMT 30
    +
    118 C STEP 3
    +
    119 C ADD SET OF PARAMETERS AT STMT 2000 (FOR POLA)
    +
    120 C STEP4
    +
    121 C ADD SET OF PARAMETERS AT STMT 6000 (FOR POLA)
    +
    122 C
    +
    123 C HERE TOO IS A RECIPE FOR ADDING A NEW (POLA) INPUT GRID
    +
    124 C
    +
    125 C STEP 1:
    +
    126 C PUT NEW NUMBER IN COMMENT ABOVE
    +
    127 C STEP2:
    +
    128 C ADD NUMBER TO IF(MAPIN.. ) TEST BELOW
    +
    129 C STEP 3:
    +
    130 C ADD INPUT MAP CHARACTERISTICS AT STMT 1000
    +
    131 C STEP 4:
    +
    132 C DITTO AT STMT 3000
    +
    133 C
    +
    134  LOGICAL LOLAIN, POLAIN, LOLAOU, POLAOU
    +
    135 C
    +
    136  SAVE
    +
    137 C
    +
    138 C BEGIN HERE - SET ERROR RETURN TO O.K.
    +
    139 C
    +
    140  ier = 0
    +
    141 C
    +
    142 C DETERMINE WHETHER INPUT GRID IS LOLA OR POLA
    +
    143 C
    +
    144 C THIS LIST CAN BE AUGMENTED ONLY AT THE COST OF A LOT OF
    +
    145 C WORK ELSEWHERE IN THE PROGRAM
    +
    146 C HAVE AT IT IF YOU WANT OTHER MAPS
    +
    147 C
    +
    148 C POLA MAPS
    +
    149 C
    +
    150  IF (mapin.EQ. 5) GO TO 10
    +
    151  IF (mapin.EQ.25) GO TO 10
    +
    152  IF (mapin.EQ.26) GO TO 10
    +
    153  IF (mapin.EQ.27) GO TO 10
    +
    154  IF (mapin.EQ.28) GO TO 10
    +
    155  IF (mapin.EQ.49) GO TO 10
    +
    156  IF (mapin.EQ.50) GO TO 10
    +
    157  IF (mapin.EQ.51) GO TO 10
    +
    158  IF (mapin.EQ.55) GO TO 10
    +
    159  IF (mapin.EQ.56) GO TO 10
    +
    160  IF (mapin.EQ.60) GO TO 10
    +
    161  IF (mapin.EQ.87) GO TO 10
    +
    162  IF (mapin.EQ.100) GO TO 10
    +
    163  IF (mapin.EQ.101) GO TO 10
    +
    164  IF (mapin.EQ.105) GO TO 10
    +
    165  IF (mapin.EQ.106) GO TO 10
    +
    166  IF (mapin.EQ.107) GO TO 10
    +
    167 C
    +
    168 C LOLA MAPS
    +
    169 C
    +
    170  IF (mapin.EQ.21) GO TO 20
    +
    171  IF (mapin.EQ.22) GO TO 20
    +
    172  IF (mapin.EQ.29) GO TO 20
    +
    173  IF (mapin.EQ.30) GO TO 20
    +
    174  IF (mapin.EQ.33) GO TO 20
    +
    175  IF (mapin.EQ.34) GO TO 20
    +
    176  IF (mapin.EQ.45) GO TO 20
    +
    177  IF (mapin.EQ.46) GO TO 20
    +
    178 C
    +
    179 C IF NO MATCH - ERROR
    +
    180 C
    +
    181  ier = 1
    +
    182  RETURN
    +
    183 C
    +
    184 C SET LOGICAL FLAGS
    +
    185 C
    +
    186  10 lolain = .false.
    +
    187  polain = .true.
    +
    188  GO TO 30
    +
    189 C
    +
    190  20 lolain = .true.
    +
    191  polain = .false.
    +
    192 C
    +
    193 C DITTO FOR OUTPUT MAP TYPE
    +
    194 C
    +
    195 C POLA MAPS
    +
    196 C
    +
    197  30 IF (mapout.EQ. 5) GO TO 40
    +
    198  IF (mapout.EQ.25) GO TO 40
    +
    199  IF (mapout.EQ.26) GO TO 40
    +
    200  IF (mapout.EQ.27) GO TO 40
    +
    201  IF (mapout.EQ.28) GO TO 40
    +
    202  IF (mapout.EQ.49) GO TO 40
    +
    203  IF (mapout.EQ.50) GO TO 40
    +
    204  IF (mapout.EQ.51) GO TO 40
    +
    205  IF (mapout.EQ.55) GO TO 40
    +
    206  IF (mapout.EQ.56) GO TO 40
    +
    207  IF (mapout.EQ.60) GO TO 40
    +
    208  IF (mapout.EQ.87) GO TO 40
    +
    209  IF (mapout.EQ.100) GO TO 40
    +
    210  IF (mapout.EQ.101) GO TO 40
    +
    211  IF (mapout.EQ.105) GO TO 40
    +
    212  IF (mapout.EQ.106) GO TO 40
    +
    213  IF (mapout.EQ.107) GO TO 40
    +
    214  IF (mapout.EQ.400) GO TO 40
    +
    215  IF (mapout.EQ.401) GO TO 40
    +
    216  IF (mapout.EQ.402) GO TO 40
    +
    217  IF (mapout.EQ.403) GO TO 40
    +
    218 C
    +
    219 C LOLA MAPS
    +
    220 C
    +
    221  IF (mapout.EQ.21) GO TO 50
    +
    222  IF (mapout.EQ.22) GO TO 50
    +
    223  IF (mapout.EQ.29) GO TO 50
    +
    224  IF (mapout.EQ.30) GO TO 50
    +
    225  IF (mapout.EQ.33) GO TO 50
    +
    226  IF (mapout.EQ.34) GO TO 50
    +
    227  IF (mapout.EQ.45) GO TO 50
    +
    228  IF (mapout.EQ.46) GO TO 50
    +
    229  IF (mapout.EQ.500) GO TO 50
    +
    230  IF (mapout.EQ.501) GO TO 50
    +
    231 C
    +
    232 C NO MATCH - ERROR
    +
    233 C
    +
    234  ier = 2
    +
    235  RETURN
    +
    236 C
    +
    237 C SET LOGICAL FLAGS
    +
    238 C
    +
    239  40 lolaou = .false.
    +
    240  polaou = .true.
    +
    241  GO TO 60
    +
    242 C
    +
    243  50 lolaou = .true.
    +
    244  polaou = .false.
    +
    245 C
    +
    246 C GO TO DIFFERENT SECTIONS FOR IN/OUT OPTIONS
    +
    247 C
    +
    248  60 IF (polain) GO TO 1000
    +
    249  IF (lolain) GO TO 5000
    +
    250 C
    +
    251 C ##################################################################
    +
    252 C ##################################################################
    +
    253 C
    +
    254 C THIS SECTION FOR POLAR STEREOGRAPHIC INPUT MAPS
    +
    255 C
    +
    256 C SUBDIVIDED FOR OUTPUT TYPE
    +
    257 C
    +
    258  1000 IF (lolaou) GO TO 3000
    +
    259 C
    +
    260 C POLAR STEREO TO POLAR STEREO
    +
    261 C USE HOWCROFTS FIELD TRANSFORMER
    +
    262 C ORIENT IS DEGREES OF ROTATION FROM NMC STANDARD
    +
    263 C (80 DEG CENTER VERTIVAL) TO INPUT GRID (POSITIVE ANTICLOCKWISE)
    +
    264 C
    +
    265  IF (mapin.EQ. 5) GO TO 1005
    +
    266  IF (mapin.EQ.25) GO TO 1025
    +
    267  IF (mapin.EQ.26) GO TO 1026
    +
    268  IF (mapin.EQ.27) GO TO 1027
    +
    269  IF (mapin.EQ.28) GO TO 1027
    +
    270  IF (mapin.EQ.49) GO TO 1049
    +
    271  IF (mapin.EQ.50) GO TO 1049
    +
    272  IF (mapin.EQ.51) GO TO 1051
    +
    273  IF (mapin.EQ.55) GO TO 1055
    +
    274  IF (mapin.EQ.56) GO TO 1056
    +
    275  IF (mapin.EQ.60) GO TO 1060
    +
    276  IF (mapin.EQ.87) GO TO 1087
    +
    277  IF (mapin.EQ.100) GO TO 1100
    +
    278  IF (mapin.EQ.101) GO TO 1101
    +
    279  IF (mapin.EQ.105) GO TO 1105
    +
    280  IF (mapin.EQ.106) GO TO 1106
    +
    281  IF (mapin.EQ.107) GO TO 1107
    +
    282  ier = 1
    +
    283  RETURN
    +
    284 C
    +
    285  1005 imaxin =53
    +
    286  jmaxin = 57
    +
    287  comiin = 27.
    +
    288  comjin = 49.
    +
    289  orient = -25.
    +
    290  xmesh = 190.5
    +
    291  GO TO 2000
    +
    292 C
    +
    293  1025 imaxin = 53
    +
    294  jmaxin = 57
    +
    295  comiin = 27.
    +
    296  comjin = 29.
    +
    297  orient = 0.
    +
    298  xmesh = 381.
    +
    299  GO TO 2000
    +
    300 C
    +
    301  1026 imaxin = 53
    +
    302  jmaxin = 45
    +
    303  comiin = 27.
    +
    304  comjin = 49.
    +
    305  orient = -25.
    +
    306  xmesh = 190.5
    +
    307  GO TO 2000
    +
    308 C
    +
    309  1027 imaxin = 65
    +
    310  jmaxin = 65
    +
    311  comiin = 33.
    +
    312  comjin = 33.
    +
    313  orient = 0.
    +
    314  xmesh = 381.
    +
    315  GO TO 2000
    +
    316 C
    +
    317  1049 imaxin = 129
    +
    318  jmaxin = 129
    +
    319  comiin = 65.
    +
    320  comjin = 65.
    +
    321  orient = 0.
    +
    322  xmesh = 190.5
    +
    323  GOTO 2000
    +
    324 C
    +
    325  1051 imaxin = 129
    +
    326  jmaxin = 129
    +
    327  comiin = 65.
    +
    328  comjin = 65.
    +
    329  orient = -25.
    +
    330  xmesh = 190.5
    +
    331  GOTO 2000
    +
    332 C
    +
    333  1055 imaxin = 87
    +
    334  jmaxin = 71
    +
    335  comiin = 44.
    +
    336  comjin = 38.
    +
    337  orient = -25.
    +
    338  xmesh = 254.
    +
    339  GOTO 2000
    +
    340 C
    +
    341  1056 imaxin = 87
    +
    342  jmaxin = 71
    +
    343  comiin = 40.
    +
    344  comjin = 73.
    +
    345  orient = -25.
    +
    346  xmesh = 127.
    +
    347  GOTO 2000
    +
    348 C
    +
    349  1060 imaxin= 57
    +
    350  jmaxin = 57
    +
    351  comiin = 29.
    +
    352  comjin = 49.
    +
    353  orient = -25.
    +
    354  xmesh = 190.5
    +
    355  GO TO 2000
    +
    356 C
    +
    357  1087 imaxin= 81
    +
    358  jmaxin = 62
    +
    359  comiin = 31.91
    +
    360  comjin = 112.53
    +
    361  orient = -25.
    +
    362  xmesh = 68.153
    +
    363  GO TO 2000
    +
    364 C
    +
    365  1100 imaxin = 83
    +
    366  jmaxin = 83
    +
    367  comiin = 40.5
    +
    368  comjin = 88.5
    +
    369  orient = -25.
    +
    370  xmesh = 91.452
    +
    371  GO TO 2000
    +
    372 C
    +
    373  1101 imaxin = 113
    +
    374  jmaxin = 91
    +
    375  comiin = 58.5
    +
    376  comjin = 92.5
    +
    377  orient = -25.
    +
    378  xmesh = 91.452
    +
    379  GO TO 2000
    +
    380 C
    +
    381  1105 imaxin = 83
    +
    382  jmaxin = 83
    +
    383  comiin = 40.5
    +
    384  comjin = 88.5
    +
    385  orient = -25.
    +
    386  xmesh = 90.75464
    +
    387  GO TO 2000
    +
    388 C
    +
    389  1106 imaxin = 165
    +
    390  jmaxin = 117
    +
    391  comiin = 80.0
    +
    392  comjin = 176.0
    +
    393  orient = -25.
    +
    394  xmesh = 45.37732
    +
    395  GO TO 2000
    +
    396 C
    +
    397  1107 imaxin = 120
    +
    398  jmaxin = 92
    +
    399  comiin = 46.0
    +
    400  comjin = 167.0
    +
    401  orient = -25.
    +
    402  xmesh = 45.37732
    +
    403  GO TO 2000
    +
    404 C
    +
    405 C SELECT I, J, DILATION, ROTATION, AND COMMON POINT (POLE) OUTPUT
    +
    406 C DILATE = XMESHOUT / XMESHIN
    +
    407 C IN THE FOLLOWING, ROT IS THE ROTATION FROM THE INPUT TO
    +
    408 C THE OUTPUT GRID - NOT THE ORIENTATION OF THE OUT-GRID
    +
    409 C
    +
    410  2000 IF (mapout.EQ. 5) GO TO 2005
    +
    411  IF (mapout.EQ.25) GO TO 2025
    +
    412  IF (mapout.EQ.26) GO TO 2026
    +
    413  IF (mapout.EQ.27) GO TO 2027
    +
    414  IF (mapout.EQ.28) GO TO 2027
    +
    415  IF (mapout.EQ.49) GO TO 2049
    +
    416  IF (mapout.EQ.50) GO TO 2049
    +
    417  IF (mapout.EQ.51) GO TO 2051
    +
    418  IF (mapout.EQ.55) GO TO 2055
    +
    419  IF (mapout.EQ.56) GO TO 2056
    +
    420  IF (mapout.EQ.60) GO TO 2060
    +
    421  IF (mapout.EQ.87) GO TO 2087
    +
    422  IF (mapout.EQ.100) GO TO 2100
    +
    423  IF (mapout.EQ.101) GO TO 2101
    +
    424  IF (mapout.EQ.105) GO TO 2105
    +
    425  IF (mapout.EQ.106) GO TO 2106
    +
    426  IF (mapout.EQ.107) GO TO 2107
    +
    427  IF (mapout.EQ.400) GO TO 2400
    +
    428  IF (mapout.EQ.401) GO TO 2401
    +
    429  IF (mapout.EQ.402) GO TO 2402
    +
    430  IF (mapout.EQ.403) GO TO 2403
    +
    431  ier = 3
    +
    432  RETURN
    +
    433 C
    +
    434  2005 imaxou = 53
    +
    435  jmaxou = 57
    +
    436  dilat = 190.5/xmesh
    +
    437  rot = -25. - orient
    +
    438  comiou = 27.
    +
    439  comjou = 49.
    +
    440  GO TO 2700
    +
    441 C
    +
    442  2025 imaxou = 53
    +
    443  jmaxou = 57
    +
    444  dilat = 381./xmesh
    +
    445  rot = 0. - orient
    +
    446  comiou = 27.
    +
    447  comjou = 29.
    +
    448  GO TO 2700
    +
    449 C
    +
    450  2026 imaxou = 53
    +
    451  jmaxou = 45
    +
    452  dilat = 190.5/xmesh
    +
    453  rot = -25. - orient
    +
    454  comiou = 27.
    +
    455  comjou = 49.
    +
    456  GO TO 2700
    +
    457 C
    +
    458  2027 imaxou = 65
    +
    459  jmaxou = 65
    +
    460  dilat = 381./xmesh
    +
    461  rot = 0. - orient
    +
    462  comiou = 33.
    +
    463  comjou = 33.
    +
    464  GO TO 2700
    +
    465 C
    +
    466  2049 imaxou = 129
    +
    467  jmaxou = 129
    +
    468  dilat = 190.5/xmesh
    +
    469  rot = 0. - orient
    +
    470  comiou = 65.
    +
    471  comjou = 65.
    +
    472  GOTO 2700
    +
    473 C
    +
    474  2051 imaxou = 129
    +
    475  jmaxou = 129
    +
    476  dilat = 190.5/xmesh
    +
    477  rot = -25. - orient
    +
    478  comiou = 65.
    +
    479  comjou = 65.
    +
    480  GOTO 2700
    +
    481 C
    +
    482  2055 imaxou = 87
    +
    483  jmaxou = 71
    +
    484  dilat = 254./xmesh
    +
    485  rot = -25. - orient
    +
    486  comiou = 44.
    +
    487  comjou = 38.
    +
    488  GOTO 2700
    +
    489 C
    +
    490  2056 imaxou = 87
    +
    491  jmaxou = 71
    +
    492  dilat = 127./xmesh
    +
    493  rot = -25. - orient
    +
    494  comiou = 40.
    +
    495  comjou = 73.
    +
    496  GOTO 2700
    +
    497 C
    +
    498  2060 imaxou = 57
    +
    499  jmaxou = 57
    +
    500  dilat = 190.5/xmesh
    +
    501  rot = -25. - orient
    +
    502  comiou = 29.
    +
    503  comjou = 49.
    +
    504  GO TO 2700
    +
    505 C
    +
    506  2087 imaxou = 81
    +
    507  jmaxou = 62
    +
    508  dilat = 68.153/xmesh
    +
    509  rot = -25. - orient
    +
    510  comiou = 31.91
    +
    511  comjou = 112.53
    +
    512  GO TO 2700
    +
    513 C
    +
    514  2100 imaxou = 83
    +
    515  jmaxou = 83
    +
    516  dilat = 91.452/xmesh
    +
    517  rot = -25. - orient
    +
    518  comiou = 40.5
    +
    519  comjou = 88.5
    +
    520  GO TO 2700
    +
    521 C
    +
    522  2101 imaxou = 113
    +
    523  jmaxou = 91
    +
    524  dilat = 91.452/xmesh
    +
    525  rot = -25. - orient
    +
    526  comiou = 58.5
    +
    527  comjou = 92.5
    +
    528  GO TO 2700
    +
    529 C
    +
    530  2105 imaxou = 83
    +
    531  jmaxou = 83
    +
    532  dilat = 90.75464/xmesh
    +
    533  rot = -25. - orient
    +
    534  comiou = 40.5
    +
    535  comjou = 88.5
    +
    536  GO TO 2700
    +
    537 C
    +
    538  2106 imaxou = 165
    +
    539  jmaxou = 117
    +
    540  dilat = 45.37732/xmesh
    +
    541  rot = -25. - orient
    +
    542  comiou = 80.0
    +
    543  comjou = 176.0
    +
    544  GO TO 2700
    +
    545 C
    +
    546  2107 imaxou = 120
    +
    547  jmaxou = 92
    +
    548  dilat = 45.37732/xmesh
    +
    549  rot = -25. - orient
    +
    550  comiou = 46.0
    +
    551  comjou = 167.0
    +
    552  GO TO 2700
    +
    553 C
    +
    554  2400 imaxou = 39
    +
    555  jmaxou = 39
    +
    556  dilat = 508./ xmesh
    +
    557  rot = 0. - orient
    +
    558  comiou = 20.
    +
    559  comjou = 20.
    +
    560  GO TO 2700
    +
    561 C
    +
    562  2401 imaxou = 25
    +
    563  jmaxou = 35
    +
    564  dilat = 254./xmesh
    +
    565  rot = -25. + 90. - orient
    +
    566  comiou =31.75
    +
    567  comjou = 18.
    +
    568  GO TO 2700
    +
    569 C
    +
    570  2402 imaxou = 97
    +
    571  jmaxou = 97
    +
    572  dilat = 254./xmesh
    +
    573  rot = -25. - orient
    +
    574  comiou = 49.
    +
    575  comjou = 49.
    +
    576  GOTO 2700
    +
    577 C
    +
    578  2403 imaxou = 97
    +
    579  jmaxou = 97
    +
    580  dilat = 254./xmesh
    +
    581  rot = 0. - orient
    +
    582  comiou = 49.
    +
    583  comjou = 49.
    +
    584  GOTO 2700
    +
    585 C
    +
    586  2700 CALL w3ft00
    +
    587  1 (field, DATA, imaxin, jmaxin, imaxou, jmaxou,
    +
    588  2 comiin, comjin, comiou, comjou,
    +
    589  3 dilat, rot, interp)
    +
    590  RETURN
    +
    591 C
    +
    592 C ##################################################################
    +
    593 C
    +
    594 C HERE FOR POLAR STEREO TO LO/LA
    +
    595 C
    +
    596  3000 IF (mapin.EQ. 5) GO TO 3005
    +
    597  IF (mapin.EQ.25) GO TO 3025
    +
    598  IF (mapin.EQ.26) GO TO 3026
    +
    599  IF (mapin.EQ.27) GO TO 3027
    +
    600  IF (mapin.EQ.28) GO TO 3027
    +
    601  IF (mapin.EQ.49) GO TO 3049
    +
    602  IF (mapin.EQ.50) GO TO 3049
    +
    603  IF (mapin.EQ.51) GO TO 3051
    +
    604  IF (mapin.EQ.55) GO TO 3055
    +
    605  IF (mapin.EQ.56) GO TO 3056
    +
    606  IF (mapin.EQ.60) GO TO 3060
    +
    607  IF (mapin.EQ.87) GO TO 3087
    +
    608  IF (mapin.EQ.100) GO TO 3100
    +
    609  IF (mapin.EQ.101) GO TO 3101
    +
    610  IF (mapin.EQ.105) GO TO 3105
    +
    611  IF (mapin.EQ.106) GO TO 3106
    +
    612  IF (mapin.EQ.107) GO TO 3107
    +
    613 C
    +
    614  3005 xmesh = 190.5
    +
    615  imaxin = 53
    +
    616  jmaxin = 57
    +
    617  nthsth = 1
    +
    618  polei = 27.
    +
    619  polej = 49.
    +
    620  orient = 105.
    +
    621  GO TO 4000
    +
    622 C
    +
    623  3025 xmesh = 381.
    +
    624  imaxin = 53
    +
    625  jmaxin = 57
    +
    626  nthsth = 2
    +
    627  polei = 27.
    +
    628  polej = 29.
    +
    629  GO TO 4000
    +
    630 C
    +
    631  3026 xmesh = 190.5
    +
    632  imaxin = 53
    +
    633  jmaxin = 45
    +
    634  nthsth = 1
    +
    635  polei = 27.
    +
    636  polej = 49.
    +
    637  orient = 105.
    +
    638  GO TO 4000
    +
    639 C
    +
    640  3027 xmesh = 381.
    +
    641  imaxin = 65
    +
    642  jmaxin = 65
    +
    643  nthsth = 1
    +
    644  IF (mapin.EQ.28) nthsth = 2
    +
    645  polei = 33.
    +
    646  polej = 33.
    +
    647  orient = 80.
    +
    648  GO TO 4000
    +
    649 C
    +
    650  3049 xmesh = 190.5
    +
    651  imaxin = 129
    +
    652  jmaxin = 129
    +
    653  nthsth = 1
    +
    654  IF (mapin.EQ.50) nthsth=2
    +
    655  polei = 65.
    +
    656  polej = 65.
    +
    657  orient = 80.
    +
    658  GOTO 4000
    +
    659 C
    +
    660  3051 xmesh = 190.5
    +
    661  imaxin = 129
    +
    662  jmaxin = 129
    +
    663  nthsth = 1
    +
    664  polei = 65.
    +
    665  polej = 65.
    +
    666  orient = 105.
    +
    667  GOTO 4000
    +
    668 C
    +
    669  3055 xmesh = 254.
    +
    670  imaxin = 87
    +
    671  jmaxin = 71
    +
    672  nthsth = 1
    +
    673  polei = 44.
    +
    674  polej = 38.
    +
    675  orient = 105.
    +
    676  GOTO 4000
    +
    677 C
    +
    678  3056 xmesh = 127.
    +
    679  imaxin = 87
    +
    680  jmaxin = 71
    +
    681  nthsth = 1
    +
    682  polei = 40.
    +
    683  polej = 73.
    +
    684  orient = 105.
    +
    685  GOTO 4000
    +
    686 C
    +
    687  3060 xmesh = 190.5
    +
    688  imaxin = 57
    +
    689  jmaxin = 57
    +
    690  nthsth = 1
    +
    691  polei = 29.
    +
    692  polej = 49.
    +
    693  orient = 105.
    +
    694  GO TO 4000
    +
    695 C
    +
    696  3087 xmesh = 68.153
    +
    697  imaxin = 81
    +
    698  jmaxin = 62
    +
    699  nthsth = 1
    +
    700  polei = 31.91
    +
    701  polej = 112.53
    +
    702  orient = 105.
    +
    703  GO TO 4000
    +
    704 C
    +
    705  3100 xmesh = 91.452
    +
    706  imaxin = 83
    +
    707  jmaxin = 83
    +
    708  nthsth = 1
    +
    709  polei = 40.5
    +
    710  polej = 88.5
    +
    711  orient = 105.
    +
    712  GO TO 4000
    +
    713 C
    +
    714  3101 xmesh = 91.452
    +
    715  imaxin = 113
    +
    716  jmaxin = 91
    +
    717  nthsth = 1
    +
    718  polei = 58.5
    +
    719  polej = 92.5
    +
    720  orient = 105.
    +
    721  GO TO 4000
    +
    722 C
    +
    723  3105 xmesh = 90.75464
    +
    724  imaxin = 83
    +
    725  jmaxin = 83
    +
    726  nthsth = 1
    +
    727  polei = 40.5
    +
    728  polej = 88.5
    +
    729  orient = 105.
    +
    730  GO TO 4000
    +
    731 C
    +
    732  3106 xmesh = 45.37732
    +
    733  imaxin = 165
    +
    734  jmaxin = 117
    +
    735  nthsth = 1
    +
    736  polei = 80.0
    +
    737  polej = 176.0
    +
    738  orient = 105.
    +
    739  GO TO 4000
    +
    740 C
    +
    741  3107 xmesh = 45.37732
    +
    742  imaxin = 120
    +
    743  jmaxin = 92
    +
    744  nthsth = 1
    +
    745  polei = 46.0
    +
    746  polej = 167.0
    +
    747  orient = 105.
    +
    748  GO TO 4000
    +
    749 C
    +
    750 C SELECT OUTPUT LO/LA VARIATIONS
    +
    751 C
    +
    752  4000 IF (mapout.EQ.21) GO TO 4021
    +
    753  IF (mapout.EQ.22) GO TO 4021
    +
    754  IF (mapout.EQ.29) GO TO 4029
    +
    755  IF (mapout.EQ.30) GO TO 4029
    +
    756  IF (mapout.EQ.33) GO TO 4033
    +
    757  IF (mapout.EQ.34) GO TO 4033
    +
    758  IF (mapout.EQ.45) GO TO 4045
    +
    759  IF (mapout.EQ.46) GO TO 4045
    +
    760  IF (mapout.EQ.500) GO TO 4500
    +
    761  IF (mapout.EQ.501) GO TO 4501
    +
    762  ier = 4
    +
    763  RETURN
    +
    764 C
    +
    765  4021 iminou = 1
    +
    766  jminou = 1
    +
    767  imaxou = 73
    +
    768  jmaxou = 19
    +
    769  deg = 5.0
    +
    770  GO TO 4700
    +
    771 C
    +
    772  4029 iminou = 1
    +
    773  imaxou = 145
    +
    774  jminou = 1
    +
    775  jmaxou = 37
    +
    776  deg = 2.5
    +
    777  GO TO 4700
    +
    778 C
    +
    779  4033 iminou = 1
    +
    780  imaxou = 181
    +
    781  jminou = 1
    +
    782  jmaxou = 46
    +
    783  deg = 2.0
    +
    784  GO TO 4700
    +
    785 C
    +
    786  4045 iminou = 1
    +
    787  imaxou = 97
    +
    788  jminou = 1
    +
    789  jmaxou = 25
    +
    790  deg = 3.75
    +
    791  GOTO 4700
    +
    792 C
    +
    793  4500 iminou = 93
    +
    794  imaxou = 117
    +
    795  jminou = 1
    +
    796  jmaxou = 37
    +
    797  deg = 2.5
    +
    798  GO TO 4700
    +
    799 C
    +
    800  4501 iminou = 116
    +
    801  imaxou = 140
    +
    802  jminou = 1
    +
    803  jmaxou = 46
    +
    804  deg = 2.0
    +
    805  GO TO 4700
    +
    806 C
    +
    807 C FIND INPUT POLA I,J FOR DESIRED LOLA OUTPUT POINTS
    +
    808 C
    +
    809  4700 ijout = 0
    +
    810  DO 4740 j = jminou, jmaxou
    +
    811  xlat = (j-1) * deg
    +
    812  IF (nthsth.EQ.2) xlat = xlat - 90.
    +
    813  DO 4740 i = iminou, imaxou
    +
    814  elon = (i-1) * deg
    +
    815  wlon = amod(360. - elon, 360.)
    +
    816  GO TO (4710, 4720), nthsth
    +
    817  4710 CALL w3fb04(xlat, wlon, xmesh, orient, xi, xj)
    +
    818  GO TO 4730
    +
    819  4720 CALL w3fb02(xlat, wlon, xmesh, xi, xj)
    +
    820  4730 xiin = xi + polei
    +
    821  xjin = xj + polej
    +
    822 C
    +
    823 C MACDONALDS SUPER GENERAL INTERPOLATOR
    +
    824 C IN WHICH D = FIELD(XIIN, XJIN)
    +
    825 C
    +
    826  CALL w3ft01
    +
    827  1 (xiin, xjin, field, d, imaxin, jmaxin, 0, interp)
    +
    828  ijout = ijout + 1
    +
    829  DATA(ijout) = d
    +
    830  4740 CONTINUE
    +
    831  RETURN
    +
    832 C
    +
    833 C ##################################################################
    +
    834 C ##################################################################
    +
    835 C
    +
    836 C THIS SECTION FOR LOLA INPUT MAP
    +
    837 C
    +
    838 C SELCT OUTPUT TYPE
    +
    839 C
    +
    840  5000 IF (lolaou) GO TO 7000
    +
    841 C
    +
    842 C LOLA TO POLA
    +
    843 C SELECT INPUT INFO
    +
    844 C (THIS PATTERN CAN BE USED WITH POLA INPUT, TOO - TRY IT
    +
    845 C
    +
    846  IF (mapin.EQ.21) GO TO 5021
    +
    847  IF (mapin.EQ.22) GO TO 5021
    +
    848  IF (mapin.EQ.29) GO TO 5029
    +
    849  IF (mapin.EQ.30) GO TO 5029
    +
    850  IF (mapin.EQ.33) GO TO 5033
    +
    851  IF (mapin.EQ.34) GO TO 5033
    +
    852  IF (mapin.EQ.45) GO TO 5045
    +
    853  IF (mapin.EQ.46) GO TO 5045
    +
    854  ier = 5
    +
    855  RETURN
    +
    856 C
    +
    857  5021 imaxin = 73
    +
    858  jmaxin = 19
    +
    859  deg = 5.0
    +
    860  nthsth = 1
    +
    861  IF (mapin.EQ.22) nthsth = 2
    +
    862  GO TO 6000
    +
    863 C
    +
    864  5029 imaxin = 145
    +
    865  jmaxin = 37
    +
    866  deg = 2.5
    +
    867  nthsth = 1
    +
    868  IF (mapin.EQ.30) nthsth = 2
    +
    869  GO TO 6000
    +
    870 C
    +
    871  5033 imaxin = 181
    +
    872  jmaxin = 46
    +
    873  deg = 2.0
    +
    874  nthsth = 1
    +
    875  IF (mapin.EQ.34) nthsth = 2
    +
    876  GO TO 6000
    +
    877 C
    +
    878  5045 imaxin = 97
    +
    879  jmaxin = 25
    +
    880  deg = 3.75
    +
    881  nthsth = 1
    +
    882  IF (mapin.EQ.46) nthsth = 2
    +
    883  GOTO 6000
    +
    884 C
    +
    885 C SELECT OUTPUT POLA VARIETY
    +
    886 C ROT INDICATES HOW MANY DEGREES THE POLA GRID IS TO BE ROTATED
    +
    887 C (POSITIVE COUNTER-CLOCKWISE) FROM THE NMC 'STANDARD'
    +
    888 C OF 80 DEG WEST AT THE BOTTOM (OR TOP IF SOUTHERN HEMISPHERE)
    +
    889 C
    +
    890  6000 IF (mapout.EQ. 5) GO TO 6005
    +
    891  IF (mapout.EQ.25) GO TO 6025
    +
    892  IF (mapout.EQ.26) GO TO 6026
    +
    893  IF (mapout.EQ.27) GO TO 6027
    +
    894  IF (mapout.EQ.28) GO TO 6027
    +
    895  IF (mapout.EQ.49) GO TO 6049
    +
    896  IF (mapout.EQ.50) GO TO 6049
    +
    897  IF (mapout.EQ.51) GO TO 6051
    +
    898  IF (mapout.EQ.55) GO TO 6055
    +
    899  IF (mapout.EQ.56) GO TO 6056
    +
    900  IF (mapout.EQ.60) GO TO 6060
    +
    901  IF (mapout.EQ.87) GO TO 6087
    +
    902  IF (mapout.EQ.100) GO TO 6100
    +
    903  IF (mapout.EQ.101) GO TO 6101
    +
    904  IF (mapout.EQ.105) GO TO 6105
    +
    905  IF (mapout.EQ.106) GO TO 6106
    +
    906  IF (mapout.EQ.107) GO TO 6107
    +
    907  IF (mapout.EQ.400) GO TO 6400
    +
    908  IF (mapout.EQ.401) GO TO 6401
    +
    909  IF (mapout.EQ.402) GO TO 6402
    +
    910  IF (mapout.EQ.403) GO TO 6403
    +
    911  ier = 6
    +
    912  RETURN
    +
    913 C
    +
    914  6005 imaxou = 53
    +
    915  jmaxou = 57
    +
    916  xmesh = 190.5
    +
    917  rot = -25.
    +
    918  polei = 27.
    +
    919  polej = 49.
    +
    920  GO TO 6700
    +
    921 C
    +
    922  6025 imaxou = 53
    +
    923  jmaxou = 57
    +
    924  xmesh = 381.
    +
    925  rot = 0.
    +
    926  polei = 27.
    +
    927  polej = 29.
    +
    928  GO TO 6700
    +
    929 C
    +
    930  6026 imaxou = 53
    +
    931  jmaxou = 45
    +
    932  xmesh = 190.5
    +
    933  rot = -25.
    +
    934  polei = 27.
    +
    935  polej = 49.
    +
    936  GO TO 6700
    +
    937 C
    +
    938  6027 imaxou = 65
    +
    939  jmaxou = 65
    +
    940  xmesh = 381.
    +
    941  rot = 0.
    +
    942  polei = 33.
    +
    943  polej = 33.
    +
    944  GO TO 6700
    +
    945 C
    +
    946  6049 imaxou = 129
    +
    947  jmaxou = 129
    +
    948  xmesh = 190.5
    +
    949  rot = 0.
    +
    950  polei = 65.
    +
    951  polej = 65.
    +
    952  GOTO 6700
    +
    953 C
    +
    954  6051 imaxou = 129
    +
    955  jmaxou = 129
    +
    956  xmesh = 190.5
    +
    957  rot = -25.
    +
    958  polei = 65.
    +
    959  polej = 65.
    +
    960  GOTO 6700
    +
    961 C
    +
    962  6055 imaxou = 87
    +
    963  jmaxou = 71
    +
    964  xmesh = 254.
    +
    965  rot = -25.
    +
    966  polei = 44.
    +
    967  polej = 38.
    +
    968  GOTO 6700
    +
    969 C
    +
    970  6056 imaxou = 87
    +
    971  jmaxou = 71
    +
    972  xmesh = 127.
    +
    973  rot = -25.
    +
    974  polei = 40.
    +
    975  polej = 73.
    +
    976  GOTO 6700
    +
    977 C
    +
    978  6060 imaxou = 57
    +
    979  jmaxou = 57
    +
    980  xmesh = 190.5
    +
    981  rot = -25.
    +
    982  polei = 29.
    +
    983  polej = 49.
    +
    984  GO TO 6700
    +
    985 C
    +
    986  6087 imaxou = 81
    +
    987  jmaxou = 62
    +
    988  xmesh = 68.153
    +
    989  rot = -25.
    +
    990  polei = 31.91
    +
    991  polej = 112.53
    +
    992  GO TO 6700
    +
    993 C
    +
    994  6100 imaxou = 83
    +
    995  jmaxou = 83
    +
    996  xmesh = 91.452
    +
    997  rot = -25.
    +
    998  polei = 40.5
    +
    999  polej = 88.5
    +
    1000  GO TO 6700
    +
    1001 C
    +
    1002  6101 imaxou = 113
    +
    1003  jmaxou = 91
    +
    1004  xmesh = 91.452
    +
    1005  rot = -25.
    +
    1006  polei = 58.5
    +
    1007  polej = 92.5
    +
    1008  GO TO 6700
    +
    1009 C
    +
    1010  6105 imaxou = 83
    +
    1011  jmaxou = 83
    +
    1012  xmesh = 90.75464
    +
    1013  rot = -25.
    +
    1014  polei = 40.5
    +
    1015  polej = 88.5
    +
    1016  GO TO 6700
    +
    1017 C
    +
    1018  6106 imaxou = 165
    +
    1019  jmaxou = 117
    +
    1020  xmesh = 45.37732
    +
    1021  rot = -25.
    +
    1022  polei = 80.0
    +
    1023  polej = 176.0
    +
    1024  GO TO 6700
    +
    1025 C
    +
    1026  6107 imaxou = 120
    +
    1027  jmaxou = 92
    +
    1028  xmesh = 45.37732
    +
    1029  rot = -25.
    +
    1030  polei = 46.0
    +
    1031  polej = 167.0
    +
    1032  GO TO 6700
    +
    1033 C
    +
    1034  6400 imaxou = 39
    +
    1035  jmaxou = 39
    +
    1036  xmesh = 508.
    +
    1037  rot = 0.
    +
    1038  polei = 20.
    +
    1039  polej = 20.
    +
    1040  GO TO 6700
    +
    1041 C
    +
    1042 C THIS ONE GETS SPECIAL TREATMENT BECAUSE WE ARE
    +
    1043 C INTERCHANGING ROWS AND COLUMNS FOR GRIDPRINT AFTER INTERPOLATION
    +
    1044 C (ACTUALLY IT IS DONE ALL AT ONCE)
    +
    1045 C
    +
    1046  6401 imaxou = 25
    +
    1047  jmaxou = 35
    +
    1048  xmesh = 254.
    +
    1049  rot = -25.
    +
    1050  polei = 18.
    +
    1051  polej = 31.75
    +
    1052 C
    +
    1053  ijout = 0
    +
    1054  DO 64011 j=1,jmaxou
    +
    1055  xi = jmaxou - j + 1
    +
    1056  xxi = xi - polei
    +
    1057  DO 64011 i = 1,imaxou
    +
    1058  xj = i
    +
    1059  xxj = xj - polej
    +
    1060  CALL w3fb01(xxi, xxj, xmesh, xlat, wlon)
    +
    1061  wlon = wlon - rot
    +
    1062  IF (wlon.GT.360.) wlon = wlon - 360.
    +
    1063  IF (wlon.LT.0.) wlon = wlon + 360.
    +
    1064  xiin = (360.-wlon)/deg + 1.
    +
    1065  xjin = xlat/deg + 1.
    +
    1066  CALL w3ft01
    +
    1067  1 (xiin, xjin, field, d, imaxin, jmaxin, 1, interp)
    +
    1068  ijout = ijout + 1
    +
    1069  DATA(ijout) = d
    +
    1070 64011 CONTINUE
    +
    1071  RETURN
    +
    1072 C
    +
    1073  6402 imaxou = 97
    +
    1074  jmaxou = 97
    +
    1075  xmesh = 254.
    +
    1076  rot = -25.
    +
    1077  polei = 49.
    +
    1078  polej = 49.
    +
    1079  GOTO 6700
    +
    1080 C
    +
    1081  6403 imaxou = 97
    +
    1082  jmaxou = 97
    +
    1083  xmesh = 254.
    +
    1084  rot = 0.
    +
    1085  polei = 49.
    +
    1086  polej = 49.
    +
    1087  GOTO 6700
    +
    1088 C
    +
    1089 C FIND INPUT LOLA I,J FOR DESIRED POLA OUTPUT POINTS
    +
    1090 C
    +
    1091  6700 ijout = 0
    +
    1092  DO 6740 j=1,jmaxou
    +
    1093  xj = j - polej
    +
    1094  DO 6740 i=1,imaxou
    +
    1095  xi = i - polei
    +
    1096  GOTO (6710, 6720), nthsth
    +
    1097  6710 CALL w3fb01(xi, xj, xmesh, xlat, wlon)
    +
    1098  wlon = wlon - rot
    +
    1099  GO TO 6730
    +
    1100  6720 CALL w3fb03(xi, xj, xmesh, xlat, wlon)
    +
    1101  wlon = wlon + rot
    +
    1102  xlat = xlat + 90.
    +
    1103  6730 IF (wlon.GT.360.) wlon = wlon - 360.
    +
    1104  IF (wlon.LT.0.) wlon = wlon + 360.
    +
    1105  xiin = (360.-wlon)/deg + 1.
    +
    1106  xjin = xlat/deg + 1.
    +
    1107  CALL w3ft01
    +
    1108  1 (xiin, xjin, field, d, imaxin, jmaxin, 1, interp)
    +
    1109  ijout = ijout + 1
    +
    1110  DATA(ijout) = d
    +
    1111  6740 CONTINUE
    +
    1112  RETURN
    +
    1113 C
    +
    1114 C ##################################################################
    +
    1115 C
    +
    1116 C LOLA TO LOLA
    +
    1117 C
    +
    1118 C SELECT INPUT GRID INFO
    +
    1119 C
    +
    1120  7000 IF (mapin.EQ.21) GO TO 7021
    +
    1121  IF (mapin.EQ.22) GO TO 7021
    +
    1122  IF (mapin.EQ.29) GO TO 7029
    +
    1123  IF (mapin.EQ.30) GO TO 7029
    +
    1124  IF (mapin.EQ.33) GO TO 7033
    +
    1125  IF (mapin.EQ.34) GO TO 7033
    +
    1126  IF (mapin.EQ.45) GOTO 7045
    +
    1127  IF (mapin.EQ.46) GOTO 7045
    +
    1128  ier = 7
    +
    1129  RETURN
    +
    1130 C
    +
    1131  7021 imaxin = 73
    +
    1132  jmaxin = 19
    +
    1133  degin = 5.0
    +
    1134  GO TO 8000
    +
    1135 C
    +
    1136  7029 imaxin = 145
    +
    1137  jmaxin = 37
    +
    1138  degin = 2.5
    +
    1139  GO TO 8000
    +
    1140 C
    +
    1141  7033 imaxin = 181
    +
    1142  jmaxin = 46
    +
    1143  degin = 2.0
    +
    1144  GO TO 8000
    +
    1145 C
    +
    1146  7045 imaxin = 97
    +
    1147  jmaxin = 25
    +
    1148  degin = 3.75
    +
    1149  GOTO 8000
    +
    1150 C
    +
    1151 C SELECT OUTPUT LOLA GRID
    +
    1152 C
    +
    1153  8000 IF (mapout.EQ.21) GO TO 8021
    +
    1154  IF (mapout.EQ.22) GO TO 8021
    +
    1155  IF (mapout.EQ.29) GO TO 8029
    +
    1156  IF (mapout.EQ.30) GO TO 8029
    +
    1157  IF (mapout.EQ.33) GO TO 8033
    +
    1158  IF (mapout.EQ.34) GO TO 8033
    +
    1159  IF (mapout.EQ.45) GO TO 8045
    +
    1160  IF (mapout.EQ.46) GO TO 8045
    +
    1161  IF (mapout.EQ.500) GO TO 8500
    +
    1162  IF (mapout.EQ.501) GO TO 8501
    +
    1163  ier = 8
    +
    1164  RETURN
    +
    1165 C
    +
    1166  8021 iminou = 1
    +
    1167  imaxou = 73
    +
    1168  jminou = 1
    +
    1169  jmaxou = 19
    +
    1170  degou = 5.
    +
    1171  GO TO 8700
    +
    1172 C
    +
    1173  8029 iminou = 1
    +
    1174  imaxou = 145
    +
    1175  jminou = 1
    +
    1176  jmaxou = 37
    +
    1177  degou = 2.5
    +
    1178  GO TO 8700
    +
    1179 C
    +
    1180  8033 iminou = 1
    +
    1181  imaxou = 181
    +
    1182  jminou = 1
    +
    1183  jmaxou = 46
    +
    1184  degou = 2.0
    +
    1185  GO TO 8700
    +
    1186 C
    +
    1187  8045 iminou = 1
    +
    1188  imaxou = 97
    +
    1189  jminou = 1
    +
    1190  jmaxou = 25
    +
    1191  degou = 3.75
    +
    1192  GOTO 8700
    +
    1193 C
    +
    1194  8500 iminou = 93
    +
    1195  imaxou = 117
    +
    1196  jminou = 1
    +
    1197  jmaxou = 37
    +
    1198  degou = 2.5
    +
    1199  GO TO 8700
    +
    1200 C
    +
    1201  8501 iminou = 116
    +
    1202  imaxou = 140
    +
    1203  jminou = 1
    +
    1204  jmaxou = 46
    +
    1205  degou = 2.0
    +
    1206  GO TO 8700
    +
    1207 C
    +
    1208  8700 ijout = 0
    +
    1209  rdeg = degou/degin
    +
    1210  DO 8710 j=jminou, jmaxou
    +
    1211  xjin = (j-1)*rdeg + 1.
    +
    1212  DO 8710 i=iminou, imaxou
    +
    1213  xiin = (i-1)*rdeg + 1.
    +
    1214  CALL w3ft01
    +
    1215  1 (xiin, xjin, field, d, imaxin, jmaxin, 1, interp)
    +
    1216  ijout = ijout + 1
    +
    1217  DATA(ijout) = d
    +
    1218  8710 CONTINUE
    +
    1219  RETURN
    +
    1220 C
    +
    1221  END
    +
    +
    +
    w3fb03
    subroutine w3fb03(XI, XJ, XMESHL, TLAT, TLONG)
    Converts i,j grid coordinates to the corresponding latitude/longitude on a southern hemisphere polar ...
    Definition: w3fb03.f:21
    +
    w3fb02
    subroutine w3fb02(ALAT, ALONG, XMESHL, XI, XJ)
    Computes i and j coordinates for a latitude/longitude point on the southern hemisphere polar stereogr...
    Definition: w3fb02.f:21
    +
    w3fb01
    subroutine w3fb01(XI, XJ, XMESHL, ALAT, ALONG)
    Converts the coordinates of a location from the grid(i,j) coordinate system overlaid on the polar ste...
    Definition: w3fb01.f:31
    +
    w3ft32
    subroutine w3ft32(FIELD, MAPIN, DATA, MAPOUT, INTERP, IER)
    Interpolate scalar quantity from any given nmc field (in office note 84) to any other field.
    Definition: w3ft32.f:49
    +
    w3ft00
    subroutine w3ft00(FLD, B, IA, JA, IB, JB, CIP, CJP, FIPB, FJPB, SC, ARG, LIN)
    Transforms data contained in a grid array by translation, rotation about a common point and dilatatio...
    Definition: w3ft00.f:40
    +
    w3ft01
    subroutine w3ft01(STI, STJ, FLD, HI, II, JJ, NCYCLK, LIN)
    For a given grid coordinate in a data array, estimates a data value for that point using either a lin...
    Definition: w3ft01.f:36
    +
    w3fb04
    subroutine w3fb04(ALAT, ALONG, XMESHL, ORIENT, XI, XJ)
    Converts the coordinates of a location on earth from the natural coordinate system of latitude/longit...
    Definition: w3fb04.f:40
    + + + + diff --git a/ver-2.10.0/w3ft33_8f.html b/ver-2.10.0/w3ft33_8f.html new file mode 100644 index 00000000..9b2c2673 --- /dev/null +++ b/ver-2.10.0/w3ft33_8f.html @@ -0,0 +1,174 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft33.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft33.f File Reference
    +
    +
    + +

    Thicken thinned wafs grib grid 37-44. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft33 (AIN, OUT, NSFLAG)
     Subroutine thickens one thinned wafs grib grid to a real array of 5329 numbers (73,73) 1.25 degree grid. More...
     
    +

    Detailed Description

    +

    Thicken thinned wafs grib grid 37-44.

    +
    Author
    Ralph Peterson
    +
    Date
    1994
    + +

    Definition in file w3ft33.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft33()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft33 (real, dimension(*) AIN,
    real, dimension(nx,ny) OUT,
     NSFLAG 
    )
    +
    + +

    Subroutine thickens one thinned wafs grib grid to a real array of 5329 numbers (73,73) 1.25 degree grid.

    +

    +Program History Log:

    +

    Date | Programmer | Comment --—|---------—|-----— 1994-??-?? | Ralph Peterson 1994-11-07 | Ralph Jones | Add doc block, change call to 3 parameters. Replace cos with table lookup. 1995-06-02 | Ralph Peterson | Changes to correct miss-position between + or - 8.75 n/s. 1995-06-03 | Ralph Jones | Changes so 8 rows with 73 values are not thickened, 10% faster.

    +
    Parameters
    + + + + +
    [in]AINReal 3447 word array with unpacked thinned wafs grib type 37-44.
    [in]NSFLAGInteger = 1 AIN is wafs grib grid 37-40 n. hemi. = -1 AIN is wafs grib grid 41-44 s. hemi.
    [out]OUTReal (73,73) word array with thickened wafs grib grid 37-44.
    +
    +
    +
    Remarks
    The pole point for u and v wind components will have only one point. If you need the pole row corrected see page 9 section 1 in office note 388. You need both u and v to make the correction.
    +
    Author
    Ralph Peterson
    +
    Date
    1994
    + +

    Definition at line 32 of file w3ft33.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft33_8f.js b/ver-2.10.0/w3ft33_8f.js new file mode 100644 index 00000000..68d71545 --- /dev/null +++ b/ver-2.10.0/w3ft33_8f.js @@ -0,0 +1,4 @@ +var w3ft33_8f = +[ + [ "w3ft33", "w3ft33_8f.html#aa788035129e6f04923f7f351fb343ff0", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft33_8f_source.html b/ver-2.10.0/w3ft33_8f_source.html new file mode 100644 index 00000000..c3c0a177 --- /dev/null +++ b/ver-2.10.0/w3ft33_8f_source.html @@ -0,0 +1,239 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft33.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft33.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Thicken thinned wafs grib grid 37-44
    +
    3 C> @author Ralph Peterson @date 1994
    +
    4 
    +
    5 C> Subroutine thickens one thinned wafs grib grid to a
    +
    6 C> real array of 5329 numbers (73,73) 1.25 degree grid.
    +
    7 C>
    +
    8 C> ### Program History Log:
    +
    9 C> Date | Programmer | Comment
    +
    10 C> -----|------------|--------
    +
    11 C> 1994-??-?? | Ralph Peterson
    +
    12 C> 1994-11-07 | Ralph Jones | Add doc block, change call to 3 parameters.
    +
    13 C> Replace cos with table lookup.
    +
    14 C> 1995-06-02 | Ralph Peterson | Changes to correct miss-position
    +
    15 C> between + or - 8.75 n/s.
    +
    16 C> 1995-06-03 | Ralph Jones | Changes so 8 rows with 73 values
    +
    17 C> are not thickened, 10% faster.
    +
    18 C>
    +
    19 C> @param[in] AIN Real 3447 word array with unpacked thinned wafs
    +
    20 C> grib type 37-44.
    +
    21 C> @param[in] NSFLAG Integer = 1 AIN is wafs grib grid 37-40 n. hemi.
    +
    22 C> = -1 AIN is wafs grib grid 41-44 s. hemi.
    +
    23 C> @param[out] OUT Real (73,73) word array with thickened wafs grib grid 37-44.
    +
    24 C>
    +
    25 C> @remark The pole point for u and v wind components will have only
    +
    26 C> one point. If you need the pole row corrected see page 9 section
    +
    27 C> 1 in office note 388. You need both u and v to make the
    +
    28 C> correction.
    +
    29 C>
    +
    30 C> @author Ralph Peterson @date 1994
    +
    31  SUBROUTINE w3ft33(AIN,OUT,NSFLAG)
    +
    32 C
    +
    33  parameter(nx=73,ny=73)
    +
    34  parameter(nin=3447)
    +
    35 C
    +
    36  REAL AIN(*)
    +
    37  REAL OUT(NX,NY)
    +
    38 C
    +
    39  INTEGER IPOINT(NX)
    +
    40 C
    +
    41  SAVE
    +
    42 C
    +
    43  DATA ipoint/
    +
    44  & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70,
    +
    45  & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60,
    +
    46  & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43,
    +
    47  & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22,
    +
    48  & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/
    +
    49 C
    +
    50  nxm = nx - 1
    +
    51  fnxm = float(nxm)
    +
    52 C
    +
    53 C TEST FOR GRIDS (37-40)
    +
    54 C
    +
    55  IF (nsflag.GT.0) THEN
    +
    56 C
    +
    57 C DO NOT THICKEN 8 ROWS WITH 73 VALUES, MOVE DATA
    +
    58 C TO OUT ARRAY. GRIDS (37-40) N.
    +
    59 C
    +
    60  is = 0
    +
    61  DO j = 1,8
    +
    62  DO i = 1,nx
    +
    63  is = is + 1
    +
    64  out(i,j) = ain(is)
    +
    65  END DO
    +
    66  END DO
    +
    67 C
    +
    68  ie = nx * 8
    +
    69  DO j = 9,ny
    +
    70  npoint = ipoint(j)
    +
    71  is = ie + 1
    +
    72  ie = is + npoint - 1
    +
    73  dpts = (float(npoint)-1.) / fnxm
    +
    74  pw = 1.0
    +
    75  pe = pw + dpts
    +
    76  out(1,j) = ain(is)
    +
    77  valw = ain(is)
    +
    78  vale = ain(is+1)
    +
    79  dval = (vale-valw)
    +
    80  DO i = 2,nxm
    +
    81  wght = pe -float(ifix(pe))
    +
    82  out(i,j) = valw + wght * dval
    +
    83  pw = pe
    +
    84  pe = pe + dpts
    +
    85  IF (ifix(pw).NE.ifix(pe)) THEN
    +
    86  is = is + 1
    +
    87  valw = vale
    +
    88  vale = ain(is+1)
    +
    89  dval = (vale - valw)
    +
    90  END IF
    +
    91  END DO
    +
    92  out(nx,j) = ain(ie)
    +
    93  END DO
    +
    94 C
    +
    95  ELSE
    +
    96 C
    +
    97 C DO NOT THICKEN 8 ROWS WITH 73 VALUES, MOVE DATA
    +
    98 C TO OUT ARRAY. GRIDS (41-44) S.
    +
    99 C
    +
    100  is = nin - (8 * nx)
    +
    101  DO j = 66,ny
    +
    102  DO i = 1,nx
    +
    103  is = is + 1
    +
    104  out(i,j) = ain(is)
    +
    105  END DO
    +
    106  END DO
    +
    107 C
    +
    108  ie = 0
    +
    109  DO j = 1,65
    +
    110  npoint = ipoint(74-j)
    +
    111  is = ie + 1
    +
    112  ie = is + npoint - 1
    +
    113  dpts = (float(npoint)-1.) / fnxm
    +
    114  pw = 1.0
    +
    115  pe = pw + dpts
    +
    116  out(1,j) = ain(is)
    +
    117  valw = ain(is)
    +
    118  vale = ain(is+1)
    +
    119  dval = (vale-valw)
    +
    120  DO i = 2,nxm
    +
    121  wght = pe -float(ifix(pe))
    +
    122  out(i,j) = valw + wght * dval
    +
    123  pw = pe
    +
    124  pe = pe + dpts
    +
    125  IF (ifix(pw).NE.ifix(pe)) THEN
    +
    126  is = is + 1
    +
    127  valw = vale
    +
    128  vale = ain(is+1)
    +
    129  dval = (vale - valw)
    +
    130  END IF
    +
    131  END DO
    +
    132  out(nx,j) = ain(ie)
    +
    133  END DO
    +
    134  END IF
    +
    135 C
    +
    136  RETURN
    +
    137  END
    +
    +
    +
    w3ft33
    subroutine w3ft33(AIN, OUT, NSFLAG)
    Subroutine thickens one thinned wafs grib grid to a real array of 5329 numbers (73,...
    Definition: w3ft33.f:32
    + + + + diff --git a/ver-2.10.0/w3ft38_8f.html b/ver-2.10.0/w3ft38_8f.html new file mode 100644 index 00000000..8a8dccd1 --- /dev/null +++ b/ver-2.10.0/w3ft38_8f.html @@ -0,0 +1,218 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft38.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft38.f File Reference
    +
    +
    + +

    Computes 2.5 x 2.5 n. hemi. grid-scaler. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft38 (FLN, GN, PLN, FL, WORK, TRIGS)
     Computes 2.5 x 2.5 n. More...
     
    +

    Detailed Description

    +

    Computes 2.5 x 2.5 n. hemi. grid-scaler.

    +
    Author
    Ralph Jones
    +
    Date
    1993-07-23
    + +

    Definition in file w3ft38.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft38()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft38 (complex, dimension( 31 , 31 ) FLN,
    real, dimension(145,37) GN,
    real, dimension( 32, 31, 37 ) PLN,
    complex, dimension( 31 ) FL,
    real, dimension(144) WORK,
    real, dimension(216) TRIGS 
    )
    +
    + +

    Computes 2.5 x 2.5 n.

    +

    hemi. grid of 145 x 37 points from spectral coefficients in a rhomboidal 30 resolution representing a scaler field.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1993-07-23 Ralph Jones New version of w3ft08(), takes out w3fa12()
    +

    makes pln 3 dimensions, pln is computed one time in main program, trades\ memory for more speed. w3fa12() used 70% of cpu time.

    +
    Parameters
    + + + + + + + +
    [in]FLN961 complex coeff.
    [in]PLN(32,31,37) real space with legendre polynomials computed by w3fa12().
    [in]FL31 complex space for fourier coeff.
    [in]WORK144 real work space for subr. w3ft12()
    [in]TRIGS216 precomputed trig funcs. Used in w3ft12(), computed by w3fa13()
    [out]GN(145,37) grid values. 5365 point grid is type 29 or 1d hex o.n. 84
    +
    +
    +
    Note
    w3ft08() was optimized to run in a small amount of memory, it was not optimized for speed, 70 percent of the time was used by subroutine w3fa12() computing the legendre polynomials. Since the legendre polynomials are constant they need to be computed only once in a program. By moving w3fa12() to the main program and computing pln as a (32,31,37) array and changing this subroutine to use pln as a three dimension array the running time was cut 70 percent. Add following code to main program to compute eps, pln, trigs, and rcos one time in program.
    DOUBLE PRECISION EPS(992) (REAL ON CRAY)
    +
    DOUBLE PRECISION COLRA (REAL ON CRAY)
    +
    +
    REAL PLN( 32, 31, 37 )
    +
    REAL RCOS(37)
    +
    REAL TRIGS(216)
    +
    +
    DATA pi /3.14159265/
    +
    +
    drad = 2.5 * pi / 180.0
    +
    CALL w3fa11(eps,30)
    +
    CALL w3fa13(trigs,rcos)
    +
    DO lat = 1,37
    +
    colra = (lat - 1) * drad
    +
    CALL w3fa12 (pln(1,1,lat), colra, 30, eps)
    +
    END DO
    +
    + +

    Definition at line 54 of file w3ft38.f.

    + +
    +
    +
    +
    +
    w3fa13
    subroutine w3fa13(TRIGS, RCOS)
    Computes trig functions used in 2.5 by 2.5 lat,lon mapping routines.
    Definition: w3fa13.f:18
    +
    w3fa11
    subroutine w3fa11(EPS, JCAP)
    Subroutine computes double precision coefficients used in generating legendre polynomials in subr.
    Definition: w3fa11.f:21
    + + + + diff --git a/ver-2.10.0/w3ft38_8f.js b/ver-2.10.0/w3ft38_8f.js new file mode 100644 index 00000000..85523d44 --- /dev/null +++ b/ver-2.10.0/w3ft38_8f.js @@ -0,0 +1,4 @@ +var w3ft38_8f = +[ + [ "w3ft38", "w3ft38_8f.html#a1826351145421b3de7f51f5b798ae391", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft38_8f_source.html b/ver-2.10.0/w3ft38_8f_source.html new file mode 100644 index 00000000..9f314183 --- /dev/null +++ b/ver-2.10.0/w3ft38_8f_source.html @@ -0,0 +1,188 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft38.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft38.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes 2.5 x 2.5 n. hemi. grid-scaler
    +
    3 C> @author Ralph Jones @date 1993-07-23
    +
    4 
    +
    5 C> Computes 2.5 x 2.5 n. hemi. grid of 145 x 37 points
    +
    6 C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7 C> representing a scaler field.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1993-07-23 | Ralph Jones | New version of w3ft08(), takes out w3fa12()
    +
    13 C> makes pln 3 dimensions, pln is computed one time in main program, trades\
    +
    14 C> memory for more speed. w3fa12() used 70% of cpu time.
    +
    15 C>
    +
    16 C> @param[in] FLN 961 complex coeff.
    +
    17 C> @param[in] PLN (32,31,37) real space with legendre polynomials
    +
    18 C> computed by w3fa12().
    +
    19 C> @param[in] FL 31 complex space for fourier coeff.
    +
    20 C> @param[in] WORK 144 real work space for subr. w3ft12()
    +
    21 C> @param[in] TRIGS 216 precomputed trig funcs. Used
    +
    22 C> in w3ft12(), computed by w3fa13()
    +
    23 C> @param[out] GN (145,37) grid values. 5365 point grid is type 29 or 1d hex o.n. 84
    +
    24 C>
    +
    25 C> @note w3ft08() was optimized to run in a small amount of
    +
    26 C> memory, it was not optimized for speed, 70 percent of the time was
    +
    27 C> used by subroutine w3fa12() computing the legendre polynomials. Since
    +
    28 C> the legendre polynomials are constant they need to be computed
    +
    29 C> only once in a program. By moving w3fa12() to the main program and
    +
    30 C> computing pln as a (32,31,37) array and changing this subroutine
    +
    31 C> to use pln as a three dimension array the running time was cut
    +
    32 C> 70 percent. Add following code to main program to compute eps, pln,
    +
    33 C> trigs, and rcos one time in program.
    +
    34 C> @code
    +
    35 C> DOUBLE PRECISION EPS(992) (REAL ON CRAY)
    +
    36 C> DOUBLE PRECISION COLRA (REAL ON CRAY)
    +
    37 C>
    +
    38 C> REAL PLN( 32, 31, 37 )
    +
    39 C> REAL RCOS(37)
    +
    40 C> REAL TRIGS(216)
    +
    41 C>
    +
    42 C> DATA PI /3.14159265/
    +
    43 C>
    +
    44 C> DRAD = 2.5 * PI / 180.0
    +
    45 C> CALL W3FA11(EPS,30)
    +
    46 C> CALL W3FA13(TRIGS,RCOS)
    +
    47 C> DO LAT = 1,37
    +
    48 C> COLRA = (LAT - 1) * DRAD
    +
    49 C> CALL W3FA12 (PLN(1,1,LAT), COLRA, 30, EPS)
    +
    50 C> END DO
    +
    51 C> @endcode
    +
    52 C>
    +
    53  SUBROUTINE w3ft38(FLN,GN,PLN,FL,WORK,TRIGS)
    +
    54 C
    +
    55  COMPLEX FL( 31 )
    +
    56  COMPLEX FLN( 31 , 31 )
    +
    57 C
    +
    58  REAL GN(145,37)
    +
    59  REAL PLN( 32, 31, 37 )
    +
    60  REAL TRIGS(216)
    +
    61  REAL WORK(144)
    +
    62 C
    +
    63  SAVE
    +
    64 C
    +
    65  DO 400 lat = 1,37
    +
    66  latn = 38 - lat
    +
    67 C
    +
    68  DO 100 l = 1, 31
    +
    69  fl(l) = (0.,0.)
    +
    70  100 CONTINUE
    +
    71 C
    +
    72  DO 300 l = 1, 31
    +
    73  DO 200 i = 1, 31
    +
    74  fl(l) = fl(l) + cmplx(pln(i,l,lat) * real(fln(i,l)) ,
    +
    75  & pln(i,l,lat) * aimag(fln(i,l)) )
    +
    76  200 CONTINUE
    +
    77 C
    +
    78  300 CONTINUE
    +
    79 C
    +
    80  CALL w3ft12(fl,work,gn(1,latn),trigs)
    +
    81 C
    +
    82  400 CONTINUE
    +
    83 C
    +
    84  RETURN
    +
    85  END
    +
    +
    +
    w3ft38
    subroutine w3ft38(FLN, GN, PLN, FL, WORK, TRIGS)
    Computes 2.5 x 2.5 n.
    Definition: w3ft38.f:54
    +
    w3ft12
    subroutine w3ft12(COEF, WORK, GRID, TRIGS)
    Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients.
    Definition: w3ft12.f:25
    + + + + diff --git a/ver-2.10.0/w3ft39_8f.html b/ver-2.10.0/w3ft39_8f.html new file mode 100644 index 00000000..1b82c71d --- /dev/null +++ b/ver-2.10.0/w3ft39_8f.html @@ -0,0 +1,227 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft39.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft39.f File Reference
    +
    +
    + +

    Computes 2.5x2.5 n. hemi. grid-vector. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft39 (VLN, GN, PLN, FL, WORK, TRIGS, RCOS)
     Computes 2.5 x 2.5 n. More...
     
    +

    Detailed Description

    +

    Computes 2.5x2.5 n. hemi. grid-vector.

    +
    Author
    Ralph Jones
    +
    Date
    1993-07-23
    + +

    Definition in file w3ft39.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft39()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft39 (complex, dimension( 32 , 31 ) VLN,
    real, dimension(145,37) GN,
    real, dimension( 32, 31, 37 ) PLN,
    complex, dimension( 31 ) FL,
    real, dimension(144) WORK,
    real, dimension(216) TRIGS,
    real, dimension(37) RCOS 
    )
    +
    + +

    Computes 2.5 x 2.5 n.

    +

    hemi. grid of 145 x 37 points from spectral coefficients in a rhomboidal 30 resolution representing a vector field.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1993-07-23 Ralph Jones New version of w3ft09(), takes out w3fa12()
    +

    makes pln 3 dimensions, pln is computed one time in main program, trades memory for more speed. w3fa12() used 70% of cpu time.

    +
    Parameters
    + + + + + + + + +
    [in]VLN992 complex coeff.
    [in]PLN(32,31,37) real space with legendre polynomials computed by w3fa12().
    [in]FL31 complex space for fourier coeff.
    [in]WORK144 work space for subr. w3ft12()
    [in]TRIGS216 precomputed trig funcs. used in w3ft12, computed by w3fa13().
    [in]RCOS37 reciprocal cosine latitudes of 2.5 x 2.5 grid must be computed before first call to w3ft11 using sr w3fa13().
    [out]GN(145,37) grid values. 5365 point grid is type 29 or 1d o.n. 84
    +
    +
    +
    Note
    w3ft09() was optimized to run in a small amount of memory, it was not optimized for speed, 70 percent of the time was used by subroutine w3fa12() computing the legendre polynomials. Since the legendre polynomials are constant they need to be computed only once in a program. By moving w3fa12() to the main program and computing pln as a (32,31,37) array and changing this subroutine to use pln as a three dimension array the running time was cut 70 percent. Add following code to main program to compute eps, pln, trigs, and rcos one time in program.
    DOUBLE PRECISION EPS(992)
    +
    DOUBLE PRECISION COLRA
    +
    +
    REAL PLN( 32, 31, 37 )
    +
    REAL RCOS(37)
    +
    REAL TRIGS(216)
    +
    +
    DATA pi /3.14159265/
    +
    +
    drad = 2.5 * pi / 180.0
    +
    CALL w3fa11(eps,30)
    +
    CALL w3fa13(trigs,rcos)
    +
    DO lat = 1,37
    +
    colra = (lat - 1) * drad
    +
    CALL w3fa12 (pln(1,1,lat), colra, 30, eps)
    +
    END DO
    +
    +
    Author
    Ralph Jones
    +
    Date
    1993-07-23
    + +

    Definition at line 58 of file w3ft39.f.

    + +
    +
    +
    +
    +
    w3fa13
    subroutine w3fa13(TRIGS, RCOS)
    Computes trig functions used in 2.5 by 2.5 lat,lon mapping routines.
    Definition: w3fa13.f:18
    +
    w3fa11
    subroutine w3fa11(EPS, JCAP)
    Subroutine computes double precision coefficients used in generating legendre polynomials in subr.
    Definition: w3fa11.f:21
    + + + + diff --git a/ver-2.10.0/w3ft39_8f.js b/ver-2.10.0/w3ft39_8f.js new file mode 100644 index 00000000..0cf9c445 --- /dev/null +++ b/ver-2.10.0/w3ft39_8f.js @@ -0,0 +1,4 @@ +var w3ft39_8f = +[ + [ "w3ft39", "w3ft39_8f.html#a858e5d96caaef7d2d5882420f7bc3556", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft39_8f_source.html b/ver-2.10.0/w3ft39_8f_source.html new file mode 100644 index 00000000..1b833c49 --- /dev/null +++ b/ver-2.10.0/w3ft39_8f_source.html @@ -0,0 +1,201 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft39.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft39.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes 2.5x2.5 n. hemi. grid-vector.
    +
    3 C> @author Ralph Jones @date 1993-07-23
    +
    4 
    +
    5 C> Computes 2.5 x 2.5 n. hemi. grid of 145 x 37 points
    +
    6 C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7 C> representing a vector field.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1993-07-23 | Ralph Jones | New version of w3ft09(), takes out w3fa12()
    +
    13 C> makes pln 3 dimensions, pln is computed one time in main program, trades memory
    +
    14 C> for more speed. w3fa12() used 70% of cpu time.
    +
    15 C>
    +
    16 C> @param[in] VLN 992 complex coeff.
    +
    17 C> @param[in] PLN (32,31,37) real space with legendre polynomials
    +
    18 C> computed by w3fa12().
    +
    19 C> @param[in] FL 31 complex space for fourier coeff.
    +
    20 C> @param[in] WORK 144 work space for subr. w3ft12()
    +
    21 C> @param[in] TRIGS 216 precomputed trig funcs. used
    +
    22 C> in w3ft12, computed by w3fa13().
    +
    23 C> @param[in] RCOS 37 reciprocal cosine latitudes of
    +
    24 C> 2.5 x 2.5 grid must be computed before
    +
    25 C> first call to w3ft11 using sr w3fa13().
    +
    26 C> @param[out] GN (145,37) grid values. 5365 point grid is type 29 or 1d o.n. 84
    +
    27 C>
    +
    28 C> @note w3ft09() was optimized to run in a small amount of
    +
    29 C> memory, it was not optimized for speed, 70 percent of the time was
    +
    30 C> used by subroutine w3fa12() computing the legendre polynomials. Since
    +
    31 C> the legendre polynomials are constant they need to be computed
    +
    32 C> only once in a program. By moving w3fa12() to the main program and
    +
    33 C> computing pln as a (32,31,37) array and changing this subroutine
    +
    34 C> to use pln as a three dimension array the running time was cut
    +
    35 C> 70 percent. Add following code to main program to compute eps, pln,
    +
    36 C> trigs, and rcos one time in program.
    +
    37 C> @code
    +
    38 C> DOUBLE PRECISION EPS(992)
    +
    39 C> DOUBLE PRECISION COLRA
    +
    40 C>
    +
    41 C> REAL PLN( 32, 31, 37 )
    +
    42 C> REAL RCOS(37)
    +
    43 C> REAL TRIGS(216)
    +
    44 C>
    +
    45 C> DATA PI /3.14159265/
    +
    46 C>
    +
    47 C> DRAD = 2.5 * PI / 180.0
    +
    48 C> CALL W3FA11(EPS,30)
    +
    49 C> CALL W3FA13(TRIGS,RCOS)
    +
    50 C> DO LAT = 1,37
    +
    51 C> COLRA = (LAT - 1) * DRAD
    +
    52 C> CALL W3FA12 (PLN(1,1,LAT), COLRA, 30, EPS)
    +
    53 C> END DO
    +
    54 C> @endcode
    +
    55 C>
    +
    56 C> @author Ralph Jones @date 1993-07-23
    +
    57  SUBROUTINE w3ft39(VLN,GN,PLN,FL,WORK,TRIGS,RCOS)
    +
    58 C
    +
    59  COMPLEX FL( 31 )
    +
    60  COMPLEX VLN( 32 , 31 )
    +
    61 C
    +
    62  REAL GN(145,37)
    +
    63  REAL PLN( 32, 31, 37 )
    +
    64  REAL RCOS(37)
    +
    65  REAL TRIGS(216)
    +
    66  REAL WORK(144)
    +
    67 C
    +
    68  SAVE
    +
    69 C
    +
    70  DO 400 lat = 2,37
    +
    71  latn = 38 - lat
    +
    72 C
    +
    73  DO 100 l = 1, 31
    +
    74  fl(l) = (0.,0.)
    +
    75  100 CONTINUE
    +
    76 C
    +
    77  DO 300 l = 1, 31
    +
    78 C
    +
    79  DO 200 i = 1, 32
    +
    80  fl(l) = fl(l) + cmplx(pln(i,l,lat) * real(vln(i,l)),
    +
    81  & pln(i,l,lat) * aimag(vln(i,l)) )
    +
    82  200 CONTINUE
    +
    83 C
    +
    84  fl(l)=cmplx(real(fl(l))*rcos(lat),aimag(fl(l))*rcos(lat))
    +
    85  300 CONTINUE
    +
    86 C
    +
    87  CALL w3ft12(fl,work,gn(1,latn),trigs)
    +
    88 C
    +
    89  400 CONTINUE
    +
    90 C
    +
    91 C*** POLE ROW=CLOSEST LATITUDE ROW
    +
    92 C
    +
    93  DO 500 i = 1,145
    +
    94  gn(i,37) = gn(i,36)
    +
    95  500 CONTINUE
    +
    96 C
    +
    97  RETURN
    +
    98  END
    +
    +
    +
    w3ft12
    subroutine w3ft12(COEF, WORK, GRID, TRIGS)
    Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients.
    Definition: w3ft12.f:25
    +
    w3ft39
    subroutine w3ft39(VLN, GN, PLN, FL, WORK, TRIGS, RCOS)
    Computes 2.5 x 2.5 n.
    Definition: w3ft39.f:58
    + + + + diff --git a/ver-2.10.0/w3ft40_8f.html b/ver-2.10.0/w3ft40_8f.html new file mode 100644 index 00000000..31213755 --- /dev/null +++ b/ver-2.10.0/w3ft40_8f.html @@ -0,0 +1,220 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft40.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft40.f File Reference
    +
    +
    + +

    Computes 2.5 x 2.5 s. hemi. grid-scaler. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft40 (FLN, GN, PLN, FL, WORK, TRIGS)
     Computes 2.5 x 2.5 s. More...
     
    +

    Detailed Description

    +

    Computes 2.5 x 2.5 s. hemi. grid-scaler.

    +
    Author
    Ralph Jones
    +
    Date
    1993-07-23
    + +

    Definition in file w3ft40.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft40()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft40 (complex, dimension( 31 , 31 ) FLN,
    real, dimension(145,37) GN,
    real, dimension( 32, 31, 37 ) PLN,
    complex, dimension( 31 ) FL,
    real, dimension(144) WORK,
    real, dimension(216) TRIGS 
    )
    +
    + +

    Computes 2.5 x 2.5 s.

    +

    hemi. grid of 145 x 37 points from spectral coefficients in a rhomboidal 30 resolution representing a scaler field.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1993-07-23 Ralph Jones New version of w3ft10(), takes out w3fa12()
    +

    makes pln 3 dimensions, pln is computed one time in main program, trades memory for more speed. w3fa12() used 70% of cpu time.

    +
    Parameters
    + + + + + + + +
    [in]FLN961 complex coeff.
    [in]PLN(32,31,37) real space with legendre polynomials computed by w3fa12().
    [in]FL31 complex space for fourier coeff.
    [in]WORK144 real work space for subr. w3ft12()
    [in]TRIGS216 precomputed trig funcs. used in w3ft12, computed by w3fa13().
    [out]GN(145,37) grid values. 5365 point grid is type 30 or 1e o.n. 84
    +
    +
    +
    Note
    w3ft10() was optimized to run in a small amount of memory, it was not optimized for speed, 70 percent of the time was used by subroutine w3fa12() computing the legendre polynomials. Since the legendre polynomials are constant they need to be computed only once in a program. By moving w3fa12() to the main program and computing pln as a (32,31,37) array and changing this subroutine to use pln as a three dimension array the running time was cut 70 percent. Add following code to main program to compute eps, pln, trigs, and rcos one time in program.
    DOUBLE PRECISION EPS(992) [CHANGE TO REAL ON CRAY]
    +
    DOUBLE PRECISION COLRA [CHANGE TO REAL ON CRAY]
    +
    +
    REAL PLN( 32, 31, 37 )
    +
    REAL RCOS(37)
    +
    REAL TRIGS(216)
    +
    +
    DATA pi /3.14159265/
    +
    +
    drad = 2.5 * pi / 180.0
    +
    CALL w3fa11(eps,30)
    +
    CALL w3fa13(trigs,rcos)
    +
    DO lat = 1,37
    +
    colra = (lat - 1) * drad
    +
    CALL w3fa12 (pln(1,1,lat), colra, 30, eps)
    +
    END DOC
    +
    +
    Author
    Ralph Jones
    +
    Date
    1993-07-23
    + +

    Definition at line 55 of file w3ft40.f.

    + +
    +
    +
    +
    +
    w3fa13
    subroutine w3fa13(TRIGS, RCOS)
    Computes trig functions used in 2.5 by 2.5 lat,lon mapping routines.
    Definition: w3fa13.f:18
    +
    w3fa11
    subroutine w3fa11(EPS, JCAP)
    Subroutine computes double precision coefficients used in generating legendre polynomials in subr.
    Definition: w3fa11.f:21
    + + + + diff --git a/ver-2.10.0/w3ft40_8f.js b/ver-2.10.0/w3ft40_8f.js new file mode 100644 index 00000000..ac074128 --- /dev/null +++ b/ver-2.10.0/w3ft40_8f.js @@ -0,0 +1,4 @@ +var w3ft40_8f = +[ + [ "w3ft40", "w3ft40_8f.html#a3bc42dc396a768eb87167924c73c65d6", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft40_8f_source.html b/ver-2.10.0/w3ft40_8f_source.html new file mode 100644 index 00000000..a9b9cca7 --- /dev/null +++ b/ver-2.10.0/w3ft40_8f_source.html @@ -0,0 +1,193 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft40.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft40.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes 2.5 x 2.5 s. hemi. grid-scaler
    +
    3 C> @author Ralph Jones @date 1993-07-23
    +
    4 
    +
    5 C> Computes 2.5 x 2.5 s. hemi. grid of 145 x 37 points
    +
    6 C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7 C> representing a scaler field.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1993-07-23 | Ralph Jones | New version of w3ft10(), takes out w3fa12()
    +
    13 C> makes pln 3 dimensions, pln is computed one time in main program, trades memory
    +
    14 C> for more speed. w3fa12() used 70% of cpu time.
    +
    15 C>
    +
    16 C> @param[in] FLN 961 complex coeff.
    +
    17 C> @param[in] PLN (32,31,37) real space with legendre polynomials
    +
    18 C> computed by w3fa12().
    +
    19 C> @param[in] FL 31 complex space for fourier coeff.
    +
    20 C> @param[in] WORK 144 real work space for subr. w3ft12()
    +
    21 C> @param[in] TRIGS 216 precomputed trig funcs. used
    +
    22 C> in w3ft12, computed by w3fa13().
    +
    23 C> @param[out] GN (145,37) grid values. 5365 point grid is type 30 or 1e o.n. 84
    +
    24 C>
    +
    25 C> @note w3ft10() was optimized to run in a small amount of
    +
    26 C> memory, it was not optimized for speed, 70 percent of the time was
    +
    27 C> used by subroutine w3fa12() computing the legendre polynomials. Since
    +
    28 C> the legendre polynomials are constant they need to be computed
    +
    29 C> only once in a program. By moving w3fa12() to the main program and
    +
    30 C> computing pln as a (32,31,37) array and changing this subroutine
    +
    31 C> to use pln as a three dimension array the running time was cut
    +
    32 C> 70 percent. Add following code to main program to compute eps, pln,
    +
    33 C> trigs, and rcos one time in program.
    +
    34 C> @code
    +
    35 C> DOUBLE PRECISION EPS(992) [CHANGE TO REAL ON CRAY]
    +
    36 C> DOUBLE PRECISION COLRA [CHANGE TO REAL ON CRAY]
    +
    37 C>
    +
    38 C> REAL PLN( 32, 31, 37 )
    +
    39 C> REAL RCOS(37)
    +
    40 C> REAL TRIGS(216)
    +
    41 C>
    +
    42 C> DATA PI /3.14159265/
    +
    43 C>
    +
    44 C> DRAD = 2.5 * PI / 180.0
    +
    45 C> CALL W3FA11(EPS,30)
    +
    46 C> CALL W3FA13(TRIGS,RCOS)
    +
    47 C> DO LAT = 1,37
    +
    48 C> COLRA = (LAT - 1) * DRAD
    +
    49 C> CALL W3FA12 (PLN(1,1,LAT), COLRA, 30, EPS)
    +
    50 C> END DOC
    +
    51 C> @endcode
    +
    52 C>
    +
    53 C> @author Ralph Jones @date 1993-07-23
    +
    54  SUBROUTINE w3ft40(FLN,GN,PLN,FL,WORK,TRIGS)
    +
    55 C
    +
    56  COMPLEX FL( 31 )
    +
    57  COMPLEX FLN( 31 , 31 )
    +
    58 C
    +
    59  REAL GN(145,37)
    +
    60  REAL PLN( 32, 31, 37 )
    +
    61  REAL TRIGS(216)
    +
    62  REAL WORK(144)
    +
    63 C
    +
    64  SAVE
    +
    65 C
    +
    66  DO 400 lat = 1,37
    +
    67 C
    +
    68  DO 100 l = 1, 31
    +
    69  fl(l) = (0.,0.)
    +
    70  100 CONTINUE
    +
    71 C
    +
    72  DO 300 l = 1, 31
    +
    73  i = 1
    +
    74  fl(l) = fl(l)+cmplx(pln(i,l,lat) * real(fln(i,l)) ,
    +
    75  & pln(i,l,lat) * aimag(fln(i,l)) )
    +
    76 C
    +
    77  DO 200 i = 2, 30 ,2
    +
    78  fl(l) = fl(l)-cmplx(pln(i,l,lat) * real(fln(i,l)) ,
    +
    79  & pln(i,l,lat) * aimag(fln(i,l)) )
    +
    80  fl(l) = fl(l)+cmplx(pln(i+1,l,lat) * real(fln(i+1,l)),
    +
    81  & pln(i+1,l,lat) * aimag(fln(i+1,l)))
    +
    82  200 CONTINUE
    +
    83 C
    +
    84  300 CONTINUE
    +
    85 C
    +
    86  CALL w3ft12(fl,work,gn(1,lat ),trigs)
    +
    87  400 CONTINUE
    +
    88 C
    +
    89  RETURN
    +
    90  END
    +
    +
    +
    w3ft12
    subroutine w3ft12(COEF, WORK, GRID, TRIGS)
    Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients.
    Definition: w3ft12.f:25
    +
    w3ft40
    subroutine w3ft40(FLN, GN, PLN, FL, WORK, TRIGS)
    Computes 2.5 x 2.5 s.
    Definition: w3ft40.f:55
    + + + + diff --git a/ver-2.10.0/w3ft41_8f.html b/ver-2.10.0/w3ft41_8f.html new file mode 100644 index 00000000..2d69040e --- /dev/null +++ b/ver-2.10.0/w3ft41_8f.html @@ -0,0 +1,227 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft41.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft41.f File Reference
    +
    +
    + +

    Computes 2.5x2.5 s. hemi. grid vector. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft41 (VLN, GN, PLN, FL, WORK, TRIGS, RCOS)
     Computes 2.5 x 2.5 s. More...
     
    +

    Detailed Description

    +

    Computes 2.5x2.5 s. hemi. grid vector.

    +
    Author
    Ralph Jones
    +
    Date
    1992-07-23
    + +

    Definition in file w3ft41.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft41()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft41 (complex, dimension( 32 , 31 ) VLN,
    real, dimension(145,37) GN,
    real, dimension( 32, 31, 37 ) PLN,
    complex, dimension( 31 ) FL,
    real, dimension(144) WORK,
    real, dimension(216) TRIGS,
    real, dimension(37) RCOS 
    )
    +
    + +

    Computes 2.5 x 2.5 s.

    +

    hemi. grid of 145 x 37 points from spectral coefficients in a rhomboidal 30 resolution representing a vector field.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1993-07-23 Ralph Jones New version of w3ft11(), takes out w3fa12()
    +

    makes pln 3 dimensions, pln is computed one time in main program, trades memory for more speed. w3fa12() used 70% of cpu time.

    +
    Parameters
    + + + + + + + + +
    [in]VLN992 complex coeff.
    [in]PLN(32,31,37) real space with legendre polynomials computed by w3fa12().
    [in]FL31 complex space for fourier coeff.
    [in]WORK144 real work space for subr. w3ft12()
    [in]TRIGS216 precomputed trig funcs. used in w3ft12(), computed by w3fa13()
    [in]RCOS37 reciprocal cosine latitudes of 2.5 x 2.5 grid must be computed before first call to w3ft11 using subr. w3fa13().
    [out]GN(145,37) grid values. 5365 point grid is type 30 or 1e hex o.n. 84
    +
    +
    +
    Note
    w3ft11() was optimized to run in a small amount of memory, it was not optimized for speed, 70 percent of the time was used by subroutine w3fa12() computing the legendre polynomials. Since the legendre polynomials are constant they need to be computed only once in a program. By moving w3fa12() to the main program and computing pln as a (32,31,37) array and changing this subroutine to use pln as a three dimension array the running time was cut 70 percent. Add following code to main program to compute eps, pln, trigs, and rcos one time in program.
    DOUBLE PRECISION EPS(992)
    +
    DOUBLE PRECISION COLRA
    +
    +
    REAL PLN( 32, 31, 37 )
    +
    REAL RCOS(37)
    +
    REAL TRIGS(216)
    +
    +
    DATA pi /3.14159265/
    +
    +
    drad = 2.5 * pi / 180.0
    +
    CALL w3fa11(eps,30)
    +
    CALL w3fa13(trigs,rcos)
    +
    DO lat = 1,37
    +
    colra = (lat - 1) * drad
    +
    CALL w3fa12 (pln(1,1,lat), colra, 30, eps)
    +
    END DO
    +
    +
    Author
    Ralph Jones
    +
    Date
    1992-07-23
    + +

    Definition at line 58 of file w3ft41.f.

    + +
    +
    +
    +
    +
    w3fa13
    subroutine w3fa13(TRIGS, RCOS)
    Computes trig functions used in 2.5 by 2.5 lat,lon mapping routines.
    Definition: w3fa13.f:18
    +
    w3fa11
    subroutine w3fa11(EPS, JCAP)
    Subroutine computes double precision coefficients used in generating legendre polynomials in subr.
    Definition: w3fa11.f:21
    + + + + diff --git a/ver-2.10.0/w3ft41_8f.js b/ver-2.10.0/w3ft41_8f.js new file mode 100644 index 00000000..567e013f --- /dev/null +++ b/ver-2.10.0/w3ft41_8f.js @@ -0,0 +1,4 @@ +var w3ft41_8f = +[ + [ "w3ft41", "w3ft41_8f.html#a261b10911c4a789b882deef2c1f312ca", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft41_8f_source.html b/ver-2.10.0/w3ft41_8f_source.html new file mode 100644 index 00000000..7850085f --- /dev/null +++ b/ver-2.10.0/w3ft41_8f_source.html @@ -0,0 +1,202 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft41.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft41.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Computes 2.5x2.5 s. hemi. grid vector.
    +
    3 C> @author Ralph Jones @date 1992-07-23
    +
    4 
    +
    5 C> Computes 2.5 x 2.5 s. hemi. grid of 145 x 37 points
    +
    6 C> from spectral coefficients in a rhomboidal 30 resolution
    +
    7 C> representing a vector field.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1993-07-23 | Ralph Jones | New version of w3ft11(), takes out w3fa12()
    +
    13 C> makes pln 3 dimensions, pln is computed one time in main program, trades memory
    +
    14 C> for more speed. w3fa12() used 70% of cpu time.
    +
    15 C>
    +
    16 C> @param[in] VLN 992 complex coeff.
    +
    17 C> @param[in] PLN (32,31,37) real space with legendre polynomials
    +
    18 C> computed by w3fa12().
    +
    19 C> @param[in] FL 31 complex space for fourier coeff.
    +
    20 C> @param[in] WORK 144 real work space for subr. w3ft12()
    +
    21 C> @param[in] TRIGS 216 precomputed trig funcs. used
    +
    22 C> in w3ft12(), computed by w3fa13()
    +
    23 C> @param[in] RCOS 37 reciprocal cosine latitudes of
    +
    24 C> 2.5 x 2.5 grid must be computed before
    +
    25 C> first call to w3ft11 using subr. w3fa13().
    +
    26 C> @param[out] GN (145,37) grid values. 5365 point grid is type 30 or 1e hex o.n. 84
    +
    27 C>
    +
    28 C> @note w3ft11() was optimized to run in a small amount of
    +
    29 C> memory, it was not optimized for speed, 70 percent of the time was
    +
    30 C> used by subroutine w3fa12() computing the legendre polynomials. Since
    +
    31 C> the legendre polynomials are constant they need to be computed
    +
    32 C> only once in a program. By moving w3fa12() to the main program and
    +
    33 C> computing pln as a (32,31,37) array and changing this subroutine
    +
    34 C> to use pln as a three dimension array the running time was cut
    +
    35 C> 70 percent. Add following code to main program to compute eps, pln,
    +
    36 C> trigs, and rcos one time in program.
    +
    37 C> @code
    +
    38 C> DOUBLE PRECISION EPS(992)
    +
    39 C> DOUBLE PRECISION COLRA
    +
    40 C>
    +
    41 C> REAL PLN( 32, 31, 37 )
    +
    42 C> REAL RCOS(37)
    +
    43 C> REAL TRIGS(216)
    +
    44 C>
    +
    45 C> DATA PI /3.14159265/
    +
    46 C>
    +
    47 C> DRAD = 2.5 * PI / 180.0
    +
    48 C> CALL W3FA11(EPS,30)
    +
    49 C> CALL W3FA13(TRIGS,RCOS)
    +
    50 C> DO LAT = 1,37
    +
    51 C> COLRA = (LAT - 1) * DRAD
    +
    52 C> CALL W3FA12 (PLN(1,1,LAT), COLRA, 30, EPS)
    +
    53 C> END DO
    +
    54 C> @endcode
    +
    55 C>
    +
    56 C> @author Ralph Jones @date 1992-07-23
    +
    57  SUBROUTINE w3ft41(VLN,GN,PLN,FL,WORK,TRIGS,RCOS)
    +
    58 C
    +
    59  COMPLEX FL( 31 )
    +
    60  COMPLEX VLN( 32 , 31 )
    +
    61 C
    +
    62  REAL GN(145,37)
    +
    63  REAL PLN( 32, 31, 37 )
    +
    64  REAL RCOS(37)
    +
    65  REAL TRIGS(216)
    +
    66  REAL WORK(144)
    +
    67 C
    +
    68  SAVE
    +
    69 C
    +
    70  DO 400 lat = 2,37
    +
    71 C
    +
    72  DO 100 l = 1, 31
    +
    73  fl(l) = (0.,0.)
    +
    74  100 CONTINUE
    +
    75 C
    +
    76  DO 300 l = 1, 31
    +
    77 C
    +
    78  DO 200 i = 1, 31 ,2
    +
    79  fl(l) = fl(l)+cmplx(pln(i,l,lat) * real(vln(i,l)) ,
    +
    80  & pln(i,l,lat) * aimag(vln(i,l)) )
    +
    81  fl(l) = fl(l)-cmplx(pln(i+1,l,lat) * real(vln(i+1,l)),
    +
    82  & pln(i+1,l,lat) * aimag(vln(i+1,l)))
    +
    83  200 CONTINUE
    +
    84 C
    +
    85  fl(l) = cmplx(real(fl(l))*rcos(lat),aimag(fl(l))*rcos(lat))
    +
    86 C
    +
    87  300 CONTINUE
    +
    88 C
    +
    89  CALL w3ft12(fl,work,gn(1,lat ),trigs)
    +
    90 C
    +
    91  400 CONTINUE
    +
    92 C
    +
    93 C*** POLE ROW = CLOSEST LATITUDE ROW
    +
    94 C
    +
    95  DO 500 i = 1,145
    +
    96  gn(i,1) = gn(i,2)
    +
    97  500 CONTINUE
    +
    98  RETURN
    +
    99  END
    +
    +
    +
    w3ft12
    subroutine w3ft12(COEF, WORK, GRID, TRIGS)
    Fast fourier to compute 145 grid values at desired latitude from 31 complex fourier coefficients.
    Definition: w3ft12.f:25
    +
    w3ft41
    subroutine w3ft41(VLN, GN, PLN, FL, WORK, TRIGS, RCOS)
    Computes 2.5 x 2.5 s.
    Definition: w3ft41.f:58
    + + + + diff --git a/ver-2.10.0/w3ft43v_8f.html b/ver-2.10.0/w3ft43v_8f.html new file mode 100644 index 00000000..ecffcf43 --- /dev/null +++ b/ver-2.10.0/w3ft43v_8f.html @@ -0,0 +1,185 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft43v.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ft43v.f File Reference
    +
    +
    + +

    Convert (361,181) grid to (65,65) n. hemi. grid. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ft43v (ALOLA, APOLA, INTERP)
     Convert a global 1.0 degree lat.,lon. More...
     
    +

    Detailed Description

    +

    Convert (361,181) grid to (65,65) n. hemi. grid.

    +
    Author
    Ralph Jones
    +
    Date
    1993-03-29
    + +

    Definition in file w3ft43v.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ft43v()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ft43v (real, dimension(361,181) ALOLA,
    real, dimension(npts) APOLA,
     INTERP 
    )
    +
    + +

    Convert a global 1.0 degree lat.,lon.

    +

    361 by 181 grid to a polar stereographic 65 by 65 grid. the polar stereographic map projection is true at 60 deg. n. , the mesh length is 381 km. and the oriention is 80 deg. w.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1993-03-29 Ralph Jones Add save statement.
    +
    Parameters
    + + + + +
    [in]ALOLA361*181 grid 1.0 deg. lat,lon grid n. hemi. 65341 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish added to right side to make 361 * 181.
    [in]INTERP1 linear interpolation , ne.1 biquadratic
    [out]APOLA65*65 grid of northern hemisphere. 4225 point grid is o.n.84 type 27 or 1b hex
    +
    +
    +
    Note
      +
    • 1. W1 and w2 are used to store sets of constants which are reusable for repeated calls to the subroutine. 20 other arrays are saved and reused on the next calls to the subroutine.
      • +
    • 2. Wind components are not rotated to the 65*65 grid orientation after interpolation. You may use w3fc08 to do this.
      • +
    • 3. The about 1100 points below the equator will be in this map.
      • +
    +
    +
    Author
    Ralph Jones
    +
    Date
    1993-03-29
    + +

    Definition at line 32 of file w3ft43v.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ft43v_8f.js b/ver-2.10.0/w3ft43v_8f.js new file mode 100644 index 00000000..2b294ba4 --- /dev/null +++ b/ver-2.10.0/w3ft43v_8f.js @@ -0,0 +1,4 @@ +var w3ft43v_8f = +[ + [ "w3ft43v", "w3ft43v_8f.html#a2296d6ab6d8638d5d0d59468cc6402d5", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ft43v_8f_source.html b/ver-2.10.0/w3ft43v_8f_source.html new file mode 100644 index 00000000..f9d38700 --- /dev/null +++ b/ver-2.10.0/w3ft43v_8f_source.html @@ -0,0 +1,351 @@ + + + + + + + +NCEPLIBS-w3emc: w3ft43v.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ft43v.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Convert (361,181) grid to (65,65) n. hemi. grid.
    +
    3 C> @author Ralph Jones @date 1993-03-29
    +
    4 
    +
    5 C> Convert a global 1.0 degree lat.,lon. 361 by
    +
    6 C> 181 grid to a polar stereographic 65 by 65 grid. the polar
    +
    7 C> stereographic map projection is true at 60 deg. n. , the mesh
    +
    8 C> length is 381 km. and the oriention is 80 deg. w.
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comment
    +
    12 C> -----|------------|--------
    +
    13 C> 1993-03-29 | Ralph Jones | Add save statement.
    +
    14 C>
    +
    15 C> @param[in] ALOLA 361*181 grid 1.0 deg. lat,lon grid n. hemi.
    +
    16 C> 65341 point grid. 360 * 181 one degree grib grid 3 was flipped, greenwish
    +
    17 C> added to right side to make 361 * 181.
    +
    18 C> @param[in] INTERP 1 linear interpolation , ne.1 biquadratic
    +
    19 C> @param[out] APOLA 65*65 grid of northern hemisphere. 4225 point grid is
    +
    20 C> o.n.84 type 27 or 1b hex
    +
    21 C>
    +
    22 C> @note
    +
    23 C> - 1. W1 and w2 are used to store sets of constants which are
    +
    24 C> reusable for repeated calls to the subroutine. 20 other arrays
    +
    25 C> are saved and reused on the next calls to the subroutine.
    +
    26 C> - 2. Wind components are not rotated to the 65*65 grid orientation
    +
    27 C> after interpolation. You may use w3fc08 to do this.
    +
    28 C> - 3. The about 1100 points below the equator will be in this map.
    +
    29 C>
    +
    30 C> @author Ralph Jones @date 1993-03-29
    +
    31  SUBROUTINE w3ft43v(ALOLA,APOLA,INTERP)
    +
    32 C
    +
    33  parameter(npts=4225,ii=65,jj=65)
    +
    34  parameter(orient=80.0,ipole=33,jpole=33)
    +
    35  parameter(xmesh=381.0)
    +
    36 C
    +
    37  REAL R2(NPTS), WLON(NPTS)
    +
    38  REAL XLAT(NPTS), XI(II,JJ), XJ(II,JJ)
    +
    39  REAL XII(NPTS), XJJ(NPTS), ANGLE(NPTS)
    +
    40  REAL ALOLA(361,181), APOLA(NPTS), ERAS(NPTS,4)
    +
    41  REAL W1(NPTS), W2(NPTS)
    +
    42  REAL XDELI(NPTS), XDELJ(NPTS)
    +
    43  REAL XI2TM(NPTS), XJ2TM(NPTS)
    +
    44 C
    +
    45  INTEGER IV(NPTS), JV(NPTS), JY(NPTS,4)
    +
    46  INTEGER IM1(NPTS), IP1(NPTS), IP2(NPTS)
    +
    47 C
    +
    48  LOGICAL LIN
    +
    49 C
    +
    50  SAVE
    +
    51 C
    +
    52  equivalence(xi(1,1),xii(1)),(xj(1,1),xjj(1))
    +
    53 C
    +
    54  DATA degprd/57.2957795/
    +
    55  DATA earthr/6371.2/
    +
    56  DATA intrpo/99/
    +
    57  DATA iswt /0/
    +
    58 C
    +
    59  lin = .false.
    +
    60  IF (interp.EQ.1) lin = .true.
    +
    61 C
    +
    62  IF (iswt.EQ.1) GO TO 900
    +
    63 C
    +
    64  deg = 1.0
    +
    65  gi2 = (1.86603 * earthr) / xmesh
    +
    66  gi2 = gi2 * gi2
    +
    67 C
    +
    68 C NEXT 32 LINES OF CODE PUTS SUBROUTINE W3FB05 IN LINE
    +
    69 C
    +
    70  DO 100 j = 1,jj
    +
    71  xj1 = j - jpole
    +
    72  DO 100 i = 1,ii
    +
    73  xi(i,j) = i - ipole
    +
    74  xj(i,j) = xj1
    +
    75  100 CONTINUE
    +
    76 C
    +
    77  DO 200 kk = 1,npts
    +
    78  r2(kk) = xjj(kk) * xjj(kk) + xii(kk) * xii(kk)
    +
    79  xlat(kk) = degprd *
    +
    80  & asin((gi2 - r2(kk)) / (gi2 + r2(kk)))
    +
    81  200 CONTINUE
    +
    82 C
    +
    83  xii(2113) = 1.0
    +
    84  DO 300 kk = 1,npts
    +
    85  angle(kk) = degprd * atan2(xjj(kk),xii(kk))
    +
    86  300 CONTINUE
    +
    87 C
    +
    88  DO 400 kk = 1,npts
    +
    89  IF (angle(kk).LT.0.0) angle(kk) = angle(kk) + 360.0
    +
    90  400 CONTINUE
    +
    91 C
    +
    92  DO 500 kk = 1,npts
    +
    93  wlon(kk) = 270.0 + orient - angle(kk)
    +
    94  500 CONTINUE
    +
    95 C
    +
    96  DO 600 kk = 1,npts
    +
    97  IF (wlon(kk).LT.0.0) wlon(kk) = wlon(kk) + 360.0
    +
    98  600 CONTINUE
    +
    99 C
    +
    100  DO 700 kk = 1,npts
    +
    101  IF (wlon(kk).GE.360.0) wlon(kk) = wlon(kk) - 360.0
    +
    102  700 CONTINUE
    +
    103 C
    +
    104  xlat(2113) = 90.0
    +
    105  wlon(2113) = 0.0
    +
    106 C
    +
    107  DO 800 kk = 1,npts
    +
    108  w1(kk) = (360.0 - wlon(kk)) / deg + 1.0
    +
    109  w2(kk) = xlat(kk) / deg + 91.0
    +
    110  800 CONTINUE
    +
    111 C
    +
    112  iswt = 1
    +
    113  intrpo = interp
    +
    114  GO TO 1000
    +
    115 C
    +
    116 C AFTER THE 1ST CALL TO W3FT43V TEST INTERP, IF IT HAS
    +
    117 C CHANGED RECOMPUTE SOME CONSTANTS
    +
    118 C
    +
    119  900 CONTINUE
    +
    120  IF (interp.EQ.intrpo) GO TO 2100
    +
    121  intrpo = interp
    +
    122 C
    +
    123  1000 CONTINUE
    +
    124  DO 1100 k = 1,npts
    +
    125  iv(k) = w1(k)
    +
    126  jv(k) = w2(k)
    +
    127  xdeli(k) = w1(k) - iv(k)
    +
    128  xdelj(k) = w2(k) - jv(k)
    +
    129  ip1(k) = iv(k) + 1
    +
    130  jy(k,3) = jv(k) + 1
    +
    131  jy(k,2) = jv(k)
    +
    132  1100 CONTINUE
    +
    133 C
    +
    134  IF (lin) GO TO 1400
    +
    135 C
    +
    136  DO 1200 k = 1,npts
    +
    137  ip2(k) = iv(k) + 2
    +
    138  im1(k) = iv(k) - 1
    +
    139  jy(k,1) = jv(k) - 1
    +
    140  jy(k,4) = jv(k) + 2
    +
    141  xi2tm(k) = xdeli(k) * (xdeli(k) - 1.0) * .25
    +
    142  xj2tm(k) = xdelj(k) * (xdelj(k) - 1.0) * .25
    +
    143  1200 CONTINUE
    +
    144 C
    +
    145  DO 1300 kk = 1,npts
    +
    146  IF (iv(kk).EQ.1) THEN
    +
    147  ip2(kk) = 3
    +
    148  im1(kk) = 360
    +
    149  ELSE IF (iv(kk).EQ.360) THEN
    +
    150  ip2(kk) = 2
    +
    151  im1(kk) = 359
    +
    152  ENDIF
    +
    153  1300 CONTINUE
    +
    154 C
    +
    155  1400 CONTINUE
    +
    156 C
    +
    157  IF (lin) GO TO 1700
    +
    158 C
    +
    159  DO 1500 kk = 1,npts
    +
    160  IF (jv(kk).GE.180) xj2tm(kk) = 0.0
    +
    161  1500 CONTINUE
    +
    162 C
    +
    163  DO 1600 kk = 1,npts
    +
    164  IF (ip2(kk).LT.1) ip2(kk) = 1
    +
    165  IF (im1(kk).LT.1) im1(kk) = 1
    +
    166  IF (ip2(kk).GT.361) ip2(kk) = 361
    +
    167  IF (im1(kk).GT.361) im1(kk) = 361
    +
    168  1600 CONTINUE
    +
    169 C
    +
    170  1700 CONTINUE
    +
    171  DO 1800 kk = 1,npts
    +
    172  IF (iv(kk).LT.1) iv(kk) = 1
    +
    173  IF (ip1(kk).LT.1) ip1(kk) = 1
    +
    174  IF (iv(kk).GT.361) iv(kk) = 361
    +
    175  IF (ip1(kk).GT.361) ip1(kk) = 361
    +
    176  1800 CONTINUE
    +
    177 C
    +
    178 C LINEAR INTERPOLATION
    +
    179 C
    +
    180  DO 1900 kk = 1,npts
    +
    181  IF (jy(kk,2).GT.181) jy(kk,2) = 181
    +
    182  IF (jy(kk,3).GT.181) jy(kk,3) = 181
    +
    183  1900 CONTINUE
    +
    184 C
    +
    185  IF (.NOT.lin) THEN
    +
    186  DO 2000 kk = 1,npts
    +
    187  IF (jy(kk,1).GT.181) jy(kk,1) = 181
    +
    188  IF (jy(kk,4).GT.181) jy(kk,4) = 181
    +
    189  2000 CONTINUE
    +
    190  ENDIF
    +
    191 C
    +
    192  2100 CONTINUE
    +
    193  IF (lin) THEN
    +
    194 C
    +
    195 C LINEAR INTERPOLATION
    +
    196 C
    +
    197  DO 2200 kk = 1,npts
    +
    198  eras(kk,2) = (alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    199  & * xdeli(kk) + alola(iv(kk),jy(kk,2))
    +
    200  eras(kk,3) = (alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    201  & * xdeli(kk) + alola(iv(kk),jy(kk,3))
    +
    202  2200 CONTINUE
    +
    203 C
    +
    204  DO 2300 kk = 1,npts
    +
    205  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    206  & * xdelj(kk)
    +
    207  2300 CONTINUE
    +
    208 C
    +
    209  ELSE
    +
    210 C
    +
    211 C QUADRATIC INTERPOLATION
    +
    212 C
    +
    213  DO 2400 kk = 1,npts
    +
    214  eras(kk,1)=(alola(ip1(kk),jy(kk,1))-alola(iv(kk),jy(kk,1)))
    +
    215  & * xdeli(kk) + alola(iv(kk),jy(kk,1)) +
    +
    216  & ( alola(im1(kk),jy(kk,1)) - alola(iv(kk),jy(kk,1))
    +
    217  & - alola(ip1(kk),jy(kk,1))+alola(ip2(kk),jy(kk,1)))
    +
    218  & * xi2tm(kk)
    +
    219  eras(kk,2)=(alola(ip1(kk),jy(kk,2))-alola(iv(kk),jy(kk,2)))
    +
    220  & * xdeli(kk) + alola(iv(kk),jy(kk,2)) +
    +
    221  & ( alola(im1(kk),jy(kk,2)) - alola(iv(kk),jy(kk,2))
    +
    222  & - alola(ip1(kk),jy(kk,2))+alola(ip2(kk),jy(kk,2)))
    +
    223  & * xi2tm(kk)
    +
    224  eras(kk,3)=(alola(ip1(kk),jy(kk,3))-alola(iv(kk),jy(kk,3)))
    +
    225  & * xdeli(kk) + alola(iv(kk),jy(kk,3)) +
    +
    226  & ( alola(im1(kk),jy(kk,3)) - alola(iv(kk),jy(kk,3))
    +
    227  & - alola(ip1(kk),jy(kk,3))+alola(ip2(kk),jy(kk,3)))
    +
    228  & * xi2tm(kk)
    +
    229  eras(kk,4)=(alola(ip1(kk),jy(kk,4))-alola(iv(kk),jy(kk,4)))
    +
    230  & * xdeli(kk) + alola(iv(kk),jy(kk,4)) +
    +
    231  & ( alola(im1(kk),jy(kk,4)) - alola(iv(kk),jy(kk,4))
    +
    232  & - alola(ip1(kk),jy(kk,4))+alola(ip2(kk),jy(kk,4)))
    +
    233  & * xi2tm(kk)
    +
    234  2400 CONTINUE
    +
    235 C
    +
    236  DO 2500 kk = 1,npts
    +
    237  apola(kk) = eras(kk,2) + (eras(kk,3) - eras(kk,2))
    +
    238  & * xdelj(kk) + (eras(kk,1) - eras(kk,2)
    +
    239  & - eras(kk,3) + eras(kk,4)) * xj2tm(kk)
    +
    240  2500 CONTINUE
    +
    241 C
    +
    242  ENDIF
    +
    243 C
    +
    244 C SET POLE POINT , WMO STANDARD FOR U OR V
    +
    245 C
    +
    246  apola(2113) = alola(181,181)
    +
    247 C
    +
    248  RETURN
    +
    249  END
    +
    +
    +
    w3ft43v
    subroutine w3ft43v(ALOLA, APOLA, INTERP)
    Convert a global 1.0 degree lat.,lon.
    Definition: w3ft43v.f:32
    + + + + diff --git a/ver-2.10.0/w3kind_8f.html b/ver-2.10.0/w3kind_8f.html new file mode 100644 index 00000000..c96025a0 --- /dev/null +++ b/ver-2.10.0/w3kind_8f.html @@ -0,0 +1,171 @@ + + + + + + + +NCEPLIBS-w3emc: w3kind.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3kind.f File Reference
    +
    +
    + +

    Return the real kind and integer kind used in w3 lib. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3kind (kindreal, kindint)
     This subprogram returns the real kind and the integer kind that the w3 lib is compiled with. More...
     
    +

    Detailed Description

    +

    Return the real kind and integer kind used in w3 lib.

    +
    Author
    Jun Wang
    +
    Date
    2011-06-24
    + +

    Definition in file w3kind.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3kind()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3kind (integer, intent(out) kindreal,
    integer, intent(out) kindint 
    )
    +
    + +

    This subprogram returns the real kind and the integer kind that the w3 lib is compiled with.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    2011-06-24 Jun Wang Initial
    +
    Parameters
    + + + +
    [out]KINDREALKind of real number in w3 lib
    [out]KINDINTKind of integer number in w3 lib
    +
    +
    +
    Author
    Jun Wang
    +
    Date
    2011-06-24
    + +

    Definition at line 18 of file w3kind.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3kind_8f.js b/ver-2.10.0/w3kind_8f.js new file mode 100644 index 00000000..c3ce0219 --- /dev/null +++ b/ver-2.10.0/w3kind_8f.js @@ -0,0 +1,4 @@ +var w3kind_8f = +[ + [ "w3kind", "w3kind_8f.html#adbff650124d647848a96ff9e35b0fa4a", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3kind_8f_source.html b/ver-2.10.0/w3kind_8f_source.html new file mode 100644 index 00000000..31b40209 --- /dev/null +++ b/ver-2.10.0/w3kind_8f_source.html @@ -0,0 +1,114 @@ + + + + + + + +NCEPLIBS-w3emc: w3kind.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3kind.f
    +
    +
    +Go to the documentation of this file.
    1 
    +
    4 
    +
    17  subroutine w3kind(kindreal,kindint)
    +
    18  IMPLICIT NONE
    +
    19 !
    +
    20  integer,intent(out) :: kindreal,kindint
    +
    21 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    22 ! get real kind from a real number
    +
    23  kindreal=kind(1.0)
    +
    24  kindint=kind(1)
    +
    25 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    26  end
    +
    +
    +
    w3kind
    subroutine w3kind(kindreal, kindint)
    This subprogram returns the real kind and the integer kind that the w3 lib is compiled with.
    Definition: w3kind.f:18
    + + + + diff --git a/ver-2.10.0/w3locdat_8f.html b/ver-2.10.0/w3locdat_8f.html new file mode 100644 index 00000000..7ca38812 --- /dev/null +++ b/ver-2.10.0/w3locdat_8f.html @@ -0,0 +1,163 @@ + + + + + + + +NCEPLIBS-w3emc: w3locdat.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3locdat.f File Reference
    +
    +
    + +

    Return the local date and time. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3locdat (idat)
     This subprogram returns the local date and time in the ncep absolute date and time data structure. More...
     
    +

    Detailed Description

    +

    Return the local date and time.

    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition in file w3locdat.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3locdat()

    + +
    +
    + + + + + + + + +
    subroutine w3locdat (integer, dimension(8) idat)
    +
    + +

    This subprogram returns the local date and time in the ncep absolute date and time data structure.

    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    1998-01-05 Mark Iredell Initial.
    1999-04-28 Stephen 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 | Stephen Gilbert | Changed so that czone variable is saved and the system call is only done for first invocation of this routine.

    +
    Parameters
    + + +
    [in]IDAT(8) NCEP absolute date and time (year, month, day, time zone, hour, minute, second, millisecond)
    +
    +
    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition at line 23 of file w3locdat.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3locdat_8f.js b/ver-2.10.0/w3locdat_8f.js new file mode 100644 index 00000000..c60ba247 --- /dev/null +++ b/ver-2.10.0/w3locdat_8f.js @@ -0,0 +1,4 @@ +var w3locdat_8f = +[ + [ "w3locdat", "w3locdat_8f.html#aa6df8f7e0aa6aa5067becb1ca7a6ebe1", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3locdat_8f_source.html b/ver-2.10.0/w3locdat_8f_source.html new file mode 100644 index 00000000..b6095df1 --- /dev/null +++ b/ver-2.10.0/w3locdat_8f_source.html @@ -0,0 +1,113 @@ + + + + + + + +NCEPLIBS-w3emc: w3locdat.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3locdat.f
    +
    +
    +Go to the documentation of this file.
    1 
    +
    4 
    +
    22  subroutine w3locdat(idat)
    +
    23  integer idat(8)
    +
    24  character cdate*8,ctime*10,czone*5
    +
    25 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    26 ! get local date and time but use the character time zone
    +
    27  call date_and_time(cdate,ctime,czone,idat)
    +
    28  read(czone,'(i5)') idat(4)
    +
    29 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    30  end
    +
    +
    +
    w3locdat
    subroutine w3locdat(idat)
    This subprogram returns the local date and time in the ncep absolute date and time data structure.
    Definition: w3locdat.f:23
    + + + + diff --git a/ver-2.10.0/w3log_8f_source.html b/ver-2.10.0/w3log_8f_source.html new file mode 100644 index 00000000..a4399b9a --- /dev/null +++ b/ver-2.10.0/w3log_8f_source.html @@ -0,0 +1,103 @@ + + + + + + + +NCEPLIBS-w3emc: w3log.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3log.f
    +
    +
    +
    1  subroutine w3log
    +
    2  end
    +
    +
    + + + + diff --git a/ver-2.10.0/w3miscan_8f.html b/ver-2.10.0/w3miscan_8f.html new file mode 100644 index 00000000..202b88fc --- /dev/null +++ b/ver-2.10.0/w3miscan_8f.html @@ -0,0 +1,967 @@ + + + + + + + +NCEPLIBS-w3emc: w3miscan.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3miscan.f File Reference
    +
    +
    + +

    Reads 1 ssm/i scan line from bufr d-set. +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

    +Functions/Subroutines

    subroutine misc01 (NNALG, GBALG, KDATA, SWNN, TPWNN, SWGB, NRFGB)
     Prepares for in-line caluclation of prods. More...
     
    subroutine misc04 (INLSF, BLAT, BLNG, LSTAG)
     Returns land/sea tag for given lat/lon. More...
     
    subroutine misc05 (INLSF, NUMRGN,)
     Reads 2 records from land/sea tag database. More...
     
    subroutine misc06 (INGBI, INGBD, IDAT1, IDAT2,,,,)
     Reads in nh and sh 1-deg. More...
     
    subroutine misc10 (X, Y)
     Calc. More...
     
    function risc02 (XT, V, L, SST, JERR)
     Calc. More...
     
    function risc02xx (X)
     Calc. More...
     
    function risc03 (X)
     Calc. More...
     
    subroutine w3miscan (INDTA, INLSF, INGBI, INGBD, LSAT, LPROD, LBRIT, NNALG, GBALG, KDATE, LDATE, IGNRTM, IBUFTN, IBDATE, IER)
     Reads one ssm/i scan line (64 retrievals) from the NCEP bufr ssm/i dump file. More...
     
    +

    Detailed Description

    +

    Reads 1 ssm/i scan line from bufr d-set.

    +
    Author
    Dennis Keyser
    +
    Date
    1996-07-30
    + +

    Definition in file w3miscan.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ misc01()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine misc01 (logical NNALG,
    logical GBALG,
    integer, dimension(7) KDATA,
     SWNN,
     TPWNN,
     SWGB,
     NRFGB 
    )
    +
    + +

    Prepares for in-line caluclation of prods.

    +
    Author
    Dennis Keyser
    +
    Date
    1995-01-04 Based on input 7-channel ssm/i brightness temperatures, determines the rain flag category for wind speed product for the goodberlet algorithm. Then calls the appropriate function to calculate either the wind speed product for the goodberlet algorithm (if requested) or the wind speed and tpw products for the neural net 3 algorithm (if requested).
    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    ????-??-?? W. Gemmill (w/nmc21) – original author
    1995-01-04 Dennis Keyser – incorporated into w3miscan and
    +

    streamlined code 1996-05-07 | Dennis Keyser | (np22) – in-line neural network 1 algoritm replaced by neural network 2 algorithm 1996-07-30 | Dennis Keyser | (np22) – can now process wind speed from both algorithms if desired 1998-01-28 | Dennis Keyser | (np22) – replaced neural net 2 algorithm which calculated only wind speed product with neural net 3 algorithm which calculates both wind speed and total precipitable water products (among others) but, unlike nn2, does not return a rain flag value (it does set all retrievals to missing that fail rain flag and ice contamination tests)

    +
    Parameters
    + + + + + + + + +
    [in]NNALGProcess wind speed and tpw via neural net 3 algorithm if true
    [in]GBALGProcess wind speed via goodberlet algorithm if true
    [in]KDATA7-word array containing 7 channels of brightness temperature (kelvin x 100)
    [out]SWNNalculated wind speed based on neural net 3 algorithm (meters/second)
    [out]TPWNNCalculated total column precipitable water based on neural net 3 algorithm (millimeters)
    [out]SWGBCalculated wind speed based on goodberlet algorith (meters/second)
    [out]NRFGBRain flag category for calculated wind speed from goodberlet algorithm
    +
    +
    +
    Remarks
    If an algorithm is not chosen, the output products are set to values of 99999. for that algorithm and, for the goodberlet algorithm only, the rain flag is set to 99999. Called by subroutine w3miscan().
    +
    Author
    Dennis Keyser
    +
    Date
    1995-01-04
    + +

    Definition at line 1007 of file w3miscan.f.

    + +
    +
    + +

    ◆ misc04()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine misc04 ( INLSF,
     BLAT,
     BLNG,
     LSTAG 
    )
    +
    + +

    Returns land/sea tag for given lat/lon.

    +
    Author
    Dennis Keyser
    +
    Date
    1995-01-04 Finds and returns the low resolution land/sea tag nearest to the requested latitude and longitude.
    +

    +Program History Log:

    + + + + + + + + + + + +
    Date Programmer Comment
    1978-01-20 J. K. Kalinowski (S11213) Original author
    1978-10-03 J. K. Kalinowski (S1214) Changes unknown
    1985-03-01 N. Digirolamo (SSAI) Conversion to vs fortran
    1995-01-04 Dennis Keyser Incorporated into w3miscan and streamlined code
    +
    Parameters
    + + + + + +
    [in]INLSFUnit number of direct access nesdis land/sea file
    [in]BLATLatitude (whole degrees: range is 0. to +90. north, 0. to -90. south)
    [in]BLNGLongitude (whole degrees: range is 0. to +179.99 east, 0. to -180. west)
    [out]LSTAGLand/sea tag {=0 - sea; =1 - land; =2 - coastal interface (higher resolution tags are available); =3 - coastal interface (no higher resolution tags exist)}
    +
    +
    +
    Remarks
    Called by subroutine w3miscan.
    +
    Author
    Dennis Keyser
    +
    Date
    1995-01-04
    + +

    Definition at line 1449 of file w3miscan.f.

    + +
    +
    + +

    ◆ misc05()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine misc05 ( INLSF,
     NUMRGN 
    )
    +
    + +

    Reads 2 records from land/sea tag database.

    +
    Author
    Dennis Keyser
    +
    Date
    195-01-04 Reads two records from a low resolution land/sea database and stores into common.
    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    1978-01-20 J. K. Kalinowski (S11213) Original author
    1995-01-04 Dennis Keyser Incorporated into w3miscan and
    +

    streamlined code; modified to be machine independent thru use of standard fortran direct access read

    +
    Parameters
    + + + +
    [in]INLSFUnit number of direct access nesdis land/sea file
    [in]NUMRGNThe region (1,2 or 3) of the database to be accessed (dependent on latitude band)
    +
    +
    +
    Remarks
    Called by subroutne misc04.
    +
    Author
    Dennis Keyser
    +
    Date
    195-01-04
    + +

    Definition at line 1518 of file w3miscan.f.

    + +
    +
    + +

    ◆ misc06()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine misc06 ( INGBI,
     INGBD,
    integer, dimension(5) IDAT1,
    integer, dimension(5) IDAT2 
    )
    +
    + +

    Reads in nh and sh 1-deg.

    +

    sea-sfc temps.

    Author
    Dennis Keyser
    +
    Date
    200-02-18 Reads in global sea-surface temperature field on a one-degree grid from grib file.
    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    ????-??-?? W. Gemmill (NP21) Original author
    1995-01-04 Dennis Keyser Incorporated into w3miscan and
    +

    streamlined code; converted sst input file from vsam/on84 to grib to allow code compile and run on the cray machines. 2000-02-18 | Dennis Keyser | Modified to call w3lib routine "getgb", this allows code to compile and run properly on ibm-sp

    +
    Parameters
    + + + + + +
    [in]INGBIUnit number of grib index file for grib file containing global 1-degree sea-surface temp field
    [in]INGBDUnit number of grib file containing global 1-degree sea-surface temp field
    [in]IDAT1Requested earliest year(yyyy), month, day, hour, min
    [in]IDAT2Requested latest year(yyyy), month, day, hour, min
    +
    +
    +
    Remarks
    Called by subroutine w3miscan.
    +
    Author
    Dennis Keyser
    +
    Date
    200-02-18
    + +

    Definition at line 1569 of file w3miscan.f.

    + +
    +
    + +

    ◆ misc10()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine misc10 (dimension(in) X,
    dimension(out) Y 
    )
    +
    + +

    Calc.

    +

    ssm/i prods from neural net 3 alg.

    Author
    V. Krasnopolsky
    +
    Date
    1996-07-15 This nn calculates w (in m/s), v (in mm), l (in mm), and sst (in deg c). This nn was trained on blended f11 data set (ssmi/buoy matchups plus ssmi/ows matchups 15 km x 15 min) under clear + cloudy conditions.
    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1996-07-15 V. Krasnopolsky Initial.
    +
    Parameters
    + + + +
    [in]X5-word array containing brightness temperature in the order: t19v (word 1), t19h (word 2), t22v (word 3), t37v (word 4), t37h (word 5) (all in kelvin)
    [out]Y4-word array containing calculated products in the order: wind speed (m/s) (word 1), columnar water vapor (total precip. water) (mm) (word 2), columnar liquid water (mm) (word 3), sea surface temperature (deg. c) (word 4)
    +
    +
    +
    Remarks
    Called by subroutine risc02().
    +
    Author
    V. Krasnopolsky
    +
    Date
    1996-07-15
    + +

    Definition at line 1238 of file w3miscan.f.

    + +
    +
    + +

    ◆ risc02()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    function risc02 (real, dimension(7) XT,
    real V,
    real L,
    real SST,
     JERR 
    )
    +
    + +

    Calc.

    +

    ssm/i prods from neural net 3 alg.

    Author
    V. Krasnopolsky
    +
    Date
    1997-02-02 This retrieval algorithm is a neural network implementation of the ssm/i transfer function. It retrieves the wind speed (w) at the height 20 meters, columnar water vapor (v), columnar liquid water (l) and sst. The nn was trained using back-propagation algorithm. Transfer function is described and compared with cal/val and other algorithms in omb technical note no. 137. See remarks for detailed info on this algorithm. This is an improved version of the earlier neural network 2 algorithm.
    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1997-02-02 V. Krasnopolsky Initial.
    +
    Parameters
    + + + + + + +
    [in]XT7-word array containing brightness temperature in the order: t19v (word 1), t19h (word 2), t22v (word 3), t37v (word 4), t37h (word 5), t85v (word 6), t85h (word 7) (all in kelvin)
    [in]VColumnar water vapor (total precip. water) (mm)
    [in]LColumnar liquid water (mm)
    [in]SSTSea surface temperature (deg. c)
    [in]JERRError return code:
      +
    • = 0 – Good retrievals
      • +
    • = 1 – Retrievals could not be made due to one or more brightness temperatures out of range (i.e, failed the rain flag test)
      • +
    • = 2 – Retrievals could not be made due to ice contamination {for either 1 or 2 above, all retrievals set to
      • +
    +
      +
    1. (missing)}
      2. +
    +
    +
    +
    +
    Remarks
    Function, called by subroutine misc01.
    +

    +Description of training and test data set:

    +

    The training set consists of 3460 matchups which were received from two sources:

      +
    • 1. 3187 F11/SSMI/buoy matchups were filtered out from a preliminary version of the new NRL database which was kindly provided by G. Poe (NRL). Maximum available wind speed is 24 m/s.
      • +
    • 2. 273 F11/SSMI/OWS matchups were filtered out from two datasets collected by high latitude OWS LIMA and MIKE. These data sets were kindly provided by D. Kilham (University of Bristol). Maximum available wind speed is 26.4 m/s.
      • +
    +

    Satellite data are collocated with both buoy and OWS data in space within 15 km and in time within 15 min.

    +

    The test data set has the same structure, the same number of matchups and maximum buoy wind speed.

    +

    +Description of retrieval flags:

    +

    Retrieval flags by Stogryn et al. are used. The algorithm produces retrievals under CLEAR + CLOUDY conditions, that is if:

      +
    • T37V - T37H > 50. => CLEAR condition -or-
      • +
    • T37V - T37H =< 50.|
      • +
    • T19H =< 185. and |
      • +
    • T37H =< 210. and | => CLOUDY conditions
      • +
    • T19V < T37V |
      • +
    +
    Author
    V. Krasnopolsky
    +
    Date
    1997-02-02
    + +

    Definition at line 1139 of file w3miscan.f.

    + +
    +
    + +

    ◆ risc02xx()

    + +
    +
    + + + + + + + + +
    function risc02xx (dimension(in) X)
    +
    + +

    Calc.

    +

    wspd from neural net 2 algorithm

    Author
    V. Krasnopolsky
    +
    Date
    1996-05-07 Calculates a single neural network output for wind speed. the network was trained on the whole data set without any separation into subsets. It gives rms = 1.64 m/s for training set and 1.65 m/s for testing set. This is an improved version of the earlier neural network 1 algorithm.
    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    1994-03-20 V. Krasnopolsky Initial.
    1995-05-07 V. Krasnopolsky Replaced with neural net 2 algorithm.
    +
    Parameters
    + + +
    [in]X5-Word array containing brightness temperature in the order: t19v (word 1), t22v (word 2), t37v (word 3), t37h (word 4), t85v (word 5) (all in kelvin)
    +
    +
    +
    Returns
    XX Wind speed (meters/second)
    +
    Remarks
    Function, no longer called by this program. It is here simply to save neural net 2 algorithm for possible later use (has been replaced by neural net 3 algorithm, see subr. risc02 and misc10).
    +
    Author
    V. Krasnopolsky
    +
    Date
    1996-05-07
    + +

    Definition at line 1352 of file w3miscan.f.

    + +
    +
    + +

    ◆ risc03()

    + +
    +
    + + + + + + + + +
    function risc03 (dimension(4) X)
    +
    + +

    Calc.

    +

    w.spd from b temp.- goodberlet alg.

    Author
    W. Gemmill
    +
    Date
    1994-08-15 Calculates a single goodberlet output for wind speed. This is a linear regression algorithm from 1989.
    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1994-08-15 W. Gemmill Initial.
    +
    Parameters
    + + +
    [in]X4-word array containing brightness temperature in the order: t19v (word 1), t22v (word 2), t37v (word 3), t37h (word 4) (all in kelvin)
    +
    +
    +
    Returns
    XX Wind speed (meters/second)
    +
    Remarks
    Function, called by subroutine misc01.
    +
    Author
    W. Gemmill
    +
    Date
    1994-08-15
    + +

    Definition at line 1413 of file w3miscan.f.

    + +
    +
    + +

    ◆ w3miscan()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3miscan ( INDTA,
     INLSF,
     INGBI,
     INGBD,
    logical, dimension(240:249) LSAT,
    logical LPROD,
    logical LBRIT,
    logical NNALG,
    logical GBALG,
    integer, dimension(5) KDATE,
    integer, dimension(5) LDATE,
     IGNRTM,
    integer, dimension(1737) IBUFTN,
     IBDATE,
     IER 
    )
    +
    + +

    Reads one ssm/i scan line (64 retrievals) from the NCEP bufr ssm/i dump file.

    +

    Each scan is time checked against the user-requested time window and satellite id combinations. When a valid scan is read the program returns to the calling program. the user must pass in the type of the input ssm/i dump file, either derived products (regardless of source) or brightness temperatures (7-channels). If the latter is chosen, the user has the further option of processing, in addition to the brightness temperatures, in-line calculation of wind speed product via the goodberlet algorithm, and/or in-line calculation of both wind speed and total column precipitable water (tpw) products using the neural net 3 algorithm. If the wind speed or tpw is calculated here (either algorithm), this subroutine will check for brightness temperatures outside of a preset range and will return a missing wind speed/tpw if any b. temp is unreasonable. Also, for calculated wind speeds and tpw, this program will check to see if the b. temps are over land or ice, and if they are it will also return missing values since these data are valid only over ocean.

    +

    +Program History Log:

    + + + + + + + + + + + + + + + + + + + + + + + +
    Date Programmer Comment
    1996-07-30 Dennis Keyser Original author - subroutine is a modified version of w3lib w3fi86 which read one scan line from the 30-orbit shared processing data sets
    1997-05-22 Dennis Keyser Crisis fix to account for clon now returned from bufr as -180 to 0 (west) or 0 to 180 (east), used to return as 0 to 360 east which was not the bufr standard
    1998-01-28 Dennis Keyser Replaced neural net 2 algorithm which calculated only wind speed product with neural net 3 algorithm which calculates both wind speed and total precipitable water products (among others) but, unlike nn2, does not return a rain flag value (it does set all retrievals to missing that fail rain flag and ice contamination tests)
    1998-03-30 Dennis Keyser Modified to handle neural net 3 ssm/i products input in a products bufr data dump file; now prints out number of scans processed by satellite number in final summary
    1998-10-23 Dennis Keyser Subroutine now y2k and fortran 90 compliant
    1999-02-18 Dennis Keyser Modified to compile and run properly on ibm-sp
    2000-06-08 Dennis Keyser Corrected mnemonic for rain rate to "reqv" (was "prer" for some unknown reason)
    2001-01-03 Dennis Keyser Changed units of returned rain rate from whole mm/hr to 10**6 mm/sec, changed units of returned surface temp from whole kelvin to 10**2 kelvin (to incr. precision to that orig. in input bufr file)
    2004-09-12 Dennis Keyser Now decodes sea-surface temperature if valid into same location as surface temperature, quantity is surface temperature if surface tag is not 5, otherwise quantity is sea-surface temperature (ncep products data dump file now contains sst); checks to see if old or new version of mnemonic table bufrtab.012 is being used here (old version had "ph2o" instead of "tpwt", "sndp" instead of "tosd", "wsos" instead of "wspd" and "ch2o" instead of the sequence "metfet vilwc metfet"), and decodes using whichever mnemonics are found {note: a further requirement for "vilwc" is that the first "metfet" (meteorological feature) in the sequence must be 12 (=cloud), else cloud water set to missing, regardless of "vilwc" value}
    2011-08-04 Dennis Keyser Add ibdate (input bufr message date) to output argument list (now used by calling program prepobs_prepssmi)
    +
    Parameters
    + + + + + + + + + + + + + + + + +
    [in]INDTAUnit number of ncep bufr ssm/i dump data set
    [in]INLSFUnit number of direct access nesdis land/sea file (valid only if lbrit and either nnalg or gbalg true).
    [in]INGBIUnit number of grib index file for grib file Containing global 1-degree sea-surface temp field. (valid only if lbrit and either nnalg or gbalg true).
    [in]INGBDUnit number of grib file containing global 1-degree Sea-surface temp field (valid only if lbrit and either. Nnalg or gbalg true).
    [in]LSAT10-word logical array (240:249) indicating which Satellite ids should be processed (see remarks)
    [in]LPRODLogical indicating if the input bufr file contains Products (regardless of source) - in this case one or. More available products can be processed and returned.
    [in]LBRITLogical indicating if the input bufr file contains Brightness temperatures - in this case b. temps are. Processed and returned along with, if requested, in-. Line generated products from one or both algorithms. (see next two switches).
      +
    • The following two switches apply only if lbrit is true --—
      • +
    +
    [in]NNALGIndicating if the subroutine should calculate and return ssm/i wind speed and tpw via the neural net 3 algorithm (note: b o t h wind speed and tpw are returned here)
    [in]GBALGIndicating if the subroutine should calculate and return ssm/i wind speed via the goodberlet algorithm
    [in]KDATERequested earliest year(yyyy), month, day, hour, Min for accepting scans.
    [in]LDATERequested latest year(yyyy), month, day, hour, Min for accepting scans.
    [in]IGNRTMSwitch to indicate whether scans should be time- Checked (= 0) or not time checked (=1) {if =1, all. Scans read in are processed regardless of their time.. The input arguments "kdate" and "ldate" (earliest and. Latest date for processing data) are ignored in the. Time checking for scans. (note: the earliest and. Latest dates should still be specified to the. "expected" time range, but they will not be used for. Time checking in this case)}.
    [out]IBUFTNOutput buffer holding data for a scan (1737 words - See remarks for format. some words may be missing Depending upon lprod, lbrit, nnalg and gbalg
    [out]IBDATEInput bufr message section 1 date (yyyymmddhh)
    [out]IERError return code (see remarks)
    +
    +
    +
    Remarks
    Return code ier can have the following values:
      +
    • IER = 0 Successful return of scan
      • +
    • IER = 1 All scans have been read, all done
      • +
    • IER = 2 Abnormal return - input bufr file in unit 'indta' is either empty (null) or is not bufr
      • +
    • IER = 3 Abnormal return - requested earliest and latest dates are backwards
      • +
    • IER = 4 Abnormal return - error opening random access file holding land/sea tags
      • +
    • IER = 5 Abnormal return - the number of decoded "levels" is not what is expected
      • +
    • IER = 6 Abnormal return - sea-surface temperature not found in grib index file - error returned from grib decoder getgb is 96
      • +
    • IER = 7 Abnormal return - sea-surface temperature grib message has a date that is either: 1) more than 7-days prior to the earliest requested date or 2) more than 7-days after the latest requested date
      • +
    • IER = 8 Abnormal return - byte-addressable read error for grib file containing sea-surface temperature field - error returned from grib decoder getgb is 97-99
      • +
    • IER = 9 Abnormal return - error returned from grib decoder - getgb - for sea-surface temperature field - > 0 but not 96-99
      • +
    +
    +

    Input argument lsat is set-up as follows:

      +
    • LSAT(X) = TRUE – Process scans from satellite id x (where x is code figure from bufr code table 0-01-007)
      • +
    • LSAT(X) = FALSE - Do not process scans from satellite id x
        +
      • X = 240 is f-7 dmsp satellite (this satellite is no longer available)
        • +
      • X = 241 is f-8 dmsp satellite (this satellite is no longer available)
        • +
      • X = 242 is f-9 dmsp satellite (this satellite is no longer available)
        • +
      • X = 243 is f-10 dmsp satellite (this satellite is no longer available)
        • +
      • X = 244 is f-11 dmsp satellite (this is available as of 8/96 but is not considered to be an operational dmsp ssm/i satellite)
        • +
      • X = 245 is f-12 dmsp satellite (this satellite is no longer available)
        • +
      • X = 246 is f-13 dmsp satellite (this is available and is considered to be an operational odd dmsp ssm/i satellite as of 8/1996)
        • +
      • X = 247 is f-14 dmsp satellite (this is available as of 5/97 but is not considered to be an operational dmsp ssm/i satellite)
        • +
      • X = 248 is f-15 dmsp satellite (this is available as of 2/2000 and is considered to be an operational odd dmsp ssm/i satellite as of 2/2000)
        • +
      • X = 249 is reserved for a future dmsp satellite
        • +
      +
      • +
    +
    Note
    Here "even" means value in ibuftn(1) is an odd number while "odd" means value in ibuftn(1) is an even number Contents of array 'ibuftn' holding one complete scan (64 individual retrievlas (1737 words)
    +

    +Always returned:

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    WORD CONTENTS
    1 Satellite id (244 is f-11; 246 is f-13; 247 is f-14; 248 is f-15)
    2 4-digit year for scan
    3 2-digit month of year for scan
    4 2-digit day of month for scan
    5 2-digit hour of day for scan
    6 2-digit minute of hour for scan
    7 2-digit second of minute for scan
    8 Scan number in orbit
    9 Orbit number for scan
    10 Retrieval #1 latitude (*100 degrees: + n, - s)
    11 Retrieval #1 longitude (*100 degrees east)
    12 Retrieval #1 position number
    13 Retrieval #1 surface tag (code figure)
    +

    +For LPROD = TRUE {Input products file: note all products below except sea-surface temperature are available in the fnoc "operational" products data dump; most ncep products data dumps contain only wind speed, total precipitable water, cloud water and sea-surface temperature (all over ocean only)}:

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    WORD CONTENTS
    14 Retrieval #1 cloud water (*100 kilogram/meter**2)
    15 Retrieval #1 rain rate (*1000000 millimeters/second)
    16 Retrieval #1 wind speed (*10 meters/second)
    17 Retrieval #1 soil moisture (millimeters)
    18 Retrieval #1 sea-ice concentration (per cent)
    19 Retrieval #1 sea-ice age (code figure)
    20 Retrieval #1 ice edge (code figure)
    21 Retrieval #1 total precip. water (*10 millimeters)
    22 Retrieval #1 surface temp (*100 k) if not over ocean -OR-
    22 Retrieval #1 sea-surface temp (*100 k) if over ocean
    23 Retrieval #1 snow depth (millimeters)
    24 Retrieval #1 rain flag (code figure)
    25 Retrieval #1 calculated surface type (code figure)
    +

    +For LBRIT = TRUE (Input brightness temperature file):

    + + + + + + + + + + + + + + + + + +
    WORD CONTENTS
    26 Retrieval #1 19 ghz v brightness temp (*100 deg. k)
    27 Retrieval #1 19 ghz h brightness temp (*100 deg. k)
    28 Retrieval #1 22 ghz v brightness temp (*100 deg. k)
    29 Retrieval #1 37 ghz v brightness temp (*100 deg. k)
    30 Retrieval #1 37 ghz h brightness temp (*100 deg. k)
    31 Retrieval #1 85 ghz v brightness temp (*100 deg. k)
    32 Retrieval #1 85 ghz h brightness temp (*100 deg. k)
    +

    +For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):

    + + + + + + + +
    WORD CONTENTS
    33 Retrieval #1 Neural net 3 algorithm wind speed (generated in-line) (*10 meters/second)
    34 Retrieval #1 Neural net 3 algorithm total precip. water (generated in-line) (*10 millimeters)
    +

    +For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):

    + + + + + + + + + +
    WORD CONTENTS
    35 Retrieval #1 goodberlet algorithm wind speed (generated in-line) (*10 meters/second)
    36 Retrieval #1 goodberlet algorithm rain flag (code figure)
    37-1737 Repeat 10-36 for 63 more retrievals
    +
    Note
    All missing data or data not selected by calling program are set to 99999
    +
    Author
    Dennis Keyser
    +
    Date
    1996-07-30
    + +

    Definition at line 194 of file w3miscan.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3miscan_8f.js b/ver-2.10.0/w3miscan_8f.js new file mode 100644 index 00000000..00fcdccc --- /dev/null +++ b/ver-2.10.0/w3miscan_8f.js @@ -0,0 +1,12 @@ +var w3miscan_8f = +[ + [ "misc01", "w3miscan_8f.html#afdde0d874410648935ffd0d1c5457321", null ], + [ "misc04", "w3miscan_8f.html#acde6036e077def96f8071397d2eec3f5", null ], + [ "misc05", "w3miscan_8f.html#a7ee0202db29014a39612fd133a9ca421", null ], + [ "misc06", "w3miscan_8f.html#aded626863c4df7539accbced4b6ab799", null ], + [ "misc10", "w3miscan_8f.html#adda71e84fc0a136a1b9de35eb6c02d19", null ], + [ "risc02", "w3miscan_8f.html#a6edc5e68c541091294d41f99e804a05e", null ], + [ "risc02xx", "w3miscan_8f.html#a4b77772e4547b0f74a9b1c669a839be6", null ], + [ "risc03", "w3miscan_8f.html#ac30ceca6f563c3f755520f227e068930", null ], + [ "w3miscan", "w3miscan_8f.html#af1352ee5db91f6a057c1378cf9b00df1", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3miscan_8f_source.html b/ver-2.10.0/w3miscan_8f_source.html new file mode 100644 index 00000000..6268b2ea --- /dev/null +++ b/ver-2.10.0/w3miscan_8f_source.html @@ -0,0 +1,1777 @@ + + + + + + + +NCEPLIBS-w3emc: w3miscan.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3miscan.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Reads 1 ssm/i scan line from bufr d-set
    +
    3 C> @author Dennis Keyser @date 1996-07-30
    +
    4 
    +
    5 C> Reads one ssm/i scan line (64 retrievals) from the NCEP
    +
    6 C> bufr ssm/i dump file. Each scan is time checked against the
    +
    7 C> user-requested time window and satellite id combinations. When a
    +
    8 C> valid scan is read the program returns to the calling program.
    +
    9 C> the user must pass in the type of the input ssm/i dump file,
    +
    10 C> either derived products (regardless of source) or brightness
    +
    11 C> temperatures (7-channels). If the latter is chosen, the user
    +
    12 C> has the further option of processing, in addition to the
    +
    13 C> brightness temperatures, in-line calculation of wind speed
    +
    14 C> product via the goodberlet algorithm, and/or in-line calculation
    +
    15 C> of both wind speed and total column precipitable water (tpw)
    +
    16 C> products using the neural net 3 algorithm. If the wind speed
    +
    17 C> or tpw is calculated here (either algorithm), this subroutine
    +
    18 C> will check for brightness temperatures outside of a preset range
    +
    19 C> and will return a missing wind speed/tpw if any b. temp is
    +
    20 C> unreasonable. Also, for calculated wind speeds and tpw, this
    +
    21 C> program will check to see if the b. temps are over land or ice,
    +
    22 C> and if they are it will also return missing values since these
    +
    23 C> data are valid only over ocean.
    +
    24 C>
    +
    25 C> ### Program History Log:
    +
    26 C> Date | Programmer | Comment
    +
    27 C> -----|------------|--------
    +
    28 C> 1996-07-30 | Dennis Keyser | Original author - subroutine is a modified version of w3lib w3fi86 which read one scan line from the 30-orbit shared processing data sets
    +
    29 C> 1997-05-22 | Dennis Keyser | Crisis fix to account for clon now returned from bufr as -180 to 0 (west) or 0 to 180 (east), used to return as 0 to 360 east which was not the bufr standard
    +
    30 C> 1998-01-28 | Dennis Keyser | Replaced neural net 2 algorithm which calculated only wind speed product with neural net 3 algorithm which calculates both wind speed and total precipitable water products (among others) but, unlike nn2, does not return a rain flag value (it does set all retrievals to missing that fail rain flag and ice contamination tests)
    +
    31 C> 1998-03-30 | Dennis Keyser | Modified to handle neural net 3 ssm/i products input in a products bufr data dump file; now prints out number of scans processed by satellite number in final summary
    +
    32 C> 1998-10-23 | Dennis Keyser | Subroutine now y2k and fortran 90 compliant
    +
    33 C> 1999-02-18 | Dennis Keyser | Modified to compile and run properly on ibm-sp
    +
    34 C> 2000-06-08 | Dennis Keyser | Corrected mnemonic for rain rate to "reqv" (was "prer" for some unknown reason)
    +
    35 C> 2001-01-03 | Dennis Keyser | Changed units of returned rain rate from whole mm/hr to 10**6 mm/sec, changed units of returned surface temp from whole kelvin to 10**2 kelvin (to incr. precision to that orig. in input bufr file)
    +
    36 C> 2004-09-12 | Dennis Keyser | Now decodes sea-surface temperature if valid into same location as surface temperature, quantity is surface temperature if surface tag is not 5, otherwise quantity is sea-surface temperature (ncep products data dump file now contains sst); checks to see if old or new version of mnemonic table bufrtab.012 is being used here (old version had "ph2o" instead of "tpwt", "sndp" instead of "tosd", "wsos" instead of "wspd" and "ch2o" instead of the sequence "metfet vilwc metfet"), and decodes using whichever mnemonics are found {note: a further requirement for "vilwc" is that the first "metfet" (meteorological feature) in the sequence must be 12 (=cloud), else cloud water set to missing, regardless of "vilwc" value}
    +
    37 C> 2011-08-04 | Dennis Keyser | Add ibdate (input bufr message date) to output argument list (now used by calling program prepobs_prepssmi)
    +
    38 C>
    +
    39 C> @param[in] INDTA Unit number of ncep bufr ssm/i dump data set
    +
    40 C> @param[in] INLSF Unit number of direct access nesdis land/sea file
    +
    41 C> (valid only if lbrit and either nnalg or gbalg true).
    +
    42 C> @param[in] INGBI Unit number of grib index file for grib file
    +
    43 C> Containing global 1-degree sea-surface temp field.
    +
    44 C> (valid only if lbrit and either nnalg or gbalg true).
    +
    45 C> @param[in] INGBD Unit number of grib file containing global 1-degree
    +
    46 C> Sea-surface temp field (valid only if lbrit and either.
    +
    47 C> Nnalg or gbalg true).
    +
    48 C> @param[in] LSAT 10-word logical array (240:249) indicating which
    +
    49 C> Satellite ids should be processed (see remarks)
    +
    50 C> @param[in] LPROD Logical indicating if the input bufr file contains
    +
    51 C> Products (regardless of source) - in this case one or.
    +
    52 C> More available products can be processed and returned.
    +
    53 C> @param[in] LBRIT Logical indicating if the input bufr file contains
    +
    54 C> Brightness temperatures - in this case b. temps are.
    +
    55 C> Processed and returned along with, if requested, in-.
    +
    56 C> Line generated products from one or both algorithms.
    +
    57 C> (see next two switches).
    +
    58 C> - The following two switches apply only if lbrit is true -----
    +
    59 C> @param[in] NNALG Indicating if the subroutine should
    +
    60 C> calculate and return ssm/i wind speed and tpw
    +
    61 C> via the neural net 3 algorithm (note: b o t h
    +
    62 C> wind speed and tpw are returned here)
    +
    63 C> @param[in] GBALG Indicating if the subroutine should
    +
    64 C> calculate and return ssm/i wind speed via the
    +
    65 C> goodberlet algorithm
    +
    66 C> @param[in] KDATE Requested earliest year(yyyy), month, day, hour,
    +
    67 C> Min for accepting scans.
    +
    68 C> @param[in] LDATE Requested latest year(yyyy), month, day, hour,
    +
    69 C> Min for accepting scans.
    +
    70 C> @param[in] IGNRTM Switch to indicate whether scans should be time-
    +
    71 C> Checked (= 0) or not time checked (=1) {if =1, all.
    +
    72 C> Scans read in are processed regardless of their time..
    +
    73 C> The input arguments "kdate" and "ldate" (earliest and.
    +
    74 C> Latest date for processing data) are ignored in the.
    +
    75 C> Time checking for scans. (note: the earliest and.
    +
    76 C> Latest dates should still be specified to the.
    +
    77 C> "expected" time range, but they will not be used for.
    +
    78 C> Time checking in this case)}.
    +
    79 C> @param[out] IBUFTN Output buffer holding data for a scan (1737 words -
    +
    80 C> See remarks for format. some words may be missing
    +
    81 C> Depending upon lprod, lbrit, nnalg and gbalg
    +
    82 C> @param[out] IBDATE Input bufr message section 1 date (yyyymmddhh)
    +
    83 C> @param[out] IER Error return code (see remarks)
    +
    84 C>
    +
    85 C> @remark
    +
    86 C> Return code ier can have the following values:
    +
    87 C> - IER = 0 Successful return of scan
    +
    88 C> - IER = 1 All scans have been read, all done
    +
    89 C> - IER = 2 Abnormal return - input bufr file in unit
    +
    90 C> 'indta' is either empty (null) or is not bufr
    +
    91 C> - IER = 3 Abnormal return - requested earliest and
    +
    92 C> latest dates are backwards
    +
    93 C> - IER = 4 Abnormal return - error opening random
    +
    94 C> access file holding land/sea tags
    +
    95 C> - IER = 5 Abnormal return - the number of decoded
    +
    96 C> "levels" is not what is expected
    +
    97 C> - IER = 6 Abnormal return - sea-surface temperature
    +
    98 C> not found in grib index file - error returned
    +
    99 C> from grib decoder getgb is 96
    +
    100 C> - IER = 7 Abnormal return - sea-surface temperature
    +
    101 C> grib message has a date that is either:
    +
    102 C> 1) more than 7-days prior to the earliest
    +
    103 C> requested date or 2) more than 7-days after
    +
    104 C> the latest requested date
    +
    105 C> - IER = 8 Abnormal return - byte-addressable read error
    +
    106 C> for grib file containing sea-surface
    +
    107 C> temperature field - error returned from grib
    +
    108 C> decoder getgb is 97-99
    +
    109 C> - IER = 9 Abnormal return - error returned from grib
    +
    110 C> decoder - getgb - for sea-surface
    +
    111 C> temperature field - > 0 but not 96-99
    +
    112 C>
    +
    113 C> Input argument lsat is set-up as follows:
    +
    114 C> - LSAT(X) = TRUE -- Process scans from satellite id x (where x is code figure from bufr code table 0-01-007)
    +
    115 C> - LSAT(X) = FALSE - Do not process scans from satellite id x
    +
    116 C> - X = 240 is f-7 dmsp satellite (this satellite is no longer available)
    +
    117 C> - X = 241 is f-8 dmsp satellite (this satellite is no longer available)
    +
    118 C> - X = 242 is f-9 dmsp satellite (this satellite is no longer available)
    +
    119 C> - X = 243 is f-10 dmsp satellite (this satellite is no longer available)
    +
    120 C> - X = 244 is f-11 dmsp satellite (this is available as of 8/96 but is not considered to be an operational dmsp ssm/i satellite)
    +
    121 C> - X = 245 is f-12 dmsp satellite (this satellite is no longer available)
    +
    122 C> - X = 246 is f-13 dmsp satellite (this is available and is considered to be an operational odd dmsp ssm/i satellite as of 8/1996)
    +
    123 C> - X = 247 is f-14 dmsp satellite (this is available as of 5/97 but is not considered to be an operational dmsp ssm/i satellite)
    +
    124 C> - X = 248 is f-15 dmsp satellite (this is available as of 2/2000 and is considered to be an operational odd dmsp ssm/i satellite as of 2/2000)
    +
    125 C> - X = 249 is reserved for a future dmsp satellite
    +
    126 C>
    +
    127 C> @note Here "even" means value in ibuftn(1) is an odd number while "odd" means value in ibuftn(1) is an even number
    +
    128 C> Contents of array 'ibuftn' holding one complete scan (64 individual retrievlas (1737 words)
    +
    129 C>
    +
    130 C> #### Always returned:
    +
    131 C> WORD | CONTENTS
    +
    132 C> ---- | --------
    +
    133 C> 1 | Satellite id (244 is f-11; 246 is f-13; 247 is f-14; 248 is f-15)
    +
    134 C> 2 | 4-digit year for scan
    +
    135 C> 3 | 2-digit month of year for scan
    +
    136 C> 4 | 2-digit day of month for scan
    +
    137 C> 5 | 2-digit hour of day for scan
    +
    138 C> 6 | 2-digit minute of hour for scan
    +
    139 C> 7 | 2-digit second of minute for scan
    +
    140 C> 8 | Scan number in orbit
    +
    141 C> 9 | Orbit number for scan
    +
    142 C> 10 | Retrieval #1 latitude (*100 degrees: + n, - s)
    +
    143 C> 11 | Retrieval #1 longitude (*100 degrees east)
    +
    144 C> 12 | Retrieval #1 position number
    +
    145 C> 13 | Retrieval #1 surface tag (code figure)
    +
    146 C>
    +
    147 C> #### For LPROD = TRUE {Input products file: note all products below except sea-surface temperature are available in the fnoc "operational" products data dump; most ncep products data dumps contain only wind speed, total precipitable water, cloud water and sea-surface temperature (all over ocean only)}:
    +
    148 C> WORD | CONTENTS
    +
    149 C> ---- | --------
    +
    150 C> 14 | Retrieval #1 cloud water (*100 kilogram/meter**2)
    +
    151 C> 15 | Retrieval #1 rain rate (*1000000 millimeters/second)
    +
    152 C> 16 | Retrieval #1 wind speed (*10 meters/second)
    +
    153 C> 17 | Retrieval #1 soil moisture (millimeters)
    +
    154 C> 18 | Retrieval #1 sea-ice concentration (per cent)
    +
    155 C> 19 | Retrieval #1 sea-ice age (code figure)
    +
    156 C> 20 | Retrieval #1 ice edge (code figure)
    +
    157 C> 21 | Retrieval #1 total precip. water (*10 millimeters)
    +
    158 C> 22 | Retrieval #1 surface temp (*100 k) if not over ocean -OR-
    +
    159 C> 22 | Retrieval #1 sea-surface temp (*100 k) if over ocean
    +
    160 C> 23 | Retrieval #1 snow depth (millimeters)
    +
    161 C> 24 | Retrieval #1 rain flag (code figure)
    +
    162 C> 25 | Retrieval #1 calculated surface type (code figure)
    +
    163 C>
    +
    164 C> #### For LBRIT = TRUE (Input brightness temperature file):
    +
    165 C> WORD | CONTENTS
    +
    166 C> ---- | --------
    +
    167 C> 26 | Retrieval #1 19 ghz v brightness temp (*100 deg. k)
    +
    168 C> 27 | Retrieval #1 19 ghz h brightness temp (*100 deg. k)
    +
    169 C> 28 | Retrieval #1 22 ghz v brightness temp (*100 deg. k)
    +
    170 C> 29 | Retrieval #1 37 ghz v brightness temp (*100 deg. k)
    +
    171 C> 30 | Retrieval #1 37 ghz h brightness temp (*100 deg. k)
    +
    172 C> 31 | Retrieval #1 85 ghz v brightness temp (*100 deg. k)
    +
    173 C> 32 | Retrieval #1 85 ghz h brightness temp (*100 deg. k)
    +
    174 C>
    +
    175 C> #### For LBRIT = TRUE and NNALG = TRUE (Input brightness temperature file):
    +
    176 C> WORD | CONTENTS
    +
    177 C> ---- | --------
    +
    178 C> 33 | Retrieval #1 Neural net 3 algorithm wind speed (generated in-line) (*10 meters/second)
    +
    179 C> 34 | Retrieval #1 Neural net 3 algorithm total precip. water (generated in-line) (*10 millimeters)
    +
    180 C>
    +
    181 C> #### For LBRIT = TRUE and GBALG = TRUE (Input brightness temperature file):
    +
    182 C> WORD | CONTENTS
    +
    183 C> ---- | --------
    +
    184 C> 35 | Retrieval #1 goodberlet algorithm wind speed (generated in-line) (*10 meters/second)
    +
    185 C> 36 | Retrieval #1 goodberlet algorithm rain flag (code figure)
    +
    186 C> 37-1737 | Repeat 10-36 for 63 more retrievals
    +
    187 C>
    +
    188 C> @note All missing data or data not selected by calling program are set to 99999
    +
    189 C>
    +
    190 C> @author Dennis Keyser @date 1996-07-30
    +
    191 
    +
    192  SUBROUTINE w3miscan(INDTA,INLSF,INGBI,INGBD,LSAT,LPROD,LBRIT,
    +
    193  $ NNALG,GBALG,KDATE,LDATE,IGNRTM,IBUFTN,IBDATE,IER)
    +
    194 
    +
    195  LOGICAL LPROD,LBRIT,NNALG,GBALG,LSAT(240:249)
    +
    196 
    +
    197  CHARACTER*1 CDUMMY
    +
    198  CHARACTER*2 ATXT(2)
    +
    199  CHARACTER*8 SUBSET
    +
    200  CHARACTER*20 RHDER,PROD2,BRITE
    +
    201  CHARACTER*46 SHDER,PROD1
    +
    202 
    +
    203  REAL SHDR(9),RHDR(4,64),PROD(13,64),BRIT(2,448),RINC(5),
    +
    204  $ metfet(64)
    +
    205 
    +
    206  REAL(8) SHDR_8(9),RHDR_8(4,64),PROD_8(13,64),BRIT_8(2,448),
    +
    207  $ ufbint_8(64)
    +
    208 
    +
    209  INTEGER IBUFTN(1737),KDATA(7),KDATE(5),LDATE(5),LBTER(7),
    +
    210  $ kspsat(239:249),kntsat(239:249),iflag(64),kdat(8),ldat(8),
    +
    211  $ mdat(8),icdate(5),iddate(5)
    +
    212 
    +
    213  common/misccc/sstdat(360,180)
    +
    214  common/miscee/lflag,licec
    +
    215 
    +
    216  SAVE
    +
    217 
    +
    218  DATA shder /'SAID YEAR MNTH DAYS HOUR MINU SECO SCNN ORBN '/
    +
    219  DATA rhder /'CLAT CLON POSN SFTG '/
    +
    220  DATA prod1 /'VILWC REQV WSPD SMOI ICON ICAG ICED TPWT TMSK '/
    +
    221  DATA prod2 /'TOSD RFLG SFTP SST1 '/
    +
    222  DATA brite /'CHNM TMBR '/
    +
    223  DATA atxt /'NN','GB'/
    +
    224  DATA imsg /99999/,kntscn/0/,knttim/0/,laerr/0/,
    +
    225  $ loerr/0/,lbter/7*0/,itimes/0/,nlr/0/,nir/0/,dmax/-99999./,
    +
    226  $ dmin/99999./,kspsat/11*0/,kntsat/11*0/,ilflg/0/,bmiss/10.0e10/
    +
    227 
    +
    228  IF(itimes.EQ.0) THEN
    +
    229 
    +
    230 C***********************************************************************
    +
    231 C FIRST CALL INTO SUBROUTINE DO A FEW THINGS .....
    +
    232  itimes = 1
    +
    233  lflag = 0
    +
    234  licec = 0
    +
    235  print 65, indta
    +
    236  65 FORMAT(//' ---> W3MISCAN: Y2K/F90 VERSION 08/04/2011: ',
    +
    237  $ 'PROCESSING SSM/I DATA FROM BUFR DATA SET READ FROM UNIT ',
    +
    238  $ i4/)
    +
    239  IF(lprod) print 66
    +
    240  66 FORMAT(//' ===> WILL READ FROM BUFR PRODUCTS DATA DUMP ',
    +
    241  $ 'FILE (EITHER FNOC OR NCEP) AND PROCESS ONE OR MORE SSM/I ',
    +
    242  $ 'PRODUCTS'//)
    +
    243  IF(lbrit) THEN
    +
    244  print 167
    +
    245  167 FORMAT(//' ===> WILL READ FROM BUFR BRIGHTNESS ',
    +
    246  $ 'TEMPERATURE DATA DUMP FILE AND PROCESS BRIGHTNESS ',
    +
    247  $ 'TEMPERATURES'//)
    +
    248  IF(nnalg) print 169
    +
    249  169 FORMAT(' ===> IN ADDITION, WILL PERFORM IN-LINE ',
    +
    250  $ 'CALCULATION OF NEURAL NETWORK 3 WIND SPEED AND TOTAL ',
    +
    251  $ 'PRECIPITABLE WATER AND PROCESS THESE'/)
    +
    252  IF(gbalg) print 170
    +
    253  170 FORMAT(' ===> IN ADDITION, WILL PERFORM IN-LINE ',
    +
    254  $ 'CALCULATION OF GOODBERLET WIND SPEED AND PROCESS THESE'/)
    +
    255  END IF
    +
    256  IF(ignrtm.EQ.1) print 704
    +
    257  704 FORMAT(' W3MISCAN: INPUT ARGUMENT "IGNRTM" IS SET TO 1 -- NO ',
    +
    258  $ 'TIME CHECKS WILL BE PERFORMED ON SCANS - ALL SCANS READ IN ',
    +
    259  $ 'ARE PROCESSED'/)
    +
    260 
    +
    261  print 104, kdate,ldate
    +
    262  104 FORMAT(' W3MISCAN: REQUESTED EARLIEST DATE:',i7,4i5/
    +
    263  $ ' REQUESTED LATEST DATE:',i7,4i5)
    +
    264 
    +
    265  kdat = 0
    +
    266  kdat(1:3) = kdate(1:3)
    +
    267  kdat(5:6) = kdate(4:5)
    +
    268  ldat = 0
    +
    269  ldat(1:3) = ldate(1:3)
    +
    270  ldat(5:6) = ldate(4:5)
    +
    271 
    +
    272 C DO REQUESTED EARLIEST AND LATEST DATES MAKE SENSE?
    +
    273 
    +
    274  CALL w3difdat(ldat,kdat,3,rinc)
    +
    275  IF(rinc(3).LT.0) THEN
    +
    276 C.......................................................................
    +
    277  print 103
    +
    278  103 FORMAT(' ##W3MISCAN: REQUESTED EARLIEST AND LATEST DATES ',
    +
    279  $ 'ARE BACKWARDS!! - IER = 3'/)
    +
    280  ier = 3
    +
    281  RETURN
    +
    282 C.......................................................................
    +
    283  END IF
    +
    284 
    +
    285 C DETERMINE MACHINE WORD LENGTH IN BYTES AND TYPE OF CHARACTER SET
    +
    286 C {ASCII(ICHTP=0) OR EBCDIC(ICHTP=1)}
    +
    287 
    +
    288  CALL w3fi04(iendn,ichtp,lw)
    +
    289  print 2213, lw, ichtp, iendn
    +
    290  2213 FORMAT(/' ---> W3MISCAN: CALL TO W3FI04 RETURNS: LW = ',i3,
    +
    291  $ ', ICHTP = ',i3,', IENDN = ',i3/)
    +
    292 
    +
    293  CALL datelen(10)
    +
    294 
    +
    295  CALL dumpbf(indta,icdate,iddate)
    +
    296 cppppp
    +
    297  print *,'CENTER DATE (ICDATE) = ',icdate
    +
    298  print *,'DUMP DATE (IDDATE) = ',iddate
    +
    299 cppppp
    +
    300 
    +
    301 C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE
    +
    302 C - RETURN WITH IRET = 2
    +
    303 
    +
    304  IF(icdate(1).LE.0) GO TO 998
    +
    305 
    +
    306 C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE
    +
    307 C - RETURN WITH IRET = 2
    +
    308 
    +
    309  IF(iddate(1).LE.0) GO TO 998
    +
    310  IF(icdate(1).LT.100) THEN
    +
    311 
    +
    312 C IF 2-DIGIT YEAR RETURNED IN ICDATE(1), MUST USE "WINDOWING" TECHNIQUE
    +
    313 C TO CREATE A 4-DIGIT YEAR
    +
    314 
    +
    315 C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
    +
    316 C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
    +
    317 C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)
    +
    318 
    +
    319  print *, '##W3MISCAN - THE FOLLOWING SHOULD NEVER ',
    +
    320  $ 'HAPPEN!!!!!'
    +
    321  print *, '##W3MISCAN - 2-DIGIT YEAR IN ICDATE(1) RETURNED ',
    +
    322  $ 'FROM DUMPBF (ICDATE IS: ',icdate,') - USE WINDOWING ',
    +
    323  $ 'TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
    +
    324  IF(icdate(1).GT.20) THEN
    +
    325  icdate(1) = 1900 + icdate(1)
    +
    326  ELSE
    +
    327  icdate(1) = 2000 + icdate(1)
    +
    328  ENDIF
    +
    329  print *, '##W3MISCAN - CORRECTED ICDATE(1) WITH 4-DIGIT ',
    +
    330  $ 'YEAR, ICDATE NOW IS: ',icdate
    +
    331  ENDIF
    +
    332 
    +
    333  IF(iddate(1).LT.100) THEN
    +
    334 
    +
    335 C IF 2-DIGIT YEAR RETURNED IN IDDATE(1), MUST USE "WINDOWING" TECHNIQUE
    +
    336 C TO CREATE A 4-DIGIT YEAR
    +
    337 
    +
    338 C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
    +
    339 C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
    +
    340 C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)
    +
    341 
    +
    342  print *, '##W3MISCAN - THE FOLLOWING SHOULD NEVER ',
    +
    343  $ 'HAPPEN!!!!!'
    +
    344  print *, '##W3MISCAN - 2-DIGIT YEAR IN IDDATE(1) RETURNED ',
    +
    345  $ 'FROM DUMPBF (IDDATE IS: ',iddate,') - USE WINDOWING ',
    +
    346  $ 'TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
    +
    347  IF(iddate(1).GT.20) THEN
    +
    348  iddate(1) = 1900 + iddate(1)
    +
    349  ELSE
    +
    350  iddate(1) = 2000 + iddate(1)
    +
    351  ENDIF
    +
    352  print *, '##W3MISCAN - CORRECTED IDDATE(1) WITH 4-DIGIT ',
    +
    353  $ 'YEAR, IDDATE NOW IS: ',iddate
    +
    354  END IF
    +
    355 
    +
    356 C OPEN BUFR FILE - READ IN DICTIONARY MESSAGES (TABLE A, B, D ENTRIES)
    +
    357 
    +
    358  CALL openbf(indta,'IN',indta)
    +
    359 
    +
    360  print *, ' '
    +
    361  print *, 'OPEN NCEP BUFR SSM/I DUMP FILE'
    +
    362  print *, ' '
    +
    363 
    +
    364 C Check to see if the old (pre 9/2004) version of the mnemonic
    +
    365 C table is being used here (had "PH2O" instead of "TPWT",
    +
    366 C "SNDP" instead of "TOSD", "WSOS" instead of "WSPD")
    +
    367 C ------------------------------------------------------------
    +
    368 
    +
    369  CALL status(indta,lun,idummy1,idummy2)
    +
    370  CALL nemtab(lun,'PH2O',idummy1,cdummy,iret_ph2o)
    +
    371  CALL nemtab(lun,'SNDP',idummy1,cdummy,iret_sndp)
    +
    372  CALL nemtab(lun,'WSOS',idummy1,cdummy,iret_wsos)
    +
    373  CALL nemtab(lun,'CH2O',idummy1,cdummy,iret_ch2o)
    +
    374 
    +
    375  IF(lbrit.AND.(nnalg.OR.gbalg)) THEN
    +
    376 
    +
    377 C-----------------------------------------------------------------------
    +
    378 C IF IN-LINE CALC. OF WIND SPEED FROM GOODBERLET ALG. OR
    +
    379 C IN-LINE CALCULATION OF WIND SPEED AND TPW FROM NEURAL NET 3 ALG.
    +
    380 C FIRST CALL TO THIS SUBROUTINE WILL READ IN SEA-SURFACE TEMPERATURE
    +
    381 C FIELD AS A CHECK FOR ICE LIMITS
    +
    382 C WILL ALSO OPEN DIRECT ACCESS NESDIS LAND SEA FILE
    +
    383 C-----------------------------------------------------------------------
    +
    384 
    +
    385  CALL misc06(ingbi,ingbd,kdate,ldate,*993,*994,*995,*996)
    +
    386  print 67, inlsf
    +
    387  67 FORMAT(//4x,'** W3MISCAN: OPEN R. ACCESS NESDIS LAND/SEA ',
    +
    388  $ 'FILE IN UNIT ',i2/)
    +
    389  OPEN(unit=inlsf,err=997,access='DIRECT',iostat=ierr,recl=10980)
    +
    390  END IF
    +
    391 
    +
    392 C READ THE FIRST BUFR MESSAGE IN THE BUFR FILE
    +
    393 
    +
    394  CALL readmg(indta,subset,ibdate,iret)
    +
    395 
    +
    396  print *, 'READ FIRST BUFR MESSAGE: SUBSET = ',subset,
    +
    397  $ '; IBDATE = ',ibdate,'; IRET = ',iret
    +
    398 
    +
    399  IF(iret.NE.0) GO TO 998
    +
    400 
    +
    401 C***********************************************************************
    +
    402 
    +
    403  END IF
    +
    404 
    +
    405  30 CONTINUE
    +
    406 
    +
    407 C TIME TO DECODE NEXT SUBSET (SCAN) OUT OF BUFR MESSAGE
    +
    408 
    +
    409  ibuftn = imsg
    +
    410  CALL readsb(indta,iret)
    +
    411  IF(iret.NE.0) THEN
    +
    412 
    +
    413 C ALL SUBSETS OUT OF THIS MESSAGE READ, TIME TO MOVE ON TO NEXT MESSAGE
    +
    414 
    +
    415  CALL readmg(indta,subset,ibdate,iret)
    +
    416 
    +
    417  print *, 'READ NEXT BUFR MESSAGE: SUBSET = ',subset,
    +
    418  $ '; IBDATE = ',ibdate,'; IRET = ',iret
    +
    419 
    +
    420  IF(iret.NE.0) THEN
    +
    421 c.......................................................................
    +
    422 
    +
    423 C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ
    +
    424 C - ALL FINISHED, NO OTHER SCANS W/I DESIRED TIME RANGE -- SET IER TO 1
    +
    425 C AND RETURN TO CALLING PROGRAM
    +
    426 
    +
    427  print 124, kntscn
    +
    428  124 FORMAT(/' W3MISCAN: +++++ ALL VALID SCANS UNPACKED AND ',
    +
    429  $ 'RETURNED FROM THIS NCEP BUFR SSM/I DUMP FILE'//34x,
    +
    430  $ '** W3MISCAN: SUMMARY **'//35x,'TOTAL NUMBER OF SCANS ',
    +
    431  $ 'PROCESSED AND RETURNED',11x,i7)
    +
    432  DO jj = 239,249
    +
    433  IF(kntsat(jj).GT.0) THEN
    +
    434  print 294, jj,kntsat(jj)
    +
    435  294 FORMAT(35x,'......NO. OF SCANS PROCESSED AND ',
    +
    436  $ 'RETURNED FROM SAT',i4,':',i7)
    +
    437  END IF
    +
    438  END DO
    +
    439  DO jj = 239,249
    +
    440  IF(kspsat(jj).GT.0) THEN
    +
    441  ii = jj
    +
    442  IF(jj.EQ.239) ii = 1
    +
    443  print 224, ii,kspsat(jj)
    +
    444  224 FORMAT(35x,'NO. OF SCANS SKIPPED DUE TO BEING FROM ',
    +
    445  $ 'NON-REQ SAT',i4,':',i7)
    +
    446  END IF
    +
    447  END DO
    +
    448  print 194, knttim
    +
    449  194 FORMAT(35x,'NUMBER OF SCANS SKIPPED DUE TO BEING OUTSIDE ',
    +
    450  $ 'TIME INT.:',i7)
    +
    451  print 324, laerr,loerr
    +
    452  324 FORMAT(
    +
    453  $/35x,'NUMBER OF RETRIEVALS WITH LATITUDE OUT OF RANGE: ',i7/
    +
    454  $ 35x,'NUMBER OF RETRIEVALS WITH LONGITUDE OUT OF RANGE: ',i7)
    +
    455  IF(lbrit) THEN
    +
    456  IF(nnalg.OR.gbalg) print 780, lbter,nlr,nir
    +
    457  780 FORMAT(
    +
    458  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 19 GHZ V BRIGHT. TEMP:',i7/
    +
    459  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 19 GHZ H BRIGHT. TEMP:',i7/
    +
    460  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 22 GHZ V BRIGHT. TEMP:',i7/
    +
    461  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 37 GHZ V BRIGHT. TEMP:',i7/
    +
    462  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 37 GHZ H BRIGHT. TEMP:',i7/
    +
    463  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 85 GHZ V BRIGHT. TEMP:',i7/
    +
    464  $ 35x,'NUMBER OF RETRIEVALS W/ ERROR IN 85 GHZ H BRIGHT. TEMP:',i7/
    +
    465  $ 35x,'NUMBER OF RETRIEVALS REJECTED DUE TO BEING OVER LAND: ',i7/
    +
    466  $ 35x,'NUMBER OF RETRIEVALS REJECTED DUE TO BEING OVER ICE: ',i7)
    +
    467  IF(nnalg) print 781, lflag,licec
    +
    468  781 FORMAT(
    +
    469  $ 35x,'NUMBER OF NN3 RETR. REJECTED DUE TO FAILING RAIN FLAG: ',i7/
    +
    470  $ 35x,'NUMBER OF NN3 RETR. REJECTED DUE TO ICE CONTAMINATION: ',i7)
    +
    471  IF(nnalg.OR.gbalg) print 782, dmax,dmin
    +
    472  782 FORMAT(/' ** FOR SEA-SFC TEMP AT ALL RETRIEVAL LOCATIONS: FIELD',
    +
    473  $ ' MAX =',f8.3,' DEG K, FIELD MIN =',f8.3,' DEG K'/)
    +
    474  END IF
    +
    475  ier = 1
    +
    476  RETURN
    +
    477 C.......................................................................
    +
    478  END IF
    +
    479 
    +
    480  GO TO 30
    +
    481  END IF
    +
    482 
    +
    483 C***********************************************************************
    +
    484 C COME HERE FOR BOTH PRODUCTS AND BRIGHTNESS TEMPERATURES
    +
    485 C***********************************************************************
    +
    486  shdr = bmiss
    +
    487  CALL ufbint(indta,shdr_8,09,1,nlev,shder) ; shdr = shdr_8
    +
    488  ilflg = 1
    +
    489  IF(nlev.NE.1) GO TO 999
    +
    490 
    +
    491 C STORE THE SCAN'S SATELLITE ID IN WORD 1
    +
    492 C STORE SCAN'S YEAR (YYYY), MONTH, DAY, HOUR, MIN, SEC INTO WORDS 2-7
    +
    493 C STORE THE SCAN NUMBER IN WORD 8
    +
    494 C STORE THE SCAN'S ORBIT NUMBER IN WORD 9
    +
    495 
    +
    496  ibuftn(1:9) = min(imsg,nint(shdr(1:9)))
    +
    497 
    +
    498 C CHECK TO SEE IF SCAN IS FROM REQUESTED SATELLITE ID
    +
    499 
    +
    500  IF(ibuftn(1).LT.240.OR.ibuftn(1).GT.249) THEN
    +
    501  print 523, (ibuftn(ii),ii=1,9)
    +
    502  kspsat(239) = kspsat(239) + 1
    +
    503  GO TO 30
    +
    504  END IF
    +
    505  IF(.NOT.lsat(ibuftn(1))) THEN
    +
    506 CDAK PRINT 523, (IBUFTN(II),II=1,9)
    +
    507  523 FORMAT(' ##W3MISCAN: SCAN NOT FROM REQ. SAT. ID -SAT. ID',i4,
    +
    508  $ ', SCAN TIME:',6i4,', SCAN',i6,', ORBIT',i8,'-GO TO NEXT SCAN')
    +
    509  kspsat(ibuftn(1)) = kspsat(ibuftn(1)) + 1
    +
    510  GO TO 30
    +
    511  END IF
    +
    512 
    +
    513  IF(ignrtm.EQ.0) THEN
    +
    514 
    +
    515 C TIME CHECK THIS SCAN IF USER REQUESTS SUCH
    +
    516 
    +
    517  mdat = 0
    +
    518  mdat(1:3) = ibuftn(2:4)
    +
    519  mdat(5:7) = ibuftn(5:7)
    +
    520  CALL w3difdat(kdat,mdat,4,rinc)
    +
    521  ksec = rinc(4)
    +
    522  CALL w3difdat(ldat,mdat,4,rinc)
    +
    523  lsec = rinc(4)
    +
    524  IF(ksec.GT.0.OR.lsec.LT.0) THEN
    +
    525 
    +
    526 C TIME CHECK FOR SCAN FAILED: GO ON TO NEXT SCAN
    +
    527 
    +
    528 CDAK PRINT 123, (IBUFTN(II),II=2,9)
    +
    529  123 FORMAT(' ##W3MISCAN: SCAN NOT IN REQUESTED TIME WINDOW-',
    +
    530  $ 'SCAN TIME:',6i5,' SCAN',i6,', ORBIT',i8,' - GO TO NEXT SCAN')
    +
    531  knttim = knttim + 1
    +
    532  GO TO 30
    +
    533  END IF
    +
    534  END IF
    +
    535  rhdr = bmiss
    +
    536  CALL ufbint(indta,rhdr_8,04,64,nlev,rhder) ; rhdr = rhdr_8
    +
    537  ilflg = 2
    +
    538  IF(nlev.NE.64) GO TO 999
    +
    539  iflag = 0
    +
    540  DO irt = 1,64
    +
    541 
    +
    542 C THIS ROUTINE EXPECTS LONGITUDE TO BE 0-360 E; BUFR NOW RETURNS -180-0
    +
    543 C FOR WEST AND 0-180 FOR EAST
    +
    544 
    +
    545  IF(rhdr(2,irt).LT.0.0) rhdr(2,irt) = rhdr(2,irt) + 360.
    +
    546 C-----------------------------------------------------------------------
    +
    547 C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN
    +
    548 C-----------------------------------------------------------------------
    +
    549 C STORE THE LATITUDE (*100 DEGREES; + : NORTH, - : SOUTH)
    +
    550  IF(nint(rhdr(1,irt)*100.).GE.-9000.AND.nint(rhdr(1,irt)*100.)
    +
    551  $ .LE.9000) THEN
    +
    552  ibuftn((27*irt)-17) = nint(rhdr(1,irt)*100.)
    +
    553  ELSE
    +
    554 
    +
    555 C.......................................................................
    +
    556 
    +
    557 C BAD LATITUDE
    +
    558 
    +
    559  laerr = laerr + 1
    +
    560  print 777, irt,ibuftn(8),ibuftn(9),nint(rhdr(1,irt)*100.)
    +
    561  777 FORMAT(' ##W3MISCAN: BAD LAT: RETR.',i3,', SCAN',i6,
    +
    562  $ ', ORBIT',i8,'; INPUT LAT=',i7,' - ALL DATA IN THIS ',
    +
    563  $ 'RETRIEVAL SET TO MISSING')
    +
    564  iflag(irt) = 1
    +
    565 C.......................................................................
    +
    566 
    +
    567  END IF
    +
    568 
    +
    569 C STORE THE LONGITUDE (*100 DEGREES EAST)
    +
    570 
    +
    571  IF(nint(rhdr(2,irt)*100.).GE.0.AND.nint(rhdr(2,irt)*100.).LE.
    +
    572  $ 36000) THEN
    +
    573  IF(iflag(irt).EQ.0)
    +
    574  $ ibuftn((27*irt)-16) = nint(rhdr(2,irt)*100.)
    +
    575  ELSE
    +
    576 
    +
    577 C.......................................................................
    +
    578 
    +
    579 C BAD LONGITUDE
    +
    580 
    +
    581  loerr = loerr + 1
    +
    582  print 778, irt,ibuftn(8),ibuftn(9),nint(rhdr(2,irt)*100.)
    +
    583  778 FORMAT(' ##W3MISCAN: BAD LON: RETR.',i3,', SCAN',i6,
    +
    584  $ ', ORBIT',i8,'; INPUT LON=',i7,' - ALL DATA IN THIS ',
    +
    585  $ 'RETRIEVAL SET TO MISSING')
    +
    586  iflag(irt) = 1
    +
    587 C.......................................................................
    +
    588 
    +
    589  END IF
    +
    590  IF(iflag(irt).NE.0) GO TO 110
    +
    591 
    +
    592 C STORE THE POSITION NUMBER
    +
    593 
    +
    594  ibuftn((27*irt)-15) = min(imsg,nint(rhdr(3,irt)))
    +
    595 
    +
    596 C STORE THE SURFACE TAG (0-6)
    +
    597 
    +
    598  ibuftn((27*irt)-14) = min(imsg,nint(rhdr(4,irt)))
    +
    599  110 CONTINUE
    +
    600 C-----------------------------------------------------------------------
    +
    601  END DO
    +
    602 
    +
    603  IF(lprod) THEN
    +
    604 C***********************************************************************
    +
    605 C COME HERE TO PROCESS PRODUCTS FROM INPUT SSM/I PRODUCTS FILE
    +
    606 C***********************************************************************
    +
    607 
    +
    608  prod = bmiss
    +
    609  CALL ufbint(indta,prod_8,13,64,nlev,prod1//prod2)
    +
    610  ufbint_8 = bmiss
    +
    611  IF(iret_ph2o.GT.0) THEN ! Prior to 9/2004
    +
    612  CALL ufbint(indta,ufbint_8,1,64,nlev,'PH2O')
    +
    613  prod_8(8,:) = ufbint_8(:)
    +
    614  END IF
    +
    615  ufbint_8 = bmiss
    +
    616  IF(iret_sndp.GT.0) THEN ! Prior to 9/2004
    +
    617  CALL ufbint(indta,ufbint_8,1,64,nlev,'SNDP')
    +
    618  prod_8(10,:) = ufbint_8(:)
    +
    619  END IF
    +
    620  ufbint_8 = bmiss
    +
    621  IF(iret_wsos.GT.0) THEN ! Prior to 9/2004
    +
    622  CALL ufbint(indta,ufbint_8,1,64,nlev,'WSOS')
    +
    623  prod_8(3,:) = ufbint_8(:)
    +
    624  END IF
    +
    625  ufbint_8 = bmiss
    +
    626  IF(iret_ch2o.GT.0) THEN ! Prior to 9/2004
    +
    627  CALL ufbint(indta,ufbint_8,1,64,nlev,'CH2O')
    +
    628  prod_8(1,:) = ufbint_8(:)
    +
    629  ELSE
    +
    630  CALL ufbint(indta,ufbint_8,1,64,nlev,'METFET')
    +
    631  metfet = ufbint_8
    +
    632  DO irt = 1,64
    +
    633  IF(nint(metfet(irt)).NE.12) prod_8(1,irt) = bmiss
    +
    634  END DO
    +
    635  END IF
    +
    636 
    +
    637  prod=prod_8
    +
    638  ilflg = 3
    +
    639  IF(nlev.EQ.0) THEN
    +
    640  print 797, ibuftn(8),ibuftn(9)
    +
    641  797 FORMAT(' ##W3MISCAN: PRODUCTS REQ. BUT SCAN',i6,', ORBIT',
    +
    642  $ i8,' DOES NOT CONTAIN PRODUCT DATA - CONTINUE PROCESSING ',
    +
    643  $ 'SCAN (B.TEMPS REQ.?)')
    +
    644  GO TO 900
    +
    645  ELSE IF(nlev.NE.64) THEN
    +
    646  GO TO 999
    +
    647  END IF
    +
    648  DO irt = 1,64
    +
    649 C-----------------------------------------------------------------------
    +
    650 C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN
    +
    651 C-----------------------------------------------------------------------
    +
    652  IF(iflag(irt).NE.0) GO TO 111
    +
    653 
    +
    654 C STORE THE CLOUD WATER (*100 KG/M**2) IF AVAILABLE
    +
    655 
    +
    656  IF(nint(prod(01,irt)).LT.imsg)
    +
    657  $ ibuftn((27*irt)-13) = nint(prod(01,irt)*100.)
    +
    658 
    +
    659 C STORE THE RAIN RATE (*1000000 KG/((M**2)*SEC)) IF AVAILABLE
    +
    660 C (THIS IS ALSO RAIN RATE (*1000000 MM/SEC))
    +
    661 
    +
    662  IF(nint(prod(02,irt)).LT.imsg)
    +
    663  $ ibuftn((27*irt)-12) = nint(prod(02,irt)*1000000.)
    +
    664 
    +
    665 C STORE THE WIND SPEED (*10 M/SEC) IF AVAILABLE
    +
    666 
    +
    667  ibuftn((27*irt)-11) = min(imsg,nint(prod(03,irt)*10.))
    +
    668 
    +
    669 C STORE THE SOIL MOISTURE (MM) IF AVAILABLE
    +
    670 
    +
    671  IF(nint(prod(04,irt)).LT.imsg)
    +
    672  $ ibuftn((27*irt)-10) = nint(prod(04,irt)*1000.)
    +
    673 
    +
    674 C STORE THE SEA ICE CONCENTRATION (PERCENT) IF AVAILABLE
    +
    675 
    +
    676  ibuftn((27*irt)-09) = min(imsg,nint(prod(05,irt)))
    +
    677 
    +
    678 C STORE THE SEA ICE AGE (0,1) IF AVAILABLE
    +
    679 
    +
    680  ibuftn((27*irt)-08) = min(imsg,nint(prod(06,irt)))
    +
    681 
    +
    682 C STORE THE ICE EDGE (0,1) IF AVAILABLE
    +
    683 
    +
    684  ibuftn((27*irt)-07) = min(imsg,nint(prod(07,irt)))
    +
    685 
    +
    686 C STORE THE WATER VAPOR (*10 KG/M**2) IF AVAILABLE
    +
    687 C (THIS IS ALSO TOTAL PRECIPITABLE WATER SCALED AS *10 MM)
    +
    688 
    +
    689  ibuftn((27*irt)-06) = min(imsg,nint(prod(08,irt)*10.))
    +
    690 
    +
    691  IF(ibuftn((27*irt)-14).NE.5) THEN
    +
    692 
    +
    693 C STORE THE SURFACE TEMPERATURE (*100 DEGREES KELVIN) IF AVAILABLE
    +
    694 C (NOTE: SURFACE TAG MUST NOT BE 5)
    +
    695 
    +
    696  ibuftn((27*irt)-05) = min(imsg,nint(prod(09,irt)*100.))
    +
    697 
    +
    698  ELSE
    +
    699 
    +
    700 C STORE THE SEA-SURFACE TEMPERATURE (*100 DEGREES KELVIN) IF AVAILABLE
    +
    701 C (NOTE: SURFACE TAG MUST BE 5)
    +
    702 
    +
    703  ibuftn((27*irt)-05) = min(imsg,nint(prod(13,irt)*100.))
    +
    704 
    +
    705  END IF
    +
    706 
    +
    707 C STORE THE SNOW DEPTH (MM) IF AVAILABLE
    +
    708 
    +
    709  IF(nint(prod(10,irt)).LT.imsg)
    +
    710  $ ibuftn((27*irt)-04) = nint(prod(10,irt)*1000.)
    +
    711 
    +
    712 C STORE THE RAIN FLAG (0-3) IF AVAILABLE
    +
    713 
    +
    714  ibuftn((27*irt)-03) = min(imsg,nint(prod(11,irt)))
    +
    715 
    +
    716 C STORE THE CALCULATED SURFACE TYPE (1-20) IF AVAILABLE
    +
    717 
    +
    718  ibuftn((27*irt)-02) = min(imsg,nint(prod(12,irt)))
    +
    719  111 CONTINUE
    +
    720 C-----------------------------------------------------------------------
    +
    721  END DO
    +
    722  END IF
    +
    723  900 CONTINUE
    +
    724 
    +
    725  IF(lbrit) THEN
    +
    726 C***********************************************************************
    +
    727 C COME HERE TO PROCESS BRIGHTNESS TEMPERATURES FROM INPUT SSM/I
    +
    728 C BRIGHTNESS TEMPERATURE FILE
    +
    729 C AND POSSIBLY FOR IN-LINE CALC. OF WIND SPEED VIA GOODBERLET ALG.
    +
    730 C AND POSSIBLY FOR IN-LINE CALC. OF WIND SPEED AND TPW VIA N. NET 3 ALG.
    +
    731 C***********************************************************************
    +
    732 
    +
    733  brit = bmiss
    +
    734  CALL ufbrep(indta,brit_8,2,448,nlev,brite) ; brit = brit_8
    +
    735  ilflg = 4
    +
    736  IF(nlev.EQ.0) THEN
    +
    737  print 798, ibuftn(8),ibuftn(9)
    +
    738  798 FORMAT(' ##W3MISCAN: B. TEMPS REQ. BUT SCAN',i6,', ORBIT',
    +
    739  $ i8,' DOES NOT CONTAIN B. TEMP DATA - DONE PROCESSING THIS',
    +
    740  $ ' SCAN')
    +
    741  GO TO 901
    +
    742  ELSE IF(nlev.NE.448) THEN
    +
    743  GO TO 999
    +
    744  END IF
    +
    745  DO irt = 1,64
    +
    746 C-----------------------------------------------------------------------
    +
    747 C LOOP THROUGH THE 64 RETRIEVALS IN A SCAN
    +
    748 C-----------------------------------------------------------------------
    +
    749  IF(iflag(irt).NE.0) GO TO 112
    +
    750 
    +
    751 C STORE THE 7 BRIGHTNESS TEMPS (*100 DEGREES KELVIN)
    +
    752 C -- CHANNELS ARE IN THIS ORDER FOR A PARTICULAR RETRIEVAL:
    +
    753 C 19 GHZ V, 19 GHZ H, 22 GHZ V, 37 GHZ V, 37 GHZ H, 85 GHZ V, 85 GHZ H
    +
    754 
    +
    755  igood = 0
    +
    756  mindx = (irt * 7) - 6
    +
    757  DO lch = mindx,mindx+6
    +
    758  ichnn = nint(brit(1,lch))
    +
    759  IF(ichnn.GT.7) GO TO 79
    +
    760  IF(nint(brit(2,lch)).LT.imsg) THEN
    +
    761  ibuftn((27*irt)-02+ichnn) = nint(brit(2,lch)*100.)
    +
    762  igood = 1
    +
    763  END IF
    +
    764  79 CONTINUE
    +
    765  END DO
    +
    766 
    +
    767  IF(nnalg.OR.gbalg) THEN
    +
    768  kdata = imsg
    +
    769  IF(igood.EQ.1) THEN
    +
    770 C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    771 C COME HERE FOR IN-LINE CALC. OF WIND SPEED VIA GOODBERLET ALG. AND/OR
    +
    772 C FOR IN-LINE CALC. OF WIND SPEED AND TPW VIA NEURAL NET 3 ALG.
    +
    773 C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    774 
    +
    775 C GET LAND/SEA TAG AND CHECK FOR LAT/LON OVER LAND OR ICE
    +
    776 
    +
    777  balon=real(mod(ibuftn((27*irt)-16)+18000,36000)-18000)/100.
    +
    778  ialon = mod(36000-ibuftn((27*irt)-16),36000)
    +
    779  ix = 361. - real(ialon)/100.
    +
    780  jy = 91 - nint(real(ibuftn((27*irt)-17))/100. + 0.50)
    +
    781  dmin = min(dmin,sstdat(ix,jy))
    +
    782  dmax = max(dmax,sstdat(ix,jy))
    +
    783  CALL misc04(inlsf,real(ibuftn((27*irt)-17))/100.,balon,lstag)
    +
    784 
    +
    785 C ..... REJECT IF OVER LAND (USE LAND/SEA TAG HERE)
    +
    786 
    +
    787  IF(lstag.NE.0) THEN
    +
    788  nlr = nlr + 1
    +
    789  GO TO 112
    +
    790  END IF
    +
    791 
    +
    792 C ..... REJECT IF OVER ICE (USE SEA-SURFACE TEMPERATURE HERE)
    +
    793 
    +
    794  IF(sstdat(ix,jy).LE.272.96) THEN
    +
    795  nir = nir + 1
    +
    796  GO TO 112
    +
    797  END IF
    +
    798 
    +
    799  kdata = ibuftn((27*irt)-01:(27*irt)+05)
    +
    800  DO it = 1,7
    +
    801  IF((it.NE.2.AND.kdata(it).LT.10000).OR.
    +
    802  $ (it.EQ.2.AND.kdata(it).LT. 8000)) THEN
    +
    803  lbter(it) = lbter(it) + 1
    +
    804  print 779,it,ibuftn(8),ibuftn(9),kdata
    +
    805  779 FORMAT(' ##W3MISCAN: BT, CHN',i2,' BAD: SCAN',i6,', ORBIT',i8,
    +
    806  $ '; BT:',7i6,'-CANNOT CALC. PRODS VIA ALG.')
    +
    807  GO TO 112
    +
    808  END IF
    +
    809  END DO
    +
    810 
    +
    811 C CALL SUBR. MISC01 TO INITIATE IN-LINE PRODUCT CALCULATION
    +
    812 
    +
    813  CALL misc01(nnalg,gbalg,kdata,swnn,tpwnn,swgb,nrfgb)
    +
    814 
    +
    815  IF(nnalg) THEN
    +
    816 CDAK IF(MOD(KNTSCN,100).EQ.0) PRINT 6021, ATXT(1),SWNN,
    +
    817 CDAK $ TPWNN,REAL(KDATA(1))/100.,(REAL(KDATA(KKK))/100.,
    +
    818 CDAK $ KKK=3,5),(REAL(KDATA(4)-KDATA(5)))/100.
    +
    819  6021 FORMAT(' W3MISCAN: ',a2,' SPD',f6.1,' TPW',f6.1,' TB19V',f6.1,
    +
    820  $ ' TB22V',f6.1,' TB37V',f6.1,' TB37H',f6.1,' TD37',f5.1)
    +
    821 
    +
    822 C STORE THE CALCULATED NEURAL NET 3 WIND SPEED (*10 M/SEC)
    +
    823 
    +
    824  ibuftn((27*irt)+6) = min(imsg,nint(swnn*10.))
    +
    825 
    +
    826 C STORE THE CALCULATED NEURAL NET 3 TPW (*10 MILLIMETERS)
    +
    827 
    +
    828  ibuftn((27*irt)+7) = min(imsg,nint(tpwnn*10.))
    +
    829  END IF
    +
    830 
    +
    831  IF(gbalg) THEN
    +
    832 CDAK IF(MOD(KNTSCN,100).EQ.0) PRINT 602, ATXT(2),NRFGB,
    +
    833 CDAK $ SWGB,REAL(KDATA(1))/100.,(REAL(KDATA(KKK))/100.,
    +
    834 CDAK $ KKK=3,5),(REAL(KDATA(4)-KDATA(5)))/100.
    +
    835  602 FORMAT(' W3MISCAN: ',a2,' RF, SPD',i2,f6.1,' TB19V',f6.1,
    +
    836  $ ' TB22V',f6.1,' TB37V',f6.1,' TB37H',f6.1,' TD37',f5.1)
    +
    837 
    +
    838 C STORE THE CALCULATED GOODBERLET WIND SPEED (*10 M/SEC)
    +
    839 
    +
    840  ibuftn((27*irt)+8) = min(imsg,nint(swgb*10.))
    +
    841 
    +
    842 C STORE THE GOODBERLET RAIN FLAG (0-3)
    +
    843 
    +
    844  ibuftn((27*irt)+9) = min(imsg,nrfgb)
    +
    845  END IF
    +
    846 
    +
    847 C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    848  ELSE
    +
    849 
    +
    850 C......................................................................
    +
    851 
    +
    852 C PROBLEM - CAN'T CALCULATE PRODUCTS VIA ANY ALG., ALL B.TEMPS MISSING
    +
    853 
    +
    854  print 879, ibuftn(8),ibuftn(9),kdata
    +
    855  879 FORMAT(' ##W3MISCAN: ALL B.TMPS MSSNG: SCAN',i6,', ',
    +
    856  $ 'ORBIT',i8,'; BT:',7i6,'-CANNOT CALC PRODS VIA ALG.')
    +
    857 C......................................................................
    +
    858 
    +
    859  END IF
    +
    860  END IF
    +
    861 
    +
    862  112 CONTINUE
    +
    863 C-----------------------------------------------------------------------
    +
    864  END DO
    +
    865  END IF
    +
    866 C***********************************************************************
    +
    867  901 CONTINUE
    +
    868 
    +
    869 C RETURN TO CALLING PROGRAM - IER = 0 SCAN SUCCESSFULLY READ
    +
    870 
    +
    871  kntscn = kntscn + 1
    +
    872  kntsat(ibuftn(1)) = kntsat(ibuftn(1)) + 1
    +
    873  ier = 0
    +
    874  RETURN
    +
    875 
    +
    876 C.......................................................................
    +
    877  993 CONTINUE
    +
    878 
    +
    879 C PROBLEM: SEA-SURFACE TEMPERATURE NOT FOUND IN GRIB INDEX FILE - ERROR
    +
    880 C RETURNED FROM GRIB DECODER GETGB IS 96 - SET IER = 6 & RETURN
    +
    881 
    +
    882  print 2008, ingbi
    +
    883  2008 FORMAT(/' ##W3MISCAN: SEA-SURFACE TEMPERATURE NOT FOUND IN GRIB ',
    +
    884  $ 'INDEX FILE IN UNIT ',i2,' - IER = 6'/)
    +
    885  ier = 6
    +
    886  RETURN
    +
    887 
    +
    888 C.......................................................................
    +
    889  994 CONTINUE
    +
    890 
    +
    891 C PROBLEM: SEA-SURFACE TEMPERATURE GRIB MESSAGE HAS A DATE THAT IS
    +
    892 C EITHER: 1) MORE THAN 7-DAYS PRIOR TO THE EARLIEST REQ. DATE
    +
    893 C (INPUT ARG. "KDATE") OR 2) MORE THAN 7-DAYS AFTER THE LATEST
    +
    894 C REQ. DATE (INPUT ARG. "LDATE") - SET IER = 7 AND RETURN
    +
    895 
    +
    896  print 2009
    +
    897  2009 FORMAT(' SST GRIB MSG HAS DATE WHICH IS EITHER 7-DAYS',
    +
    898  $ ' PRIOR TO EARLIEST REQ. DATE'/14x,'OR 7-DAYS LATER THAN LATEST',
    +
    899  $ ' REQ. DATE - IER = 7'/)
    +
    900  ier = 7
    +
    901  RETURN
    +
    902 
    +
    903 C.......................................................................
    +
    904  995 CONTINUE
    +
    905 
    +
    906 C PROBLEM: BYTE-ADDRESSABLE READ ERROR FOR GRIB FILE CONTAINING SEA-
    +
    907 C SURFACE TEMPERATURE FIELD - ERROR RETURNED FROM GRIB DECODER
    +
    908 C GETGB IS 97-99 - SET IER = 8 AND RETURN
    +
    909 
    +
    910  print 2010
    +
    911  2010 FORMAT(' BYTE-ADDRESSABLE READ ERROR FOR GRIB FILE ',
    +
    912  $ 'CONTAINING SEA-SURFACE TEMPERATURE FIELD - IER = 8'/)
    +
    913  ier = 8
    +
    914  RETURN
    +
    915 
    +
    916 C.......................................................................
    +
    917  996 CONTINUE
    +
    918 
    +
    919 C PROBLEM: ERROR RETURNED FROM GRIB DECODER - GETGB - FOR SEA-SURFACE
    +
    920 C TEMPERATURE FIELD - > 0 BUT NOT 96-99 - SET IER = 9 & RETURN
    +
    921 
    +
    922  print 2011
    +
    923  2011 FORMAT(' - IER = 9'/)
    +
    924  ier = 9
    +
    925  RETURN
    +
    926 
    +
    927 C.......................................................................
    +
    928  997 CONTINUE
    +
    929 
    +
    930 C PROBLEM: ERROR OPENING R. ACCESS FILE HOLDING LAND/SEA TAGS - SET IER
    +
    931 C = 4 AND RETURN
    +
    932 
    +
    933  print 2012, ierr,inlsf
    +
    934  2012 FORMAT(/' ##W3MISCAN: ERROR OPENING R. ACCESS LAND/SEA FILE IN ',
    +
    935  $ 'UNIT ',i2,' -- IOSTAT =',i5,' -- NO SCANS PROCESSED - IER = 4'/)
    +
    936  ier = 4
    +
    937  RETURN
    +
    938 
    +
    939 C.......................................................................
    +
    940  998 CONTINUE
    +
    941 
    +
    942 C PROBLEM: THE INPUT DATA SET IS EITHER EMPTY (NULL), NOT BUFR, OR
    +
    943 C CONTAINS NO DATA MESSAGES - SET IER = 2 AND RETURN
    +
    944 
    +
    945  print 14, indta
    +
    946  14 FORMAT(/' ##W3MISCAN: SSM-I DATA SET IN UNIT',i3,' IS EITHER ',
    +
    947  $'EMPTY (NULL), NOT BUFR, OR CONTAINS NO DATA MESSAGES - IER = 2'/)
    +
    948  ier = 2
    +
    949  RETURN
    +
    950 
    +
    951 C.......................................................................
    +
    952  999 CONTINUE
    +
    953 
    +
    954 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED - SET
    +
    955 C IER = 5 AND RETURN
    +
    956 
    +
    957  print 217, nlev,ilflg
    +
    958  217 FORMAT(/' ##W3MISCAN: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
    +
    959  $ 'IS NOT WHAT IS EXPECTED (ILFLG=',i1,') - IER = 5'/)
    +
    960  ier = 5
    +
    961  RETURN
    +
    962 
    +
    963 C.......................................................................
    +
    964  END
    +
    965 C> @brief Prepares for in-line caluclation of prods.
    +
    966 C> @author Dennis Keyser @date 1995-01-04
    +
    967 
    +
    968 C> Based on input 7-channel ssm/i brightness temperatures,
    +
    969 C> determines the rain flag category for wind speed product for the
    +
    970 C> goodberlet algorithm. Then calls the appropriate function to
    +
    971 C> calculate either the wind speed product for the goodberlet
    +
    972 C> algorithm (if requested) or the wind speed and tpw products for
    +
    973 C> the neural net 3 algorithm (if requested).
    +
    974 C>
    +
    975 C> ### Program History Log:
    +
    976 C> Date | Programmer | Comment
    +
    977 C> -----|------------|--------
    +
    978 C> ????-??-?? | W. Gemmill | (w/nmc21) -- original author
    +
    979 C> 1995-01-04 | Dennis Keyser | -- incorporated into w3miscan and
    +
    980 C> streamlined code
    +
    981 C> 1996-05-07 | Dennis Keyser | (np22) -- in-line neural network 1 algoritm
    +
    982 C> replaced by neural network 2 algorithm
    +
    983 C> 1996-07-30 | Dennis Keyser | (np22) -- can now process wind speed from
    +
    984 C> both algorithms if desired
    +
    985 C> 1998-01-28 | Dennis Keyser | (np22) -- replaced neural net 2 algorithm
    +
    986 C> which calculated only wind speed product with neural net 3
    +
    987 C> algorithm which calculates both wind speed and total
    +
    988 C> precipitable water products (among others) but, unlike nn2,
    +
    989 C> does not return a rain flag value (it does set all retrievals
    +
    990 C> to missing that fail rain flag and ice contamination tests)
    +
    991 C>
    +
    992 C> @param[in] NNALG Process wind speed and tpw via neural net 3 algorithm if true
    +
    993 C> @param[in] GBALG Process wind speed via goodberlet algorithm if true
    +
    994 C> @param[in] KDATA 7-word array containing 7 channels of brightness temperature (kelvin x 100)
    +
    995 C> @param[out] SWNN alculated wind speed based on neural net 3 algorithm (meters/second)
    +
    996 C> @param[out] TPWNN Calculated total column precipitable water based on neural net 3 algorithm (millimeters)
    +
    997 C> @param[out] SWGB Calculated wind speed based on goodberlet algorith (meters/second)
    +
    998 C> @param[out] NRFGB Rain flag category for calculated wind speed from goodberlet algorithm
    +
    999 C>
    +
    1000 C> @remark If an algorithm is not chosen, the output products are set
    +
    1001 C> to values of 99999. for that algorithm and, for the goodberlet
    +
    1002 C> algorithm only, the rain flag is set to 99999. Called by
    +
    1003 C> subroutine w3miscan().
    +
    1004 C>
    +
    1005 C> @author Dennis Keyser @date 1995-01-04
    +
    1006  SUBROUTINE misc01(NNALG,GBALG,KDATA,SWNN,TPWNN,SWGB,NRFGB)
    +
    1007  LOGICAL NNALG,GBALG
    +
    1008  REAL BTA(4),BTAA(7)
    +
    1009  INTEGER KDATA(7)
    +
    1010 
    +
    1011  common/miscee/lflag,licec
    +
    1012 
    +
    1013  SAVE
    +
    1014 
    +
    1015  swnn = 99999.
    +
    1016  tpwnn = 99999.
    +
    1017  swgb = 99999.
    +
    1018  nrfgb = 99999
    +
    1019 
    +
    1020  tb19v = real(kdata(1))/100.
    +
    1021  tb19h = real(kdata(2))/100.
    +
    1022  tb22v = real(kdata(3))/100.
    +
    1023  tb37v = real(kdata(4))/100.
    +
    1024  tb37h = real(kdata(5))/100.
    +
    1025  tb85v = real(kdata(6))/100.
    +
    1026  tb85h = real(kdata(7))/100.
    +
    1027  td37 = tb37v - tb37h
    +
    1028 
    +
    1029  IF(nnalg) THEN
    +
    1030 C COMPUTE WIND SPEED FROM NEURAL NET 2 ALGORITHM (1995)
    +
    1031 C (no longer a possibility - subr. expects dim. of 5 on BTAA)
    +
    1032 cdak NRFNN = 1
    +
    1033 cdak IF(TB19H.LE.185.0.AND.TB37H.LE.210.0.AND.TB19V.LT.TB37V)
    +
    1034 cdak $ NRFNN = 0
    +
    1035 cdak BTAA(1) = TB19V
    +
    1036 cdak BTAA(2) = TB22V
    +
    1037 cdak BTAA(3) = TB37V
    +
    1038 cdak BTAA(4) = TB37H
    +
    1039 cdak BTAA(5) = TB85V
    +
    1040 cdak SWNN = RISC02xx(BTAA)
    +
    1041 
    +
    1042 C COMPUTE WIND SPEED AND TPW FROM NEURAL NET 3 ALGORITHM (1997)
    +
    1043  btaa(1) = tb19v
    +
    1044  btaa(2) = tb19h
    +
    1045  btaa(3) = tb22v
    +
    1046  btaa(4) = tb37v
    +
    1047  btaa(5) = tb37h
    +
    1048  btaa(6) = tb85v
    +
    1049  btaa(7) = tb85h
    +
    1050  swnn = risc02(btaa,tpwnn,lqwnn,sstnn,jerr)
    +
    1051  IF(jerr.EQ.1) lflag = lflag + 1
    +
    1052  IF(jerr.EQ.2) licec = licec + 1
    +
    1053  END IF
    +
    1054 
    +
    1055  IF(gbalg) THEN
    +
    1056 C COMPUTE WIND SPEED FROM GOODBERLET ALGORITHM
    +
    1057  nrfgb = 0
    +
    1058  IF(td37.LE.50.0.OR.tb19h.GE.165.0) THEN
    +
    1059  IF(td37.LE.50.0.OR.tb19h.GE.165.0) nrfgb = 1
    +
    1060  IF(td37.LE.37.0) nrfgb = 2
    +
    1061  IF(td37.LE.30.0) nrfgb = 3
    +
    1062  END IF
    +
    1063  bta(1) = tb19v
    +
    1064  bta(2) = tb22v
    +
    1065  bta(3) = tb37v
    +
    1066  bta(4) = tb37h
    +
    1067  swgb = risc03(bta)
    +
    1068  END IF
    +
    1069 
    +
    1070  RETURN
    +
    1071  END
    +
    1072 C> @brief Calc. ssm/i prods from neural net 3 alg.
    +
    1073 C> @author V. Krasnopolsky @date 1997-02-02
    +
    1074 
    +
    1075 C> This retrieval algorithm is a neural network implementation
    +
    1076 C> of the ssm/i transfer function. It retrieves the wind speed (w)
    +
    1077 C> at the height 20 meters, columnar water vapor (v), columnar liquid
    +
    1078 C> water (l) and sst. The nn was trained using back-propagation
    +
    1079 C> algorithm. Transfer function is described and compared with
    +
    1080 C> cal/val and other algorithms in omb technical note no. 137. See
    +
    1081 C> remarks for detailed info on this algorithm. This is an improved
    +
    1082 C> version of the earlier neural network 2 algorithm.
    +
    1083 C>
    +
    1084 C> ### Program History Log:
    +
    1085 C> Date | Programmer | Comment
    +
    1086 C> -----|------------|--------
    +
    1087 C> 1997-02-02 | V. Krasnopolsky | Initial.
    +
    1088 C>
    +
    1089 C> @param[in] XT 7-word array containing brightness temperature in the order:
    +
    1090 C> t19v (word 1), t19h (word 2), t22v (word 3), t37v (word 4), t37h (word 5),
    +
    1091 C> t85v (word 6), t85h (word 7) (all in kelvin)
    +
    1092 C> @param[in] V Columnar water vapor (total precip. water) (mm)
    +
    1093 C> @param[in] L Columnar liquid water (mm)
    +
    1094 C> @param[in] SST Sea surface temperature (deg. c)
    +
    1095 C> @param[in] JERR Error return code:
    +
    1096 C> - = 0 -- Good retrievals
    +
    1097 C> - = 1 -- Retrievals could not be made due to one or
    +
    1098 C> more brightness temperatures out of range
    +
    1099 C> (i.e, failed the rain flag test)
    +
    1100 C> - = 2 -- Retrievals could not be made due to ice
    +
    1101 C> contamination
    +
    1102 C> {for either 1 or 2 above, all retrievals set to
    +
    1103 C> 99999. (missing)}
    +
    1104 C>
    +
    1105 C> @remark Function, called by subroutine misc01.
    +
    1106 C> Description of training and test data set:
    +
    1107 C> ------------------------------------------
    +
    1108 C> The training set consists of 3460 matchups which were received
    +
    1109 C> from two sources:
    +
    1110 C> - 1. 3187 F11/SSMI/buoy matchups were filtered out from a
    +
    1111 C> preliminary version of the new NRL database which was
    +
    1112 C> kindly provided by G. Poe (NRL). Maximum available wind
    +
    1113 C> speed is 24 m/s.
    +
    1114 C> - 2. 273 F11/SSMI/OWS matchups were filtered out from two
    +
    1115 C> datasets collected by high latitude OWS LIMA and MIKE.
    +
    1116 C> These data sets were kindly provided by D. Kilham
    +
    1117 C> (University of Bristol). Maximum available wind speed
    +
    1118 C> is 26.4 m/s.
    +
    1119 C>
    +
    1120 C> Satellite data are collocated with both buoy and OWS data in
    +
    1121 C> space within 15 km and in time within 15 min.
    +
    1122 C>
    +
    1123 C> The test data set has the same structure, the same number of
    +
    1124 C> matchups and maximum buoy wind speed.
    +
    1125 C>
    +
    1126 C> Description of retrieval flags:
    +
    1127 C> -------------------------------
    +
    1128 C> Retrieval flags by Stogryn et al. are used. The algorithm
    +
    1129 C> produces retrievals under CLEAR + CLOUDY conditions, that is
    +
    1130 C> if:
    +
    1131 C> - T37V - T37H > 50. => CLEAR condition -or-
    +
    1132 C> - T37V - T37H =< 50.|
    +
    1133 C> - T19H =< 185. and |
    +
    1134 C> - T37H =< 210. and | => CLOUDY conditions
    +
    1135 C> - T19V < T37V |
    +
    1136 C>
    +
    1137 C> @author V. Krasnopolsky @date 1997-02-02
    +
    1138  FUNCTION risc02(XT,V,L,SST,JERR)
    +
    1139  parameter(iout =4)
    +
    1140  LOGICAL lq1,lq2,lq3,lq4
    +
    1141  REAL xt(7),y(iout),v,l,sst
    +
    1142  equivalence(y(1),spn)
    +
    1143 
    +
    1144  jerr = 0
    +
    1145 
    +
    1146 C -------- Retrieval flag (Stogryn) -------------------------
    +
    1147 
    +
    1148 C T19H =< 185
    +
    1149 
    +
    1150  lq1 = (xt(2).LE.185.)
    +
    1151 
    +
    1152 C T37H =< 210
    +
    1153 
    +
    1154  lq2 = (xt(5).LE.210.)
    +
    1155 
    +
    1156 C T19V < T37V
    +
    1157 
    +
    1158  lq3 = (xt(1).LT.xt(4))
    +
    1159 
    +
    1160 C T37V - T37H =< 50.
    +
    1161 
    +
    1162  lq4 = ((xt(4) - xt(5)).LE.50.)
    +
    1163  lq1 = (lq1.AND.lq2.AND.lq3)
    +
    1164  IF(.NOT.lq1.AND.lq4) THEN
    +
    1165  spn = 99999.
    +
    1166  v = 99999.
    +
    1167  l = 99999.
    +
    1168  sst = 99999.
    +
    1169  jerr = 1
    +
    1170  GO TO 111
    +
    1171  END IF
    +
    1172 
    +
    1173 C --------------- Call NN ----------------------
    +
    1174 
    +
    1175 C NN WIND SPEED
    +
    1176 
    +
    1177  CALL misc10(xt,y)
    +
    1178  v = y(2)
    +
    1179  l = y(3)
    +
    1180  sst = y(4)
    +
    1181 
    +
    1182 C --------- Remove negative values ----------------------------
    +
    1183 
    +
    1184  IF(spn.LT.0.0) spn = 0.0
    +
    1185  IF(sst.LT.0.0) sst = 0.0
    +
    1186  IF(v .LT.0.0) v = 0.0
    +
    1187 
    +
    1188 C ------ Remove ice contamination ------------------------------------
    +
    1189 
    +
    1190  ice = 0
    +
    1191  si85 = -174.4 + (0.715 * xt(1)) + (2.439 * xt(3)) - (0.00504 *
    +
    1192  $ xt(3) * xt(3)) - xt(6)
    +
    1193  tt = 44. + (0.85 * xt(1))
    +
    1194  IF(si85.GE.10.) THEN
    +
    1195  IF(xt(3).LE.tt) ice = 1
    +
    1196  IF((xt(3).GT.264.).AND.((xt(3)-xt(1)).LT.2.)) ice = 1
    +
    1197  END IF
    +
    1198  IF(ice.EQ.1) THEN
    +
    1199  spn = 99999.
    +
    1200  v = 99999.
    +
    1201  l = 99999.
    +
    1202  sst = 99999.
    +
    1203  jerr = 2
    +
    1204  END IF
    +
    1205 
    +
    1206  111 CONTINUE
    +
    1207 
    +
    1208  risc02 = spn
    +
    1209 
    +
    1210  RETURN
    +
    1211  END
    +
    1212 C> @brief Calc. ssm/i prods from neural net 3 alg.
    +
    1213 C> @author V. Krasnopolsky @date 1996-07-15
    +
    1214 
    +
    1215 C> This nn calculates w (in m/s), v (in mm), l (in mm), and
    +
    1216 C> sst (in deg c). This nn was trained on blended f11 data set
    +
    1217 C> (ssmi/buoy matchups plus ssmi/ows matchups 15 km x 15 min) under
    +
    1218 C> clear + cloudy conditions.
    +
    1219 C>
    +
    1220 C> ### Program History Log:
    +
    1221 C> Date | Programmer | Comment
    +
    1222 C> -----|------------|--------
    +
    1223 C> 1996-07-15 | V. Krasnopolsky | Initial.
    +
    1224 C>
    +
    1225 C> @param[in] X 5-word array containing brightness temperature in the
    +
    1226 C> order: t19v (word 1), t19h (word 2), t22v (word 3),
    +
    1227 C> t37v (word 4), t37h (word 5) (all in kelvin)
    +
    1228 C> @param[out] Y 4-word array containing calculated products in the
    +
    1229 C> order: wind speed (m/s) (word 1), columnar water
    +
    1230 C> vapor (total precip. water) (mm) (word 2), columnar
    +
    1231 C> liquid water (mm) (word 3), sea surface temperature
    +
    1232 C> (deg. c) (word 4)
    +
    1233 C>
    +
    1234 C> @remark Called by subroutine risc02().
    +
    1235 C>
    +
    1236 C> @author V. Krasnopolsky @date 1996-07-15
    +
    1237  SUBROUTINE misc10(X,Y)
    +
    1238  INTEGER HID,OUT
    +
    1239 
    +
    1240 C IN IS THE NUMBER OF NN INPUTS, HID IS THE NUMBER OF HIDDEN NODES,
    +
    1241 C OUT IS THE NUMBER OF OUTPUTS
    +
    1242 
    +
    1243  parameter(in =5, hid =12, out =4)
    +
    1244  dimension x(in),y(out),w1(in,hid),w2(hid,out),b1(hid),b2(out),
    +
    1245  $ o1(in),x2(hid),o2(hid),x3(out),o3(out),a(out),b(out)
    +
    1246 
    +
    1247 C W1 HOLDS INPUT WEIGHTS
    +
    1248 
    +
    1249  DATA ((w1(i,j),j = 1,hid),i = 1,in)/
    +
    1250  $-0.0435901, 0.0614709,-0.0453639,-0.0161106,-0.0271382, 0.0229015,
    +
    1251  $-0.0650678, 0.0704302, 0.0383939, 0.0773921, 0.0661954,-0.0643473,
    +
    1252  $-0.0108528,-0.0283174,-0.0308437,-0.0199316,-0.0131226, 0.0107767,
    +
    1253  $ 0.0234265,-0.0291637, 0.0140943, .00567931,-.00931768,
    +
    1254  $-.00860661, 0.0159747,-0.0749903,-0.0503523, 0.0524172, 0.0195771,
    +
    1255  $ 0.0302056, 0.0331725, 0.0326714,-0.0291429, 0.0180438, 0.0281923,
    +
    1256  $-0.0269554, 0.102836, 0.0591511, 0.134313, -0.0109854,-0.0786303,
    +
    1257  $ 0.0117111, 0.0231543,-0.0205603,-0.0382944,-0.0342049,
    +
    1258  $ 0.00052407,0.110301, -0.0404777, 0.0428816, 0.0878070, 0.0168326,
    +
    1259  $ 0.0196183, 0.0293995, 0.00954805,-.00716287,0.0269475,
    +
    1260  $-0.0418217,-0.0165812, 0.0291809/
    +
    1261 
    +
    1262 C W2 HOLDS HIDDEN WEIGHTS
    +
    1263 
    +
    1264  DATA ((w2(i,j),j = 1,out),i = 1,hid)/
    +
    1265  $-0.827004, -0.169961,-0.230296, -0.311201, -0.243296, 0.00454425,
    +
    1266  $ 0.950679, 1.09296, 0.0842604, 0.0140775, 1.80508, -0.198263,
    +
    1267  $-0.0678487, 0.428192, 0.827626, 0.253772, 0.112026, 0.00563793,
    +
    1268  $-1.28161, -0.169509, 0.0019085,-0.137136, -0.334738, 0.224899,
    +
    1269  $-0.189678, 0.626459,-0.204658, -0.885417, -0.148720, 0.122903,
    +
    1270  $ 0.650024, 0.715758, 0.735026, -0.123308, -0.387411,-0.140137,
    +
    1271  $ 0.229058, 0.244314,-1.08613, -0.294565, -0.192568, 0.608760,
    +
    1272  $-0.753586, 0.897605, 0.0322991,-0.178470, 0.0807701,
    +
    1273  $-0.781417/
    +
    1274 
    +
    1275 C B1 HOLDS HIDDEN BIASES
    +
    1276 
    +
    1277  DATA (b1(i), i=1,hid)/
    +
    1278  $ -9.92116,-10.3103,-17.2536, -5.26287, 17.7729,-20.4812,
    +
    1279  $ -4.80869,-11.5222, 0.592880,-4.89773,-17.3294, -7.74136/
    +
    1280 
    +
    1281 C B2 HOLDS OUTPUT BIAS
    +
    1282 
    +
    1283  DATA (b2(i), i=1,out)/-0.882873,-0.0120802,-3.19400,1.00314/
    +
    1284 
    +
    1285 C A(OUT), B(OUT) HOLD TRANSFORMATION COEFFICIENTS
    +
    1286 
    +
    1287  DATA (a(i), i=1,out)/18.1286,31.8210,0.198863,37.1250/
    +
    1288  DATA (b(i), i=1,out)/13.7100,32.0980,0.198863,-5.82500/
    +
    1289 
    +
    1290 C INITIALIZE
    +
    1291 
    +
    1292  o1 = x
    +
    1293 
    +
    1294 C START NEURAL NETWORK
    +
    1295 
    +
    1296 C - INITIALIZE X2
    +
    1297 
    +
    1298  DO i = 1,hid
    +
    1299  x2(i) = 0.
    +
    1300  DO j = 1,in
    +
    1301  x2(i) = x2(i) + (o1(j) * w1(j,i))
    +
    1302  END DO
    +
    1303  x2(i) = x2(i) + b1(i)
    +
    1304  o2(i) = tanh(x2(i))
    +
    1305  END DO
    +
    1306 
    +
    1307 C - INITIALIZE X3
    +
    1308 
    +
    1309  DO k = 1,out
    +
    1310  x3(k) = 0.
    +
    1311  DO j = 1,hid
    +
    1312  x3(k) = x3(k) + (w2(j,k) * o2(j))
    +
    1313  END DO
    +
    1314 
    +
    1315  x3(k) = x3(k) + b2(k)
    +
    1316 
    +
    1317 C --- CALCULATE O3
    +
    1318 
    +
    1319  o3(k) = tanh(x3(k))
    +
    1320  y(k) = (a(k) * o3(k)) + b(k)
    +
    1321  END DO
    +
    1322 
    +
    1323  RETURN
    +
    1324  END
    +
    1325 C> @brief Calc. wspd from neural net 2 algorithm
    +
    1326 C> @author V. Krasnopolsky @date 1996-05-07
    +
    1327 
    +
    1328 C> Calculates a single neural network output for wind speed.
    +
    1329 C> the network was trained on the whole data set without any
    +
    1330 C> separation into subsets. It gives rms = 1.64 m/s for training set
    +
    1331 C> and 1.65 m/s for testing set. This is an improved version of the
    +
    1332 C> earlier neural network 1 algorithm.
    +
    1333 C>
    +
    1334 C> ### Program History Log:
    +
    1335 C> Date | Programmer | Comment
    +
    1336 C> -----|------------|--------
    +
    1337 C> 1994-03-20 | V. Krasnopolsky | Initial.
    +
    1338 C> 1995-05-07 | V. Krasnopolsky | Replaced with neural net 2 algorithm.
    +
    1339 C>
    +
    1340 C> @param[in] X 5-Word array containing brightness temperature in the
    +
    1341 C> order: t19v (word 1), t22v (word 2), t37v (word 3),
    +
    1342 C> t37h (word 4), t85v (word 5) (all in kelvin)
    +
    1343 C> @return XX Wind speed (meters/second)
    +
    1344 C>
    +
    1345 C> @remark Function, no longer called by this program. It is here
    +
    1346 C> simply to save neural net 2 algorithm for possible later use
    +
    1347 C> (has been replaced by neural net 3 algorithm, see subr. risc02
    +
    1348 C> and misc10).
    +
    1349 C>
    +
    1350 C> @author V. Krasnopolsky @date 1996-05-07
    +
    1351  FUNCTION risc02xx(X)
    +
    1352  INTEGER hid
    +
    1353 C IN IS THE NUMBER OF B. TEMP. CHNLS, HID IS THE NUMBER OF HIDDEN NODES
    +
    1354  parameter(in =5, hid =2)
    +
    1355  dimension x(in),w1(in,hid),w2(hid),b1(hid),o1(in),x2(hid),o2(hid)
    +
    1356 
    +
    1357  SAVE
    +
    1358 
    +
    1359 C W1 HOLDS INPUT WEIGHTS
    +
    1360  DATA ((w1(i,j),j=1,hid),i=1,in)/
    +
    1361  $ 4.402388e-02, 2.648334e-02, 6.361322e-04,-1.766535e-02,
    +
    1362  $ 7.876555e-03,-7.387260e-02,-2.656543e-03, 2.957161e-02,
    +
    1363  $-1.181134e-02, 4.520317e-03/
    +
    1364 C W2 HOLDS HIDDEN WEIGHTS
    +
    1365  DATA (w2(i),i=1,hid)/8.705661e-01,1.430968/
    +
    1366 C B1 HOLDS HIDDEN BIASES
    +
    1367  DATA (b1(i),i=1,hid)/-6.436114,8.799655/
    +
    1368 C B2 HOLDS OUTPUT BIAS
    +
    1369 C AY AND BY HOLD OUTPUT TRANSFORMATION COEFFICIENTS
    +
    1370  DATA b2/-0.736255/,ay/16.7833/,by/11.08/
    +
    1371  o1 = x
    +
    1372 C INITIALIZE
    +
    1373  x3 = 0.
    +
    1374  DO i = 1, hid
    +
    1375  o2(i) = 0.
    +
    1376  x2(i) = 0.
    +
    1377  DO j = 1,in
    +
    1378  x2(i) = x2(i) + (o1(j) * w1(j,i))
    +
    1379  END DO
    +
    1380  x2(i) = x2(i) + b1(i)
    +
    1381  o2(i) = tanh(x2(i))
    +
    1382  x3 = x3 + (o2(i)* w2(i))
    +
    1383  END DO
    +
    1384  x3 = x3 + b2
    +
    1385  o3 = tanh(x3)
    +
    1386  risc02xx = (ay * o3) + by
    +
    1387  risc02xx = max(risc02xx,0.0)
    +
    1388 C BIAS CORRECTION
    +
    1389  bias = 0.5 + 0.004*((risc02xx-10.)**3)*(1.-exp(-0.5*risc02xx))
    +
    1390  risc02xx = risc02xx + bias
    +
    1391  RETURN
    +
    1392  END
    +
    1393 C> @brief Calc. w.spd from b temp.- goodberlet alg.
    +
    1394 C> @author W. Gemmill @date 1994-08-15
    +
    1395 
    +
    1396 C> Calculates a single goodberlet output for wind speed.
    +
    1397 C> This is a linear regression algorithm from 1989.
    +
    1398 C>
    +
    1399 C> ### Program History Log:
    +
    1400 C> Date | Programmer | Comment
    +
    1401 C> -----|------------|--------
    +
    1402 C> 1994-08-15 | W. Gemmill | Initial.
    +
    1403 C>
    +
    1404 C> @param[in] X 4-word array containing brightness temperature in the
    +
    1405 C> order: t19v (word 1), t22v (word 2), t37v (word 3),
    +
    1406 C> t37h (word 4) (all in kelvin)
    +
    1407 C> @return XX Wind speed (meters/second)
    +
    1408 C>
    +
    1409 C> @remark Function, called by subroutine misc01.
    +
    1410 C>
    +
    1411 C> @author W. Gemmill @date 1994-08-15
    +
    1412  FUNCTION risc03(X)
    +
    1413  dimension x(4)
    +
    1414 
    +
    1415  SAVE
    +
    1416 
    +
    1417  risc03 = 147.90 + (1.0969 * x(1)) - (0.4555 * x(2)) -
    +
    1418  $ (1.76 * x(3)) + (0.7860 * x(4))
    +
    1419  RETURN
    +
    1420  END
    +
    1421 C> @brief Returns land/sea tag for given lat/lon
    +
    1422 C> @author Dennis Keyser @date 1995-01-04
    +
    1423 
    +
    1424 C> Finds and returns the low resolution land/sea tag nearest
    +
    1425 C> to the requested latitude and longitude.
    +
    1426 C>
    +
    1427 C> ### Program History Log:
    +
    1428 C> Date | Programmer | Comment
    +
    1429 C> -----|------------|--------
    +
    1430 C> 1978-01-20 | J. K. Kalinowski (S11213) | Original author
    +
    1431 C> 1978-10-03 | J. K. Kalinowski (S1214) | Changes unknown
    +
    1432 C> 1985-03-01 | N. Digirolamo (SSAI) | Conversion to vs fortran
    +
    1433 C> 1995-01-04 | Dennis Keyser | Incorporated into w3miscan and streamlined code
    +
    1434 C>
    +
    1435 C> @param[in] INLSF Unit number of direct access nesdis land/sea file
    +
    1436 C> @param[in] BLAT Latitude (whole degrees: range is 0. to +90. north,
    +
    1437 C> 0. to -90. south)
    +
    1438 C> @param[in] BLNG Longitude (whole degrees: range is 0. to +179.99 east,
    +
    1439 C> 0. to -180. west)
    +
    1440 C> @param[out] LSTAG Land/sea tag {=0 - sea; =1 - land; =2 - coastal
    +
    1441 C> interface (higher resolution tags are available);
    +
    1442 C> =3 - coastal interface (no higher resolution tags
    +
    1443 C> exist)}
    +
    1444 C>
    +
    1445 C> @remark Called by subroutine w3miscan.
    +
    1446 C>
    +
    1447 C> @author Dennis Keyser @date 1995-01-04
    +
    1448  SUBROUTINE misc04(INLSF,BLAT,BLNG,LSTAG)
    +
    1449  CHARACTER*1 LPUT
    +
    1450  REAL RGS(3)
    +
    1451 C LPUT CONTAINS A REGION OF LAND/SEA TAGS (RETURNED FROM CALL TO MISC05)
    +
    1452  common/miscdd/lput(21960)
    +
    1453 
    +
    1454  SAVE
    +
    1455 
    +
    1456 C RGS IS ARRAY HOLDING SOUTHERN BOUNDARIES OF EACH LAND/SEA TAG REGION
    +
    1457  DATA rgs/-85.,-30.,25./,numrgl/0/,iflag/0/
    +
    1458 C INITIALIZE LAND/SEA TAG AS 1 (OVER LAND)
    +
    1459  lstag = 1
    +
    1460 C FIND NEAREST POINT OF A HALF-DEGREE (LAT,LONG) GRID
    +
    1461 C ..ALAT IS LATITUDE TO THE NEAREST HALF-DEGREE
    +
    1462  alat = int((blat+sign(.25,blat))/.5) * .5
    +
    1463 C ..ALNG IS LONGITUDE TO THE NEAREST HALF-DEGREE
    +
    1464  alng = int((blng+sign(.25,blng))/.5) * .5
    +
    1465  IF(nint(alng*10.).EQ.1800) alng = -180.
    +
    1466 C IDENTIFY DATABASE REGION IN WHICH TO FIND CORRECT TAG
    +
    1467  numrgn = 1
    +
    1468  IF(iabs(nint(alat*10)).GT.850) THEN
    +
    1469  RETURN
    +
    1470  ELSE IF(nint(alat*10).GT.275) THEN
    +
    1471  numrgn = 3
    +
    1472  ELSE IF(nint(alat*10.).GE.-275) THEN
    +
    1473  numrgn = 2
    +
    1474  END IF
    +
    1475  IF(numrgn.NE.numrgl.OR.iflag.EQ.1) THEN
    +
    1476  numrgl = numrgn
    +
    1477  CALL misc05(inlsf,numrgn,*99)
    +
    1478  END IF
    +
    1479 C FIND THE BYTE & BIT PAIR W/I DATA BASE REGION CONTAINING DESIRED TAG
    +
    1480  trm1 = ((alat - rgs(numrgn)) * 1440.) + 360.
    +
    1481  lstpt = trm1 + (2. * alng)
    +
    1482 C ..NBYTE IS THE BYTE IN LPUT CONTAINING THE TAG
    +
    1483  nbyte = (180 * 8) + (lstpt/4 * 8)
    +
    1484  nshft = (2 * (mod(lstpt,4) + 1)) - 2
    +
    1485 C PULL OUT THE TAG
    +
    1486  CALL gbyte(lput,lstag,nbyte+nshft,2)
    +
    1487  iflag = 0
    +
    1488  RETURN
    +
    1489 C-----------------------------------------------------------------------
    +
    1490  99 CONTINUE
    +
    1491 C COME HERE IF LAND/SEA TAG COULD NOT BE RETURNED FROM SUBR. W3MISCAN
    +
    1492 C (IN THIS CASE IT WILL REMAIN SET TO 1 INDICATING OVER LAND)
    +
    1493  iflag = 1
    +
    1494  RETURN
    +
    1495 C-----------------------------------------------------------------------
    +
    1496  END
    +
    1497 C> @brief Reads 2 records from land/sea tag database
    +
    1498 C> @author Dennis Keyser @date 195-01-04
    +
    1499 
    +
    1500 C> Reads two records from a low resolution land/sea database and stores into common.
    +
    1501 C>
    +
    1502 C> ### Program History Log:
    +
    1503 C> Date | Programmer | Comment
    +
    1504 C> -----|------------|--------
    +
    1505 C> 1978-01-20 | J. K. Kalinowski (S11213) | Original author
    +
    1506 C> 1995-01-04 | Dennis Keyser | Incorporated into w3miscan and
    +
    1507 C> streamlined code; modified to be machine independent thru
    +
    1508 C> use of standard fortran direct access read
    +
    1509 C>
    +
    1510 C> @param[in] INLSF Unit number of direct access nesdis land/sea file
    +
    1511 C> @param[in] NUMRGN The region (1,2 or 3) of the database to be accessed
    +
    1512 C> (dependent on latitude band)
    +
    1513 C>
    +
    1514 C> @remark Called by subroutne misc04.
    +
    1515 C>
    +
    1516 C> @author Dennis Keyser @date 195-01-04
    +
    1517  SUBROUTINE misc05(INLSF,NUMRGN,*)
    +
    1518  CHARACTER*1 LPUT
    +
    1519 
    +
    1520 C LPUT CONTAINS A REGION OF LAND/SEA TAGS (COMPRISED OF 2 RECORDS FROM
    +
    1521 C LAND/SEA FILE) -- 180 BYTES OF DOCUMENTATION FOLLOWED BY 21780 BYTES
    +
    1522 C OF LAND/SEA TAGS
    +
    1523 
    +
    1524  common/miscdd/lput(21960)
    +
    1525 
    +
    1526  SAVE
    +
    1527 
    +
    1528  nrec = (2 * numrgn) - 1
    +
    1529  READ(inlsf,rec=nrec,err=10) (lput(ii),ii=1,10980)
    +
    1530  nrec = nrec + 1
    +
    1531  READ(inlsf,rec=nrec,err=10) (lput(ii),ii=10981,21960)
    +
    1532  RETURN
    +
    1533 C-----------------------------------------------------------------------
    +
    1534  10 CONTINUE
    +
    1535 C ERROR READING IN A RECORD FROM LAND-SEA FILE -- RETURN (TAG WILL BE
    +
    1536 C SET TO 1 MEANING OVER LAND IN THIS CASE)
    +
    1537  print 1000, nrec,inlsf
    +
    1538  1000 FORMAT(' ##W3MISCAN/MISC05: ERROR READING IN LAND-SEA DATA ',
    +
    1539  $ 'RECORD',i7,' IN UNIT ',i2,' -- SET TAG TO LAND'/)
    +
    1540  RETURN 1
    +
    1541 C-----------------------------------------------------------------------
    +
    1542  END
    +
    1543 C> @brief Reads in nh and sh 1-deg. sea-sfc temps.
    +
    1544 C> @author Dennis Keyser @date 200-02-18
    +
    1545 
    +
    1546 C> Reads in global sea-surface temperature field on a one-degree grid from grib file.
    +
    1547 C>
    +
    1548 C> ### Program History Log:
    +
    1549 C> Date | Programmer | Comment
    +
    1550 C> -----|------------|--------
    +
    1551 C> ????-??-?? | W. Gemmill (NP21) | Original author
    +
    1552 C> 1995-01-04 | Dennis Keyser | Incorporated into w3miscan and
    +
    1553 C> streamlined code; converted sst input file from vsam/on84 to
    +
    1554 C> grib to allow code compile and run on the cray machines.
    +
    1555 C> 2000-02-18 | Dennis Keyser | Modified to call w3lib routine "getgb",
    +
    1556 C> this allows code to compile and run properly on ibm-sp
    +
    1557 C>
    +
    1558 C> @param[in] INGBI Unit number of grib index file for grib file
    +
    1559 C> containing global 1-degree sea-surface temp field
    +
    1560 C> @param[in] INGBD Unit number of grib file containing global 1-degree
    +
    1561 C> sea-surface temp field
    +
    1562 C> @param[in] IDAT1 Requested earliest year(yyyy), month, day, hour, min
    +
    1563 C> @param[in] IDAT2 Requested latest year(yyyy), month, day, hour, min
    +
    1564 C>
    +
    1565 C> @remark Called by subroutine w3miscan.
    +
    1566 C>
    +
    1567 C> @author Dennis Keyser @date 200-02-18
    +
    1568  SUBROUTINE misc06(INGBI,INGBD,IDAT1,IDAT2,*,*,*,*)
    +
    1569  parameter(maxpts=360*180)
    +
    1570  LOGICAL*1 LBMS(360,180)
    +
    1571  INTEGER KPDS(200),KGDS(200),LPDS(200),LGDS(200),IDAT1(5),
    +
    1572  $ idat2(5),jdat1(8),jdat2(8),kdat(8),ldat(8),mdate(8)
    +
    1573  REAL RINC(5)
    +
    1574  CHARACTER*11 ENVVAR
    +
    1575  CHARACTER*80 FILEB,FILEI
    +
    1576  common/misccc/sstdat(360,180)
    +
    1577 
    +
    1578  SAVE
    +
    1579 
    +
    1580  envvar='XLFUNIT_ '
    +
    1581  WRITE(envvar(9:10),fmt='(I2)') ingbd
    +
    1582  CALL getenv(envvar,fileb)
    +
    1583  envvar='XLFUNIT_ '
    +
    1584  WRITE(envvar(9:10),fmt='(I2)') ingbi
    +
    1585  CALL getenv(envvar,filei)
    +
    1586  CALL baopenr(ingbd,fileb,iret1)
    +
    1587 ccccc PRINT *,'SAGT: ',INGBD,FILEB,IRET1
    +
    1588  CALL baopenr(ingbi,filei,iret2)
    +
    1589 ccccc PRINT *,'SAGT: ',INGBI,FILEI,IRET2
    +
    1590 
    +
    1591  kpds = -1
    +
    1592  kgds = -1
    +
    1593  n = -1
    +
    1594  kpds(5) = 11
    +
    1595  kpds(6) = 1
    +
    1596  kpds(7) = 0
    +
    1597  kpds(8) = -1
    +
    1598  kpds(9) = -1
    +
    1599  kpds(10) = -1
    +
    1600  print 68, ingbd
    +
    1601  68 FORMAT(//4x,'** W3MISCAN/MISC06: READ IN "CURRENT" SEA-SURFACE ',
    +
    1602  $ 'TEMPERATURE DATA FROM GRIB MESSAGE IN UNIT',i3)
    +
    1603  CALL getgb(ingbd,ingbi,maxpts,0,kpds,kgds,kf,k,lpds,lgds,lbms,
    +
    1604  $ sstdat,iret)
    +
    1605 C.......................................................................
    +
    1606 C ABNORMAL RETURN IF PROBLEM WITH SST IN GRIB FILE
    +
    1607  IF(iret.NE.0) THEN
    +
    1608  WRITE(6,*)' ERROR READING SST USING GETGB. IRET = ',iret
    +
    1609  IF (iret.EQ.96) RETURN 1
    +
    1610  IF (iret.EQ.97) RETURN 3
    +
    1611  IF (iret.EQ.98) RETURN 3
    +
    1612  IF (iret.EQ.99) RETURN 3
    +
    1613  RETURN 4
    +
    1614  ENDIF
    +
    1615 C.......................................................................
    +
    1616 C READ SUCCESSFUL
    +
    1617  jdat1 = 0
    +
    1618  jdat2 = 0
    +
    1619  jdat1(1:3) = idat1(1:3)
    +
    1620  jdat1(5:6) = idat1(4:5)
    +
    1621  jdat2(1:3) = idat2(1:3)
    +
    1622  jdat2(5:6) = idat2(4:5)
    +
    1623  mdate = 0
    +
    1624  mdate(1) = ((lpds(21) - 1) * 100) + lpds(8)
    +
    1625  mdate(2:3) = lpds(9:10)
    +
    1626  mdate(5:6) = lpds(11:12)
    +
    1627  CALL w3movdat((/-7.,0.,0.,0.,0./),jdat1,kdat)
    +
    1628  CALL w3movdat((/ 7.,0.,0.,0.,0./),jdat2,ldat)
    +
    1629 cppppp
    +
    1630  print *, '** W3MISCAN/MISCO6: SST GRIB FILE MUST HAVE DATE ',
    +
    1631  $ 'BETWEEN ',(kdat(iii),iii=1,3),(kdat(iii),iii=5,6),' AND ',
    +
    1632  $ (ldat(iii),iii=1,3),(ldat(iii),iii=5,6)
    +
    1633  print *, ' RETURNED FROM GRIB FILE IS YEAR ',
    +
    1634  $ 'OF CENTURY = ',lpds(8),' AND CENTURY = ',lpds(21)
    +
    1635  print *, ' CALULATED 4-DIGIT YEAR IS = ',
    +
    1636  $ mdate(1)
    +
    1637 cppppp
    +
    1638  CALL w3difdat(kdat,mdate,3,rinc)
    +
    1639  kmin = rinc(3)
    +
    1640  CALL w3difdat(ldat,mdate,3,rinc)
    +
    1641  lmin = rinc(3)
    +
    1642  IF(kmin.GT.0.OR.lmin.LT.0) THEN
    +
    1643 C.......................................................................
    +
    1644 C COME HERE IF SST GRIB MSG HAS A DATE THAT IS EITHER: 1) MORE THAN 7-
    +
    1645 C DAYS PRIOR TO THE EARLIEST REQ. DATE (INPUT ARG. "IDAT1" TO W3MISCAN)
    +
    1646 C OR 2) MORE THAN 7-DAYS AFTER THE LATEST REQ. DATE (INPUT ARG.
    +
    1647 C "IDAT2" TO W3MISCAN)
    +
    1648  print 27, (mdate(iii),iii=1,3),(mdate(iii),iii=5,6)
    +
    1649  27 FORMAT(/' ##W3MISCAN/MISC06: SST GRIB MSG HAS DATE:',i5,4i3,
    +
    1650  $ ' - AS A RESULT......')
    +
    1651  RETURN 2
    +
    1652 C.......................................................................
    +
    1653  END IF
    +
    1654  print 60, (mdate(iii),iii=1,3),(mdate(iii),iii=5,6)
    +
    1655  60 FORMAT(/4x,'** W3MISCAN/MISC06: SEA-SFC TEMP SUCCESSFULLY READ ',
    +
    1656  $ 'IN FROM GRIB FILE, DATE IS: ',i5,4i3/)
    +
    1657  RETURN
    +
    1658 
    +
    1659  CALL baclose(ingbi,iret)
    +
    1660  CALL baclose(ingbd,iret)
    +
    1661 
    +
    1662  END
    +
    +
    +
    misc01
    subroutine misc01(NNALG, GBALG, KDATA, SWNN, TPWNN, SWGB, NRFGB)
    Prepares for in-line caluclation of prods.
    Definition: w3miscan.f:1007
    +
    risc03
    function risc03(X)
    Calc.
    Definition: w3miscan.f:1413
    +
    misc10
    subroutine misc10(X, Y)
    Calc.
    Definition: w3miscan.f:1238
    +
    misc05
    subroutine misc05(INLSF, NUMRGN,)
    Reads 2 records from land/sea tag database.
    Definition: w3miscan.f:1518
    +
    misc06
    subroutine misc06(INGBI, INGBD, IDAT1, IDAT2,,,,)
    Reads in nh and sh 1-deg.
    Definition: w3miscan.f:1569
    +
    misc04
    subroutine misc04(INLSF, BLAT, BLNG, LSTAG)
    Returns land/sea tag for given lat/lon.
    Definition: w3miscan.f:1449
    +
    getgb
    subroutine getgb(LUGB, LUGI, JF, J, JPDS, JGDS, KF, K, KPDS, KGDS, LB, F, IRET)
    Find and unpack a grib message.
    Definition: getgb.f:166
    +
    risc02xx
    function risc02xx(X)
    Calc.
    Definition: w3miscan.f:1352
    +
    risc02
    function risc02(XT, V, L, SST, JERR)
    Calc.
    Definition: w3miscan.f:1139
    +
    w3miscan
    subroutine w3miscan(INDTA, INLSF, INGBI, INGBD, LSAT, LPROD, LBRIT, NNALG, GBALG, KDATE, LDATE, IGNRTM, IBUFTN, IBDATE, IER)
    Reads one ssm/i scan line (64 retrievals) from the NCEP bufr ssm/i dump file.
    Definition: w3miscan.f:194
    +
    gbyte
    subroutine gbyte(IPACKD, IUNPKD, NOFF, NBITS)
    This is the fortran version of gbyte.
    Definition: gbyte.f:27
    +
    w3difdat
    subroutine w3difdat(jdat, idat, it, rinc)
    Returns the elapsed time interval from an NCEP absolute date and time given in the second argument un...
    Definition: w3difdat.f:29
    +
    w3movdat
    subroutine w3movdat(rinc, idat, jdat)
    This subprogram returns the date and time that is a given NCEP relative time interval from an NCEP ab...
    Definition: w3movdat.f:24
    +
    w3fi04
    subroutine w3fi04(IENDN, ITYPEC, LW)
    Subroutine computes word size, the type of character set, ASCII or EBCDIC, and if the computer is big...
    Definition: w3fi04.f:30
    + + + + diff --git a/ver-2.10.0/w3movdat_8f.html b/ver-2.10.0/w3movdat_8f.html new file mode 100644 index 00000000..821a530e --- /dev/null +++ b/ver-2.10.0/w3movdat_8f.html @@ -0,0 +1,179 @@ + + + + + + + +NCEPLIBS-w3emc: w3movdat.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3movdat.f File Reference
    +
    +
    + +

    Return a date from a time interval and date. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3movdat (rinc, idat, jdat)
     This subprogram returns the date and time that is a given NCEP relative time interval from an NCEP absolute date and time. More...
     
    +

    Detailed Description

    +

    Return a date from a time interval and date.

    +
    Author
    Mark Iredell
    +
    Date
    1998-08-01
    + +

    Definition in file w3movdat.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3movdat()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3movdat (real, dimension(5) rinc,
    integer, dimension(8) idat,
    integer, dimension(8) jdat 
    )
    +
    + +

    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:

    + + + + + +
    Date Programmer Comment
    1998-01-05 Mark Iredell Initial.
    +
    Parameters
    + + + + +
    [in]RINCNCEP relative time interval (days, hours, minutes, seconds milliseconds)
    [in]IDATNCEP absolute date and time (year, month, day, time zone, hour, minute, second, millisecond)
    [in]JDATNCEP absolute date and time (year, month, day, time zone, hour, minute, second, millisecond) (jdat is later than idat if time interval is positive.)
    +
    +
    +
    Author
    Mark Iredell
    +
    Date
    1998-08-01
    + +

    Definition at line 24 of file w3movdat.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3movdat_8f.js b/ver-2.10.0/w3movdat_8f.js new file mode 100644 index 00000000..41d43788 --- /dev/null +++ b/ver-2.10.0/w3movdat_8f.js @@ -0,0 +1,4 @@ +var w3movdat_8f = +[ + [ "w3movdat", "w3movdat_8f.html#a999d6ea7410cb2a3a220722b4ddb7339", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3movdat_8f_source.html b/ver-2.10.0/w3movdat_8f_source.html new file mode 100644 index 00000000..45264063 --- /dev/null +++ b/ver-2.10.0/w3movdat_8f_source.html @@ -0,0 +1,124 @@ + + + + + + + +NCEPLIBS-w3emc: w3movdat.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3movdat.f
    +
    +
    +Go to the documentation of this file.
    1 
    +
    4 
    +
    23  subroutine w3movdat(rinc,idat,jdat)
    +
    24 
    +
    25  real rinc(5)
    +
    26  integer idat(8),jdat(8)
    +
    27  real rinc1(5),rinc2(5)
    +
    28 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    29 ! add the interval to the input time of day and put into reduced form
    +
    30 ! and then compute new date using julian day arithmetic.
    +
    31  rinc1(1)=rinc(1)
    +
    32  rinc1(2:5)=rinc(2:5)+idat(5:8)
    +
    33  call w3reddat(-1,rinc1,rinc2)
    +
    34  jldayn=iw3jdn(idat(1),idat(2),idat(3))+nint(rinc2(1))
    +
    35  call w3fs26(jldayn,jdat(1),jdat(2),jdat(3),jdow,jdoy)
    +
    36  jdat(4)=idat(4)
    +
    37  jdat(5:8)=nint(rinc2(2:5))
    +
    38 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    39  end
    +
    +
    +
    w3fs26
    subroutine w3fs26(JLDAYN, IYEAR, MONTH, IDAY, IDAYWK, IDAYYR)
    Computes year (4 digits), month, day, day of week, day of year from julian day number.
    Definition: w3fs26.f:56
    +
    w3reddat
    subroutine w3reddat(it, rinc, dinc)
    This subprogram reduces an ncep relative time interval into one of seven canonical forms,...
    Definition: w3reddat.f:86
    +
    w3movdat
    subroutine w3movdat(rinc, idat, jdat)
    This subprogram returns the date and time that is a given NCEP relative time interval from an NCEP ab...
    Definition: w3movdat.f:24
    +
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    + + + + diff --git a/ver-2.10.0/w3nogds_8f.html b/ver-2.10.0/w3nogds_8f.html new file mode 100644 index 00000000..e38dfca1 --- /dev/null +++ b/ver-2.10.0/w3nogds_8f.html @@ -0,0 +1,318 @@ + + + + + + + +NCEPLIBS-w3emc: w3nogds.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3nogds.f File Reference
    +
    +
    + +

    Make a complete grib message. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3nogds (ITYPE, FLD, IFLD, IBITL, IPFLAG, ID, PDS, IGFLAG, IGRID, IGDS, ICOMP, IBFLAG, IBMAP, IBLEN, IBDSFL, NPTS, KBUF, ITOT, JERR)
     Makes a complete grib message from a user supplied array of floating point or integer data. More...
     
    +

    Detailed Description

    +

    Make a complete grib message.

    +
    Author
    Farley
    +
    Date
    1997-02-24
    + +

    Definition in file w3nogds.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3nogds()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3nogds ( ITYPE,
    real, dimension(*) FLD,
    integer, dimension(*) IFLD,
     IBITL,
     IPFLAG,
    integer, dimension(*) ID,
    character * 1, dimension(*) PDS,
     IGFLAG,
     IGRID,
    integer, dimension(*) IGDS,
     ICOMP,
     IBFLAG,
    integer, dimension(*) IBMAP,
     IBLEN,
    integer, dimension(*) IBDSFL,
     NPTS,
    character * 1, dimension(*) KBUF,
     ITOT,
     JERR 
    )
    +
    + +

    Makes a complete grib message from a user supplied array of floating point or integer data.

    +

    The user has the option of supplying the pds or an integer array that will be used to create a pds (with w3fi68()). The user must also supply other necessary info; see usage section below.

    +

    +Program History Log:

    + + + + + + + + + +
    Date Programmer Comment
    1997-02-24 M. Farley Modified w3fi72() - this routine allows for no gds (errors in w3fi71 for grib grids 21-26, 61-64 forced the need for this routine).
    1998-06-24 Stephen Gilbert Added number of gridpoint values for grids 61-64, needed when igflag=2 ( no gds ).
    1998-12-21 Stephen Gilbert Replaced function ichar with mova2i.
    +
    Parameters
    + + + + + + + + + + + + + + + + + + + + +
    [in]ITYPE0 = Floating point data supplied in array 'fld' 1 = Data supplied in array 'ifld'
    [in]FLDArray of data (at proper gridpoints) to be converted to grib format if itype=0. see remarks #1 & 2.
    [in]IFLDArray of data (at proper gridpoints) to be converted to grib format if itype=1. see remarks #1 & 2.
    [in]IBITL0 = Computer computes length for packing data from power of 2 (number of bits) best fit of data using 'variable' bit packer w3fi58. 8, 12, etc. computer rescales data to fit into that 'fixed' number of bits using w3fi59. see remarks #3.
    [in]IPFLAG0 = Make pds from user supplied array (id) 1 = user supplying pds note: if pds is greater than 30, use iplfag=1. the user could call w3fi68 before he calls w3nogds. this would make the first 30 bytes of the pds, user then would make bytes after 30.
    [in]IDArray of values that w3fi68 will use to make an edition 1 pds if ipflag=0. (see the docblock for w3fi68 for layout of array)
    [in]PDSArray of values (valid pds supplied by user) if ipflag=1. length may exceed 28 bytes (contents of bytes beyond 28 are passed through unchanged).
    [in]IGFLAG0 = Make gds based on 'igrid' value. 1 = make gds from user supplied info in 'igds' and 'igrid' value. see remarks #4. 2 = no gds will be included...for international grids *** this is an exception to remarks #4!!!!
    [in]IGRID# = Grid identification (table b) 255 = if user defined grid; igds must be supplied and igflag must =1.
    [in]IGDSArray containing user gds info (same format as supplied by w3fi71 - see dockblock for layout) if igflag=1.
    [in]ICOMPResolution and component flag for bit 5 of gds(17) 0 = earth oriented winds 1 = grid oriented winds
    [in]IBFLAG0 = Make bit map from user supplied data
      +
    • # = bit map predefined by center see remarks #5.
      • +
    +
    [in]IBMAPArray containing bit map
    [in]IBLENLength of bit map will be used to verify length of field (error if it doesn't match).
    [in]IBDSFLArray containing table 11 flag info bds octet 4: (1) 0 = grid point data 1 = spherical harmonic coefficients (2) 0 = simple packing 1 = second order packing (3) ... same value as 'itype' 0 = original data were floating point values 1 = original data were integer values (4) 0 = no additional flags at octet 14 1 = octet 14 contains flag bits 5-12 (5) 0 = reserved - always set to 0 byte 6 option 1 not available (as of 5-16-93) (6) 0 = single datum at each grid point 1 = matrix of values at each grid point byte 7 option 0 with second order packing n/a (as of 5-16-93) (7) 0 = no secondary bit maps 1 = secondary bit maps present (8) 0 = second order values have constant width 1 = second order values have different widths
    [out]NPTSNumber of gridpoints in array fld or ifld
    [out]KBUFEntire grib message ('grib' to '7777') equivalence to integer array to make sure it is on word bounary.
    [out]ITOTTotal length of grib message in bytes
    [out]JERR=:
      +
    • 0, Completed making grib field without error
      • +
    • 1, Ipflag not 0 or 1
      • +
    • 2, Igflag not 0 or 1 or 2
      • +
    • 3, Error converting ieee f.p. number to ibm370 f.p.
      • +
    • 4, W3fi71 error/igrid not defined
      • +
    • 5, W3fk74 error/grid representation type not valid
      • +
    • 6, Grid too large for packer dimension arrays see automation division for revision!
      • +
    • 7, Length of bit map not equal to size of fld/ifld
      • +
    • 8, W3fi73 error, all values in ibmap are zero
      • +
    +
    +
    +
    +
    Remarks
      +
    • 1 If bit map to be included in message, null data should be included in fld or ifld. this routine will take care of 'discarding' any null data based on the bit map.
      • +
    • 2 Units must be those in grib documentation: nmc o.n. 388 or wmo publication 306.
      • +
    • 3 In either case, input numbers will be multiplied by '10 to the nth' power found in id(25) or pds(27-28), the d-scaling factor, prior to binary packing.
      • +
    • 4 All nmc produced grib fields will have a grid definition section included in the grib message. id(6) will be set to '1'.
      • +
    • gds will be built based on grid number (igrid), unless igflag=1 (user supplying igds). user must still supply igrid even if igds provided.
      • +
    • 5 If bit map used then id(7) or pds(8) must indicate the presence of a bit map.
      • +
    • 6 Array kbuf should be equivalenced to an integer value or array to make sure it is on a word boundary.
      • +
    • 7 Subprogram can be called from a multiprocessing environment.
      • +
    +
    + +

    Definition at line 125 of file w3nogds.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3nogds_8f.js b/ver-2.10.0/w3nogds_8f.js new file mode 100644 index 00000000..3f931c62 --- /dev/null +++ b/ver-2.10.0/w3nogds_8f.js @@ -0,0 +1,4 @@ +var w3nogds_8f = +[ + [ "w3nogds", "w3nogds_8f.html#a9fee3e95f39d96f49f71d4fe1a681e6a", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3nogds_8f_source.html b/ver-2.10.0/w3nogds_8f_source.html new file mode 100644 index 00000000..93e3f4d2 --- /dev/null +++ b/ver-2.10.0/w3nogds_8f_source.html @@ -0,0 +1,526 @@ + + + + + + + +NCEPLIBS-w3emc: w3nogds.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3nogds.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Make a complete grib message
    +
    3 C> @author Farley @date 1997-02-24
    +
    4 
    +
    5 C> Makes a complete grib message from a user supplied
    +
    6 C> array of floating point or integer data. The user has the
    +
    7 C> option of supplying the pds or an integer array that will be
    +
    8 C> used to create a pds (with w3fi68()). The user must also
    +
    9 C> supply other necessary info; see usage section below.
    +
    10 C>
    +
    11 C> ### Program History Log:
    +
    12 C> Date | Programmer | Comment
    +
    13 C> -----|------------|--------
    +
    14 C> 1997-02-24 | M. Farley | Modified w3fi72() - this routine allows for no gds (errors in w3fi71 for grib grids 21-26, 61-64 forced the need for this routine).
    +
    15 C> 1998-06-24 | Stephen Gilbert | Added number of gridpoint values for grids 61-64, needed when igflag=2 ( no gds ).
    +
    16 C> 1998-12-21 | Stephen Gilbert | Replaced function ichar with mova2i.
    +
    17 C>
    +
    18 C> @param[in] ITYPE 0 = Floating point data supplied in array 'fld'
    +
    19 C> 1 = Data supplied in array 'ifld'
    +
    20 C> @param[in] FLD Array of data (at proper gridpoints) to be
    +
    21 C> converted to grib format if itype=0.
    +
    22 C> see remarks #1 & 2.
    +
    23 C> @param[in] IFLD Array of data (at proper gridpoints) to be
    +
    24 C> converted to grib format if itype=1.
    +
    25 C> see remarks #1 & 2.
    +
    26 C> @param[in] IBITL 0 = Computer computes length for packing data from
    +
    27 C> power of 2 (number of bits) best fit of data
    +
    28 C> using 'variable' bit packer w3fi58.
    +
    29 C> 8, 12, etc. computer rescales data to fit into that
    +
    30 C> 'fixed' number of bits using w3fi59.
    +
    31 C> see remarks #3.
    +
    32 C> @param[in] IPFLAG 0 = Make pds from user supplied array (id)
    +
    33 C> 1 = user supplying pds
    +
    34 C> note: if pds is greater than 30, use iplfag=1.
    +
    35 C> the user could call w3fi68 before he calls
    +
    36 C> w3nogds. this would make the first 30 bytes of
    +
    37 C> the pds, user then would make bytes after 30.
    +
    38 C> @param[in] ID Array of values that w3fi68 will use
    +
    39 C> to make an edition 1 pds if ipflag=0. (see the
    +
    40 C> docblock for w3fi68 for layout of array)
    +
    41 C> @param[in] PDS Array of values (valid pds supplied
    +
    42 C> by user) if ipflag=1. length may exceed 28 bytes
    +
    43 C> (contents of bytes beyond 28 are passed
    +
    44 C> through unchanged).
    +
    45 C> @param[in] IGFLAG 0 = Make gds based on 'igrid' value.
    +
    46 C> 1 = make gds from user supplied info in 'igds' and 'igrid' value. see remarks #4.
    +
    47 C> 2 = no gds will be included...for international grids
    +
    48 C> *** this is an exception to remarks #4!!!!
    +
    49 C> @param[in] IGRID # = Grid identification (table b)
    +
    50 C> 255 = if user defined grid; igds must be supplied and igflag must =1.
    +
    51 C> @param[in] IGDS Array containing user gds info (same
    +
    52 C> format as supplied by w3fi71 - see dockblock for
    +
    53 C> layout) if igflag=1.
    +
    54 C> @param[in] ICOMP Resolution and component flag for bit 5 of gds(17)
    +
    55 C> 0 = earth oriented winds
    +
    56 C> 1 = grid oriented winds
    +
    57 C> @param[in] IBFLAG 0 = Make bit map from user supplied data
    +
    58 C> - # = bit map predefined by center see remarks #5.
    +
    59 C> @param[in] IBMAP Array containing bit map
    +
    60 C> @param[in] IBLEN Length of bit map will be used to verify length
    +
    61 C> of field (error if it doesn't match).
    +
    62 C> @param[in] IBDSFL Array containing table 11 flag info
    +
    63 C> bds octet 4:
    +
    64 C> (1) 0 = grid point data
    +
    65 C> 1 = spherical harmonic coefficients
    +
    66 C> (2) 0 = simple packing
    +
    67 C> 1 = second order packing
    +
    68 C> (3) ... same value as 'itype'
    +
    69 C> 0 = original data were floating point values
    +
    70 C> 1 = original data were integer values
    +
    71 C> (4) 0 = no additional flags at octet 14
    +
    72 C> 1 = octet 14 contains flag bits 5-12
    +
    73 C> (5) 0 = reserved - always set to 0
    +
    74 C> byte 6 option 1 not available (as of 5-16-93)
    +
    75 C> (6) 0 = single datum at each grid point
    +
    76 C> 1 = matrix of values at each grid point
    +
    77 C> byte 7 option 0 with second order packing n/a (as of 5-16-93)
    +
    78 C> (7) 0 = no secondary bit maps
    +
    79 C> 1 = secondary bit maps present
    +
    80 C> (8) 0 = second order values have constant width
    +
    81 C> 1 = second order values have different widths
    +
    82 C> @param[out] NPTS Number of gridpoints in array fld or ifld
    +
    83 C> @param[out] KBUF Entire grib message ('grib' to '7777')
    +
    84 C> equivalence to integer array to make sure it
    +
    85 C> is on word bounary.
    +
    86 C> @param[out] ITOT Total length of grib message in bytes
    +
    87 C> @param[out] JERR =:
    +
    88 C> - 0, Completed making grib field without error
    +
    89 C> - 1, Ipflag not 0 or 1
    +
    90 C> - 2, Igflag not 0 or 1 or 2
    +
    91 C> - 3, Error converting ieee f.p. number to ibm370 f.p.
    +
    92 C> - 4, W3fi71 error/igrid not defined
    +
    93 C> - 5, W3fk74 error/grid representation type not valid
    +
    94 C> - 6, Grid too large for packer dimension arrays
    +
    95 C> see automation division for revision!
    +
    96 C> - 7, Length of bit map not equal to size of fld/ifld
    +
    97 C> - 8, W3fi73 error, all values in ibmap are zero
    +
    98 C>
    +
    99 C> @remark
    +
    100 C> - 1 If bit map to be included in message, null data should
    +
    101 C> be included in fld or ifld. this routine will take care
    +
    102 C> of 'discarding' any null data based on the bit map.
    +
    103 C> - 2 Units must be those in grib documentation: nmc o.n. 388
    +
    104 C> or wmo publication 306.
    +
    105 C> - 3 In either case, input numbers will be multiplied by
    +
    106 C> '10 to the nth' power found in id(25) or pds(27-28),
    +
    107 C> the d-scaling factor, prior to binary packing.
    +
    108 C> - 4 All nmc produced grib fields will have a grid definition
    +
    109 C> section included in the grib message. id(6) will be
    +
    110 C> set to '1'.
    +
    111 C> - gds will be built based on grid number (igrid), unless
    +
    112 C> igflag=1 (user supplying igds). user must still supply
    +
    113 C> igrid even if igds provided.
    +
    114 C> - 5 If bit map used then id(7) or pds(8) must indicate the
    +
    115 C> presence of a bit map.
    +
    116 C> - 6 Array kbuf should be equivalenced to an integer value or
    +
    117 C> array to make sure it is on a word boundary.
    +
    118 C> - 7 Subprogram can be called from a multiprocessing environment.
    +
    119 C>
    +
    120  SUBROUTINE w3nogds(ITYPE,FLD,IFLD,IBITL,
    +
    121  & IPFLAG,ID,PDS,
    +
    122  & IGFLAG,IGRID,IGDS,ICOMP,
    +
    123  & IBFLAG,IBMAP,IBLEN,IBDSFL,
    +
    124  & NPTS,KBUF,ITOT,JERR)
    +
    125 C
    +
    126  parameter(mxsize=260000)
    +
    127 C ALLOW UP TO 24 BITS PER POINT
    +
    128  parameter(mxsiz3=mxsize*3)
    +
    129  parameter(mxsizb=mxsize/8+6)
    +
    130 C FOR 64 BIT CRAY
    +
    131  parameter(mxsizi=mxsiz3/8)
    +
    132 C FOR 32 BIT WORKSTATIONS AND HDS
    +
    133 C PARAMETER (MXSIZI=MXSIZ3/4)
    +
    134 C
    +
    135  REAL FLD(*)
    +
    136 C
    +
    137  INTEGER IBDSFL(*)
    +
    138  INTEGER IBMAP(*)
    +
    139  INTEGER ID(*)
    +
    140  INTEGER IFLD(*)
    +
    141  INTEGER IGDS(*)
    +
    142  INTEGER IPFLD(MXSIZI)
    +
    143  INTEGER IB(4)
    +
    144 C
    +
    145  CHARACTER * 1 BDS11(11)
    +
    146  CHARACTER * 1 KBUF(*)
    +
    147  CHARACTER * 1 PDS(*)
    +
    148  CHARACTER * 1 GDS(200)
    +
    149  CHARACTER * 1 BMS(MXSIZB)
    +
    150  CHARACTER * 1 PFLD(MXSIZ3)
    +
    151  CHARACTER * 1 SEVEN
    +
    152  CHARACTER * 1 ZERO
    +
    153 C
    +
    154  equivalence(ipfld(1),pfld(1))
    +
    155  equivalence(bds11(1),idummy)
    +
    156 C
    +
    157 C ASCII REP OF /'G', 'R', 'I', 'B'/
    +
    158 C
    +
    159  DATA ib / 71, 82, 73, 66/
    +
    160 C
    +
    161  ier = 0
    +
    162  iberr = 0
    +
    163  jerr = 0
    +
    164  igribl = 8
    +
    165  ipdsl = 0
    +
    166  lengds = 0
    +
    167  lenbms = 0
    +
    168  lenbds = 0
    +
    169  itoss = 0
    +
    170 C
    +
    171 C$ 1.0 PRODUCT DEFINITION SECTION(PDS).
    +
    172 C
    +
    173 C SET ID(6) TO 1 ...OR... MODIFY PDS(8) ...
    +
    174 C REGARDLESS OF USER SPECIFICATION...
    +
    175 C NMC GRIB FIELDS WILL ALWAYS HAVE A GDS
    +
    176 C ***** exception for international GRIB GRIDS 21-26, 61-64
    +
    177 C ***** which will NOT contain a GDS until subroutine W3FI71 is fixed!
    +
    178 C
    +
    179  IF (ipflag .EQ.0) THEN
    +
    180  id(6) = 1
    +
    181  if (igflag .eq. 2) then
    +
    182  id(6) = 0
    +
    183  endif
    +
    184  CALL w3fi68(id,pds)
    +
    185  ELSE IF (ipflag .EQ. 1) THEN
    +
    186  IF (iand(mova2i(pds(8)),64) .EQ. 64) THEN
    +
    187 C BOTH GDS AND BMS
    +
    188  pds(8) = char(192)
    +
    189  ELSE IF (mova2i(pds(8)) .EQ. 0) THEN
    +
    190 C GDS ONLY
    +
    191  pds(8) = char(128)
    +
    192  END IF
    +
    193  CONTINUE
    +
    194  ELSE
    +
    195 C PRINT *,' W3NOGDS ERROR, IPFLAG IS NOT 0 OR 1 IPFLAG = ',IPFLAG
    +
    196  jerr = 1
    +
    197  GO TO 900
    +
    198  END IF
    +
    199 C
    +
    200 C GET LENGTH OF PDS
    +
    201 C
    +
    202  ipdsl = mova2i(pds(1)) * 65536 + mova2i(pds(2)) * 256 +
    +
    203  & mova2i(pds(3))
    +
    204 C
    +
    205 C$ 2.0 GRID DEFINITION SECTION (GDS).
    +
    206 C
    +
    207 C IF IGFLAG=1 THEN USER IS SUPPLYING THE IGDS INFORMATION
    +
    208 C IF IGFLAG=2 THEN USER doesn't want a GDS and this section
    +
    209 C will be skipped...LENGDS=0
    +
    210 C
    +
    211  IF (igflag .EQ. 0) THEN
    +
    212  CALL w3fi71(igrid,igds,igerr)
    +
    213  IF (igerr .EQ. 1) THEN
    +
    214 C PRINT *,' W3FI71 ERROR, GRID TYPE NOT DEFINED...',IGRID
    +
    215  jerr = 4
    +
    216  GO TO 900
    +
    217  END IF
    +
    218  END IF
    +
    219  IF (igflag .EQ. 0 .OR. igflag .EQ.1) THEN
    +
    220  CALL w3fi74(igds,icomp,gds,lengds,npts,igerr)
    +
    221  IF (igerr .EQ. 1) THEN
    +
    222 C PRINT *,' W3FI74 ERROR, GRID REP TYPE NOT VALID...',IGDS(3)
    +
    223  jerr = 5
    +
    224  GO TO 900
    +
    225  ELSE
    +
    226  END IF
    +
    227  IF (npts .GT. mxsize) THEN
    +
    228 C PRINT *,' W3NOGDS ERROR, GRID TOO LARGE FOR PACKER ARRAY',
    +
    229 C & ' DIMENSIONS'
    +
    230  jerr = 6
    +
    231  GO TO 900
    +
    232  END IF
    +
    233  else if (igflag .eq. 2) then
    +
    234  lengds = 0
    +
    235  if (igrid.eq.21) then
    +
    236  npts=1333
    +
    237  else if (igrid.eq.22) then
    +
    238  npts=1333
    +
    239  else if (igrid.eq.23) then
    +
    240  npts=1333
    +
    241  else if (igrid.eq.24) then
    +
    242  npts=1333
    +
    243  else if (igrid.eq.25) then
    +
    244  npts=1297
    +
    245  else if (igrid.eq.26) then
    +
    246  npts=1297
    +
    247  else if ((igrid.ge.61).and.(igrid.le.64)) then
    +
    248  npts=4096
    +
    249  end if
    +
    250  ELSE
    +
    251 C PRINT *,' W3NOGDS ERROR, IGFLAG IS NOT 0-2 IGFLAG = ',IGFLAG
    +
    252  GO TO 900
    +
    253  END IF
    +
    254 C
    +
    255 C$ 3.0 BIT MAP SECTION (BMS).
    +
    256 C
    +
    257 C SET ITOSS=1 IF BITMAP BEING USED. W3FI75 WILL TOSS DATA
    +
    258 C PRIOR TO PACKING. LATER CODING WILL BE NEEDED WHEN THE
    +
    259 C 'PREDEFINED' GRIDS ARE FINALLY 'DEFINED'.
    +
    260 C
    +
    261  IF (mova2i(pds(8)) .EQ. 64 .OR.
    +
    262  & mova2i(pds(8)) .EQ. 192) THEN
    +
    263  itoss = 1
    +
    264  IF (ibflag .EQ. 0) THEN
    +
    265  IF (iblen .NE. npts) THEN
    +
    266 C PRINT *,' W3NOGDS ERROR, IBLEN .NE. NPTS = ',IBLEN,NPTS
    +
    267  jerr = 7
    +
    268  GO TO 900
    +
    269  END IF
    +
    270  CALL w3fi73(ibflag,ibmap,iblen,bms,lenbms,ier)
    +
    271  IF (ier .NE. 0) THEN
    +
    272 C PRINT *,' W3FI73 ERROR, IBMAP VALUES ARE ALL ZERO'
    +
    273  jerr = 8
    +
    274  GO TO 900
    +
    275  END IF
    +
    276  ELSE
    +
    277 C PRINT *,' BIT MAP PREDEFINED BY CENTER, IBFLAG = ',IBFLAG
    +
    278  END IF
    +
    279  END IF
    +
    280 C
    +
    281 C$ 4.0 BINARY DATA SECTION (BDS).
    +
    282 C
    +
    283 C$ 4.1 SCALE THE DATA WITH D-SCALE FROM PDS(27-28)
    +
    284 C
    +
    285  jscale = mova2i(pds(27)) * 256 + mova2i(pds(28))
    +
    286  IF (iand(jscale,32768).NE.0) THEN
    +
    287  jscale = - iand(jscale,32767)
    +
    288  END IF
    +
    289  scale = 10.0 ** jscale
    +
    290  IF (itype .EQ. 0) THEN
    +
    291  DO 410 i = 1,npts
    +
    292  fld(i) = fld(i) * scale
    +
    293  410 CONTINUE
    +
    294  ELSE
    +
    295  DO 411 i = 1,npts
    +
    296  ifld(i) = nint(float(ifld(i)) * scale)
    +
    297  411 CONTINUE
    +
    298  END IF
    +
    299 C
    +
    300 C$ 4.2 CALL W3FI75 TO PACK DATA AND MAKE BDS.
    +
    301 C
    +
    302  CALL w3fi75(ibitl,itype,itoss,fld,ifld,ibmap,ibdsfl,
    +
    303  & npts,bds11,ipfld,pfld,len,lenbds,iberr,pds,igds)
    +
    304  IF (iberr .EQ. 1) THEN
    +
    305  jerr = 3
    +
    306  GO TO 900
    +
    307  END IF
    +
    308 C 4.3 IF D-SCALE NOT 0, RESCALE INPUT FIELD TO
    +
    309 C ORIGINAL VALUE
    +
    310 C
    +
    311  IF (jscale.NE.0) THEN
    +
    312  dscale = 1.0 / scale
    +
    313  IF (itype.EQ.0) THEN
    +
    314  DO 412 i = 1, npts
    +
    315  fld(i) = fld(i) * dscale
    +
    316  412 CONTINUE
    +
    317  ELSE
    +
    318  DO 413 i = 1, npts
    +
    319  fld(i) = nint(float(ifld(i)) * dscale)
    +
    320  413 CONTINUE
    +
    321  END IF
    +
    322  END IF
    +
    323 C
    +
    324 C$ 5.0 OUTPUT SECTION.
    +
    325 C
    +
    326 C$ 5.1 ZERO OUT THE OUTPUT ARRAY KBUF.
    +
    327 C
    +
    328  zero = char(00)
    +
    329  itot = igribl + ipdsl + lengds + lenbms + lenbds + 4
    +
    330 C PRINT *,'IGRIBL =',IGRIBL
    +
    331 C PRINT *,'IPDSL =',IPDSL
    +
    332 C PRINT *,'LENGDS =',LENGDS
    +
    333 C PRINT *,'LENBMS =',LENBMS
    +
    334 C PRINT *,'LENBDS =',LENBDS
    +
    335 C PRINT *,'ITOT =',ITOT
    +
    336 C
    +
    337 C KBUF MUST BE ON A WORD BOUNDRY, EQUIVALENCE TO AN
    +
    338 C INTEGER ARRAY IN THE MAIN PROGRAM TO MAKE SURE IT IS.
    +
    339 C THIS IS BOTH COMPUTER AND COMPILER DEPENDENT, W3FI01
    +
    340 C IS USED TO FILL OUT IF THE COMPUTER IS A 64 BIT OR
    +
    341 C 32 BIT WORD SIZE COMPUTER. LW IS SET TO 4 FOR 32 BIT
    +
    342 C COMPUTER, 8 FOR 64 BIT COMPUTER.
    +
    343 C
    +
    344  CALL w3fi01(lw)
    +
    345  iwords = itot / lw
    +
    346  CALL xstore(kbuf,0,iwords)
    +
    347  IF (mod(itot,lw).NE.0) THEN
    +
    348  ibytes = itot - iwords * lw
    +
    349  DO 510 i = 1,ibytes
    +
    350  kbuf(iwords * lw + i) = zero
    +
    351  510 CONTINUE
    +
    352  END IF
    +
    353 C
    +
    354 C$ 5.2 MOVE SECTION 0 - 'IS' INTO KBUF (8 BYTES).
    +
    355 C
    +
    356  istart = 0
    +
    357  DO 520 i = 1,4
    +
    358  kbuf(i) = char(ib(i))
    +
    359  520 CONTINUE
    +
    360 C
    +
    361  kbuf(5) = char(mod(itot / 65536,256))
    +
    362  kbuf(6) = char(mod(itot / 256,256))
    +
    363  kbuf(7) = char(mod(itot ,256))
    +
    364  kbuf(8) = char(1)
    +
    365 C
    +
    366 C$ 5.3 MOVE SECTION 1 - 'PDS' INTO KBUF (28 BYTES).
    +
    367 C
    +
    368  istart = istart + igribl
    +
    369  IF (ipdsl.GT.0) THEN
    +
    370  CALL xmovex(kbuf(istart+1),pds,ipdsl)
    +
    371  ELSE
    +
    372 C PRINT *,'LENGTH OF PDS LESS OR EQUAL 0, IPDSL = ',IPDSL
    +
    373  END IF
    +
    374 C
    +
    375 C$ 5.4 MOVE SECTION 2 - 'GDS' INTO KBUF.
    +
    376 C
    +
    377  istart = istart + ipdsl
    +
    378  IF (lengds .GT. 0) THEN
    +
    379  CALL xmovex(kbuf(istart+1),gds,lengds)
    +
    380  END IF
    +
    381 C
    +
    382 C$ 5.5 MOVE SECTION 3 - 'BMS' INTO KBUF.
    +
    383 C
    +
    384  istart = istart + lengds
    +
    385  IF (lenbms .GT. 0) THEN
    +
    386  CALL xmovex(kbuf(istart+1),bms,lenbms)
    +
    387  END IF
    +
    388 C
    +
    389 C$ 5.6 MOVE SECTION 4 - 'BDS' INTO KBUF.
    +
    390 C
    +
    391 C$ MOVE THE FIRST 11 OCTETS OF THE BDS INTO KBUF.
    +
    392 C
    +
    393  istart = istart + lenbms
    +
    394  CALL xmovex(kbuf(istart+1),bds11,11)
    +
    395 C
    +
    396 C$ MOVE THE PACKED DATA INTO THE KBUF
    +
    397 C
    +
    398  istart = istart + 11
    +
    399  IF (len.GT.0) THEN
    +
    400  CALL xmovex(kbuf(istart+1),pfld,len)
    +
    401  END IF
    +
    402 C
    +
    403 C$ ADD '7777' TO END OFF KBUF
    +
    404 C NOTE THAT THESE 4 OCTETS NOT INCLUDED IN ACTUAL SIZE OF BDS.
    +
    405 C
    +
    406  seven = char(55)
    +
    407  istart = itot - 4
    +
    408  DO 562 i = 1,4
    +
    409  kbuf(istart+i) = seven
    +
    410  562 CONTINUE
    +
    411 C
    +
    412  900 CONTINUE
    +
    413  RETURN
    +
    414  END
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    lengds
    function lengds(KGDS)
    Program history log:
    Definition: lengds.f:15
    +
    w3fi73
    subroutine w3fi73(IBFLAG, IBMAP, IBLEN, BMS, LENBMS, IER)
    This subroutine constructs a grib bit map section.
    Definition: w3fi73.f:23
    +
    w3nogds
    subroutine w3nogds(ITYPE, FLD, IFLD, IBITL, IPFLAG, ID, PDS, IGFLAG, IGRID, IGDS, ICOMP, IBFLAG, IBMAP, IBLEN, IBDSFL, NPTS, KBUF, ITOT, JERR)
    Makes a complete grib message from a user supplied array of floating point or integer data.
    Definition: w3nogds.f:125
    +
    xstore
    subroutine xstore(COUT, CON, MWORDS)
    Stores an 8-byte (fullword) value through consecutive storage locations.
    Definition: xstore.f:29
    +
    w3fi75
    subroutine w3fi75(IBITL, ITYPE, ITOSS, FLD, IFLD, IBMAP, IBDSFL, NPTS, BDS11, IPFLD, PFLD, LEN, LENBDS, IBERR, PDS, IGDS)
    This routine packs a grib field and forms octets(1-11) of the binary data section (bds).
    Definition: w3fi75.f:90
    +
    xmovex
    subroutine xmovex(OUT, IN, IBYTES)
    Definition: xmovex.f:21
    +
    w3fi74
    subroutine w3fi74(IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR)
    This subroutine constructs a GRIB grid definition section.
    Definition: w3fi74.f:19
    +
    w3fi68
    subroutine w3fi68(ID, PDS)
    Converts an array of 25, or 27 integer words into a grib product definition section (pds) of 28 bytes...
    Definition: w3fi68.f:85
    +
    w3fi71
    subroutine w3fi71(IGRID, IGDS, IERR)
    Makes a 18, 37, 55, 64, or 91 word integer array used by w3fi72() GRIB packer to make the grid descri...
    Definition: w3fi71.f:187
    +
    w3fi01
    subroutine w3fi01(LW)
    Determines the number of bytes in a full word for the particular machine (IBM or cray).
    Definition: w3fi01.f:19
    + + + + diff --git a/ver-2.10.0/w3pradat_8f.html b/ver-2.10.0/w3pradat_8f.html new file mode 100644 index 00000000..a9b1c773 --- /dev/null +++ b/ver-2.10.0/w3pradat_8f.html @@ -0,0 +1,181 @@ + + + + + + + +NCEPLIBS-w3emc: w3pradat.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3pradat.f File Reference
    +
    +
    + +

    Format a date and time into characters. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3pradat (idat, cdat)
     This subprogram forms various character strings useful in describing an NCEP absolute date and time. More...
     
    +

    Detailed Description

    +

    Format a date and time into characters.

    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition in file w3pradat.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3pradat()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine w3pradat (integer, dimension(8) idat,
    character*(*), dimension(8) cdat 
    )
    +
    + +

    This subprogram forms various character strings useful in describing an NCEP absolute date and time.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1998-01-05 Mark Iredell Initial.
    +
    Parameters
    + + + +
    [in]IDATNCEP absolute date and time (year, month, day, time zone, hour, minute, second, millisecond)
    [out]CDATStrings 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.
      • +
    +
    +
    +
    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition at line 27 of file w3pradat.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3pradat_8f.js b/ver-2.10.0/w3pradat_8f.js new file mode 100644 index 00000000..77e75b6e --- /dev/null +++ b/ver-2.10.0/w3pradat_8f.js @@ -0,0 +1,4 @@ +var w3pradat_8f = +[ + [ "w3pradat", "w3pradat_8f.html#a519f334382b52df31bbe2240584e41b6", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3pradat_8f_source.html b/ver-2.10.0/w3pradat_8f_source.html new file mode 100644 index 00000000..f16147ab --- /dev/null +++ b/ver-2.10.0/w3pradat_8f_source.html @@ -0,0 +1,146 @@ + + + + + + + +NCEPLIBS-w3emc: w3pradat.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3pradat.f
    +
    +
    +Go to the documentation of this file.
    1 
    +
    4 
    +
    26  subroutine w3pradat(idat,cdat)
    +
    27  integer idat(8)
    +
    28  character*(*) cdat(8)
    +
    29  character*10 ctmp(8)
    +
    30  character*10 cmon(12)
    +
    31  data cmon/'January ','February ','March ',
    +
    32  & 'April ','May ','June ',
    +
    33  & 'July ','August ','September ',
    +
    34  & 'October ','November ','December '/
    +
    35  character*10 cdow(7)
    +
    36  data cdow/'Sunday ','Monday ','Tuesday ',
    +
    37  & 'Wednesday ','Thursday ','Friday ',
    +
    38  & 'Saturday '/
    +
    39 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    40 ! get day of week and day of year, convert day of week and month
    +
    41 ! to english names, write other formats of date and time, and
    +
    42 ! write time zone differential in one of three ways.
    +
    43  jldayn=iw3jdn(idat(1),idat(2),idat(3))
    +
    44  call w3fs26(jldayn,jy,jm,jd,jdow,jdoy)
    +
    45  ctmp(1)=cdow(jdow)
    +
    46  ctmp(2)='********'
    +
    47  if(idat(2).ge.1.and.idat(2).le.12) ctmp(2)=cmon(idat(2))
    +
    48  write(ctmp(3),'(i2,", ",i4)') idat(3),idat(1)
    +
    49  write(ctmp(4),'(i4,"-",i2.2,"-",i2.2)') idat(1),idat(2),idat(3)
    +
    50  write(ctmp(5),'(i4,".",i3.3)') idat(1),jdoy
    +
    51  write(ctmp(6),'(i2.2,":",i2.2,":",i2.2)') idat(5),idat(6),idat(7)
    +
    52  write(ctmp(7),'(".",i3.3)') idat(8)
    +
    53  if(idat(4).eq.0) then
    +
    54  write(ctmp(8),'("UTC")')
    +
    55  elseif(mod(idat(4),100).eq.0) then
    +
    56  kh=idat(4)/100
    +
    57  write(ctmp(8),'("UTC",sp,i3.2,"h")') kh
    +
    58  else
    +
    59  kh=idat(4)/100
    +
    60  km=abs(mod(idat(4),100))
    +
    61  write(ctmp(8),'("UTC",sp,i3.2,"h",ss,i2.2,"m")') kh,km
    +
    62  endif
    +
    63  cdat=ctmp
    +
    64 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    65  end
    +
    +
    +
    w3fs26
    subroutine w3fs26(JLDAYN, IYEAR, MONTH, IDAY, IDAYWK, IDAYYR)
    Computes year (4 digits), month, day, day of week, day of year from julian day number.
    Definition: w3fs26.f:56
    +
    w3pradat
    subroutine w3pradat(idat, cdat)
    This subprogram forms various character strings useful in describing an NCEP absolute date and time.
    Definition: w3pradat.f:27
    +
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    + + + + diff --git a/ver-2.10.0/w3reddat_8f.html b/ver-2.10.0/w3reddat_8f.html new file mode 100644 index 00000000..b16730bd --- /dev/null +++ b/ver-2.10.0/w3reddat_8f.html @@ -0,0 +1,191 @@ + + + + + + + +NCEPLIBS-w3emc: w3reddat.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3reddat.f File Reference
    +
    +
    + +

    Reduce a time interval to a canonical form. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3reddat (it, rinc, dinc)
     This subprogram reduces an ncep relative time interval into one of seven canonical forms, depending on the input it value. More...
     
    +

    Detailed Description

    +

    Reduce a time interval to a canonical form.

    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition in file w3reddat.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3reddat()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3reddat ( it,
    real, dimension(5) rinc,
    real, dimension(5) dinc 
    )
    +
    + +

    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:

    + + + + + +
    Date Programmer Comment
    1998-01-05 Mark Iredell Initial.
    +
    Parameters
    + + + + +
    [in]ITRelative 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)
      • +
    +
    [in]RINCNCEP relative time interval (days, hours, minutes, seconds, milliseconds)
    [out]DINCNCEP relative time interval (days, hours, minutes, seconds, milliseconds)
    +
    +
    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition at line 86 of file w3reddat.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3reddat_8f.js b/ver-2.10.0/w3reddat_8f.js new file mode 100644 index 00000000..6420c7e0 --- /dev/null +++ b/ver-2.10.0/w3reddat_8f.js @@ -0,0 +1,4 @@ +var w3reddat_8f = +[ + [ "w3reddat", "w3reddat_8f.html#a0b2ac29ce428bb8876dca351df7fb7fb", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3reddat_8f_source.html b/ver-2.10.0/w3reddat_8f_source.html new file mode 100644 index 00000000..abe4aa87 --- /dev/null +++ b/ver-2.10.0/w3reddat_8f_source.html @@ -0,0 +1,153 @@ + + + + + + + +NCEPLIBS-w3emc: w3reddat.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3reddat.f
    +
    +
    +Go to the documentation of this file.
    1 
    +
    4 
    +
    85  subroutine w3reddat(it,rinc,dinc)
    +
    86  real rinc(5),dinc(5)
    +
    87 ! parameters for number of units in a day
    +
    88 ! and number of milliseconds in a unit
    +
    89 ! and number of next smaller units in a unit, respectively
    +
    90  integer,dimension(5),parameter:: itd=(/1,24,1440,86400,86400000/),
    +
    91  & itm=itd(5)/itd
    +
    92  integer,dimension(4),parameter:: itn=itd(2:5)/itd(1:4)
    +
    93  integer,parameter:: np=16
    +
    94  integer iinc(4),jinc(5),kinc(5)
    +
    95 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    96 ! first reduce to the first reduced form
    +
    97  iinc=floor(rinc(1:4))
    +
    98 ! convert all positive fractional parts to milliseconds
    +
    99 ! and determine canonical milliseconds
    +
    100  jinc(5)=nint(dot_product(rinc(1:4)-iinc,real(itm(1:4)))+rinc(5))
    +
    101  kinc(5)=modulo(jinc(5),itn(4))
    +
    102 ! convert remainder to seconds and determine canonical seconds
    +
    103  jinc(4)=iinc(4)+(jinc(5)-kinc(5))/itn(4)
    +
    104  kinc(4)=modulo(jinc(4),itn(3))
    +
    105 ! convert remainder to minutes and determine canonical minutes
    +
    106  jinc(3)=iinc(3)+(jinc(4)-kinc(4))/itn(3)
    +
    107  kinc(3)=modulo(jinc(3),itn(2))
    +
    108 ! convert remainder to hours and determine canonical hours
    +
    109  jinc(2)=iinc(2)+(jinc(3)-kinc(3))/itn(2)
    +
    110  kinc(2)=modulo(jinc(2),itn(1))
    +
    111 ! convert remainder to days and compute milliseconds of the day
    +
    112  kinc(1)=iinc(1)+(jinc(2)-kinc(2))/itn(1)
    +
    113  ms=dot_product(kinc(2:5),itm(2:5))
    +
    114 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    115 ! next reduce to either single value canonical form
    +
    116 ! or to one of the two reduced forms
    +
    117  if(it.ge.1.and.it.le.5) then
    +
    118 ! ensure that exact multiples of 1./np are expressed exactly
    +
    119 ! (other fractions may have precision errors)
    +
    120  rp=(np*ms)/itm(it)+mod(np*ms,itm(it))/real(itm(it))
    +
    121  dinc=0
    +
    122  dinc(it)=real(kinc(1))*itd(it)+rp/np
    +
    123  else
    +
    124 ! the reduced form is done except the second reduced form is modified
    +
    125 ! for negative time intervals with fractional days
    +
    126  dinc=kinc
    +
    127  if(it.eq.0.and.kinc(1).lt.0.and.ms.gt.0) then
    +
    128  dinc(1)=dinc(1)+1
    +
    129  dinc(2:5)=mod(ms-itm(1),itm(1:4))/itm(2:5)
    +
    130  endif
    +
    131  endif
    +
    132 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    133  end
    +
    +
    +
    w3reddat
    subroutine w3reddat(it, rinc, dinc)
    This subprogram reduces an ncep relative time interval into one of seven canonical forms,...
    Definition: w3reddat.f:86
    + + + + diff --git a/ver-2.10.0/w3tagb_8f.html b/ver-2.10.0/w3tagb_8f.html new file mode 100644 index 00000000..f72a12af --- /dev/null +++ b/ver-2.10.0/w3tagb_8f.html @@ -0,0 +1,211 @@ + + + + + + + +NCEPLIBS-w3emc: w3tagb.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3tagb.f File Reference
    +
    +
    + +

    Operational job identifier. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3tagb (PROG, KYR, JD, LF, ORG)
     Prints identifying information for operational codes. More...
     
    +

    Detailed Description

    +

    Operational job identifier.

    +
    Author
    J. Newell
    +
    Date
    1985-10-29
    + +

    Definition in file w3tagb.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3tagb()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3tagb (character *(*) PROG,
     KYR,
     JD,
     LF,
    character *(*) ORG 
    )
    +
    + +

    Prints identifying information for operational codes.

    +

    Called at the beginning of a code, w3tagb() prints the program name, the year and julian day of its compilation, and the responsible organization. On a 2nd line it prints the starting date-time. Called at the end of a job, entry routine, w3tage prints a line with the ending date-time and a 2nd line stating the program name and that it has ended.

    +

    +Program History Log:

    + + + + + + + + + + + + + + + + + + + + + +
    Date Programmer Comment
    1985-10-29 J. Newell Initial.
    1989-10-20 Ralph Jones Convert to cray cft77 fortran
    1991-03-01 Ralph Jones Add machine name to ending line
    1992-12-02 Ralph Jones Add start-ending time-date
    1993-11-16 Ralph Jones Add day of year, day of week, and julian day number.
    1997-12-24 M. Farley Print statements modified for 4-digit yr
    1998-03-17 M. Farley Replaced datimx with calls to w3locdat/w3doxdat
    1999-01-29 B. Vuong Converted to ibm rs/6000 sp
    1999-06-17 A. Spruill Adjusted the size of program name to accommodate
    +

    the 20 character name convention on the ibm sp. 1999-08-24 | Gilbert | added call to start() in w3tagb and a call to summary() in w3tage to print out a resource summary list for the program using w3tags. 2012-10-18 | Vuong | Remove print statement 604 2013-02-06 | Vuong | Modified print statement 604

    +
    Parameters
    + + + + + + +
    [in]PROGProgram name character*1
    [in]KYRYear of compilation integer
    [in]JDJulian day of compilation integer
    [in]LFHundreths of julian day of compilation integer (range is 0 to 99 inclusive)
    [in]ORGOrganization code (such as wd42) character*1
    +
    +
    +
    Remarks
    Full word used in order to have at least seven decimal digits accuracy for value of ddate. subprogram clock and date may differ for each type computer. you may have to change them for another type of computer.
    +
    Author
    J. Newell
    +
    Date
    1985-10-29
    + +

    Definition at line 47 of file w3tagb.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3tagb_8f.js b/ver-2.10.0/w3tagb_8f.js new file mode 100644 index 00000000..758641db --- /dev/null +++ b/ver-2.10.0/w3tagb_8f.js @@ -0,0 +1,4 @@ +var w3tagb_8f = +[ + [ "w3tagb", "w3tagb_8f.html#ac295260f62d3bdcf6c621177ff7d9275", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3tagb_8f_source.html b/ver-2.10.0/w3tagb_8f_source.html new file mode 100644 index 00000000..da9ad67b --- /dev/null +++ b/ver-2.10.0/w3tagb_8f_source.html @@ -0,0 +1,204 @@ + + + + + + + +NCEPLIBS-w3emc: w3tagb.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3tagb.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Operational job identifier
    +
    3 C> @author J. Newell @date 1985-10-29
    +
    4 
    +
    5 C> Prints identifying information for operational
    +
    6 C> codes. Called at the beginning of a code, w3tagb() prints
    +
    7 C> the program name, the year and julian day of its
    +
    8 C> compilation, and the responsible organization. On a 2nd
    +
    9 C> line it prints the starting date-time. Called at the
    +
    10 C> end of a job, entry routine, w3tage prints a line with the
    +
    11 C> ending date-time and a 2nd line stating the program name
    +
    12 C> and that it has ended.
    +
    13 C>
    +
    14 C> ### Program History Log:
    +
    15 C> Date | Programmer | Comment
    +
    16 C> -----|------------|--------
    +
    17 C> 1985-10-29 | J. Newell | Initial.
    +
    18 C> 1989-10-20 | Ralph Jones | Convert to cray cft77 fortran
    +
    19 C> 1991-03-01 | Ralph Jones | Add machine name to ending line
    +
    20 C> 1992-12-02 | Ralph Jones | Add start-ending time-date
    +
    21 C> 1993-11-16 | Ralph Jones | Add day of year, day of week, and julian day number.
    +
    22 C> 1997-12-24 | M. Farley | Print statements modified for 4-digit yr
    +
    23 C> 1998-03-17 | M. Farley | Replaced datimx with calls to w3locdat/w3doxdat
    +
    24 C> 1999-01-29 | B. Vuong | Converted to ibm rs/6000 sp
    +
    25 C> 1999-06-17 | A. Spruill | Adjusted the size of program name to accommodate
    +
    26 C> the 20 character name convention on the ibm sp.
    +
    27 C> 1999-08-24 | Gilbert | added call to start() in w3tagb and a call to summary() in w3tage to print out a resource summary list for the program using w3tags.
    +
    28 C> 2012-10-18 | Vuong | Remove print statement 604
    +
    29 C> 2013-02-06 | Vuong | Modified print statement 604
    +
    30 c>
    +
    31 C> @param[in] PROG Program name character*1
    +
    32 C> @param[in] KYR Year of compilation integer
    +
    33 C> @param[in] JD Julian day of compilation integer
    +
    34 C> @param[in] LF Hundreths of julian day of compilation
    +
    35 C> integer (range is 0 to 99 inclusive)
    +
    36 C> @param[in] ORG Organization code (such as wd42)
    +
    37 C> character*1
    +
    38 C>
    +
    39 C> @remark Full word used in order to have at least
    +
    40 C> seven decimal digits accuracy for value of ddate.
    +
    41 C> subprogram clock and date may differ for each type
    +
    42 C> computer. you may have to change them for another
    +
    43 C> type of computer.
    +
    44 C>
    +
    45 C> @author J. Newell @date 1985-10-29
    +
    46  SUBROUTINE w3tagb(PROG,KYR,JD,LF,ORG)
    +
    47 C
    +
    48  CHARACTER *(*) PROG,ORG
    +
    49  CHARACTER * 3 JMON(12)
    +
    50  CHARACTER * 3 DAYW(7)
    +
    51 C
    +
    52  INTEGER IDAT(8), JDOW, JDOY, JDAY
    +
    53 C
    +
    54  SAVE
    +
    55 C
    +
    56  DATA dayw/'SUN','MON','TUE','WEN','THU','FRI','SAT'/
    +
    57  DATA jmon /'JAN','FEB','MAR','APR','MAY','JUN',
    +
    58  & 'JUL','AUG','SEP','OCT','NOV','DEC'/
    +
    59 C
    +
    60  CALL start()
    +
    61 
    +
    62  dyr = kyr
    +
    63  dyr = 1.0e+03 * dyr
    +
    64  djd = jd
    +
    65  dlf = lf
    +
    66  dlf = 1.0e-02 * dlf
    +
    67  ddate = dyr + djd + dlf
    +
    68  print 600
    +
    69  600 FORMAT(//,10('* . * . '))
    +
    70  print 601, prog, ddate, org
    +
    71  601 FORMAT(5x,'PROGRAM ',a,' HAS BEGUN. COMPILED ',f10.2,
    +
    72  & 5x, 'ORG: ',a)
    +
    73 C
    +
    74  CALL w3locdat(idat)
    +
    75  CALL w3doxdat(idat,jdow,jdoy,jday)
    +
    76  print 602, jmon(idat(2)),idat(3),idat(1),idat(5),idat(6),
    +
    77  & idat(7),idat(8),jdoy,dayw(jdow),jday
    +
    78  602 FORMAT(5x,'STARTING DATE-TIME ',a3,1x,i2.2,',',
    +
    79  & i4.4,2x,2(i2.2,':'),i2.2,'.',i3.3,2x,i3,2x,a3,2x,i8,//)
    +
    80  RETURN
    +
    81 C
    +
    82  entry w3tage(prog)
    +
    83 C
    +
    84  CALL w3locdat(idat)
    +
    85  CALL w3doxdat(idat,jdow,jdoy,jday)
    +
    86  print 603, jmon(idat(2)),idat(3),idat(1),idat(5),idat(6),
    +
    87  & idat(7),idat(8),jdoy,dayw(jdow),jday
    +
    88  603 FORMAT(//,5x,'ENDING DATE-TIME ',a3,1x,i2.2,',',
    +
    89  & i4.4,2x,2(i2.2,':'),i2.2,'.',i3.3,2x,i3,2x,a3,2x,i8)
    +
    90  print 604, prog
    +
    91  604 FORMAT(5x,'PROGRAM ',a,' HAS ENDED.')
    +
    92 C 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED. CRAY J916/2048')
    +
    93 C 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED. CRAY Y-MP EL2/256')
    +
    94  print 605
    +
    95  605 FORMAT(10('* . * . '))
    +
    96 
    +
    97  CALL summary()
    +
    98 C
    +
    99  RETURN
    +
    100  END
    +
    +
    +
    w3locdat
    subroutine w3locdat(idat)
    This subprogram returns the local date and time in the ncep absolute date and time data structure.
    Definition: w3locdat.f:23
    +
    w3doxdat
    subroutine w3doxdat(idat, jdow, jdoy, jday)
    Program history log:
    Definition: w3doxdat.f:17
    +
    w3tagb
    subroutine w3tagb(PROG, KYR, JD, LF, ORG)
    Prints identifying information for operational codes.
    Definition: w3tagb.f:47
    + + + + diff --git a/ver-2.10.0/w3trnarg_8f.html b/ver-2.10.0/w3trnarg_8f.html new file mode 100644 index 00000000..37900f5b --- /dev/null +++ b/ver-2.10.0/w3trnarg_8f.html @@ -0,0 +1,232 @@ + + + + + + + +NCEPLIBS-w3emc: w3trnarg.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3trnarg.f File Reference
    +
    +
    + +

    Translates arg line from standard input. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3trnarg (SUBDIR, LSUBDR, TANKID, LTNKID, APPCHR, LAPCHR, TLFLAG, IYMDHB, IYMDHE, IERR)
     Reads argument lines from standard input and obtains subdirectory, bufr tankname, characters to append for adding an orbit, and options for limiting the time window. More...
     
    +

    Detailed Description

    +

    Translates arg line from standard input.

    +
    Author
    Dennis Keyser
    +
    Date
    2002-02-11
    + +

    Definition in file w3trnarg.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3trnarg()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3trnarg (character*(*) SUBDIR,
     LSUBDR,
    character*(*) TANKID,
     LTNKID,
    character*(*) APPCHR,
     LAPCHR,
    character*(*) TLFLAG,
     IYMDHB,
     IYMDHE,
     IERR 
    )
    +
    + +

    Reads argument lines from standard input and obtains subdirectory, bufr tankname, characters to append for adding an orbit, and options for limiting the time window.

    +

    +Program History Log:

    + + + + + + + + + +
    Date Programmer Comment
    1996-09-03 B. KATZ Original author
    1998-11-27 B. KATZ Changes for y2k and fortran 90 compliance
    2002-02-11 D. KEYSER If "tlflag" is not specified, it defaults to
    +

    "notimlim" rather than "timlim" and gross time limits will not be calculated and returned in "iymdhb" and "iymdhe"

    +
    Parameters
    + + + + + + + + + + + +
    [in]SUBDIRName of sub-directory including bufr data type where bufr data tank is located.
    [in]LSUBDRNumber of characters in 'subdir'.
    [in]TANKIDName of file including bufr data sub-type containing bufr data tank.
    [in]LTNKIDNumber of characters in 'tankid'.
    [in]APPCHRCharacters to be appended to 'tankid' giving a uniquely named file to contain the original tank with one orbit appended to it.
    [in]LAPCHRNumber of characters in 'appchr'.
    [in]TLFLAG8 character flag indicating whether time acceptance checks atre to be performed. = 'timlim ' : perform time acceptance checks. = 'notimlim' : do not perform time acceptance checks. jdate and kdate are disregarded.
    [in]IYMDHBStart of time acceptance window, in form yyyymmddhh.
    [in]IYMDHEEnd of time acceptance window, in form yyyymmddhh.
    IERRInput files : unit 05 - standard input for passing in arguments. arguments (for list-directed i/o) are as follows : record 1 - (1) subdirectory. contains bufr data type (2) tankfile. contains bufr data sub-type (3) append characters. appended to tankfile to give unique output file name. (4) date in yyyymmddhh format. next three records are optional : record 2 - (1) time limit flag. may be either 'timlim ' or 'notimlim'. see description of 'tlflag' above. (default is 'notimlim') record 3 - (1) hours before current time. record 4 - (1) hours after current time. if 'timlim ' is specified in record 2, the quantities in records 3 and 4 are used to compute the limits of the time acceptance window. if records 3 and 4 are omitted, the values default to -48 (48 hours before current time) and +12 (12 hours after current time). if 'notimlim ' is specified in record 2, then these quantities are not used regardless of whether or not they were specified.
    +
    +
    +
    Author
    Dennis Keyser
    +
    Date
    2002-02-11
    + +

    Definition at line 65 of file w3trnarg.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3trnarg_8f.js b/ver-2.10.0/w3trnarg_8f.js new file mode 100644 index 00000000..a5b20e42 --- /dev/null +++ b/ver-2.10.0/w3trnarg_8f.js @@ -0,0 +1,4 @@ +var w3trnarg_8f = +[ + [ "w3trnarg", "w3trnarg_8f.html#a469f580bad86541dc4ffe778b0eaf9bf", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3trnarg_8f_source.html b/ver-2.10.0/w3trnarg_8f_source.html new file mode 100644 index 00000000..f38546b7 --- /dev/null +++ b/ver-2.10.0/w3trnarg_8f_source.html @@ -0,0 +1,264 @@ + + + + + + + +NCEPLIBS-w3emc: w3trnarg.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3trnarg.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Translates arg line from standard input
    +
    3 C> @author Dennis Keyser @date 2002-02-11
    +
    4 
    +
    5 C> Reads argument lines from standard input and obtains subdirectory, bufr
    +
    6 C> tankname, characters to append for adding an orbit, and options for limiting
    +
    7 C> the time window.
    +
    8 C>
    +
    9 C> ### Program History Log:
    +
    10 C> Date | Programmer | Comment
    +
    11 C> -----|------------|--------
    +
    12 C> 1996-09-03 | B. KATZ | Original author
    +
    13 C> 1998-11-27 | B. KATZ | Changes for y2k and fortran 90 compliance
    +
    14 C> 2002-02-11 | D. KEYSER | If "tlflag" is not specified, it defaults to
    +
    15 C> "notimlim" rather than "timlim" and gross time limits will not be
    +
    16 C> calculated and returned in "iymdhb" and "iymdhe"
    +
    17 C>
    +
    18 C> @param[in] SUBDIR Name of sub-directory including bufr data type where
    +
    19 C> bufr data tank is located.
    +
    20 C> @param[in] LSUBDR Number of characters in 'subdir'.
    +
    21 C> @param[in] TANKID Name of file including bufr data sub-type containing
    +
    22 C> bufr data tank.
    +
    23 C> @param[in] LTNKID Number of characters in 'tankid'.
    +
    24 C> @param[in] APPCHR Characters to be appended to 'tankid' giving a
    +
    25 C> uniquely named file to contain the original tank
    +
    26 C> with one orbit appended to it.
    +
    27 C> @param[in] LAPCHR Number of characters in 'appchr'.
    +
    28 C> @param[in] TLFLAG 8 character flag indicating whether time acceptance
    +
    29 C> checks atre to be performed.
    +
    30 C> = 'timlim ' : perform time acceptance checks.
    +
    31 C> = 'notimlim' : do not perform time acceptance checks.
    +
    32 C> jdate and kdate are disregarded.
    +
    33 C> @param[in] IYMDHB Start of time acceptance window, in form yyyymmddhh.
    +
    34 C> @param[in] IYMDHE End of time acceptance window, in form yyyymmddhh.
    +
    35 C> @param IERR
    +
    36 C>
    +
    37 C> Input files :
    +
    38 C> unit 05 - standard input for passing in arguments. arguments
    +
    39 C> (for list-directed i/o) are as follows :
    +
    40 C> record 1 - (1) subdirectory. contains bufr data type
    +
    41 C> (2) tankfile. contains bufr data sub-type
    +
    42 C> (3) append characters. appended to tankfile
    +
    43 C> to give unique output file name.
    +
    44 C> (4) date in yyyymmddhh format.
    +
    45 C> next three records are optional :
    +
    46 C> record 2 - (1) time limit flag. may be either
    +
    47 C> 'timlim ' or 'notimlim'. see
    +
    48 C> description of 'tlflag' above.
    +
    49 C> (default is 'notimlim')
    +
    50 C> record 3 - (1) hours before current time.
    +
    51 C> record 4 - (1) hours after current time.
    +
    52 C> if 'timlim ' is specified in record 2, the
    +
    53 C> quantities in records 3 and 4 are used to
    +
    54 C> compute the limits of the time acceptance window.
    +
    55 C> if records 3 and 4 are omitted, the values
    +
    56 C> default to -48 (48 hours before current time)
    +
    57 C> and +12 (12 hours after current time).
    +
    58 C> if 'notimlim ' is specified in record 2, then
    +
    59 C> these quantities are not used regardless of whether
    +
    60 C> or not they were specified.
    +
    61 C>
    +
    62 C> @author Dennis Keyser @date 2002-02-11
    +
    63  SUBROUTINE w3trnarg(SUBDIR,LSUBDR,TANKID,LTNKID,APPCHR,LAPCHR,
    +
    64  1 TLFLAG,IYMDHB,IYMDHE,IERR)
    +
    65  CHARACTER*(*) SUBDIR,TANKID,APPCHR,TLFLAG
    +
    66  INTEGER IDATIN(8),IDTOUT(8)
    +
    67  REAL TIMINC(5)
    +
    68  READ(5,*,END=9999) SUBDIR,TANKID,APPCHR,iymdh
    +
    69  msubdr = len(subdir)
    +
    70  DO lsubdr=0,msubdr-1
    +
    71  IF(subdir(lsubdr+1:lsubdr+1).EQ.' ') GO TO 10
    +
    72  ENDDO
    +
    73  lsubdr = msubdr
    +
    74  10 CONTINUE
    +
    75  IF(lsubdr.LT.4) THEN
    +
    76  WRITE(6,'(1X,I2,'' CHARACTERS IN SUBDIRECTORY ARGUMENT'',
    +
    77  1 '' AT LEAST 4 CHARACTERS ARE REQUIRED'')') lsubdr
    +
    78  ierr = 2
    +
    79  RETURN
    +
    80  ENDIF
    +
    81  mtnkid = len(tankid)
    +
    82  DO ltnkid=0,mtnkid-1
    +
    83  IF(tankid(ltnkid+1:ltnkid+1).EQ.' ') GO TO 20
    +
    84  ENDDO
    +
    85  ltnkid = mtnkid
    +
    86  20 CONTINUE
    +
    87  IF(ltnkid.LT.4) THEN
    +
    88  WRITE(6,'(1X,I2,'' CHARACTERS IN TANKFILE ARGUMENT'',
    +
    89  1 '' AT LEAST 4 CHARACTERS ARE REQUIRED'')') ltnkid
    +
    90  ierr = 2
    +
    91  RETURN
    +
    92  ENDIF
    +
    93  mapchr = len(appchr)
    +
    94  DO lapchr=0,mapchr-1
    +
    95  IF(appchr(lapchr+1:lapchr+1).EQ.' ') GO TO 30
    +
    96  ENDDO
    +
    97  lapchr = mapchr
    +
    98  30 CONTINUE
    +
    99  tlflag = 'NOTIMLIM' ! The default is to NOT perform time checks
    +
    100  READ(5,*,END=40) tlflag
    +
    101  40 CONTINUE
    +
    102  IF(tlflag(1:6).NE.'TIMLIM') THEN
    +
    103  tlflag = 'NOTIMLIM'
    +
    104  print 123, iymdh,subdir(1:lsubdr),tankid(1:ltnkid)
    +
    105  123 FORMAT(/'RUN ON ',i10/'WRITE TO ',a,'/',a/'GROSS TIME LIMIT ',
    +
    106  1 'CHECKS ARE NOT PERFORMED HERE - SUBSEQUENT PROGRAM ',
    +
    107  1 'BUFR_TRANJB WILL TAKE CARE OF THIS'/)
    +
    108  iymdhb = 0000000000
    +
    109  iymdhe = 2100000000
    +
    110  ierr = 0
    +
    111  RETURN
    +
    112  ENDIF
    +
    113  tlflag(7:8) = ' '
    +
    114  READ(5,*,END=60) ihrbef
    +
    115  GO TO 70
    +
    116  60 CONTINUE
    +
    117  ihrbef = -48
    +
    118  ihraft = 12
    +
    119  GO TO 100
    +
    120  70 CONTINUE
    +
    121  READ(5,*,END=80) ihraft
    +
    122  GO TO 90
    +
    123  80 CONTINUE
    +
    124  ihraft = 12
    +
    125  GO TO 100
    +
    126  90 CONTINUE
    +
    127  IF(ihrbef.GT.0 .AND. ihraft.LT.0) THEN
    +
    128  itemp = ihrbef
    +
    129  ihrbef = ihraft
    +
    130  ihraft = itemp
    +
    131  ELSE IF(ihrbef.GT.0) THEN
    +
    132  ihrbef = -1 * ihrbef
    +
    133  ENDIF
    +
    134  100 CONTINUE
    +
    135  idatin(1) = iymdh / 1000000
    +
    136  idatin(2) = mod(iymdh,1000000) / 10000
    +
    137  idatin(3) = mod(iymdh,10000) / 100
    +
    138  idatin(4) = 0
    +
    139  idatin(5) = mod(iymdh,100)
    +
    140  idatin(6:8) = 0
    +
    141  timinc(1) = 0.0
    +
    142  timinc(2) = float(ihrbef)
    +
    143  timinc(3:5) = 0.0
    +
    144  CALL w3movdat(timinc,idatin,idtout)
    +
    145  iymdhb = ((idtout(1) * 100 + idtout(2)) * 100 + idtout(3)) *
    +
    146  1 100 + idtout(5)
    +
    147  timinc(2) = float(ihraft)
    +
    148  CALL w3movdat(timinc,idatin,idtout)
    +
    149  iymdhe = ((idtout(1) * 100 + idtout(2)) * 100 + idtout(3)) *
    +
    150  1 100 + idtout(5)
    +
    151  print 124, iymdh,subdir(1:lsubdr),tankid(1:ltnkid),iymdhb,iymdhe
    +
    152  124 FORMAT(/'RUN ON ',i10/'WRITE TO ',a,'/',a/'ACCEPT BETWEEN ',i10,
    +
    153  1 ' AND ',i10/)
    +
    154  ierr = 0
    +
    155  RETURN
    +
    156  9999 CONTINUE
    +
    157  WRITE(6,'('' INSUFFICIENT NO. OF ARGUMENTS TO BUFR '',
    +
    158  1 ''TRANSLATION PROCEDURE - AT LEAST 4 ARE NEEDED'')')
    +
    159  ierr = 1
    +
    160  RETURN
    +
    161  END
    +
    +
    +
    w3trnarg
    subroutine w3trnarg(SUBDIR, LSUBDR, TANKID, LTNKID, APPCHR, LAPCHR, TLFLAG, IYMDHB, IYMDHE, IERR)
    Reads argument lines from standard input and obtains subdirectory, bufr tankname, characters to appen...
    Definition: w3trnarg.f:65
    +
    w3movdat
    subroutine w3movdat(rinc, idat, jdat)
    This subprogram returns the date and time that is a given NCEP relative time interval from an NCEP ab...
    Definition: w3movdat.f:24
    + + + + diff --git a/ver-2.10.0/w3unpk77_8f.html b/ver-2.10.0/w3unpk77_8f.html new file mode 100644 index 00000000..1cb48d65 --- /dev/null +++ b/ver-2.10.0/w3unpk77_8f.html @@ -0,0 +1,904 @@ + + + + + + + +NCEPLIBS-w3emc: w3unpk77.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3unpk77.f File Reference
    +
    +
    + +

    Decodes single report from bufr messages. +More...

    + +

    Go to the source code of this file.

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

    +Functions/Subroutines

    subroutine unpk7701 (LUNIT, ITP, IRET)
     Reads a single report out of bufr dataset. More...
     
    subroutine unpk7702 (RDATA, ITP)
     Initializes the output array for a report. More...
     
    subroutine unpk7703 (LUNIT, RDATA, IRET)
     Fills in header in o-put array - pflr rpt. More...
     
    subroutine unpk7704 (LUNIT, RDATA)
     Fills cat.10 into o-put array - pflr rpt. More...
     
    subroutine unpk7705 (LUNIT, RDATA)
     Fills cat.11 into o-put array - pflr rpt. More...
     
    subroutine unpk7706 (LUNIT, RDATA, IRET)
     Fills in header in o-put array - vadw rpt. More...
     
    subroutine unpk7707 (LUNIT, RDATA, IRET)
     Fills cat. More...
     
    subroutine unpk7708 (LUNIT, RDATA, KOUNT, IRET)
     Fills in header in o-put array - goes snd. More...
     
    subroutine unpk7709 (LUNIT, RDATA, IRET)
     Fills cat. More...
     
    subroutine w3unpk77 (IDATE, IHE, IHL, LUNIT, RDATA, IRET)
     This subroutine decodes a single report from bufr messages in a jbufr-type data file. More...
     
    +

    Detailed Description

    +

    Decodes single report from bufr messages.

    +
    Author
    Dennis Keyser
    +
    Date
    2002-03-05
    + +

    Definition in file w3unpk77.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ unpk7701()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine unpk7701 ( LUNIT,
     ITP,
     IRET 
    )
    +
    + +

    Reads a single report out of bufr dataset.

    +
    Author
    Dennis Keyser
    +
    Date
    1996-12-16 Calls bufrlib routines to read in a bufr message and then read a single report (subset) out of the message.
    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1996-12-16 Dennis Keyser NP22 Initial.
    +
    Parameters
    + + + + +
    [in]LUNITFortran unit number for input data file.
    [out]ITPThe type of report that has been decoded {=1 - wind profiler, =2 - goes sndg, =3 - nexrad(vad) wind}
    [out]IRETReturn code as described in w3unpk77 docblock
    +
    +
    +
    Author
    Dennis Keyser
    +
    Date
    1996-12-16
    + +

    Definition at line 649 of file w3unpk77.f.

    + +
    +
    + +

    ◆ unpk7702()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine unpk7702 (real, dimension(*) RDATA,
     ITP 
    )
    +
    + +

    Initializes the output array for a report.

    +
    Author
    Dennis Keyser
    +
    Date
    1996-12-16 Initializes the output array which holds a single report in the quasi-office note 29 unpacked format to all missing.
    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1996-12-16 Dennis Keyser NP22 Initial.
    +
    Parameters
    + + + +
    [in]ITPthe type of report that has been decoded {=1 - wind profiler, =2 - goes sndg, =3 - nexrad(vad) wind}
    [out]RDATAsingle report returned an a quasi-office note 29 unpacked format; all data are missing
    +
    +
    +
    Author
    Dennis Keyser
    +
    Date
    1996-12-16
    + +

    Definition at line 800 of file w3unpk77.f.

    + +
    +
    + +

    ◆ unpk7703()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine unpk7703 ( LUNIT,
    real, dimension(*) RDATA,
     IRET 
    )
    +
    + +

    Fills in header in o-put array - pflr rpt.

    +
    Author
    Dennis Keyser
    +
    Date
    2002-03-05 For report (subset) read out of bufr message (passed in internally via bufrlib storage), calls bufrlib routine to decode header data for wind profiler report. header is then filled into the output array which holds a single wind profiler report in the quasi-office note 29 unpacked format.
    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    1996-12-16 Dennis Keyser NP22 Initial.
    2002-03-05 Dennis Keyser Accounts for changes in input proflr (wind profiler) bufr dump file after 3/2002: mnemonic "npsm" is no longer available, mnemonic "tpse" replaces "tpmi" (avg. time in minutes still output) (will still work properly for input proflr dump files prior to 3/2002)
    +
    Parameters
    + + + + +
    [in]LUNITFortran unit number for input data file
    [in,out]RDATASingle wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    [out]IRETReturn code as described in w3unpk77 docblock
    +
    +
    +
    Author
    Dennis Keyser
    +
    Date
    2002-03-05
    + +

    Definition at line 896 of file w3unpk77.f.

    + +
    +
    + +

    ◆ unpk7704()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine unpk7704 ( LUNIT,
    real, dimension(*) RDATA 
    )
    +
    + +

    Fills cat.10 into o-put array - pflr rpt.

    +
    Author
    Dennis Keyser
    +
    Date
    2002-03-05 For report (subset) read out of bufr message (passed in internally via bufrlib storage), calls bufrlib routine to decode surface data for wind profiler report. Surface data are then filled into the output array as category 10. The ouput array holds a single wind profiler report in the quasi-office note 29 unpacked format.
    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    1996-12-16 Dennis Keyser NP22 Initial.
    2002-03-05 Dennis Keyser Accounts for changes in input proflr (wind profiler) bufr dump file after 3/2002: surface data now all missing (mnemonics "pmsl", "wdir1","wspd1", "tmdb", "rehu", "reqv" no longer available) (will still work properly for input proflr dump files prior to 3/2002)
    +
    Parameters
    + + + +
    [in]LUNITFortran unit number for input data file
    [in,out]RDATASingle wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    +
    +
    +
    Remarks
    Called by subroutine w3unpkb7. after 3/2002, there is no surface data available.
    + +

    Definition at line 1116 of file w3unpk77.f.

    + +
    +
    + +

    ◆ unpk7705()

    + +
    +
    + + + + + + + + + + + + + + + + + + +
    subroutine unpk7705 ( LUNIT,
    real, dimension(*) RDATA 
    )
    +
    + +

    Fills cat.11 into o-put array - pflr rpt.

    +
    Author
    Dennis Keyser
    +
    Date
    2002-03-05 For report (subset) read out of bufr message (passed in internally via bufrlib storage), calls bufrlib routine to decode upper-air data for wind profiler report. upper-air data are then filled into the output array as category 11. the ouput array holds a single wind profiler report in the quasi-office note 29 unpacked format.
    +

    +Program History Log:

    + + + + + + + + + +
    Date Programmer Comment
    1996-12-16 Dennis Keyser NP22 Initial.
    1998-07-09 Dennis Keyser Modified wind profiler cat. 11 (height, horiz. significance, vert. significance) processing to account for updates to bufrtable mnemonics in /dcom
    2002-03-05 Dennis Keyser Accounts for changes in input proflr (wind profiler) bufr dump file after 3/2002: mnemonics "acavh", "acavv", "spp0", and "nphl" no longer available; (will still work properly for input proflr dump files prior to 3/2002)
    +
    Parameters
    + + + +
    [in]LUNITFortran unit number for input data file
    [in,out]RDATASingle wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    +
    +
    + +

    Definition at line 1222 of file w3unpk77.f.

    + +
    +
    + +

    ◆ unpk7706()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine unpk7706 ( LUNIT,
    real, dimension(*) RDATA,
     IRET 
    )
    +
    + +

    Fills in header in o-put array - vadw rpt.

    +
    Author
    Dennis Keyser
    +
    Date
    1997-06-02 For report (subset) read out of bufr message (passed in internally via bufrlib storage), calls bufrlib routine to decode header data for nexrad (vad) wind report. Header is then filled into the output array which holds a single vad wind report in the quasi-office note 29 unpacked format.
    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1997-06-02 Dennis Keyser NP22 Initial.
    +
    Parameters
    + + + + +
    [in]LUNITFortran unit number for input data file
    [in,out]RDATASingle wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    [out]IRETReturn code as described in w3unpk77 docblock
    +
    +
    +
    Author
    Dennis Keyser
    +
    Date
    1997-06-02
    + +

    Definition at line 1451 of file w3unpk77.f.

    + +
    +
    + +

    ◆ unpk7707()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine unpk7707 ( LUNIT,
    real, dimension(*) RDATA,
     IRET 
    )
    +
    + +

    Fills cat.

    +

    4 into o-put array - vadw rpt

    Author
    Dennis Keyser
    +
    Date
    1997-06-02 For report (subset) read out of bufr message (passed in internally via bufrlib storage), calls bufrlib routine to decode upper-air data for nexrad (vad) wind report. Upper-air data are then filled into the output array as category 4. The ouput array holds a single vad wind report in the quasi-office note 29 unpacked format.
    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1997-06-02 Dennis Keyser NP22 Initial.
    +
    Parameters
    + + + + +
    [in]LUNITFortran unit number for input data file
    [in,out]RDATASingle wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    [out]IRETReturn code as described in w3unpk77 docblock
    +
    +
    +
    Author
    Dennis Keyser
    +
    Date
    1997-06-02
    + +

    Definition at line 1615 of file w3unpk77.f.

    + +
    +
    + +

    ◆ unpk7708()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine unpk7708 ( LUNIT,
    real, dimension(*) RDATA,
     KOUNT,
     IRET 
    )
    +
    + +

    Fills in header in o-put array - goes snd.

    +
    Author
    Dennis Keyser
    +
    Date
    1998-07-09 For report (subset) read out of bufr message (passed in internally via bufrlib storage), calls bufrlib routine to decode header data for goes sounding report. Header is then filled into the output array which holds a single goes sounding report in the quasi-office note 29 unpacked format.
    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    1997-06-05 Dennis Keyser NP22 Initial.
    1998-07-09 Dennis Keyser Changed char. 6 of goes stnid to be unique for two different even or odd satellite id's (every other even or odd sat. id now gets same char. 6 tag)
    +
    Parameters
    + + + + + +
    [in]LUNITFortran unit number for input data file
    [in,out]RDATASingle wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    [in]KOUNTNumber of reports processed including this one
    [out]IRETReturn code as described in w3unpk77 docblock
    +
    +
    +
    Author
    Dennis Keyser
    +
    Date
    1998-07-09
    + +

    Definition at line 1794 of file w3unpk77.f.

    + +
    +
    + +

    ◆ unpk7709()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine unpk7709 ( LUNIT,
    real, dimension(*) RDATA,
     IRET 
    )
    +
    + +

    Fills cat.

    +

    12,8 to o-put array -goes sndg

    Author
    Dennis Keyser
    +
    Date
    1997-06-05 For report (subset) read out of bufr message (passed in internally via bufrlib storage), calls bufrlib routine to decode upper-air (sounding) and additional data for goes sounding. Upper- air data are then filled into the output array as category 12 (satellite sounding) and additional data are filled as category 8. The ouput array holds a single goes sounding in the quasi-office note 29 unpacked format.
    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1997-06-05 Dennis Keyser NP22 Initial.
    +
    Parameters
    + + + + +
    [in]LUNITFortran unit number for input data file
    [in,out]RDATASingle wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    [out]IRETReturn code as described in w3unpk77 docblock
    +
    +
    +
    Author
    Dennis Keyser
    +
    Date
    1997-06-05
    + +

    Definition at line 2021 of file w3unpk77.f.

    + +
    +
    + +

    ◆ w3unpk77()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3unpk77 (integer, dimension(4) IDATE,
     IHE,
     IHL,
     LUNIT,
    real, dimension(*) RDATA,
     IRET 
    )
    +
    + +

    This subroutine decodes a single report from bufr messages in a jbufr-type data file.

    +

    Currently wind profiler, nexrad (vad) wind and goes sounding/radiance data types are valid. Report is returned in quasi-office note 29 unpacked format (see remarks 4.).

    +

    +Program History Log:

    + + + + + + + + + + + +
    Date Programmer Comment
    1996-12-16 Dennis Keyser Original author (based on w3lib routine w3fi77)
    1997-06-02 Dennis Keyser Added nexrad (vad) wind data type
    1997-06-16 Dennis Keyser Added goes sounding/radiance data type
    1997-09-18 Dennis Keyser Added instrument data used in processing,
    +

    solar zenith angle, and satellite zenith angle to list of parameters returned from goes sounding/radiance data type 1998-07-09 | Dennis Keyser | Modified wind profiler cat. 11 (height, horiz. significance, vert. significance) to account for updates to bufrtable mnemonics in /dcom; changed char. 6 of goes stnid to be unique for two different even or odd satellite id's (every other even or odd sat. id now gets same char. 6 tag) 1998-08-19 | Dennis Keyser | Subroutine now y2k and fortran 90 compliant 1999-03-16 | Dennis Keyser | Incorporated bob kistler's changes needed to port the code to the ibm sp 1999-05-17 | Dennis Keyser | Made changes necessary to port this routine to the ibm sp 1999-09-26 | Dennis Keyser | Changes to make code more portable 2002-03-05 | Dennis Keyser | Accounts for changes in input proflr (wind profiler) bufr dump file after 3/2002: cat. 10 surface data now all missing (mnemonics "pmsl", "wdir1","wspd1", "tmdb", "rehu", "reqv" no longer available); cat. 11 mnemonics "acavh", "acavv", "spp0", and "nphl" no longer available; header mnemonic "npsm" is no longer available, header mnemonic "tpse" replaces "tpmi" (avg. time in minutes still output); number of upper-air levels incr. from 43 to up to 64 (size of output "rdata" array incr. from 600 to 1200 to account for this) (will still work properly for input proflr dump files prior to 3/2002)

    +
    Parameters
    + + + + + + + +
    [in]IDATE4-word array holding "central" date to process (yyyy, mm, dd, hh)
    [in]IHENumber of whole hours relative to "idate" for date of earliest bufr message that is to be decoded; earliest date is "idate" + "ihe" hours (if "ihe" is positive, latest message date is after "idate"; if "ihe" is negative latest message date is prior to "idate") example: if ihe=1, then earliest date is 1-hr after idate; if ihe=-3, then earliest date is 3-hr prior to idate
    [in]IHLNumber of whole hours relative to "idate" for date of latest bufr message that is to be decoded; latest date is "idate" + ("ihl" hours plus 59 min) if "ihl" is positive (latest message date is after "idate"), and "idate" + ("ihl"+1 hours minus 1 min) if "ihl" is negative (latest message date is prior to "idate") example: if ihl=3, then latest date is 3-hr 59-min after idate; if ihl=-2, then latest date is 1-hr 1-min prior to idate
    [in]LUNITFortran unit number for input data file
    [out]RDATASingle report returned an a quasi-office note 29 unpacked format (see remarks 4.) (minimum size is 1200 words)
    [in,out]IRET[in] Controls degree of unit 6 printout (.ge. 0 -limited printout; = -1 some additional diagnostic printout; = .lt. -1 -extensive printout) (see remarks 3.) [out] Return code as follows:
      +
    • IRET = 0 —> Report successfully returned
      • +
    • IRET > 0 —> No report returned due to:
        +
      • = 1 —> All reports read in, end
        • +
      • = 2 —> Lat and/or lon data missing
        • +
      • = 3 —> Reserved
        • +
      • = 4 —> Some/all date information missing
        • +
      • = 5 —> No data levels processed (all levels are missing)
        • +
      • = 6 —> Number of levels in report header is not 1
        • +
      • = 7 —> Number of levels in another single level sequence is not 1
        • +
      +
      • +
    +
    +
    +
    +
    Remarks
      +
    • 1 A condition code (stop) of 15 will occur if the input dates for start and/or stop time are specified incorrectly.
      • +
    • 2 A condition code (stop) of 22 will occur if the characters on this machine are neither ascii nor ebcdic.
      • +
    • 3 The input argument "iret" should be set prior to each call to this subroutine.
      • +
    +
    +
    +

    4) BELOW IS THE FORMAT OF AN UNPACKED REPORT IN OUTPUT ARRAY RDATA (EACH WORD REPRESENTS A FULL-WORD ACCORDING TO THE MACHINE) N O T E : THIS IS THE SAME FORMAT AS FOR W3LIB ROUTINE W3FI77 EXCEPT WHERE NOTED

    +
    +

    +FORMAT FOR WIND PROFILER REPORTS

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    WORD CONTENT UNIT FORMAT
    1 LATITUDE 0.01 DEGREES REAL
    2 LONGITUDE 0.01 DEGREES WEST REAL
    3 TIME SIGNIFICANCE (BUFR CODE TABLE "0 08 021") INTEGER
    4 OBSERVATION TIME 0.01 HOURS (UTC) REAL
    5 YEAR/MONTH 4-CHAR. 'YYMM' LEFT-JUSTIFIED CHARACTER
    6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER
    7 STATION ELEVATION METERS REAL
    8 SUBMODE/EDITION NO. (SM X 10) + ED. NO. (ED. NO.=2, CONSTANT; SEE &,~) INTEGER
    9 REPORT TYPE 71 (CONSTANT) INTEGER
    10 AVERAGING TIME MINUTES (NEGATIVE MEANS PRIOR TO OBS. TIME) INTEGER
    11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS LEFT-JUSTIFIED CHARACTER
    12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS LEFT-JUSTIFIED CHARACTER
    13-34 ZEROED OUT - NOT USED INTEGER
    35 CATEGORY 10, NO. LEVELS COUNT INTEGER
    36 CATEGORY 10, DATA INDEX COUNT INTEGER
    37 CATEGORY 11, NO. LEVELS COUNT INTEGER
    38 CATEGORY 11, DATA INDEX COUNT INTEGER
    39-42 ZEROED OUT - NOT USED INTEGER
    43-END UNPACKED DATA GROUPS (FOLLOWS) REAL
    +

    +CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)

    + + + + + + + + + + + + + + + + + +
    WORD PARAMETER UNITS FORMAT
    (SEE @)1 SEA-LEVEL PRESSURE 0.1 MILLIBARS REAL
    (SEE *)2 STATION PRESSURE 0.1 MILLIBARS REAL
    (SEE @)3 HORIZ. WIND DIR. DEGREES REAL
    (SEE @)4 HORIZ. WIND SPEED 0.1 M/S REAL
    (SEE @)5 AIR TEMPERATURE 0.1 DEGREES K REAL
    (SEE @)6 RELATIVE HUMIDITY PERCENT REAL
    (SEE @)7 RAINFALL RATE 0.0000001 M/S REAL
    +

    +CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)

    + + + + + + + + + + + + + + + + + + + + + +
    WORD PARAMETER UNITS FORMAT
    1 HEIGHT ABOVE SEA-LVL METERS REAL
    2 HORIZ. WIND DIR. DEGREES REAL
    3 HORIZ. WIND SPEED 0.1 M/S REAL
    4 QUALITY CODE (SEE %) INTEGER
    5 VERT. WIND COMP. (W) 0.01 M/S REAL
    (SEE @)6 HORIZ. CONSENSUS NO. (SEE $) INTEGER
    (SEE @)7 VERT. CONSENSUS NO. (SEE $) INTEGER
    (SEE @)8 SPECTRAL PEAK POWER DB REAL
    9 HORIZ. WIND SPEED 0.1 M/S REAL
    +

    | STANDARD DEVIATION | 0.1 M/S | REAL 10 | VERT. WIND COMPONENT | 0.1 M/S | REAL | STANDARD DEVIATION | 0.1 M/S | REAL (SEE @)11 | MODE | (SEE #) | INTEGER

    +

    SEE:
    +
      +
    • *- ALWAYS MISSING
      • +
    • &- THIS IS A CHANGE FROM FORMAT IN W3LIB ROUTINE W3FI77
      • +
    • %- 0 - MEDIAN AND SHEAR CHECKS BOTH PASSED
        +
      • 2 - MEDIAN AND SHEAR CHECK RESULTS INCONCLUSIVE
        • +
      • 4 - MEDIAN CHECK PASSED; SHEAR CHECK FAILED
        • +
      • 8 - MEDIAN CHECK FAILED; SHEAR CHECK PASSED
        • +
      • 12 - MEDIAN AND SHEAR CHECKS BOTH FAILED
        • +
      +
      • +
    • $- NO. OF INDIVIDUAL 6-MINUTE AVERAGE MEASUREMENTS THAT WERE INCLUDED IN FINAL ESTIMATE OF AVERAGED WIND (RANGE: 0, 2-10) (BASED ON A ONE-HOUR AVERAGE)
      • +
    • #- 1 - DATA FROM LOW MODE 2 - DATA FROM HIGH MODE 3 - MISSING
      • +
    • - THIS PARAMETER IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET TO MISSING (99999 FOR INTEGER OR 99999. FOR REAL)
      • +
    • ~- SUBMODE IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET TO 3 (ITS MISSING VALUE)
      • +
    +

    XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX FORMAT FOR GOES SOUNDING/RADIANCE REPORTS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX HEADER WORD CONTENT UNIT FORMAT

    +
    +

    1 LATITUDE 0.01 DEGREES REAL 2 LONGITUDE 0.01 DEGREES WEST REAL 3 FIELD OF VIEW NUMBER NUMERIC INTEGER 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL vvvvvdak port 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER aaaaadak port LEFT-JUSTIFIED 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER 7 STATION ELEVATION METERS REAL 8 PROCESS. TECHNIQUE (=21-CLEAR; INTEGER 8 PROCESS. TECHNIQUE =23-CLOUD-CORRECTED) 9 REPORT TYPE 61 (CONSTANT) INTEGER 10 QUALITY FLAG (BUFR CODE TABLE "0 33 002") INTEGER 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER LEFT-JUSTIFIED 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER LEFT-JUSTIFIED (SEE %)

    +

    13-26 ZEROED OUT - NOT USED 27 CATEGORY 08, NO. LEVELS COUNT INTEGER 28 CATEGORY 08, DATA INDEX COUNT INTEGER 29-38 ZEROED OUT - NOT USED 39 CATEGORY 12, NO. LEVELS COUNT INTEGER 40 CATEGORY 12, DATA INDEX COUNT INTEGER 41 CATEGORY 13, NO. LEVELS COUNT INTEGER 42 CATEGORY 13, DATA INDEX COUNT INTEGER

    +

    43-END UNPACKED DATA GROUPS (FOLLOWS) REAL

    +

    CATEGORY 12 - SATELLITE SOUNDING LEVEL DATA (FIRST LEVEL IS SURFACE; EACH LEVEL, SEE 39 ABOVE) WORD PARAMETER UNITS FORMAT

    +
    +

    1 PRESSURE 0.1 MILLIBARS REAL 2 GEOPOTENTIAL METERS REAL 3 TEMPERATURE 0.1 DEGREES C REAL 4 DEWPOINT TEMPERATURE 0.1 DEGREES C REAL 5 NOT USED SET TO MISSING REAL 6 NOT USED SET TO MISSING REAL 7 QUALITY MARKERS 4-CHARACTERS CHARACTER LEFT-JUSTIFIED (SEE &)

    +

    CATEGORY 13 - SATELLITE RADIANCE "LEVEL" DATA (EACH "LEVEL", SEE 41 ABOVE) WORD PARAMETER UNITS FORMAT

    +
    +

    1 CHANNEL NUMBER NUMERIC INTEGER 2 BRIGHTNESS TEMP. 0.01 DEG. KELVIN REAL 3 QUALITY MARKERS 4-CHARACTERS CHARACTER LEFT-JUSTIFIED (SEE &&)

    +

    CATEGORY 08 - ADDITIONAL (MISCELLANEOUS) DATA (EACH LEVEL, SEE @ BELOW) WORD PARAMETER UNITS FORMAT

    +
    +

    1 VARIABLE SEE @ BELOW REAL 2 CODE FIGURE SEE @ BELOW REAL 3 MARKERS 2-CHARACTERS CHARACTER LEFT-JUSTIFIED (SEE #)

    +

    %- SIXTH CHARACTER OF STATION ID IS A TAGGED AS FOLLOWS: "I" - GOES-EVEN-1 (252, 256, ...) SAT. , CLEAR COLUMN RETR. "J" - GOES-EVEN-1 (252, 256, ...) SAT. , CLD-CORRECTED RETR. "L" - GOES-ODD-1 (253, 257, ...) SAT. , CLEAR COLUMN RETR. "M" - GOES-ODD-1 (253, 257, ...) SAT. , CLD-CORRECTED RETR. "O" - GOES-EVEN-2 (254, 258, ...) SAT. , CLEAR COLUMN RETR. "P" - GOES-EVEN-2 (254, 258, ...) SAT. , CLD-CORRECTED RETR. "Q" - GOES-ODD-2 (251, 255, ...) SAT. , CLEAR COLUMN RETR. "R" - GOES-ODD-2 (251, 255, ...) SAT. , CLD-CORRECTED RETR. "?" - EITHER SATELLITE AND/OR RETRIEVAL TYPE UNKNOWN &- FIRST CHARACTER IS Q.M. FOR GEOPOTENTIAL SECOND CHARACTER IS Q.M. FOR TEMPERATURE THIRD CHARACTER IS Q.M. FOR DEWPOINT TEMPERATURE FOURTH CHARACTER IS NOT USED " " - INDICATES DATA NOT SUSPECT "Q" - INDICATES DATA ARE SUSPECT "F" - INDICATES DATA ARE BAD &&- FIRST CHARACTER IS Q.M. FOR BRIGHTNESS TEMPERATURE SECOND-FOURTH CHARACTERS ARE NOT USED " " - INDICATES DATA NOT SUSPECT "Q" - INDICATES DATA ARE SUSPECT "F" - INDICATES DATA ARE BAD - NUMBER OF "LEVELS" FROM WORD 27. MAXIMUM IS 12, AND ARE ORDERED AS FOLLOWS (IF A DATUM ARE MISSING THAT LEVEL NOT STORED) 1 - LIFTED INDEX -------— .01 DEG. KELVIN – C. FIG. 250. 2 - TOTAL PRECIP. WATER – .01 MILLIMETERS – C. FIG. 251. 3 - 1. TO .9 SIGMA P.WATER- .01 MILLIMETERS – C. FIG. 252. 4 - .9 TO .7 SIGMA P.WATER- .01 MILLIMETERS – C. FIG. 253. 5 - .7 TO .3 SIGMA P.WATER- .01 MILLIMETERS – C. FIG. 254. 6 - SKIN TEMPERATURE --— .01 DEG. KELVIN – C. FIG. 255. 7 - CLOUD TOP TEMPERATURE- .01 DEG. KELVIN – C. FIG. 256. 8 - CLOUD TOP PRESSURE — .1 MILLIBARS --— C. FIG. 257. 9 - CLOUD AMOUNT (BUFR TBL. C.T. 0-20-011) – C. FIG. 258. 10 - INSTR. DATA USED IN PROC. (BUFR TBL. C.T. 0-02-021) – C. FIG. 259. 11 - SOLAR ZENITH ANGLE — .01 DEGREE ----— C. FIG. 260. 12 - SAT. ZENITH ANGLE -— .01 DEGREE ----— C. FIG. 261. #- FIRST CHARACTER IS Q.M. FOR THE DATUM " " - INDICATES DATA NOT SUSPECT "Q" - INDICATES DATA ARE SUSPECT "F" - INDICATES DATA ARE BAD SECOND CHARACTER IS NOT USED

    +

    XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX FORMAT FOR NEXRAD (VAD) WIND REPORTS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX HEADER WORD CONTENT UNIT FORMAT

    +
    +

    1 LATITUDE 0.01 DEGREES REAL 2 LONGITUDE 0.01 DEGREES WEST REAL 3 ** RESERVED ** SET TO 99999 INTEGER 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL vvvvvdak port 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER aaaaadak port LEFT-JUSTIFIED 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER 7 STATION ELEVATION METERS REAL 8 ** RESERVED ** SET TO 99999 INTEGER

    +

    9 REPORT TYPE 72 (CONSTANT) INTEGER 10 ** RESERVED ** SET TO 99999 INTEGER 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER LEFT-JUSTIFIED 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER LEFT-JUSTIFIED

    +

    13-18 ZEROED OUT - NOT USED INTEGER 19 CATEGORY 04, NO. LEVELS COUNT INTEGER 20 CATEGORY 04, DATA INDEX COUNT INTEGER 21-42 ZEROED OUT - NOT USED INTEGER

    +

    43-END UNPACKED DATA GROUPS (FOLLOWS) REAL

    +

    CATEGORY 04 - UPPER-AIR WINDS-BY-HEIGHT DATA(FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 19 ABOVE) WORD PARAMETER UNITS FORMAT

    +
    +

    1 HEIGHT ABOVE SEA-LVL METERS REAL 2 HORIZ. WIND DIR. DEGREES REAL 3 HORIZ. WIND SPEED 0.1 M/S (SEE *) REAL 4 QUALITY MARKERS 4-CHARACTERS CHARACTER LEFT-JUSTIFIED (SEE %)

    +

    *- UNITS HERE DIFFER FROM THOSE IN TRUE UNPACKED OFFICE NOTE 29 (WHERE UNITS ARE KNOTS) %- THE FIRST THREE CHARACTERS ARE ALWAYS BLANK, THE FOURTH CHARACTER IS A "CONFIDENCE LEVEL" WHICH IS RELATED TO THE ROOT- MEAN-SQUARE VECTOR ERROR FOR THE HORIZONTAL WIND. IT IS DEFINED AS FOLLOWS: 'A' = RMS OF 1.9 KNOTS 'B' = RMS OF 3.9 KNOTS 'C' = RMS OF 5.8 KNOTS 'D' = RMS OF 7.8 KNOTS 'E' = RMS OF 9.7 KNOTS 'F' = RMS OF 11.7 KNOTS 'G' = RMS > 13.6 KNOTS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

    +

    FOR ALL REPORT TYPES, MISSING VALUES ARE:

      +
    1. FOR REAL 99999 FOR INTEGER 9'S FOR CHARACTERS IN WORD 5, 6 OF HEADER BLANK FOR CHARACTERS IN WORD 11, 12 OF HEADER AND FOR CHARACTERS IN ANY CATEGORY LEVEL
      2. +
    +
    Author
    Dennis Keyser
    +
    Date
    2002-03-05
    + +

    Definition at line 346 of file w3unpk77.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3unpk77_8f.js b/ver-2.10.0/w3unpk77_8f.js new file mode 100644 index 00000000..a32ee629 --- /dev/null +++ b/ver-2.10.0/w3unpk77_8f.js @@ -0,0 +1,13 @@ +var w3unpk77_8f = +[ + [ "unpk7701", "w3unpk77_8f.html#ab50a57de79ddc4377c2c17512e58c6ea", null ], + [ "unpk7702", "w3unpk77_8f.html#affac66f51c4a903f7e20d643da19f4df", null ], + [ "unpk7703", "w3unpk77_8f.html#ab7a2a42f29d7122f4273548568b0168a", null ], + [ "unpk7704", "w3unpk77_8f.html#a9589ef1331e503fdbdc2ff306ae60143", null ], + [ "unpk7705", "w3unpk77_8f.html#a83668f95551d6806db9d28f6ce577f22", null ], + [ "unpk7706", "w3unpk77_8f.html#a4196e848ecd6558e30a6c0617a35737c", null ], + [ "unpk7707", "w3unpk77_8f.html#a87aaaaef2fb86ea98c45d5c206961033", null ], + [ "unpk7708", "w3unpk77_8f.html#ab038d6f2a6c28d162b38828264552068", null ], + [ "unpk7709", "w3unpk77_8f.html#a38fd0aaaeb7ad9a2f9f9453afc11cd1e", null ], + [ "w3unpk77", "w3unpk77_8f.html#a162c40d765efa43eeae668a6af507843", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3unpk77_8f_source.html b/ver-2.10.0/w3unpk77_8f_source.html new file mode 100644 index 00000000..107df2f7 --- /dev/null +++ b/ver-2.10.0/w3unpk77_8f_source.html @@ -0,0 +1,2482 @@ + + + + + + + +NCEPLIBS-w3emc: w3unpk77.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3unpk77.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Decodes single report from bufr messages
    +
    3 C> @author Dennis Keyser @date 2002-03-05
    +
    4 
    +
    5 C> This subroutine decodes a single report from bufr messages
    +
    6 C> in a jbufr-type data file. Currently wind profiler, nexrad (vad)
    +
    7 C> wind and goes sounding/radiance data types are valid. Report is
    +
    8 C> returned in quasi-office note 29 unpacked format (see remarks 4.).
    +
    9 C>
    +
    10 C> ### Program History Log:
    +
    11 C> Date | Programmer | Comment
    +
    12 C> -----|------------|--------
    +
    13 C> 1996-12-16 | Dennis Keyser | Original author (based on w3lib routine w3fi77)
    +
    14 C> 1997-06-02 | Dennis Keyser | Added nexrad (vad) wind data type
    +
    15 C> 1997-06-16 | Dennis Keyser | Added goes sounding/radiance data type
    +
    16 C> 1997-09-18 | Dennis Keyser | Added instrument data used in processing,
    +
    17 C> solar zenith angle, and satellite zenith angle
    +
    18 C> to list of parameters returned from goes
    +
    19 C> sounding/radiance data type
    +
    20 C> 1998-07-09 | Dennis Keyser | Modified wind profiler cat. 11 (height, horiz.
    +
    21 C> significance, vert. significance) to account
    +
    22 C> for updates to bufrtable mnemonics in /dcom;
    +
    23 C> changed char. 6 of goes stnid to be unique for
    +
    24 C> two different even or odd satellite id's
    +
    25 C> (every other even or odd sat. id now gets same
    +
    26 C> char. 6 tag)
    +
    27 C> 1998-08-19 | Dennis Keyser | Subroutine now y2k and fortran 90 compliant
    +
    28 C> 1999-03-16 | Dennis Keyser | Incorporated bob kistler's changes needed
    +
    29 C> to port the code to the ibm sp
    +
    30 C> 1999-05-17 | Dennis Keyser | Made changes necessary to port this routine to
    +
    31 C> the ibm sp
    +
    32 C> 1999-09-26 | Dennis Keyser | Changes to make code more portable
    +
    33 C> 2002-03-05 | Dennis Keyser | Accounts for changes in input proflr (wind
    +
    34 C> profiler) bufr dump file after 3/2002: cat. 10
    +
    35 C> surface data now all missing (mnemonics "pmsl",
    +
    36 C> "wdir1","wspd1", "tmdb", "rehu", "reqv" no
    +
    37 C> longer available); cat. 11 mnemonics "acavh",
    +
    38 C> "acavv", "spp0", and "nphl" no longer
    +
    39 C> available; header mnemonic "npsm" is no longer
    +
    40 C> available, header mnemonic "tpse" replaces
    +
    41 C> "tpmi" (avg. time in minutes still output);
    +
    42 C> number of upper-air levels incr. from 43 to up
    +
    43 C> to 64 (size of output "rdata" array incr. from
    +
    44 C> 600 to 1200 to account for this) (will still
    +
    45 C> work properly for input proflr dump files prior
    +
    46 C> to 3/2002)
    +
    47 C>
    +
    48 C> @param[in] IDATE 4-word array holding "central" date to process (yyyy, mm, dd, hh)
    +
    49 C> @param[in] IHE Number of whole hours relative to "idate" for date of
    +
    50 C> earliest bufr message that is to be decoded; earliest date is "idate" +
    +
    51 C> "ihe" hours (if "ihe" is positive, latest message date is after "idate";
    +
    52 C> if "ihe" is negative latest message date is prior to "idate") example:
    +
    53 C> if ihe=1, then earliest date is 1-hr after idate; if ihe=-3, then earliest
    +
    54 C> date is 3-hr prior to idate
    +
    55 C> @param[in] IHL Number of whole hours relative to "idate" for date of
    +
    56 C> latest bufr message that is to be decoded; latest date is "idate" + ("ihl"
    +
    57 C> hours plus 59 min) if "ihl" is positive (latest message date is after
    +
    58 C> "idate"), and "idate" + ("ihl"+1 hours minus 1 min) if "ihl" is negative
    +
    59 C> (latest message date is prior to "idate") example: if ihl=3, then latest
    +
    60 C> date is 3-hr 59-min after idate; if ihl=-2, then latest date is 1-hr 1-min
    +
    61 C> prior to idate
    +
    62 C> @param[in] LUNIT Fortran unit number for input data file
    +
    63 C> @param[out] RDATA Single report returned an a quasi-office note 29 unpacked
    +
    64 C> format (see remarks 4.) (minimum size is 1200 words)
    +
    65 C> @param[inout] IRET [in] Controls degree of unit 6 printout (.ge. 0 -limited
    +
    66 C> printout; = -1 some additional diagnostic printout; = .lt. -1 -extensive
    +
    67 C> printout) (see remarks 3.)
    +
    68 C> [out] Return code as follows:
    +
    69 C> - IRET = 0 ---> Report successfully returned
    +
    70 C> - IRET > 0 ---> No report returned due to:
    +
    71 C> - = 1 ---> All reports read in, end
    +
    72 C> - = 2 ---> Lat and/or lon data missing
    +
    73 C> - = 3 ---> Reserved
    +
    74 C> - = 4 ---> Some/all date information missing
    +
    75 C> - = 5 ---> No data levels processed (all levels are missing)
    +
    76 C> - = 6 ---> Number of levels in report header is not 1
    +
    77 C> - = 7 ---> Number of levels in another single level sequence is not 1
    +
    78 C>
    +
    79 C> @remark
    +
    80 C> - 1 A condition code (stop) of 15 will occur if the input
    +
    81 C> dates for start and/or stop time are specified incorrectly.
    +
    82 C> - 2 A condition code (stop) of 22 will occur if the
    +
    83 C> characters on this machine are neither ascii nor ebcdic.
    +
    84 C> - 3 The input argument "iret" should be set prior to each
    +
    85 C> call to this subroutine.
    +
    86 C>
    +
    87 C> ***************************************************************
    +
    88 C> 4)
    +
    89 C> BELOW IS THE FORMAT OF AN UNPACKED REPORT IN OUTPUT ARRAY RDATA
    +
    90 C> (EACH WORD REPRESENTS A FULL-WORD ACCORDING TO THE MACHINE)
    +
    91 C> N O T E : THIS IS THE SAME FORMAT AS FOR W3LIB ROUTINE W3FI77
    +
    92 C> EXCEPT WHERE NOTED
    +
    93 C> ***************************************************************
    +
    94 C>
    +
    95 C> #### FORMAT FOR WIND PROFILER REPORTS
    +
    96 C> WORD | CONTENT | UNIT | FORMAT
    +
    97 C> ---- | --------------------- | ------------------- | ---------
    +
    98 C> 1 | LATITUDE | 0.01 DEGREES | REAL
    +
    99 C> 2 | LONGITUDE | 0.01 DEGREES WEST | REAL
    +
    100 C> 3 | TIME SIGNIFICANCE | (BUFR CODE TABLE "0 08 021") | INTEGER
    +
    101 C> 4 | OBSERVATION TIME | 0.01 HOURS (UTC) | REAL
    +
    102 C> 5 | YEAR/MONTH | 4-CHAR. 'YYMM' LEFT-JUSTIFIED | CHARACTER
    +
    103 C> 6 | DAY/HOUR | 4-CHARACTERS 'DDHH' | CHARACTER
    +
    104 C> 7 | STATION ELEVATION | METERS | REAL
    +
    105 C> 8 | SUBMODE/EDITION NO. | (SM X 10) + ED. NO. (ED. NO.=2, CONSTANT; SEE &,~) | INTEGER
    +
    106 C> 9 | REPORT TYPE | 71 (CONSTANT) | INTEGER
    +
    107 C> 10 | AVERAGING TIME | MINUTES (NEGATIVE MEANS PRIOR TO OBS. TIME) | INTEGER
    +
    108 C> 11 | STN. ID. (FIRST 4 CHAR.) | 4-CHARACTERS LEFT-JUSTIFIED| CHARACTER
    +
    109 C> 12 | STN. ID. (LAST 2 CHAR.) | 2-CHARACTERS LEFT-JUSTIFIED| CHARACTER
    +
    110 C> 13-34 | ZEROED OUT - NOT USED | | INTEGER
    +
    111 C> 35 | CATEGORY 10, NO. LEVELS | COUNT | INTEGER
    +
    112 C> 36 | CATEGORY 10, DATA INDEX | COUNT | INTEGER
    +
    113 C> 37 | CATEGORY 11, NO. LEVELS | COUNT | INTEGER
    +
    114 C> 38 | CATEGORY 11, DATA INDEX | COUNT | INTEGER
    +
    115 C> 39-42 | ZEROED OUT - NOT USED | | INTEGER
    +
    116 C> 43-END | UNPACKED DATA GROUPS | (FOLLOWS) | REAL
    +
    117 C>
    +
    118 C> #### CATEGORY 10 - WIND PROFILER SFC DATA (EACH LEVEL, SEE WORD 35 ABOVE)
    +
    119 C> WORD | PARAMETER | UNITS | FORMAT
    +
    120 C> ---- | --------- | ----------------- | -------------
    +
    121 C>(SEE @)1 | SEA-LEVEL PRESSURE | 0.1 MILLIBARS | REAL
    +
    122 C>(SEE *)2 | STATION PRESSURE | 0.1 MILLIBARS | REAL
    +
    123 C>(SEE @)3 | HORIZ. WIND DIR. | DEGREES | REAL
    +
    124 C>(SEE @)4 | HORIZ. WIND SPEED | 0.1 M/S | REAL
    +
    125 C>(SEE @)5 | AIR TEMPERATURE | 0.1 DEGREES K | REAL
    +
    126 C>(SEE @)6 | RELATIVE HUMIDITY | PERCENT | REAL
    +
    127 C>(SEE @)7 | RAINFALL RATE | 0.0000001 M/S | REAL
    +
    128 C>
    +
    129 C> #### CATEGORY 11 - WIND PROFILER UPPER-AIR DATA (FIRST LEVEL IS SURFACE) (EACH LEVEL, SEE WORD 37 ABOVE)
    +
    130 C> WORD | PARAMETER | UNITS | FORMAT
    +
    131 C> ---- | --------- | ----------------- | -------------
    +
    132 C> 1 | HEIGHT ABOVE SEA-LVL | METERS | REAL
    +
    133 C> 2 | HORIZ. WIND DIR. | DEGREES | REAL
    +
    134 C> 3 | HORIZ. WIND SPEED | 0.1 M/S | REAL
    +
    135 C> 4 | QUALITY CODE | (SEE %) | INTEGER
    +
    136 C> 5 | VERT. WIND COMP. (W) | 0.01 M/S | REAL
    +
    137 C>(SEE @)6 | HORIZ. CONSENSUS NO. | (SEE $) | INTEGER
    +
    138 C>(SEE @)7 | VERT. CONSENSUS NO. | (SEE $) | INTEGER
    +
    139 C>(SEE @)8 | SPECTRAL PEAK POWER | DB | REAL
    +
    140 C> 9 | HORIZ. WIND SPEED | 0.1 M/S | REAL
    +
    141 C> | STANDARD DEVIATION | 0.1 M/S | REAL
    +
    142 C> 10 | VERT. WIND COMPONENT | 0.1 M/S | REAL
    +
    143 C> | STANDARD DEVIATION | 0.1 M/S | REAL
    +
    144 C>(SEE @)11 | MODE | (SEE #) | INTEGER
    +
    145 C>
    +
    146 C> ##### SEE:
    +
    147 C> - *- ALWAYS MISSING
    +
    148 C> - &- THIS IS A CHANGE FROM FORMAT IN W3LIB ROUTINE W3FI77
    +
    149 C> - %- 0 - MEDIAN AND SHEAR CHECKS BOTH PASSED
    +
    150 C> - 2 - MEDIAN AND SHEAR CHECK RESULTS INCONCLUSIVE
    +
    151 C> - 4 - MEDIAN CHECK PASSED; SHEAR CHECK FAILED
    +
    152 C> - 8 - MEDIAN CHECK FAILED; SHEAR CHECK PASSED
    +
    153 C> - 12 - MEDIAN AND SHEAR CHECKS BOTH FAILED
    +
    154 C> - $- NO. OF INDIVIDUAL 6-MINUTE AVERAGE MEASUREMENTS THAT WERE
    +
    155 C> INCLUDED IN FINAL ESTIMATE OF AVERAGED WIND (RANGE: 0, 2-10)
    +
    156 C> (BASED ON A ONE-HOUR AVERAGE)
    +
    157 C> - #- 1 - DATA FROM LOW MODE
    +
    158 C> 2 - DATA FROM HIGH MODE
    +
    159 C> 3 - MISSING
    +
    160 C> - @- THIS PARAMETER IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET
    +
    161 C> TO MISSING (99999 FOR INTEGER OR 99999. FOR REAL)
    +
    162 C> - ~- SUBMODE IS NO LONGER AVAILABLE AFTER 3/2002 AND IS SET TO 3
    +
    163 C> (ITS MISSING VALUE)
    +
    164 C>
    +
    165 C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    166 C> FORMAT FOR GOES SOUNDING/RADIANCE REPORTS
    +
    167 C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    168 C> HEADER
    +
    169 C> WORD CONTENT UNIT FORMAT
    +
    170 C> ---- ---------------------- ------------------- ---------
    +
    171 C> 1 LATITUDE 0.01 DEGREES REAL
    +
    172 C> 2 LONGITUDE 0.01 DEGREES WEST REAL
    +
    173 C> 3 FIELD OF VIEW NUMBER NUMERIC INTEGER
    +
    174 C> 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL
    +
    175 c>vvvvvdak port
    +
    176 C> 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER
    +
    177 c>aaaaadak port
    +
    178 C> LEFT-JUSTIFIED
    +
    179 C> 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER
    +
    180 C> 7 STATION ELEVATION METERS REAL
    +
    181 C> 8 PROCESS. TECHNIQUE (=21-CLEAR; INTEGER
    +
    182 C> 8 PROCESS. TECHNIQUE =23-CLOUD-CORRECTED)
    +
    183 C> 9 REPORT TYPE 61 (CONSTANT) INTEGER
    +
    184 C> 10 QUALITY FLAG (BUFR CODE TABLE "0 33 002") INTEGER
    +
    185 C> 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER
    +
    186 C> LEFT-JUSTIFIED
    +
    187 C> 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER
    +
    188 C> LEFT-JUSTIFIED (SEE %)
    +
    189 C>
    +
    190 C> 13-26 ZEROED OUT - NOT USED
    +
    191 C> 27 CATEGORY 08, NO. LEVELS COUNT INTEGER
    +
    192 C> 28 CATEGORY 08, DATA INDEX COUNT INTEGER
    +
    193 C> 29-38 ZEROED OUT - NOT USED
    +
    194 C> 39 CATEGORY 12, NO. LEVELS COUNT INTEGER
    +
    195 C> 40 CATEGORY 12, DATA INDEX COUNT INTEGER
    +
    196 C> 41 CATEGORY 13, NO. LEVELS COUNT INTEGER
    +
    197 C> 42 CATEGORY 13, DATA INDEX COUNT INTEGER
    +
    198 C>
    +
    199 C> 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL
    +
    200 C>
    +
    201 C> CATEGORY 12 - SATELLITE SOUNDING LEVEL DATA (FIRST LEVEL IS SURFACE;
    +
    202 C> EACH LEVEL, SEE 39 ABOVE)
    +
    203 C> WORD PARAMETER UNITS FORMAT
    +
    204 C> ---- --------- ----------------- -------------
    +
    205 C> 1 PRESSURE 0.1 MILLIBARS REAL
    +
    206 C> 2 GEOPOTENTIAL METERS REAL
    +
    207 C> 3 TEMPERATURE 0.1 DEGREES C REAL
    +
    208 C> 4 DEWPOINT TEMPERATURE 0.1 DEGREES C REAL
    +
    209 C> 5 NOT USED SET TO MISSING REAL
    +
    210 C> 6 NOT USED SET TO MISSING REAL
    +
    211 C> 7 QUALITY MARKERS 4-CHARACTERS CHARACTER
    +
    212 C> LEFT-JUSTIFIED (SEE &)
    +
    213 C>
    +
    214 C> CATEGORY 13 - SATELLITE RADIANCE "LEVEL" DATA (EACH "LEVEL", SEE
    +
    215 C> 41 ABOVE)
    +
    216 C> WORD PARAMETER UNITS FORMAT
    +
    217 C> ---- --------- ----------------- -------------
    +
    218 C> 1 CHANNEL NUMBER NUMERIC INTEGER
    +
    219 C> 2 BRIGHTNESS TEMP. 0.01 DEG. KELVIN REAL
    +
    220 C> 3 QUALITY MARKERS 4-CHARACTERS CHARACTER
    +
    221 C> LEFT-JUSTIFIED (SEE &&)
    +
    222 C>
    +
    223 C> CATEGORY 08 - ADDITIONAL (MISCELLANEOUS) DATA (EACH LEVEL, SEE @
    +
    224 C> BELOW)
    +
    225 C> WORD PARAMETER UNITS FORMAT
    +
    226 C> ---- --------- ----------------- -------------
    +
    227 C> 1 VARIABLE SEE @ BELOW REAL
    +
    228 C> 2 CODE FIGURE SEE @ BELOW REAL
    +
    229 C> 3 MARKERS 2-CHARACTERS CHARACTER
    +
    230 C> LEFT-JUSTIFIED (SEE #)
    +
    231 C>
    +
    232 C> %- SIXTH CHARACTER OF STATION ID IS A TAGGED AS FOLLOWS:
    +
    233 C> "I" - GOES-EVEN-1 (252, 256, ...) SAT. , CLEAR COLUMN RETR.
    +
    234 C> "J" - GOES-EVEN-1 (252, 256, ...) SAT. , CLD-CORRECTED RETR.
    +
    235 
    +
    236 C> "L" - GOES-ODD-1 (253, 257, ...) SAT. , CLEAR COLUMN RETR.
    +
    237 C> "M" - GOES-ODD-1 (253, 257, ...) SAT. , CLD-CORRECTED RETR.
    +
    238 
    +
    239 C> "O" - GOES-EVEN-2 (254, 258, ...) SAT. , CLEAR COLUMN RETR.
    +
    240 C> "P" - GOES-EVEN-2 (254, 258, ...) SAT. , CLD-CORRECTED RETR.
    +
    241 
    +
    242 C> "Q" - GOES-ODD-2 (251, 255, ...) SAT. , CLEAR COLUMN RETR.
    +
    243 C> "R" - GOES-ODD-2 (251, 255, ...) SAT. , CLD-CORRECTED RETR.
    +
    244 
    +
    245 C> "?" - EITHER SATELLITE AND/OR RETRIEVAL TYPE UNKNOWN
    +
    246 
    +
    247 C> &- FIRST CHARACTER IS Q.M. FOR GEOPOTENTIAL
    +
    248 C> SECOND CHARACTER IS Q.M. FOR TEMPERATURE
    +
    249 C> THIRD CHARACTER IS Q.M. FOR DEWPOINT TEMPERATURE
    +
    250 C> FOURTH CHARACTER IS NOT USED
    +
    251 C> " " - INDICATES DATA NOT SUSPECT
    +
    252 C> "Q" - INDICATES DATA ARE SUSPECT
    +
    253 C> "F" - INDICATES DATA ARE BAD
    +
    254 C> &&- FIRST CHARACTER IS Q.M. FOR BRIGHTNESS TEMPERATURE
    +
    255 C> SECOND-FOURTH CHARACTERS ARE NOT USED
    +
    256 C> " " - INDICATES DATA NOT SUSPECT
    +
    257 C> "Q" - INDICATES DATA ARE SUSPECT
    +
    258 C> "F" - INDICATES DATA ARE BAD
    +
    259 C> @- NUMBER OF "LEVELS" FROM WORD 27. MAXIMUM IS 12, AND ARE ORDERED
    +
    260 C> AS FOLLOWS (IF A DATUM ARE MISSING THAT LEVEL NOT STORED)
    +
    261 C> 1 - LIFTED INDEX ---------- .01 DEG. KELVIN -- C. FIG. 250.
    +
    262 C> 2 - TOTAL PRECIP. WATER -- .01 MILLIMETERS -- C. FIG. 251.
    +
    263 C> 3 - 1. TO .9 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 252.
    +
    264 C> 4 - .9 TO .7 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 253.
    +
    265 C> 5 - .7 TO .3 SIGMA P.WATER- .01 MILLIMETERS -- C. FIG. 254.
    +
    266 C> 6 - SKIN TEMPERATURE ----- .01 DEG. KELVIN -- C. FIG. 255.
    +
    267 C> 7 - CLOUD TOP TEMPERATURE- .01 DEG. KELVIN -- C. FIG. 256.
    +
    268 C> 8 - CLOUD TOP PRESSURE --- .1 MILLIBARS ----- C. FIG. 257.
    +
    269 C> 9 - CLOUD AMOUNT (BUFR TBL. C.T. 0-20-011) -- C. FIG. 258.
    +
    270 C> 10 - INSTR. DATA USED IN PROC.
    +
    271 C> (BUFR TBL. C.T. 0-02-021) -- C. FIG. 259.
    +
    272 C> 11 - SOLAR ZENITH ANGLE --- .01 DEGREE ------- C. FIG. 260.
    +
    273 C> 12 - SAT. ZENITH ANGLE ---- .01 DEGREE ------- C. FIG. 261.
    +
    274 C> #- FIRST CHARACTER IS Q.M. FOR THE DATUM
    +
    275 C> " " - INDICATES DATA NOT SUSPECT
    +
    276 C> "Q" - INDICATES DATA ARE SUSPECT
    +
    277 C> "F" - INDICATES DATA ARE BAD
    +
    278 C> SECOND CHARACTER IS NOT USED
    +
    279 C>
    +
    280 C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    281 C> FORMAT FOR NEXRAD (VAD) WIND REPORTS
    +
    282 C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    283 C> HEADER
    +
    284 C> WORD CONTENT UNIT FORMAT
    +
    285 C> ---- ---------------------- ------------------- ---------
    +
    286 C> 1 LATITUDE 0.01 DEGREES REAL
    +
    287 C> 2 LONGITUDE 0.01 DEGREES WEST REAL
    +
    288 C> 3 ** RESERVED ** SET TO 99999 INTEGER
    +
    289 C> 4 OBSERVATION TIME 0.01 HOURS (UTC) REAL
    +
    290 c>vvvvvdak port
    +
    291 C> 5 YEAR/MONTH 4-CHAR. 'YYMM' CHARACTER
    +
    292 c>aaaaadak port
    +
    293 C> LEFT-JUSTIFIED
    +
    294 C> 6 DAY/HOUR 4-CHARACTERS 'DDHH' CHARACTER
    +
    295 C> 7 STATION ELEVATION METERS REAL
    +
    296 C> 8 ** RESERVED ** SET TO 99999 INTEGER
    +
    297 C>
    +
    298 C> 9 REPORT TYPE 72 (CONSTANT) INTEGER
    +
    299 C> 10 ** RESERVED ** SET TO 99999 INTEGER
    +
    300 C> 11 STN. ID. (FIRST 4 CHAR.) 4-CHARACTERS CHARACTER
    +
    301 C> LEFT-JUSTIFIED
    +
    302 C> 12 STN. ID. (LAST 2 CHAR.) 2-CHARACTERS CHARACTER
    +
    303 C> LEFT-JUSTIFIED
    +
    304 C>
    +
    305 C> 13-18 ZEROED OUT - NOT USED INTEGER
    +
    306 C> 19 CATEGORY 04, NO. LEVELS COUNT INTEGER
    +
    307 C> 20 CATEGORY 04, DATA INDEX COUNT INTEGER
    +
    308 C> 21-42 ZEROED OUT - NOT USED INTEGER
    +
    309 C>
    +
    310 C> 43-END UNPACKED DATA GROUPS (FOLLOWS) REAL
    +
    311 C>
    +
    312 C> CATEGORY 04 - UPPER-AIR WINDS-BY-HEIGHT DATA(FIRST LEVEL IS SURFACE)
    +
    313 C> (EACH LEVEL, SEE WORD 19 ABOVE)
    +
    314 C> WORD PARAMETER UNITS FORMAT
    +
    315 C> ---- --------- ----------------- -------------
    +
    316 C> 1 HEIGHT ABOVE SEA-LVL METERS REAL
    +
    317 C> 2 HORIZ. WIND DIR. DEGREES REAL
    +
    318 C> 3 HORIZ. WIND SPEED 0.1 M/S (SEE *) REAL
    +
    319 C> 4 QUALITY MARKERS 4-CHARACTERS CHARACTER
    +
    320 C> LEFT-JUSTIFIED (SEE %)
    +
    321 C>
    +
    322 C> *- UNITS HERE DIFFER FROM THOSE IN TRUE UNPACKED OFFICE NOTE 29
    +
    323 C> (WHERE UNITS ARE KNOTS)
    +
    324 C> %- THE FIRST THREE CHARACTERS ARE ALWAYS BLANK, THE FOURTH
    +
    325 C> CHARACTER IS A "CONFIDENCE LEVEL" WHICH IS RELATED TO THE ROOT-
    +
    326 C> MEAN-SQUARE VECTOR ERROR FOR THE HORIZONTAL WIND. IT IS
    +
    327 C> DEFINED AS FOLLOWS:
    +
    328 C> 'A' = RMS OF 1.9 KNOTS
    +
    329 C> 'B' = RMS OF 3.9 KNOTS
    +
    330 C> 'C' = RMS OF 5.8 KNOTS
    +
    331 C> 'D' = RMS OF 7.8 KNOTS
    +
    332 C> 'E' = RMS OF 9.7 KNOTS
    +
    333 C> 'F' = RMS OF 11.7 KNOTS
    +
    334 C> 'G' = RMS > 13.6 KNOTS
    +
    335 C>XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    +
    336 C>
    +
    337 C> FOR ALL REPORT TYPES, MISSING VALUES ARE:
    +
    338 C> 99999. FOR REAL
    +
    339 C> 99999 FOR INTEGER
    +
    340 C> 9'S FOR CHARACTERS IN WORD 5, 6 OF HEADER
    +
    341 C> BLANK FOR CHARACTERS IN WORD 11, 12 OF HEADER
    +
    342 C> AND FOR CHARACTERS IN ANY CATEGORY LEVEL
    +
    343 C>
    +
    344 C> @author Dennis Keyser @date 2002-03-05
    +
    345  SUBROUTINE w3unpk77(IDATE,IHE,IHL,LUNIT,RDATA,IRET)
    +
    346  CHARACTER*4 CBUFR
    +
    347  INTEGER IDATE(4),LSDATE(4),jdate(8),IDATA(1200)
    +
    348  dimension rinc(5)
    +
    349  REAL RDATA(*),RDATX(1200)
    +
    350  COMMON /pk77bb/kdate(8),ldate(8),iprint
    +
    351  COMMON /pk77cc/index
    +
    352  COMMON /pk77dd/lshe,lshl,icdate(5),iddate(5)
    +
    353  COMMON /pk77ff/ifov(3),kntsat(250:260)
    +
    354 
    +
    355  SAVE
    +
    356 
    +
    357  equivalence(rdatx,idata)
    +
    358  DATA itm/0/,lunitl/-99/,kount/0/
    +
    359  iprint = 0
    +
    360  IF(iret.LT.0) iprint = iabs(iret)
    +
    361  iret = 0
    +
    362  IF(itm.EQ.0) THEN
    +
    363 C-----------------------------------------------------------------------
    +
    364 
    +
    365 C FIRST AND ONLY TIME INTO THIS SUBROUTINE DO A FEW THINGS....
    +
    366 
    +
    367  itm = 1
    +
    368  ifov = 0
    +
    369  kntsat = 0
    +
    370 C DETERMINE MACHINE WORD LENGTH IN BYTES (=8 FOR CRAY) AND TYPE OF
    +
    371 C CHARACTER SET {ASCII(ICHTP=0) OR EBCDIC(ICHTP=1)}
    +
    372  CALL w3fi04(iendn,ichtp,lw)
    +
    373  print 2213, lw, ichtp, iendn
    +
    374  2213 FORMAT(/' ---> W3UNPK77: CALL TO W3FI04 RETURNS: LW = ',i3,
    +
    375  $ ', ICHTP = ',i3,', IENDN = ',i3/)
    +
    376  IF(ichtp.GT.1) THEN
    +
    377 C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC!! -- STOP 22
    +
    378  print 217
    +
    379  217 FORMAT(' *** W3UNPK77 ERROR: CHARACTERS ON THIS MACHINE ',
    +
    380  $ 'ARE NEITHER ASCII NOR EBCDIC - STOP 22'/)
    +
    381  CALL errexit(22)
    +
    382  END IF
    +
    383 C-----------------------------------------------------------------------
    +
    384  END IF
    +
    385  IF(lunit.NE.lunitl) THEN
    +
    386 C-----------------------------------------------------------------------
    +
    387 
    +
    388 C IF THE INPUT DATA UNIT NUMBER ARGUMENT IS DIFFERENT THAT THE LAST TIME
    +
    389 C THIS SUBR. WAS CALLED, PRINT NEW HEADER, SET JRET = 1
    +
    390 
    +
    391  lunitl = lunit
    +
    392  jret = 1
    +
    393  print 101, lunit
    +
    394  101 FORMAT(//' ---> W3UNPK77: VERSION 03/05/2002: JBUFR DATA SET ',
    +
    395  $ 'READ FROM UNIT ',i4/)
    +
    396 C-----------------------------------------------------------------------
    +
    397  ELSE
    +
    398 
    +
    399 C FOR SUBSEQUENT TIMES INTO THIS SUBR. W/ SAME LUNIT AS LAST TIME,
    +
    400 C TEST INPUT DATE & HR RANGE ARGUMENTS AGAINST THEIR VALUES THE LAST
    +
    401 C TIME SUBR. CALLED -- IF THEY ARE DIFFERENT, SET JRET = 1 (ELSE
    +
    402 C JRET = 0), WILL TEST JRET SOON
    +
    403 
    +
    404  jret = 1
    +
    405  DO i = 4,1,-1
    +
    406  IF(idate(i).NE.lsdate(i)) GO TO 88
    +
    407  ENDDO
    +
    408  IF(ihe.NE.lshe.OR.ihl.NE.lshl) GO TO 88
    +
    409  jret = 0
    +
    410  88 CONTINUE
    +
    411 C-----------------------------------------------------------------------
    +
    412  END IF
    +
    413  IF(jret.EQ.1) THEN
    +
    414  print 6680
    +
    415  6680 FORMAT(/' JRET = 1 - REWIND DATA FILE & SET-UP TO DO DATE CHECK'/)
    +
    416 C-----------------------------------------------------------------------
    +
    417 
    +
    418 C COME HERE IF FIRST CALL TO SUBROUTINE OR IF INPUT DATA UNIT NUMBER OR
    +
    419 C IF INPUT DATE/TIME OR RANGE IN TIME HAS BEEN CHANGED FROM LAST CALL
    +
    420 
    +
    421 C CLOSE BUFR DATA SET (IN CASE OPEN FROM PREVIOUS RUN)
    +
    422 C REWIND INPUT BUFR DATA SET, GET CENTER TIME AND DUMP TIME,
    +
    423 C OPEN BUFR DATA SET
    +
    424 
    +
    425 C SET-UP TO DETERMINE IF BUFR MESSAGE IS WITHIN REQUESTED DATES
    +
    426 
    +
    427 C (ALSO SET INDEX=0, FORCES BUFR MSG TO BE READ BEFORE RPTS ARE DECODED)
    +
    428 
    +
    429 C-----------------------------------------------------------------------
    +
    430 
    +
    431  CALL closbf(lunit)
    +
    432 
    +
    433  rewind lunit
    +
    434 
    +
    435  READ(lunit,END=9999,ERR=9999) cbufr
    +
    436  IF(cbufr.NE.'BUFR') GO TO 9999
    +
    437 
    +
    438  call datelen(10)
    +
    439 
    +
    440  CALL dumpbf(lunit,icdate,iddate)
    +
    441 cppppp
    +
    442  print *,'CENTER DATE (ICDATE) = ',icdate
    +
    443  print *,'DUMP DATE (IDDATE) = ',iddate
    +
    444 cppppp
    +
    445 
    +
    446  if(icdate(1).le.0) then
    +
    447 C COME HERE IF CENTER DATE COULD NOT BE READ FROM FIRST DUMMY MESSAGE
    +
    448 C - RETURN WITH IRET = 1
    +
    449  print *, ' *** W3UNPK77 ERROR: CENTER DATE COULD NOT BE ',
    +
    450  $ 'OBTAINED FROM INPUT FILE ON UNIT ',lunit
    +
    451  go to 9998
    +
    452  end if
    +
    453  if(iddate(1).le.0) then
    +
    454 C COME HERE IF DUMP DATE COULD NOT BE READ FROM SECOND DUMMY MESSAGE
    +
    455 C - RETURN WITH IRET = 1
    +
    456  print *, ' *** W3UNPK77 ERROR: DUMP DATE COULD NOT BE ',
    +
    457  $ 'OBTAINED FROM INPUT FILE ON UNIT ',lunit
    +
    458  go to 9998
    +
    459  end if
    +
    460  IF(icdate(1).LT.100) THEN
    +
    461 
    +
    462 C If 2-digit year returned in ICDATE(1), must use "windowing" technique
    +
    463 C to create a 4-digit year
    +
    464 
    +
    465 C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
    +
    466 C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
    +
    467 C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)
    +
    468 
    +
    469  print *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ',
    +
    470  $ 'HAPPEN!!!!!'
    +
    471  print *, '##W3UNPK77 - 2-DIGIT YEAR IN ICDATE(1) ',
    +
    472  $ 'RETURNED FROM DUMPBF (ICDATE IS: ',icdate,') - USE ',
    +
    473  $ 'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
    +
    474  IF(icdate(1).GT.20) THEN
    +
    475  icdate(1) = 1900 + icdate(1)
    +
    476  ELSE
    +
    477  icdate(1) = 2000 + icdate(1)
    +
    478  ENDIF
    +
    479  print *, '##WW3UNPK77 - CORRECTED ICDATE(1) WITH 4-DIGIT ',
    +
    480  $ 'YEAR, ICDATE NOW IS: ',icdate
    +
    481  ENDIF
    +
    482 
    +
    483  IF(iddate(1).LT.100) THEN
    +
    484 
    +
    485 C If 2-digit year returned in IDDATE(1), must use "windowing" technique
    +
    486 C to create a 4-digit year
    +
    487 
    +
    488 C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS
    +
    489 C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT
    +
    490 C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE)
    +
    491 
    +
    492  print *, '##W3UNPK77 - THE FOLLOWING SHOULD NEVER ',
    +
    493  $ 'HAPPEN!!!!!'
    +
    494  print *, '##W3UNPK77 - 2-DIGIT YEAR IN IDDATE(1) ',
    +
    495  $ 'RETURNED FROM DUMPBF (IDDATE IS: ',iddate,') - USE ',
    +
    496  $ 'WINDOWING TECHNIQUE TO OBTAIN 4-DIGIT YEAR'
    +
    497  IF(iddate(1).GT.20) THEN
    +
    498  iddate(1) = 1900 + iddate(1)
    +
    499  ELSE
    +
    500  iddate(1) = 2000 + iddate(1)
    +
    501  ENDIF
    +
    502  print *, '##W3UNPK77 - CORRECTED IDDATE(1) WITH 4-DIGIT ',
    +
    503  $ 'YEAR, IDDATE NOW IS: ',iddate
    +
    504  END IF
    +
    505 
    +
    506 C OPEN BUFR FILE - READ IN DICTIONARY MESSAGES (TABLE A, B, D ENTRIES)
    +
    507 
    +
    508  CALL openbf(lunit,'IN',lunit)
    +
    509  print 100, lunit
    +
    510  100 FORMAT(/5x,'===> BUFR DATA SET IN UNIT',i3,' SUCCESSFULLY ',
    +
    511  $ 'OPENED FOR INPUT; DCTNY MESSAGES CONTAIN BUFR TABLES A,B,D'/)
    +
    512  index = 0
    +
    513  kount = 0
    +
    514  jdate(1:3) = idate(1:3)
    +
    515  jdate(4) = 0
    +
    516  jdate(5) = idate(4)
    +
    517  jdate(6:8) = 0
    +
    518  print 6681, idate
    +
    519  6681 FORMAT(/' %%% REQUESTED "CENTRAL" DATE IS :',i5,3i3,' 0'/)
    +
    520 C DETERMINE EARLIEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING
    +
    521  call w3movdat((/0.,real(ihe),0.,0.,0./),jdate,kdate)
    +
    522  print 6682, (kdate(i),i=1,3),kdate(5),kdate(6)
    +
    523  6682 FORMAT(/' --> EARLIEST DATE FOR ACCEPTING BUFR MSGS IS:',i5,4i3/)
    +
    524 C DETERMINE LATEST DATE FOR ACCEPTING BUFR MESSAGES FOR DECODING
    +
    525  if(ihl.ge.0) then
    +
    526  xminl = (ihl * 60) + 59
    +
    527  else
    +
    528  xminl = ((ihl + 1) * 60) - 1
    +
    529  end if
    +
    530  call w3movdat((/0.,0.,xminl,0.,0./),jdate,ldate)
    +
    531  print 6683, (ldate(i),i=1,3),ldate(5),ldate(6)
    +
    532  6683 FORMAT(/' --> LATEST DATE FOR ACCEPTING BUFR MSGS IS:',i5,4i3/)
    +
    533  call w3difdat(ldate,kdate,3,rinc)
    +
    534  IF(rinc(3).LT.0) THEN
    +
    535  print 104
    +
    536  104 FORMAT(' *** W3UNPK77 ERROR: DATES SPECIFIED INCORRECTLY -',
    +
    537  $ ' STOP 15'/)
    +
    538  CALL errexit(15)
    +
    539  END IF
    +
    540 C-----------------------------------------------------------------------
    +
    541  END IF
    +
    542 C SUBR. UNPK7701 RETURNS A SINGLE DECODED REPORT FROM BUFR MESSAGE
    +
    543  CALL unpk7701(lunit,itp,iret)
    +
    544 C IRET=1 MEANS ALL DATA HAVE BEEN DECODED FOR SPECIFIED TIME PERIOD
    +
    545 C (REWIND DATA FILE AND RETURN W/ IRET=1)
    +
    546 C IRET.GE.2 MEANS REPORT NOT RETURNED DUE TO ERROR IN DECODING (RETURN)
    +
    547 C (ACTUALLY IRET.GE.2 CURRENTLY CANNOT HAPPEN OUT OF UNPK7701)
    +
    548  IF(iret.GE.1) THEN
    +
    549  IF(iret.EQ.1) THEN
    +
    550  rewind lunit
    +
    551  IF(itp.EQ.2) THEN
    +
    552  print 8101, ifov
    +
    553  8101 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED',
    +
    554  $ ' BY F-O-V NO. (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/15x,
    +
    555  $ '# WITH F-O-V NO. 00 TO 02:',i6,' - GET "BAD" Q.MARK'/15x,
    +
    556  $ '# WITH F-O-V NO. 03 TO 09:',i6,' - GET "SUSPECT" Q.MARK'/15x,
    +
    557  $ '# WITH F-O-V NO. 10 TO 25:',i6,' - GET "NEUTRAL" Q.MARK'/20x,
    +
    558  $ '(NOTE: RADIANCES ALWAYS HAVE NEUTRAL Q.MARK)'/)
    +
    559  print 8102
    +
    560  8102 FORMAT(/' ---> W3UNPK77: SUMMARY OF GOES REPORT COUNTS GROUPED',
    +
    561  $ ' BY SATELLITE ID (PRIOR TO ANY FILTERING BY CALLING PROGRAM)'/)
    +
    562  DO idsat = 250,259
    +
    563  IF(kntsat(idsat).GT.0) print 8103, idsat,kntsat(idsat)
    +
    564  ENDDO
    +
    565  8103 FORMAT(15x,'NUMBER FROM SAT. ID',i4,4x,':',i6)
    +
    566  IF(kntsat(260).GT.0) print 8104
    +
    567  8104 FORMAT(15x,'NUMBER FROM UNKNOWN SAT. ID:',i6)
    +
    568  print 8105
    +
    569  8105 FORMAT(/)
    +
    570  END IF
    +
    571  END IF
    +
    572  GO TO 99
    +
    573  END IF
    +
    574  kount = kount + 1
    +
    575 C INITIALIZE THE OUTPUT ON29 ARRAY
    +
    576  CALL unpk7702(rdata,itp)
    +
    577  IF(itp.EQ.1) THEN
    +
    578 C-----------------------------------------------------------------------
    +
    579 C THE FOLLOWING PERTAINS TO WIND PROFILER REPORTS
    +
    580 C-----------------------------------------------------------------------
    +
    581 C STORE THE HEADER INFORMATION INTO ON29 FORMAT
    +
    582  CALL unpk7703(lunit,rdata,iret)
    +
    583 C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
    +
    584  IF(iret.GE.2) GO TO 99
    +
    585 C STORE THE SURFACE DATA INTO ON29 FORMAT (CATEGORY 10)
    +
    586  CALL unpk7704(lunit,rdata)
    +
    587 C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 11)
    +
    588  CALL unpk7705(lunit,rdata)
    +
    589  rdatx(1:1200) = rdata(1:1200)
    +
    590  IF(idata(35)+idata(37).EQ.0) iret = 5
    +
    591  ELSE IF(itp.EQ.2) THEN
    +
    592 C-----------------------------------------------------------------------
    +
    593 C THE FOLLOWING PERTAINS TO GOES SOUNDING/RADIANCE REPORTS
    +
    594 C-----------------------------------------------------------------------
    +
    595 C STORE THE HEADER INFORMATION INTO ON29 FORMAT
    +
    596  CALL unpk7708(lunit,rdata,kount,iret)
    +
    597 C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
    +
    598  IF(iret.GE.2) GO TO 99
    +
    599 C STORE THE UPPER-AIR DATA/RADIANCE INTO ON29 FORMAT (CATEGORY 12, 13)
    +
    600  CALL unpk7709(lunit,rdata,iret)
    +
    601  ELSE IF(itp.EQ.3) THEN
    +
    602 C-----------------------------------------------------------------------
    +
    603 C THE FOLLOWING PERTAINS TO NEXRAD (VAD) WIND REPORTS
    +
    604 C-----------------------------------------------------------------------
    +
    605 C STORE THE HEADER INFORMATION INTO ON29 FORMAT
    +
    606  CALL unpk7706(lunit,rdata,iret)
    +
    607 C IRET.GE.2 MEANS RPT NOT RETURNED DUE TO MSG DATA IN HDR (RETURN)
    +
    608  IF(iret.GE.2) GO TO 99
    +
    609 C STORE THE UPPER-AIR DATA INTO ON29 FORMAT (CATEGORY 4)
    +
    610  CALL unpk7707(lunit,rdata,iret)
    +
    611 C-----------------------------------------------------------------------
    +
    612  END IF
    +
    613  99 CONTINUE
    +
    614 C PRIOR TO RETURNING SAVE INPUT DATE & HR RANGE ARGUMENTS FROM THIS CALL
    +
    615  lsdate = idate
    +
    616  lshe = ihe
    +
    617  lshl = ihl
    +
    618  RETURN
    +
    619 C-----------------------------------------------------------------------
    +
    620  9999 CONTINUE
    +
    621 C COME HERE IF NULL OR NON-BUFR FILE IS INPUT - RETURN WITH IRET = 1
    +
    622  print *, ' *** W3UNPK77 ERROR: INPUT FILE IN UNIT ',lunit,' IS ',
    +
    623  $ 'EITHER A NULL OR NON-BUFR FILE'
    +
    624  9998 continue
    +
    625  rewind lunit
    +
    626  iret = 1
    +
    627  lsdate = idate
    +
    628  lshe = ihe
    +
    629  lshl = ihl
    +
    630  END
    +
    631 C> @brief Reads a single report out of bufr dataset
    +
    632 C> @author Dennis Keyser @date 1996-12-16
    +
    633 
    +
    634 C> Calls bufrlib routines to read in a bufr message and then read a single
    +
    635 C> report (subset) out of the message.
    +
    636 C>
    +
    637 C> ### Program History Log:
    +
    638 C> Date | Programmer | Comment
    +
    639 C> -----|------------|--------
    +
    640 C> 1996-12-16 | Dennis Keyser NP22 | Initial.
    +
    641 C>
    +
    642 C> @param[in] LUNIT Fortran unit number for input data file.
    +
    643 C> @param[out] ITP The type of report that has been decoded {=1 - wind profiler,
    +
    644 C> =2 - goes sndg, =3 - nexrad(vad) wind}
    +
    645 C> @param[out] IRET Return code as described in w3unpk77 docblock
    +
    646 C>
    +
    647 C> @author Dennis Keyser @date 1996-12-16
    +
    648  SUBROUTINE unpk7701(LUNIT,ITP,IRET)
    +
    649  CHARACTER*8 SUBSET
    +
    650  integer mdate(4),ndate(8)
    +
    651  dimension rinc(5)
    +
    652  COMMON /pk77bb/kdate(8),ldate(8),iprint
    +
    653  COMMON /pk77cc/index
    +
    654  COMMON /pk77dd/lshe,lshl,icdate(5),iddate(5)
    +
    655 
    +
    656  SAVE
    +
    657 
    +
    658  DATA irec/0/
    +
    659 
    +
    660  10 CONTINUE
    +
    661 C=======================================================================
    +
    662  IF(index.EQ.0) THEN
    +
    663 
    +
    664 C READ IN NEXT BUFR MESSAGE
    +
    665 
    +
    666  CALL readmg(lunit,subset,ibdate,jret)
    +
    667  IF(jret.NE.0) THEN
    +
    668 C-----------------------------------------------------------------------
    +
    669  print 101
    +
    670  101 FORMAT(' ---> W3UNPK77: ALL BUFR MESSAGES READ IN AND DECODED'/)
    +
    671  iret = 1
    +
    672  RETURN
    +
    673 C-----------------------------------------------------------------------
    +
    674  END IF
    +
    675  if(ibdate.lt.100000000) then
    +
    676 c If input BUFR file does not return messages with a 4-digit year,
    +
    677 c something is wrong (even non-compliant BUFR messages should
    +
    678 c construct a 4-digit year as long as datelen(10) has been called
    +
    679  print *, '##W3UNP777/UNPK7701 - A 10-digit Sect. 1 BUFR ',
    +
    680  $ 'message date was not returned in unit ',lunit,' - ',
    +
    681  $ 'problem with BUFR file - ier = 1'
    +
    682  iret = 1
    +
    683  return
    +
    684  end if
    +
    685  CALL ufbcnt(lunit,irec,isub)
    +
    686  mdate(1) = ibdate/1000000
    +
    687  mdate(2) = mod((ibdate/10000),100)
    +
    688  mdate(3) = mod((ibdate/100),100)
    +
    689  mdate(4) = mod(ibdate,100)
    +
    690 C ALL JBUFR MESSAGES CURRENTLY HAVE "00" FOR MINUTES IN SECTION 1
    +
    691  ndate(1:3) = mdate(1:3)
    +
    692  ndate(4) = 0
    +
    693  ndate(5) = mdate(4)
    +
    694  ndate(6:8) = 0
    +
    695  IF(iprint.GE.1) THEN
    +
    696  print *,'HAVE SUCCESSFULLY READ IN A BUFR MESSAGE'
    +
    697  print 103
    +
    698  103 FORMAT(' BUFR FOUND BEGINNING AT BYTE 1 OF MESSAGE')
    +
    699  print 105, irec,mdate,subset
    +
    700  105 FORMAT(8x,'HAVE READ IN A BUFR MESSAGE NO.',i3,', DATE: ',
    +
    701  $ i6,3i4,' 0; TABLE A ENTRY = ',a8,' AND EDIT. NO. = 2'/)
    +
    702  END IF
    +
    703  IF(subset.EQ.'NC002007') THEN
    +
    704  IF(iprint.GE.1) print *, 'THIS MESSAGE CONTAINS WIND ',
    +
    705  $ 'PROFILER REPORTS'
    +
    706  itp = 1
    +
    707  ELSE IF(subset.EQ.'NC002008') THEN
    +
    708  IF(iprint.GE.1) print *, 'THIS MESSAGE CONTAINS NEXRAD ',
    +
    709  $ '(VAD) WIND REPORTS'
    +
    710  itp = 3
    +
    711  ELSE IF(subset.EQ.'NC003001') THEN
    +
    712  IF(iprint.GE.1) print *, 'THIS MESSAGE CONTAINS GOES ',
    +
    713  $ 'SOUNDING/RADIANCE REPORTS'
    +
    714  itp = 2
    +
    715  ELSE
    +
    716  print 107, irec
    +
    717  107 FORMAT(' *** W3UNPK77 WARNING: BUFR MESSAGE NO.',i3,' CONTAINS ',
    +
    718  $ 'REPORTS THAT CANNOT BE DECODED BY W3UNPK77, TRY READING NEXT ',
    +
    719  $ 'MSG'/)
    +
    720  index = 0
    +
    721  GO TO 10
    +
    722  END IF
    +
    723  call w3difdat(kdate,ndate,3,rinc)
    +
    724  kmin = rinc(3)
    +
    725  call w3difdat(ldate,ndate,3,rinc)
    +
    726  lmin = rinc(3)
    +
    727 C CHECK DATE OF MESSAGE AGAINST SPECIFIED TIME RANGES
    +
    728  if((kmin.gt.0.or.lmin.lt.0).AND.irec.GT.2) then
    +
    729  print 106, irec,mdate
    +
    730  106 FORMAT(' BUFR MESSAGE NO.',i3,' WITH DATE:',i5,3i3,' 0 NOT W/I',
    +
    731  $ ' REQ. TIME RANGE, TRY READING NEXT MSG'/)
    +
    732  index = 0
    +
    733  GO TO 10
    +
    734  END IF
    +
    735  END IF
    +
    736 C=======================================================================
    +
    737 C READ NEXT SUBSET (REPORT) IN MESSAGE
    +
    738 
    +
    739  IF(iprint.GT.1) print *,'CALL READSB'
    +
    740  CALL readsb(lunit,jret)
    +
    741  IF(iprint.GT.1) print *,'BACK FROM READSB'
    +
    742  IF(jret.NE.0) THEN
    +
    743  IF(index.GT.0) THEN
    +
    744 
    +
    745 C ALL SUBSETS IN THIS MESSAGE PROCESSED, READ IN NEXT MESSAGE (IF ALL
    +
    746 C MESSAGES READ IN NO MORE DATA TO PROCESS)
    +
    747 
    +
    748  IF(iprint.GT.1) print *, 'ALL REPORTS IN THIS MESSAGE ',
    +
    749  $ 'DECODED, GO ON TO NEXT MESSAGE'
    +
    750  ELSE
    +
    751 
    +
    752 C THERE WERE NO SUBSETS FOUND IN THIS BUFR MESSAGE, GOOD CHANCE IT IS
    +
    753 C ONE OF TWO DUMMY MESSAGES AT TOP OF FILE INDICATING CENTER TIME AND
    +
    754 C DATA DUMP TIME ONLY; READ IN NEXT MESSAGE
    +
    755 
    +
    756  IF(irec.EQ.1) THEN
    +
    757  print 4567, icdate
    +
    758  4567 FORMAT(/'===> BUFR MESSAGE NO. 1 IS A DUMMY MESSAGE CONTAINING ',
    +
    759  $ 'ONLY CENTER DATE (',i5,4i3,') - NO DATA - GO ON TO NEXT ',
    +
    760  $ 'MESSAGE'/)
    +
    761  ELSE IF(irec.EQ.2) THEN
    +
    762  print 4568, iddate
    +
    763  4568 FORMAT(/'===> BUFR MESSAGE NO. 2 IS A DUMMY MESSAGE CONTAINING ',
    +
    764  $ 'ONLY DUMP DATE (',i5,4i3,') - NO DATA - GO ON TO NEXT ',
    +
    765  $ 'MESSAGE'/)
    +
    766  ELSE
    +
    767  print 4569, irec,mdate
    +
    768  4569 FORMAT(/'===> BUFR MESSAGE NO.',i3,' (DATE:',i5,3i3,' 0) ',
    +
    769  $ 'CONTAINS ZERO REPORTS FOR SOME UNEXPLAINED REASON - GO ON TO ',
    +
    770  $ 'NEXT MESSAGE'/)
    +
    771  END IF
    +
    772  END IF
    +
    773  index = 0
    +
    774  GO TO 10
    +
    775  END IF
    +
    776 C-----------------------------------------------------------------------
    +
    777  IF(iprint.GT.1) print *, 'READY TO PROCESS NEW DECODED REPORT'
    +
    778 C***********************************************************************
    +
    779 C A SINGLE REPORT HAS BEEN SUCCESSFULLY DECODED
    +
    780 C***********************************************************************
    +
    781  index = index + 1
    +
    782  IF(iprint.GE.1) print *, 'WORKING WITH SUBSET NUMBER ',index
    +
    783  RETURN
    +
    784  END
    +
    785 C> @brief Initializes the output array for a report.
    +
    786 C> @author Dennis Keyser @date 1996-12-16
    +
    787 
    +
    788 C> Initializes the output array which holds a single report in the quasi-office
    +
    789 C> note 29 unpacked format to all missing.
    +
    790 C>
    +
    791 C> ### Program History Log:
    +
    792 C> Date | Programmer | Comment
    +
    793 C> -----|------------|--------
    +
    794 C> 1996-12-16 | Dennis Keyser NP22 | Initial.
    +
    795 C> @param[in] ITP the type of report that has been decoded {=1 - wind profiler, =2 - goes sndg, =3 - nexrad(vad) wind}
    +
    796 C> @param[out] RDATA single report returned an a quasi-office note 29 unpacked format; all data are missing
    +
    797 C>
    +
    798 C> @author Dennis Keyser @date 1996-12-16
    +
    799  SUBROUTINE unpk7702(RDATA,ITP)
    +
    800  REAL RDATA(*),RDATX(1200)
    +
    801  INTEGER IDATA(1200),IRTYP(3)
    +
    802  CHARACTER*8 COB
    +
    803 C
    +
    804  SAVE
    +
    805 C
    +
    806  equivalence(rdatx,idata),(cob,iob)
    +
    807  DATA xmsg/99999./,imsg/99999/,irtyp/71,61,72/
    +
    808  rdatx(1) = xmsg
    +
    809  rdatx(2) = xmsg
    +
    810  idata(3) = imsg
    +
    811  rdatx(4) = xmsg
    +
    812  cob = '999999 '
    +
    813  idata(5) = iob
    +
    814  cob = '9999 '
    +
    815  idata(6) = iob
    +
    816  rdatx(7) = xmsg
    +
    817  idata(8) = imsg
    +
    818  idata(9) = irtyp(itp)
    +
    819  idata(10) = imsg
    +
    820  cob = ' '
    +
    821  idata(11) = iob
    +
    822  idata(12) = iob
    +
    823 C
    +
    824 C ALL TYPES -- LOAD ZEROS INTO THE DEFINING WORD PAIRS
    +
    825 C
    +
    826  idata(13:42) = 0
    +
    827 C
    +
    828 C ALL TYPES -- LOAD MISSINGS INTO THE DATA PORTION
    +
    829 C
    +
    830  rdatx(43:1200) = xmsg
    +
    831  IF(itp.EQ.1) THEN
    +
    832 C
    +
    833 C PROFILER -- LOAD INTEGER MISSING WHERE APPROPRIATE
    +
    834 C (Current limit of 104 Cat. 11 levels)
    +
    835 C
    +
    836  idata(53:1200:11) = imsg
    +
    837  idata(55:1200:11) = imsg
    +
    838  idata(56:1200:11) = imsg
    +
    839  idata(60:1200:11) = imsg
    +
    840  ELSE IF(itp.EQ.2) THEN
    +
    841 C
    +
    842 C GOES -- LOAD DEFAULT OF BLANK CHARACTERS INTO CAT. 12
    +
    843 C LEVEL QUALITY MARKERS
    +
    844 C (Current limit of 50 Cat. 12 levels)
    +
    845 C (could be expanded if need be)
    +
    846 C
    +
    847  idata(49:392:7) = iob
    +
    848 C
    +
    849 C GOES -- LOAD DEFAULT OF BLANK CHARACTER INTO FIRST CAT. 08
    +
    850 C LEVEL QUALITY MARKER
    +
    851 C (Current limit of 9 Cat. 08 levels)
    +
    852 C (could be expanded if need be)
    +
    853 C
    +
    854  idata(395:419:3) = iob
    +
    855 C GOES -- LOAD INTEGER MISSING INTO CAT. 13 LEVEL CHANNEL NUMBER
    +
    856 C -- LOAD DEFAULT OF BLANK CHARACTER INTO CAT. 13 LEVEL
    +
    857 C QUALITY MARKER
    +
    858 C (Current limit of 60 Cat. 13 levels)
    +
    859 C (could be expanded if need be)
    +
    860 C
    +
    861  idata(420:599:3) = imsg
    +
    862  idata(422:599:3) = iob
    +
    863  ELSE IF(itp.EQ.3) THEN
    +
    864 C
    +
    865 C VADWND -- LOAD DEFAULT OF BLANK CHARACTER INTO HGHT CAT. 04
    +
    866 C LEVEL QUALITY MARKER
    +
    867 C (Current limit of 70 Cat. 04 levels)
    +
    868 C (could be expanded if need be)
    +
    869 C
    +
    870  idata(46:1200:4) = iob
    +
    871  END IF
    +
    872  rdata(1:1200) = rdatx(1:1200)
    +
    873  RETURN
    +
    874  END
    +
    875 C> @brief Fills in header in o-put array - pflr rpt.
    +
    876 C> @author Dennis Keyser @date 2002-03-05
    +
    877 
    +
    878 C> For report (subset) read out of bufr message (passed in
    +
    879 C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    880 C> header data for wind profiler report. header is then filled into
    +
    881 C> the output array which holds a single wind profiler report in the
    +
    882 C> quasi-office note 29 unpacked format.
    +
    883 C>
    +
    884 C> ### Program History Log:
    +
    885 C> Date | Programmer | Comment
    +
    886 C> -----|------------|--------
    +
    887 C> 1996-12-16 | Dennis Keyser NP22 | Initial.
    +
    888 C> 2002-03-05 | Dennis Keyser | Accounts for changes in input proflr (wind profiler) bufr dump file after 3/2002: mnemonic "npsm" is no longer available, mnemonic "tpse" replaces "tpmi" (avg. time in minutes still output) (will still work properly for input proflr dump files prior to 3/2002)
    +
    889 C>
    +
    890 C> @param[in] LUNIT Fortran unit number for input data file
    +
    891 C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    +
    892 C> @param[out] IRET Return code as described in w3unpk77 docblock
    +
    893 C>
    +
    894 C> @author Dennis Keyser @date 2002-03-05
    +
    895  SUBROUTINE unpk7703(LUNIT,RDATA,IRET)
    +
    896  CHARACTER*6 STNID
    +
    897  CHARACTER*8 COB
    +
    898  CHARACTER*35 HDR1,HDR2
    +
    899  INTEGER IDATA(1200)
    +
    900  REAL(8) HDR_8(16)
    +
    901  REAL HDR(16),RDATA(*),RDATX(1200)
    +
    902  COMMON /pk77bb/kdate(8),ldate(8),iprint
    +
    903 
    +
    904  SAVE
    +
    905 
    +
    906  equivalence(rdatx,idata),(cob,iob)
    +
    907  DATA xmsg/99999./,imsg/99999/
    +
    908  DATA hdr1/'CLAT CLON TSIG SELV NPSM TPSE WMOB '/
    +
    909  DATA hdr2/'WMOS YEAR MNTH DAYS HOUR MINU TPMI '/
    +
    910  rdatx(1:1200) = rdata(1:1200)
    +
    911  hdr_8 = 10.0e10
    +
    912  CALL ufbint(lunit,hdr_8,16,1,nlev,hdr1//hdr2);hdr=hdr_8
    +
    913  IF(nlev.NE.1) THEN
    +
    914 C.......................................................................
    +
    915 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
    +
    916 C SET IRET = 6 AND RETURN
    +
    917  print 217, nlev
    +
    918  217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
    +
    919  $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/)
    +
    920  iret = 6
    +
    921  RETURN
    +
    922 C.......................................................................
    +
    923  END IF
    +
    924 
    +
    925 C LATITUDE (STORED AS REAL)
    +
    926 
    +
    927  m = 1
    +
    928  IF(iprint.GT.1) print 199, hdr(1),m
    +
    929  199 FORMAT(5x,'HDR HERE IS: ',f17.4,'; INDEX IS: ',i3)
    +
    930  IF(hdr(1).LT.xmsg) THEN
    +
    931  rdatx(1) = nint(hdr(1) * 100.)
    +
    932  nnnnn = 1
    +
    933  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
    +
    934  198 FORMAT(5x,'DATA(',i5,') STORED AS: ',f10.2)
    +
    935  ELSE
    +
    936  iret = 2
    +
    937  print 102
    +
    938  102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR WIND PROFILER ',
    +
    939  $ 'REPORT'/)
    +
    940  RETURN
    +
    941  END IF
    +
    942 
    +
    943 C LONGITUDE (STORED AS REAL)
    +
    944 
    +
    945  m = 2
    +
    946  IF(iprint.GT.1) print 199, hdr(2),m
    +
    947  IF(hdr(2).LT.xmsg) THEN
    +
    948  rdatx(2) = nint(mod((36000.-(hdr(2)*100.)),36000.))
    +
    949  nnnnn = 2
    +
    950  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
    +
    951  ELSE
    +
    952  iret = 2
    +
    953  print 104
    +
    954  104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR WIND PROFILER ',
    +
    955  $ 'REPORT'/)
    +
    956  RETURN
    +
    957  END IF
    +
    958 
    +
    959 C TIME SIGNIFICANCE (STORED AS INTEGER)
    +
    960 
    +
    961  m = 3
    +
    962  IF(iprint.GT.1) print 199, hdr(3),m
    +
    963  IF(hdr(3).LT.xmsg) idata(3) = nint(hdr(3))
    +
    964  nnnnn = 3
    +
    965  IF(iprint.GT.1) print 197, nnnnn,idata(nnnnn)
    +
    966  197 FORMAT(5x,'IDATA(',i5,') STORED AS: ',i10)
    +
    967 
    +
    968 C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT)
    +
    969 C (STORED AS REAL)
    +
    970 
    +
    971  m = 4
    +
    972  IF(iprint.GT.1) print 199, hdr(4),m
    +
    973  IF(hdr(4).LT.xmsg) rdatx(7) = nint(hdr(4))
    +
    974  nnnnn = 7
    +
    975  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
    +
    976 
    +
    977 C SUBMODE INFORMATION
    +
    978 C EDITION NUMBER (ALWAYS = 2)
    +
    979 C (PACKED AS SUBMODE TIMES 10 PLUS EDITION NUMBER - INTEGER)
    +
    980 C {NOTE: After 3/2002, the submode information is no longer
    +
    981 C available and is stored as missing (3).}
    +
    982 
    +
    983  m = 5
    +
    984  iedtn = 2
    +
    985  idata(8) = (3 * 10) + iedtn
    +
    986  IF(iprint.GT.1) print 199, hdr(5),m
    +
    987  IF(hdr(5).LT.xmsg) idata(8) = (nint(hdr(5)) * 10) + iedtn
    +
    988  nnnnn = 8
    +
    989  IF(iprint.GT.1) print 197, nnnnn,idata(nnnnn)
    +
    990 
    +
    991 C AVERAGING TIME (STORED AS INTEGER)
    +
    992 C (NOTE: Prior to 3/2002, this is decoded in minutes, after
    +
    993 C 3/2002 this is decoded in seconds - in either case
    +
    994 C it is stored in minutes)
    +
    995 
    +
    996  m = 6
    +
    997  IF(iprint.GT.1) print 199, hdr(6),m
    +
    998  IF(iprint.GT.1) print 199, hdr(14),m
    +
    999  IF(hdr(6).LT.xmsg) THEN
    +
    1000  idata(10) = nint(hdr(6)/60.)
    +
    1001  ELSE IF(hdr(14).LT.xmsg) THEN
    +
    1002  idata(10) = nint(hdr(14))
    +
    1003  END IF
    +
    1004  nnnnn = 10
    +
    1005  IF(iprint.GT.1) print 197, nnnnn,idata(nnnnn)
    +
    1006 C-----------------------------------------------------------------------
    +
    1007 
    +
    1008 C STATION IDENTIFICATION (STORED AS CHARACTER)
    +
    1009 C (OBTAINED FROM ENCODED WMO BLOCK/STN NUMBERS)
    +
    1010 
    +
    1011  stnid = ' '
    +
    1012 
    +
    1013 C WMO BLOCK NUMBER (STORED AS CHARACTER)
    +
    1014 
    +
    1015  m = 7
    +
    1016  IF(iprint.GT.1) print 199, hdr(7),m
    +
    1017  IF(hdr(7).LT.xmsg) WRITE(stnid(1:2),'(I2.2)') nint(hdr(7))
    +
    1018 
    +
    1019 C WMO STATION NUMBER (STORED AS CHARACTER)
    +
    1020 
    +
    1021  m = 8
    +
    1022  IF(iprint.GT.1) print 199, hdr(8),m
    +
    1023  IF(hdr(8).LT.xmsg) WRITE(stnid(3:5),'(I3.3)') nint(hdr(8))
    +
    1024  cob(1:4) = stnid(1:4)
    +
    1025  idata(11) = iob
    +
    1026  nnnnn = 11
    +
    1027  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
    +
    1028  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
    +
    1029  cob(1:4) = stnid(5:6)//' '
    +
    1030  idata(12) = iob
    +
    1031  nnnnn = 12
    +
    1032  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
    +
    1033 
    +
    1034 cvvvvvdak port
    +
    1035 C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
    +
    1036 caaaaadak port
    +
    1037 
    +
    1038  m = 9
    +
    1039  IF(iprint.GT.1) print 199, hdr(9),m
    +
    1040  iyear = imsg
    +
    1041  IF(hdr(9).LT.xmsg) iyear = nint(hdr(9))
    +
    1042  m = 10
    +
    1043  IF(iprint.GT.1) print 199, hdr(10),m
    +
    1044  IF(hdr(10).LT.xmsg.AND.iyear.LT.imsg) THEN
    +
    1045 cvvvvvdak port
    +
    1046  iyear = mod(iyear,100)
    +
    1047 caaaaadak port
    +
    1048  iyear = nint(hdr(10)) + (iyear * 100)
    +
    1049 cvvvvvdak port
    +
    1050 cdak WRITE(COB,'(I6.6,2X)') IYEAR
    +
    1051  WRITE(cob,'(I4.4,4X)') iyear
    +
    1052 caaaaadak port
    +
    1053  idata(5) = iob
    +
    1054  nnnnn = 5
    +
    1055  IF(iprint.GT.1) print 9196, nnnnn,cob(1:6)
    +
    1056  9196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a6,'"')
    +
    1057  ELSE
    +
    1058  GO TO 30
    +
    1059  END IF
    +
    1060 
    +
    1061 C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
    +
    1062 C AND THE OBSERVATION TIME (STORED AS REAL)
    +
    1063 
    +
    1064  m = 11
    +
    1065  IF(iprint.GT.1) print 199, hdr(11),m
    +
    1066  iday = imsg
    +
    1067  IF(hdr(11).LT.xmsg) iday = nint(hdr(11))
    +
    1068  m = 12
    +
    1069  IF(iprint.GT.1) print 199, hdr(12),m
    +
    1070  IF(hdr(12).LT.xmsg.AND.iday.LT.imsg) THEN
    +
    1071  ihrt = nint(hdr(12))
    +
    1072  m = 13
    +
    1073  IF(iprint.GT.1) print 199, hdr(13),m
    +
    1074  IF(hdr(13).GE.xmsg) GO TO 30
    +
    1075  rmnt = hdr(13)
    +
    1076  rdatx(4) = nint((ihrt * 100.) + (rmnt * 100.)/60.)
    +
    1077  nnnnn = 4
    +
    1078  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
    +
    1079  ihrt = ihrt + (iday * 100)
    +
    1080  WRITE(cob(1:4),'(I4.4)') ihrt
    +
    1081  idata(6) = iob
    +
    1082  nnnnn = 6
    +
    1083  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
    +
    1084  ELSE
    +
    1085  GO TO 30
    +
    1086  END IF
    +
    1087  rdata(1:1200) = rdatx(1:1200)
    +
    1088  RETURN
    +
    1089  30 CONTINUE
    +
    1090  iret = 4
    +
    1091  RETURN
    +
    1092  END
    +
    1093 C> @brief Fills cat.10 into o-put array - pflr rpt
    +
    1094 C> @author Dennis Keyser @date 2002-03-05
    +
    1095 
    +
    1096 C> For report (subset) read out of bufr message (passed in
    +
    1097 C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    1098 C> surface data for wind profiler report. Surface data are then
    +
    1099 C> filled into the output array as category 10. The ouput array
    +
    1100 C> holds a single wind profiler report in the quasi-office note 29
    +
    1101 C> unpacked format.
    +
    1102 C>
    +
    1103 C> ### Program History Log:
    +
    1104 C> Date | Programmer | Comment
    +
    1105 C> -----|------------|--------
    +
    1106 C> 1996-12-16 | Dennis Keyser NP22 | Initial.
    +
    1107 C> 2002-03-05 | Dennis Keyser | Accounts for changes in input proflr (wind profiler) bufr dump file after 3/2002: surface data now all missing (mnemonics "pmsl", "wdir1","wspd1", "tmdb", "rehu", "reqv" no longer available) (will still work properly for input proflr dump files prior to 3/2002)
    +
    1108 C>
    +
    1109 C> @param[in] LUNIT Fortran unit number for input data file
    +
    1110 C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    +
    1111 C>
    +
    1112 C> @remark Called by subroutine w3unpkb7. after 3/2002, there is no surface data available.
    +
    1113 C>
    +
    1114 C$$$
    +
    1115  SUBROUTINE unpk7704(LUNIT,RDATA)
    +
    1116  CHARACTER*40 SRFC
    +
    1117  INTEGER IDATA(1200)
    +
    1118  REAL(8) SFC_8(8)
    +
    1119  REAL SFC(8),RDATA(*),RDATX(1200)
    +
    1120  COMMON /pk77bb/kdate(8),ldate(8),iprint
    +
    1121 
    +
    1122  SAVE
    +
    1123 
    +
    1124  equivalence(rdatx,idata)
    +
    1125  DATA xmsg/99999./
    +
    1126  DATA srfc/'PMSL WDIR1 WSPD1 TMDB REHU REQV '/
    +
    1127  rdatx(1:1200) = rdata(1:1200)
    +
    1128  sfc_8 = 10.0e10
    +
    1129  CALL ufbint(lunit,sfc_8,8,1,nlev,srfc);sfc=sfc_8
    +
    1130  IF(nlev.NE.1) THEN
    +
    1131 C.......................................................................
    +
    1132 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
    +
    1133  print 217, nlev
    +
    1134  217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
    +
    1135  $ 'IS NOT WHAT IS EXPECTED (1) - NO SFC DATA PROCESSED'/)
    +
    1136  GO TO 99
    +
    1137 C.......................................................................
    +
    1138  END IF
    +
    1139 
    +
    1140 C MSL PRESSURE (STORED AS REAL)
    +
    1141 
    +
    1142  m = 1
    +
    1143  IF(iprint.GT.1) print 199, sfc(1),m
    +
    1144  199 FORMAT(5x,'SFC HERE IS: ',f17.4,'; INDEX IS: ',i3)
    +
    1145  IF((sfc(1)*0.1).LT.xmsg) rdatx(43) = nint(sfc(1) * 0.1)
    +
    1146  nnnnn = 43
    +
    1147  IF(iprint.GT.1) print 198, nnnnn,rdatx(43)
    +
    1148  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
    +
    1149 
    +
    1150 C SURFACE HORIZONTAL WIND DIRECTION (STORED AS REAL)
    +
    1151 
    +
    1152  m = 2
    +
    1153  IF(iprint.GT.1) print 199, sfc(2),m
    +
    1154  IF(sfc(2).LT.xmsg) rdatx(43+2) = nint(sfc(2))
    +
    1155  nnnnn = 43 + 2
    +
    1156  IF(iprint.GT.1) print 198, nnnnn,rdatx(43+2)
    +
    1157 
    +
    1158 C SURFACE HORIZONTAL WIND SPEED (STORED AS REAL)
    +
    1159 
    +
    1160  m = 3
    +
    1161  IF(iprint.GT.1) print 199, sfc(3),m
    +
    1162  IF(sfc(3).LT.xmsg) rdatx(43+3) = nint(sfc(3) * 10.)
    +
    1163  nnnnn = 43 + 3
    +
    1164  IF(iprint.GT.1) print 198, nnnnn,rdatx(43+3)
    +
    1165 
    +
    1166 C SURFACE TEMPERATURE (STORED AS REAL)
    +
    1167 
    +
    1168  m = 4
    +
    1169  IF(iprint.GT.1) print 199, sfc(4),m
    +
    1170  IF(sfc(4).LT.xmsg) rdatx(43+4) = nint(sfc(4) * 10.)
    +
    1171  nnnnn = 43 + 4
    +
    1172  IF(iprint.GT.1) print 198, nnnnn,rdatx(43+4)
    +
    1173 
    +
    1174 C RELATIVE HUMIDITY (STORED AS REAL)
    +
    1175 
    +
    1176  m = 5
    +
    1177  IF(iprint.GT.1) print 199, sfc(5),m
    +
    1178  IF(sfc(5).LT.xmsg) rdatx(43+5) = nint(sfc(5))
    +
    1179  nnnnn = 43 + 5
    +
    1180  IF(iprint.GT.1) print 198, nnnnn,rdatx(43+5)
    +
    1181 
    +
    1182 C RAINFALL RATE (STORED AS REAL)
    +
    1183 
    +
    1184  m = 6
    +
    1185  IF(iprint.GT.1) print 199, sfc(6),m
    +
    1186  IF(sfc(6).LT.xmsg) rdatx(43+6) = nint(sfc(6) * 1.e7)
    +
    1187  nnnnn = 43 + 6
    +
    1188  IF(iprint.GT.1) print 198, nnnnn,rdatx(43+6)
    +
    1189 
    +
    1190 C SET CATEGORY COUNTERS FOR SURFACE DATA
    +
    1191 
    +
    1192  idata(35) = 1
    +
    1193  idata(36) = 43
    +
    1194  99 CONTINUE
    +
    1195  IF(iprint.GT.1) print *, 'IDATA(35)=',idata(35),'; IDATA(36)=',
    +
    1196  $ idata(36)
    +
    1197  rdata(1:1200) = rdatx(1:1200)
    +
    1198  RETURN
    +
    1199  END
    +
    1200 C> @brief Fills cat.11 into o-put array - pflr rpt
    +
    1201 C> @author Dennis Keyser @date 2002-03-05
    +
    1202 
    +
    1203 C> For report (subset) read out of bufr message (passed in
    +
    1204 C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    1205 C> upper-air data for wind profiler report. upper-air data are then
    +
    1206 C> filled into the output array as category 11. the ouput array
    +
    1207 C> holds a single wind profiler report in the quasi-office note 29
    +
    1208 C> unpacked format.
    +
    1209 C>
    +
    1210 C> ### Program History Log:
    +
    1211 C> Date | Programmer | Comment
    +
    1212 C> -----|------------|--------
    +
    1213 C> 1996-12-16 | Dennis Keyser NP22 | Initial.
    +
    1214 C> 1998-07-09 | Dennis Keyser | Modified wind profiler cat. 11 (height, horiz. significance, vert. significance) processing to account for updates to bufrtable mnemonics in /dcom
    +
    1215 C> 2002-03-05 | Dennis Keyser | Accounts for changes in input proflr (wind profiler) bufr dump file after 3/2002: mnemonics "acavh", "acavv", "spp0", and "nphl" no longer available; (will still work properly for input proflr dump files prior to 3/2002)
    +
    1216 C>
    +
    1217 C> @param[in] LUNIT Fortran unit number for input data file
    +
    1218 C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    +
    1219 C>
    +
    1220 C$$$
    +
    1221  SUBROUTINE unpk7705(LUNIT,RDATA)
    +
    1222  CHARACTER*31 UAIR1,UAIR2
    +
    1223  CHARACTER*16 UAIR3
    +
    1224  INTEGER IDATA(1200)
    +
    1225  REAL(8) UAIR_8(16,255)
    +
    1226  REAL UAIR(16,255),RDATA(*),RDATX(1200)
    +
    1227  COMMON /pk77bb/kdate(8),ldate(8),iprint
    +
    1228 
    +
    1229  SAVE
    +
    1230 
    +
    1231  equivalence(rdatx,idata)
    +
    1232  DATA xmsg/99999./
    +
    1233  DATA uair1/'HEIT WDIR WSPD NPQC WCMP ACAVH '/
    +
    1234  DATA uair2/'ACAVV SPP0 SDHS SDVS NPHL '/
    +
    1235  DATA uair3/'HAST ACAV1 ACAV2'/
    +
    1236  rdatx(1:1200) = rdata(1:1200)
    +
    1237  nsfc = 0
    +
    1238  ilvl = 0
    +
    1239  ilc = 0
    +
    1240 C FIRST UPPER-AIR LEVEL IS THE SURFACE INFORMATION
    +
    1241  IF(iprint.GT.1) print 1078, ilc,ilvl
    +
    1242  1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',i5,'; NO. LEVELS ',
    +
    1243  $ 'PROCESSED TO NOW =',i5)
    +
    1244  rdatx(50+ilc) = rdatx(7)
    +
    1245  IF(iprint.GT.1) print 198, 50+ilc,rdatx(50+ilc)
    +
    1246  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
    +
    1247  IF(rdatx(50+ilc).LT.xmsg) nsfc = 1
    +
    1248  IF(idata(35).GE.1) THEN
    +
    1249  rdatx(50+ilc+1) = rdatx(idata(36)+2)
    +
    1250  rdatx(50+ilc+2) = rdatx(idata(36)+3)
    +
    1251  END IF
    +
    1252  IF(iprint.GT.1) print 198, 50+ilc+1,rdatx(50+ilc+1)
    +
    1253  IF(rdatx(50+ilc+1).LT.xmsg) nsfc = 1
    +
    1254  IF(iprint.GT.1) print 198, 50+ilc+2,rdatx(50+ilc+2)
    +
    1255  IF(rdatx(50+ilc+2).LT.xmsg) nsfc = 1
    +
    1256  ilvl = ilvl + 1
    +
    1257  ilc = ilc + 11
    +
    1258  IF(iprint.GT.1) print *,'HAVE COMPLETED LEVEL ',ilvl,' WITH ',
    +
    1259  $ 'NSFC=',nsfc,'; GOING INTO NEXT LEVEL WITH ILC=',ilc
    +
    1260  uair_8 = 10.0e10
    +
    1261  CALL ufbint(lunit,uair_8,16,255,nlev,uair1//uair2//uair3)
    +
    1262  uair=uair_8
    +
    1263  IF(nlev.EQ.0) THEN
    +
    1264 C.......................................................................
    +
    1265 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
    +
    1266  IF(nsfc.EQ.0) THEN
    +
    1267 C ... NO UPPER AIR DATA PROCESSED
    +
    1268  print 217
    +
    1269  217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS',
    +
    1270  $ ' REPORT -- NLEV = 0 AND NSFC = 0'/)
    +
    1271  GO TO 99
    +
    1272  ELSE
    +
    1273 C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED
    +
    1274  print 218
    +
    1275  218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ',
    +
    1276  $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/)
    +
    1277  GO TO 98
    +
    1278  END IF
    +
    1279 C.......................................................................
    +
    1280  END IF
    +
    1281  IF(iprint.GT.1) print 1068, nlev
    +
    1282  1068 FORMAT(' THIS REPORT CONTAINS ',i3,' LEVELS OF DATA (NOT ',
    +
    1283  $ 'INCLUDING BOTTOM -SURFACE- LEVEL)')
    +
    1284  DO i = 1,nlev
    +
    1285  IF(iprint.GT.1) print 1079, ilc,ilvl
    +
    1286  1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',i5,'; NO. LEVELS ',
    +
    1287  $ 'PROCESSED TO NOW =',i5)
    +
    1288 
    +
    1289 C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL)
    +
    1290 C (NOTE: At one time, possibly even now, the height above sea
    +
    1291 C level was erroneously stored under mnemonic "HAST"
    +
    1292 C when it should have been stored under mnemonic "HEIT".
    +
    1293 C ("HAST" is defined as the height above the station.)
    +
    1294 C Will test first for valid data in "HEIT" - if missing,
    +
    1295 C then will use data in "HAST" - this will allow this
    +
    1296 C routine to transition w/o change when the fix is made.)
    +
    1297 
    +
    1298  IF(uair(1,i).LT.xmsg) THEN
    +
    1299  m = 1
    +
    1300  IF(iprint.GT.1) print 199, uair(1,i),m
    +
    1301  199 FORMAT(5x,'UAIR HERE IS: ',f17.4,'; INDEX IS: ',i3)
    +
    1302  rdatx(50+ilc) = nint(uair(1,i))
    +
    1303  ELSE
    +
    1304  m = 12
    +
    1305  IF(iprint.GT.1) print 199, uair(12,i),m
    +
    1306  IF(uair(12,i).LT.xmsg) rdatx(50+ilc) = nint(uair(12,i))
    +
    1307  END IF
    +
    1308  IF(iprint.GT.1) print 198, 50+ilc,rdatx(50+ilc)
    +
    1309  ilvl = ilvl + 1
    +
    1310 
    +
    1311 C HORIZONTAL WIND DIRECTION (STORED AS REAL)
    +
    1312 
    +
    1313  m = 2
    +
    1314  IF(iprint.GT.1) print 199, uair(2,i),m
    +
    1315  IF(uair(2,i).LT.xmsg) rdatx(50+ilc+1) = nint(uair(2,i))
    +
    1316  IF(iprint.GT.1) print 198, 50+ilc+1,rdatx(50+ilc+1)
    +
    1317 
    +
    1318 C HORIZONTAL WIND SPEED (STORED AS REAL)
    +
    1319 
    +
    1320  m = 3
    +
    1321  IF(iprint.GT.1) print 199, uair(3,i),m
    +
    1322  IF(uair(3,i).LT.xmsg) rdatx(50+ilc+2) =nint(uair(3,i) * 10.)
    +
    1323  IF(iprint.GT.1) print 198, 50+ilc+2,rdatx(50+ilc+2)
    +
    1324 
    +
    1325 C QUALITY CODE (STORED AS INTEGER)
    +
    1326 
    +
    1327  m = 4
    +
    1328  IF(iprint.GT.1) print 199, uair(4,i),m
    +
    1329  IF(uair(4,i).LT.xmsg) idata(50+ilc+3) = nint(uair(4,i))
    +
    1330  IF(iprint.GT.1) print 197, 50+ilc+3,idata(50+ilc+3)
    +
    1331  197 FORMAT(5x,'IDATA(',i5,') STORED AS: ',i10)
    +
    1332 
    +
    1333 C VERTICAL WIND COMPONENT (W) (STORED AS REAL)
    +
    1334 
    +
    1335  m = 5
    +
    1336  IF(iprint.GT.1) print 199, uair(5,i),m
    +
    1337  IF(uair(5,i).LT.xmsg) rdatx(50+ilc+4) = nint(uair(5,i) * 100.)
    +
    1338  IF(iprint.GT.1) print 198, 50+ilc+4,rdatx(50+ilc+4)
    +
    1339 
    +
    1340 C HORIZONTAL CONSENSUS NUMBER (STORED AS INTEGER)
    +
    1341 C (NOTE: Prior to 2/18/1999, the horizonal consensus number was
    +
    1342 C stored under mnemonic "ACAV1".
    +
    1343 C From 2/18/1999 through 3/2002, the horizontal consensus
    +
    1344 C number was stored under mnemonic "ACAVH".
    +
    1345 C After 3/2002, the horizontal consensus number is no
    +
    1346 C longer stored.
    +
    1347 C Will test first for valid data in "ACAVH" - if missing,
    +
    1348 C then will test for data in "ACAV1" - this will allow
    +
    1349 C this routine to work properly with historical data.)
    +
    1350 
    +
    1351  IF(iprint.GT.1) print 199, uair(6,i),m
    +
    1352  IF(iprint.GT.1) print 199, uair(13,i),m
    +
    1353  IF(uair(6,i).LT.xmsg) THEN
    +
    1354  m = 6
    +
    1355  idata(50+ilc+5) = nint(uair(6,i))
    +
    1356  ELSE
    +
    1357  m = 13
    +
    1358  IF(uair(13,i).LT.xmsg) idata(50+ilc+5) = nint(uair(13,i))
    +
    1359  END IF
    +
    1360  IF(iprint.GT.1) print 197, 50+ilc+5,idata(50+ilc+5)
    +
    1361 
    +
    1362 C VERTICAL CONSENSUS NUMBER (STORED AS INTEGER)
    +
    1363 C (NOTE: Prior to 2/18/1999, the vertical consensus number was
    +
    1364 C stored under mnemonic "ACAV2".
    +
    1365 C From 2/18/1999 through 3/2002, the vertical consensus
    +
    1366 C number was stored under mnemonic "ACAVV".
    +
    1367 C After 3/2002, the vertical consensus number is no
    +
    1368 C longer stored.
    +
    1369 C Will test first for valid data in "ACAVV" - if missing,
    +
    1370 C then will test for data in "ACAV2" - this will allow
    +
    1371 C this routine to work properly with historical data.)
    +
    1372 
    +
    1373  IF(iprint.GT.1) print 199, uair(7,i),m
    +
    1374  IF(iprint.GT.1) print 199, uair(14,i),m
    +
    1375  IF(uair(7,i).LT.xmsg) THEN
    +
    1376  m = 7
    +
    1377  idata(50+ilc+6) = nint(uair(7,i))
    +
    1378  ELSE
    +
    1379  m = 14
    +
    1380  IF(uair(14,i).LT.xmsg) idata(50+ilc+6) = nint(uair(14,i))
    +
    1381  END IF
    +
    1382  IF(iprint.GT.1) print 197, 50+ilc+6,idata(50+ilc+6)
    +
    1383 
    +
    1384 C SPECTRAL PEAK POWER (STORED AS REAL)
    +
    1385 C (NOTE: After 3/2002, the spectral peak power is no longer
    +
    1386 C stored.)
    +
    1387 
    +
    1388  m = 8
    +
    1389  IF(iprint.GT.1) print 199, uair(8,i),m
    +
    1390  IF(uair(8,i).LT.xmsg) rdatx(50+ilc+7) = nint(uair(8,i))
    +
    1391  IF(iprint.GT.1) print 198, 50+ilc+7,rdatx(50+ilc+7)
    +
    1392 
    +
    1393 C HORIZONTAL WIND SPEED STANDARD DEVIATION (STORED AS REAL)
    +
    1394 
    +
    1395  m = 9
    +
    1396  IF(iprint.GT.1) print 199, uair(9,i),m
    +
    1397  IF(uair(9,i).LT.xmsg) rdatx(50+ilc+8)=nint(uair(9,i) * 10.)
    +
    1398  IF(iprint.GT.1) print 198, 50+ilc+8,rdatx(50+ilc+8)
    +
    1399 
    +
    1400 C VERTICAL WIND COMPONENT STANDARD DEVIATION (STORED AS REAL)
    +
    1401 
    +
    1402  m = 10
    +
    1403  IF(iprint.GT.1) print 199, uair(10,i),m
    +
    1404  IF(uair(10,i).LT.xmsg) rdatx(50+ilc+9) =nint(uair(10,i) * 10.)
    +
    1405  IF(iprint.GT.1) print 198, 50+ilc+9,rdatx(50+ilc+9)
    +
    1406 
    +
    1407 C MODE INFORMATION (STORED AS INTEGER)
    +
    1408 C (NOTE: After 3/2002, the mode information is no longer stored.)
    +
    1409 
    +
    1410  m = 11
    +
    1411  IF(iprint.GT.1) print 199, uair(11,i),m
    +
    1412  IF(uair(11,i).LT.xmsg) idata(50+ilc+10) = nint(uair(11,i))
    +
    1413  IF(iprint.GT.1) print 197, 50+ilc+10,idata(50+ilc+10)
    +
    1414 C.......................................................................
    +
    1415  ilc = ilc + 11
    +
    1416  IF(iprint.GT.1) print *,'HAVE COMPLETED LEVEL ',ilvl,
    +
    1417  $ '; GOING INTO NEXT LEVEL WITH ILC=',ilc
    +
    1418  ENDDO
    +
    1419 
    +
    1420 C SET CATEGORY COUNTERS FOR UPPER-AIR DATA
    +
    1421 
    +
    1422  98 CONTINUE
    +
    1423  idata(37) = ilvl
    +
    1424  idata(38) = 50
    +
    1425  99 CONTINUE
    +
    1426  IF(iprint.GT.1) print *, 'NSFC=',nsfc,'; IDATA(37)=',idata(37),
    +
    1427  $ '; IDATA(38)=',idata(38)
    +
    1428  rdata(1:1200) = rdatx(1:1200)
    +
    1429  RETURN
    +
    1430  END
    +
    1431 C> @brief Fills in header in o-put array - vadw rpt.
    +
    1432 C> @author Dennis Keyser @date 1997-06-02
    +
    1433 
    +
    1434 C> For report (subset) read out of bufr message (passed in
    +
    1435 C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    1436 C> header data for nexrad (vad) wind report. Header is then filled
    +
    1437 C> into the output array which holds a single vad wind report in the
    +
    1438 C> quasi-office note 29 unpacked format.
    +
    1439 C>
    +
    1440 C> ### Program History Log:
    +
    1441 C> Date | Programmer | Comment
    +
    1442 C> -----|------------|--------
    +
    1443 C> 1997-06-02 | Dennis Keyser NP22 | Initial.
    +
    1444 C>
    +
    1445 C> @param[in] LUNIT Fortran unit number for input data file
    +
    1446 C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    +
    1447 C> @param[out] IRET Return code as described in w3unpk77 docblock
    +
    1448 C>
    +
    1449 C> @author Dennis Keyser @date 1997-06-02
    +
    1450  SUBROUTINE unpk7706(LUNIT,RDATA,IRET)
    +
    1451  CHARACTER*8 STNID,COB
    +
    1452  CHARACTER*45 HDR1
    +
    1453  INTEGER IDATA(1200)
    +
    1454  REAL(8) HDR_8(9)
    +
    1455  REAL HDR(9),RDATA(*),RDATX(1200)
    +
    1456  COMMON /pk77bb/kdate(8),ldate(8),iprint
    +
    1457 
    +
    1458  SAVE
    +
    1459 
    +
    1460  equivalence(rdatx,idata),(stnid,hdr_8(4)),(cob,iob)
    +
    1461  DATA xmsg/99999./,imsg/99999/
    +
    1462  DATA hdr1/'CLAT CLON SELV RPID YEAR MNTH DAYS HOUR MINU '/
    +
    1463  rdatx(1:1200) = rdata(1:1200)
    +
    1464  hdr_8 = 10.0e10
    +
    1465  CALL ufbint(lunit,hdr_8,9,1,nlev,hdr1);hdr=hdr_8
    +
    1466  IF(nlev.NE.1) THEN
    +
    1467 C.......................................................................
    +
    1468 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
    +
    1469 C SET IRET = 6 AND RETURN
    +
    1470  print 217, nlev
    +
    1471  217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
    +
    1472  $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/)
    +
    1473  iret = 6
    +
    1474  RETURN
    +
    1475 C.......................................................................
    +
    1476  END IF
    +
    1477 
    +
    1478 C LATITUDE (STORED AS REAL)
    +
    1479 
    +
    1480  m = 1
    +
    1481  IF(iprint.GT.1) print 199, hdr(1),m
    +
    1482  199 FORMAT(5x,'HDR HERE IS: ',f17.4,'; INDEX IS: ',i3)
    +
    1483  IF(hdr(1).LT.xmsg) THEN
    +
    1484  rdatx(1) = nint(hdr(1) * 100.)
    +
    1485  nnnnn = 1
    +
    1486  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
    +
    1487  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
    +
    1488  ELSE
    +
    1489  iret = 2
    +
    1490  print 102
    +
    1491  102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR VAD WIND REPORT'/)
    +
    1492  RETURN
    +
    1493  END IF
    +
    1494 
    +
    1495 C LONGITUDE (STORED AS REAL)
    +
    1496 
    +
    1497  m = 2
    +
    1498  IF(iprint.GT.1) print 199, hdr(2),m
    +
    1499  IF(hdr(2).LT.xmsg) THEN
    +
    1500  rdatx(2) = nint(mod((36000.-(hdr(2)*100.)),36000.))
    +
    1501  nnnnn = 2
    +
    1502  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
    +
    1503  ELSE
    +
    1504  iret = 2
    +
    1505  print 104
    +
    1506  104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR VAD WIND REPORT'/)
    +
    1507  RETURN
    +
    1508  END IF
    +
    1509 
    +
    1510 C STATION ELEVATION (FROM REPORTED STN. HGHT; STORED IN OUTPUT)
    +
    1511 C (STORED AS REAL)
    +
    1512 
    +
    1513  m = 3
    +
    1514  IF(iprint.GT.1) print 199, hdr(3),m
    +
    1515  IF(hdr(3).LT.xmsg) rdatx(7) = nint(hdr(3))
    +
    1516  nnnnn = 7
    +
    1517  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
    +
    1518 
    +
    1519 C STATION IDENTIFICATION (STORED AS CHARACTER)
    +
    1520 C ('99'//LAST 3-CHARACTERS OF PRODUCT SOURCE ID//' ')
    +
    1521 
    +
    1522  m = 4
    +
    1523  IF(iprint.GT.1) print 299, stnid,m
    +
    1524  299 FORMAT(5x,'HDR HERE IS: ',9x,a8,'; INDEX IS: ',i3)
    +
    1525  cob(1:4) = '99'//stnid(2:3)
    +
    1526  idata(11) = iob
    +
    1527  nnnnn = 11
    +
    1528  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
    +
    1529  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
    +
    1530  cob(1:4) = stnid(4:4)//' '
    +
    1531  idata(12) = iob
    +
    1532  nnnnn = 12
    +
    1533  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
    +
    1534 
    +
    1535 cvvvvvdak port
    +
    1536 C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
    +
    1537 caaaaadak port
    +
    1538 
    +
    1539  m = 5
    +
    1540  IF(iprint.GT.1) print 199, hdr(5),m
    +
    1541  iyear = imsg
    +
    1542  IF(hdr(5).LT.xmsg) iyear = nint(hdr(5))
    +
    1543  m = 6
    +
    1544  IF(iprint.GT.1) print 199, hdr(6),m
    +
    1545  IF(hdr(6).LT.xmsg.AND.iyear.LT.imsg) THEN
    +
    1546 cvvvvvdak port
    +
    1547  iyear = mod(iyear,100)
    +
    1548 caaaaadak port
    +
    1549  iyear = nint(hdr(6)) + (iyear * 100)
    +
    1550 cvvvvvdak port
    +
    1551 cdak WRITE(COB,'(I6.6,2X)') IYEAR
    +
    1552  WRITE(cob,'(I4.4,4X)') iyear
    +
    1553 caaaaadak port
    +
    1554  idata(5) = iob
    +
    1555  nnnnn = 5
    +
    1556  IF(iprint.GT.1) print 9196, nnnnn,cob(1:6)
    +
    1557  9196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a6,'"')
    +
    1558  ELSE
    +
    1559  GO TO 30
    +
    1560  END IF
    +
    1561 
    +
    1562 C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
    +
    1563 C AND THE OBSERVATION TIME (STORED AS REAL)
    +
    1564 
    +
    1565  m = 7
    +
    1566  IF(iprint.GT.1) print 199, hdr(7),m
    +
    1567  iday = imsg
    +
    1568  IF(hdr(7).LT.xmsg) iday = nint(hdr(7))
    +
    1569  m = 8
    +
    1570  IF(iprint.GT.1) print 199, hdr(8),m
    +
    1571  IF(hdr(8).LT.xmsg.AND.iday.LT.imsg) THEN
    +
    1572  ihrt = nint(hdr(8))
    +
    1573  m = 9
    +
    1574  IF(iprint.GT.1) print 199, hdr(9),m
    +
    1575  IF(hdr(9).GE.xmsg) GO TO 30
    +
    1576  rmnt = hdr(9)
    +
    1577  rdatx(4) = nint((ihrt * 100.) + (rmnt * 100.)/60.)
    +
    1578  nnnnn = 4
    +
    1579  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
    +
    1580  ihrt = ihrt + (iday * 100)
    +
    1581  WRITE(cob(1:4),'(I4.4)') ihrt
    +
    1582  idata(6) = iob
    +
    1583  nnnnn = 6
    +
    1584  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
    +
    1585  ELSE
    +
    1586  GO TO 30
    +
    1587  END IF
    +
    1588  rdata(1:1200) = rdatx(1:1200)
    +
    1589  RETURN
    +
    1590  30 CONTINUE
    +
    1591  iret = 4
    +
    1592  RETURN
    +
    1593  END
    +
    1594 C> @brief Fills cat. 4 into o-put array - vadw rpt
    +
    1595 C> @author Dennis Keyser @date 1997-06-02
    +
    1596 
    +
    1597 C> For report (subset) read out of bufr message (passed in
    +
    1598 C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    1599 C> upper-air data for nexrad (vad) wind report. Upper-air data are
    +
    1600 C> then filled into the output array as category 4. The ouput array
    +
    1601 C> holds a single vad wind report in the quasi-office note 29
    +
    1602 C> unpacked format.
    +
    1603 C>
    +
    1604 C> ### Program History Log:
    +
    1605 C> Date | Programmer | Comment
    +
    1606 C> -----|------------|--------
    +
    1607 C> 1997-06-02 | Dennis Keyser NP22 | Initial.
    +
    1608 C>
    +
    1609 C> @param[in] LUNIT Fortran unit number for input data file
    +
    1610 C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    +
    1611 C> @param[out] IRET Return code as described in w3unpk77 docblock
    +
    1612 C>
    +
    1613 C> @author Dennis Keyser @date 1997-06-02
    +
    1614  SUBROUTINE unpk7707(LUNIT,RDATA,IRET)
    +
    1615  CHARACTER*1 CRMS(0:12)
    +
    1616  CHARACTER*8 COB
    +
    1617  CHARACTER*25 UAIR1
    +
    1618  INTEGER IDATA(1200)
    +
    1619  REAL(8) UAIR_8(5,255)
    +
    1620  REAL UAIR(5,255),RDATA(*),RDATX(1200)
    +
    1621  COMMON /pk77bb/kdate(8),ldate(8),iprint
    +
    1622 
    +
    1623  SAVE
    +
    1624 
    +
    1625  equivalence(rdatx,idata),(cob,iob)
    +
    1626  DATA xmsg/99999./
    +
    1627  DATA uair1/'HEIT WDIR WSPD RMSW QMWN '/
    +
    1628  DATA crms/' ','A',' ','B',' ','C',' ','D',' ','E',' ','F',' '/
    +
    1629  rdatx(1:1200) = rdata(1:1200)
    +
    1630  nsfc = 0
    +
    1631  ilvl = 0
    +
    1632  ilc = 0
    +
    1633 C FIRST CATEGORY 4 LEVEL UPPER-AIR LEVEL CONTAINS ONLY HEIGHT (ELEV)
    +
    1634  IF(iprint.GT.1) print 1078, ilc,ilvl
    +
    1635  1078 FORMAT(' ATTEMPTING 1ST (SFC) LVL WITH ILC =',i5,'; NO. LEVELS ',
    +
    1636  $ 'PROCESSED TO NOW =',i5)
    +
    1637  rdatx(43+ilc) = rdatx(7)
    +
    1638  IF(iprint.GT.1) print 198, 43+ilc,rdatx(43+ilc)
    +
    1639  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
    +
    1640  IF(rdatx(43+ilc).LT.xmsg) nsfc = 1
    +
    1641 C NOTE: The following was added because of a problem on the sgi-ha
    +
    1642 C platform related to equivalencing character and non-character
    +
    1643 C -- for now the addition of these two lines will set the quality
    +
    1644 C mark for sfc. cat . 4 level to the correct value of " "
    +
    1645 C rather than to "9999" - Mary McCann notified SGI of this
    +
    1646 C problem on 08-21-1998
    +
    1647  cob = ' '
    +
    1648  idata(43+ilc+3) = iob
    +
    1649  ilvl = ilvl + 1
    +
    1650  ilc = ilc + 4
    +
    1651  IF(iprint.GT.1) print *,'HAVE COMPLETED LEVEL ',ilvl,' WITH ',
    +
    1652  $ 'NSFC=',nsfc,'; GOING INTO NEXT LEVEL WITH ILC=',ilc
    +
    1653  uair_8 = 10.0e10
    +
    1654  CALL ufbint(lunit,uair_8,5,255,nlev,uair1);uair=uair_8
    +
    1655  IF(nlev.EQ.0) THEN
    +
    1656 C.......................................................................
    +
    1657 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
    +
    1658  IF(nsfc.EQ.0) THEN
    +
    1659 C ... NO UPPER AIR DATA PROCESSED
    +
    1660  print 217
    +
    1661  217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA PROCESSED FOR THIS',
    +
    1662  $ ' REPORT -- NLEV = 0 AND NSFC = 0'/)
    +
    1663  GO TO 99
    +
    1664  ELSE
    +
    1665 C ... ONLY FIRST (SURFACE) UPPER AIR LEVEL DATA PROCESSED
    +
    1666  print 218
    +
    1667  218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR DATA ABOVE FIRST (SURFACE) ',
    +
    1668  $ 'LEVEL PROCESSED FOR THIS REPORT -- NLEV = 0 AND NSFC > 0'/)
    +
    1669  GO TO 98
    +
    1670  END IF
    +
    1671 C.......................................................................
    +
    1672  END IF
    +
    1673  IF(iprint.GT.1) print 1068, nlev
    +
    1674  1068 FORMAT(' THIS REPORT CONTAINS ',i3,' LEVELS OF DATA (NOT ',
    +
    1675  $ 'INCLUDING BOTTOM -SURFACE- LEVEL)')
    +
    1676  DO i = 1,nlev
    +
    1677  IF(iprint.GT.1) print 1079, ilc,ilvl
    +
    1678  1079 FORMAT(' ATTEMPTING NEW LEVEL WITH ILC =',i5,'; NO. LEVELS ',
    +
    1679  $ 'PROCESSED TO NOW =',i5)
    +
    1680 
    +
    1681 C HEIGHT ABOVE SEA-LEVEL (STORED AS REAL)
    +
    1682 
    +
    1683  m = 1
    +
    1684  IF(iprint.GT.1) print 199, uair(1,i),m
    +
    1685  199 FORMAT(5x,'UAIR HERE IS: ',f17.4,'; INDEX IS: ',i3)
    +
    1686  IF(uair(1,i).LT.xmsg) THEN
    +
    1687  rdatx(43+ilc) = nint(uair(1,i))
    +
    1688 
    +
    1689 C ... WE HAVE A VALID CATEGORY 4 LEVEL -- THERE IS A VALID HEIGHT
    +
    1690 
    +
    1691  ilvl = ilvl + 1
    +
    1692  ELSE
    +
    1693 
    +
    1694 C ... WE DO NOT HAVE A VALID CATEGORY 4 LEVEL -- THERE IS NO VALID
    +
    1695 C HEIGHT GO ON TO NEXT INPUT LEVEL
    +
    1696 
    +
    1697  IF(iprint.GT.1) print *, 'HEIGHT MISSING ON INPUT ',
    +
    1698  $ ' LEVEL ',i,', ALL OTHER DATA SET TO MSG ON THIS LEVEL'
    +
    1699  GO TO 10
    +
    1700  END IF
    +
    1701  IF(iprint.GT.1) print 198, 43+ilc,rdatx(43+ilc)
    +
    1702 
    +
    1703 C HORIZONTAL WIND DIRECTION (STORED AS REAL)
    +
    1704 
    +
    1705  m = 2
    +
    1706  IF(iprint.GT.1) print 199, uair(2,i),m
    +
    1707  IF(uair(2,i).LT.xmsg) rdatx(43+ilc+1) = nint(uair(2,i))
    +
    1708  IF(iprint.GT.1) print 198, 43+ilc+1,rdatx(43+ilc+1)
    +
    1709 
    +
    1710 C HORIZONTAL WIND SPEED (STORED AS REAL) (OUTPUT STORED
    +
    1711 C AS METERS/SECOND TIMES TEN, NOT IN KNOTS AS ON29 WOULD
    +
    1712 C INDICATE FOR CAT. 4 WIND SPEED)
    +
    1713 
    +
    1714  m = 3
    +
    1715  IF(iprint.GT.1) print 199, uair(3,i),m
    +
    1716  IF(uair(3,i).LT.xmsg) rdatx(43+ilc+2) =nint(uair(3,i) * 10.)
    +
    1717  IF(iprint.GT.1) print 198, 43+ilc+2,rdatx(43+ilc+2)
    +
    1718 
    +
    1719 C CONFIDENCE LEVEL (BASED ON RMS VECTOR WIND ERROR)
    +
    1720 C (NOTE: CONVERTED TO ORIGINAL LETTER INDICATOR AND PACKED
    +
    1721 C IN BYTE 4 OF CATEGORY 4 QUALITY MARKER LOCATION -- SEE
    +
    1722 C W3UNPK77 DOCBLOCK REMARKS 5. FOR UNPACKED VAD WIND REPORT
    +
    1723 C LAYOUT FOR VALUES
    +
    1724 
    +
    1725  m = 4
    +
    1726  IF(iprint.GT.1) print 199, uair(4,i),m
    +
    1727  IF(uair(4,i).LT.xmsg) THEN
    +
    1728 
    +
    1729 C ... CONVERT FROM M/S TO KNOTS
    +
    1730 
    +
    1731 CDAKCDAK KRMS = INT(1.93333 * UAIR(4,I))
    +
    1732  krms = int(1.9425 * uair(4,i))
    +
    1733  cob = ' '
    +
    1734  IF(krms.LT.13) THEN
    +
    1735  cob(4:4) = crms(krms)
    +
    1736  ELSE
    +
    1737  cob(4:4) = 'G'
    +
    1738  END IF
    +
    1739  idata(43+ilc+3) = iob
    +
    1740  END IF
    +
    1741  IF(iprint.GT.1) print 196, 43+ilc+3,cob(1:4)
    +
    1742  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
    +
    1743 
    +
    1744 C ON29 WIND QUALITY MARKER (CURRENTLY NOT STORED)
    +
    1745 
    +
    1746  m = 5
    +
    1747  IF(iprint.GT.1) print 199, uair(5,i),m
    +
    1748 C.......................................................................
    +
    1749  ilc = ilc + 4
    +
    1750  IF(iprint.GT.1) print *,'HAVE COMPLETED LEVEL ',ilvl,
    +
    1751  $ '; GOING INTO NEXT LEVEL WITH ILC=',ilc
    +
    1752 
    +
    1753  10 CONTINUE
    +
    1754  ENDDO
    +
    1755 
    +
    1756 C SET CATEGORY COUNTERS FOR UPPER-AIR DATA
    +
    1757 
    +
    1758  98 CONTINUE
    +
    1759  idata(19) = ilvl
    +
    1760  99 CONTINUE
    +
    1761  IF(idata(19).EQ.0) THEN
    +
    1762  idata(20) = 0
    +
    1763  iret = 5
    +
    1764  ELSE
    +
    1765  idata(20) = 43
    +
    1766  END IF
    +
    1767  IF(iprint.GT.1) print *, 'NSFC=',nsfc,'; IDATA(37)=',idata(37),
    +
    1768  $ '; IDATA(38)=',idata(38)
    +
    1769  rdata(1:1200) = rdatx(1:1200)
    +
    1770  RETURN
    +
    1771  END
    +
    1772 C> @brief Fills in header in o-put array - goes snd
    +
    1773 C> @author Dennis Keyser @date 1998-07-09
    +
    1774 
    +
    1775 C> For report (subset) read out of bufr message (passed in
    +
    1776 C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    1777 C> header data for goes sounding report. Header is then filled into
    +
    1778 C> the output array which holds a single goes sounding report in the
    +
    1779 C> quasi-office note 29 unpacked format.
    +
    1780 C>
    +
    1781 C> ### Program History Log:
    +
    1782 C> Date | Programmer | Comment
    +
    1783 C> -----|------------|--------
    +
    1784 C> 1997-06-05 | Dennis Keyser NP22 | Initial.
    +
    1785 C> 1998-07-09 | Dennis Keyser | Changed char. 6 of goes stnid to be unique for two different even or odd satellite id's (every other even or odd sat. id now gets same char. 6 tag)
    +
    1786 C>
    +
    1787 C> @param[in] LUNIT Fortran unit number for input data file
    +
    1788 C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    +
    1789 C> @param[in] KOUNT Number of reports processed including this one
    +
    1790 C> @param[out] IRET Return code as described in w3unpk77 docblock
    +
    1791 C>
    +
    1792 C> @author Dennis Keyser @date 1998-07-09
    +
    1793  SUBROUTINE unpk7708(LUNIT,RDATA,KOUNT,IRET)
    +
    1794  CHARACTER*1 C6TAG(3,0:3)
    +
    1795  CHARACTER*8 STNID,COB
    +
    1796  CHARACTER*35 HDR1,HDR2
    +
    1797  INTEGER IDATA(1200)
    +
    1798  REAL(8) HDR_8(12)
    +
    1799  REAL HDR(12),RDATA(*),RDATX(1200)
    +
    1800  COMMON /pk77bb/kdate(8),ldate(8),iprint
    +
    1801  COMMON /pk77ff/ifov(3),kntsat(250:260)
    +
    1802 
    +
    1803  SAVE
    +
    1804 
    +
    1805  equivalence(rdatx,idata),(cob,iob)
    +
    1806  DATA xmsg/99999./,imsg/99999/
    +
    1807  DATA hdr1/'CLAT CLON ACAV GSDP QMRK SAID YEAR '/
    +
    1808  DATA hdr2/'MNTH DAYS HOUR MINU SECO '/
    +
    1809 
    +
    1810 
    +
    1811 C CURRENT LIST OF SATELLITE IDENTIFIERS (BUFR C.F. 0-01-007)
    +
    1812 C -----------------------------------------------------------
    +
    1813 
    +
    1814 C GOES 6 -- 250 GOES 9 -- 253 GOES 12 -- 256
    +
    1815 C GOES 7 -- 251 GOES 10 -- 254 GOES 13 -- 257
    +
    1816 C GOES 8 -- 252 GOES 11 -- 255 GOES 14 -- 258
    +
    1817 
    +
    1818 C IDSAT = -- EVEN1 -- --- ODD1 -- -- EVEN2 -- --- ODD2 --
    +
    1819 C Sat. No. - 252,256,... 253,257,... 250,254,... 251,255,...
    +
    1820 C IRTYP = CLR COR UNKN CLR COR UNKN CLR COR UNKN CLR COR UNKN
    +
    1821 C --- --- ---- --- --- ---- --- --- ---- --- --- ----
    +
    1822 
    +
    1823  DATA c6tag/'I','J','?', 'L','M','?', 'O','P','?', 'Q','R','?' /
    +
    1824 
    +
    1825  rdatx(1:1200) = rdata(1:1200)
    +
    1826  hdr_8 = 10.0e10
    +
    1827  CALL ufbint(lunit,hdr_8,12,1,nlev,hdr1//hdr2);hdr=hdr_8
    +
    1828  IF(nlev.NE.1) THEN
    +
    1829 C.......................................................................
    +
    1830 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
    +
    1831 C SET IRET = 6 AND RETURN
    +
    1832  print 217, nlev
    +
    1833  217 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
    +
    1834  $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 6'/)
    +
    1835  iret = 6
    +
    1836  RETURN
    +
    1837 C.......................................................................
    +
    1838  END IF
    +
    1839 
    +
    1840 C LATITUDE (STORED AS REAL)
    +
    1841 
    +
    1842  m = 1
    +
    1843  IF(iprint.GT.1) print 199, hdr(1),m
    +
    1844  199 FORMAT(5x,'HDR HERE IS: ',f17.4,'; INDEX IS: ',i3)
    +
    1845  IF(hdr(1).LT.xmsg) THEN
    +
    1846  rdatx(1) = nint(hdr(1) * 100.)
    +
    1847  nnnnn = 1
    +
    1848  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
    +
    1849  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
    +
    1850  ELSE
    +
    1851  iret = 2
    +
    1852  print 102
    +
    1853  102 FORMAT(' *** W3UNPK77 ERROR: LAT MISSING FOR GOES SOUNDING'/)
    +
    1854  RETURN
    +
    1855  END IF
    +
    1856 
    +
    1857 C LONGITUDE (STORED AS REAL)
    +
    1858 
    +
    1859  m = 2
    +
    1860  IF(iprint.GT.1) print 199, hdr(2),m
    +
    1861  IF(hdr(2).LT.xmsg) THEN
    +
    1862  rdatx(2) = nint(mod((36000.-(hdr(2)*100.)),36000.))
    +
    1863  nnnnn = 2
    +
    1864  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
    +
    1865  ELSE
    +
    1866  iret = 2
    +
    1867  print 104
    +
    1868  104 FORMAT(' *** W3UNPK77 ERROR: LON MISSING FOR GOES SOUNDING'/)
    +
    1869  RETURN
    +
    1870  END IF
    +
    1871 
    +
    1872 C NUMBER OF FIELDS OF VIEW - SAMPLE SIZE (STORED AS INTEGER)
    +
    1873 
    +
    1874  m = 3
    +
    1875  IF(iprint.GT.1) print 199, hdr(3),m
    +
    1876  IF(hdr(3).LT.xmsg) idata(3) = nint(hdr(3))
    +
    1877  nnnnn = 3
    +
    1878  IF(iprint.GT.1) print 197, nnnnn,idata(nnnnn)
    +
    1879  197 FORMAT(5x,'IDATA(',i5,') STORED AS: ',i10)
    +
    1880 
    +
    1881 C STATION ELEVATION (FROM HEIGHT OF FIRST -SURFACE- LEVEL)
    +
    1882 C (STORED AS REAL) -- STORED IN SUBROUTINE UNPK7709
    +
    1883 
    +
    1884 
    +
    1885 C RETRIEVAL TYPE (GEOSTATIONARY SATELLITE DATA-PROCESSING
    +
    1886 C TECHNIQUE USED) (STORED AS INTEGER)
    +
    1887 
    +
    1888  m = 4
    +
    1889  IF(iprint.GT.1) print 199, hdr(4),m
    +
    1890  IF(hdr(4).LT.xmsg) idata(8) = nint(hdr(4))
    +
    1891  irtyp = 3
    +
    1892  IF(idata(8).EQ.21) THEN
    +
    1893  irtyp = 1
    +
    1894  ELSE IF(idata(8).EQ.23) THEN
    +
    1895  irtyp = 2
    +
    1896  END IF
    +
    1897  nnnnn = 8
    +
    1898  IF(iprint.GT.1) print 197, nnnnn,idata(nnnnn)
    +
    1899 
    +
    1900 C PRODUCT QUALITY BIT FLAGS - QUALITY INFO. (STORED AS INTEGER)
    +
    1901 
    +
    1902  m = 5
    +
    1903  IF(iprint.GT.1) print 199, hdr(5),m
    +
    1904  IF(hdr(5).LT.xmsg) idata(10) = nint(hdr(5))
    +
    1905  nnnnn = 10
    +
    1906  IF(iprint.GT.1) print 197, nnnnn,idata(nnnnn)
    +
    1907 
    +
    1908 C STATION IDENTIFICATION (STORED AS CHARACTER)
    +
    1909 C (FIRST 5-CHARACTERS OBTAINED FROM 5-DIGIT COUNT NUMBER,
    +
    1910 C 6'TH CHARACTER OBTAINED FROM SAT. ID/RETRIEVAL TYPE TAG)
    +
    1911 
    +
    1912  WRITE(stnid(1:5),'(I5.5)') min(kount,99999)
    +
    1913 
    +
    1914 C DECODE THE SATELLITE ID
    +
    1915 
    +
    1916  m = 6
    +
    1917  idsat = 2
    +
    1918  IF(iprint.GT.1) print 199, hdr(6),m
    +
    1919  IF(hdr(6).LT.xmsg) THEN
    +
    1920  idsat = mod(nint(hdr(6)),4)
    +
    1921  IF(nint(hdr(6)).GT.249.AND.nint(hdr(6)).LT.260) THEN
    +
    1922  kntsat(nint(hdr(6))) = kntsat(nint(hdr(6))) + 1
    +
    1923  ELSE
    +
    1924  kntsat(260) = kntsat(260) + 1
    +
    1925  END IF
    +
    1926  END IF
    +
    1927  IF(iprint.GT.1) print 2197, idsat,irtyp
    +
    1928  2197 FORMAT(5x,'IDSAT IS: ',i10,', IRTYP IS: ',i10)
    +
    1929  stnid(6:6) = c6tag(irtyp,idsat)
    +
    1930  cob(1:4) = stnid(1:4)
    +
    1931  idata(11) = iob
    +
    1932  nnnnn = 11
    +
    1933  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
    +
    1934  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
    +
    1935  cob(1:4) = stnid(5:6)//' '
    +
    1936  idata(12) = iob
    +
    1937  nnnnn = 12
    +
    1938  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
    +
    1939 
    +
    1940 cvvvvvdak port
    +
    1941 C LOAD THE YEAR/MONTH (STORED AS CHARACTER IN FORM YYMM)
    +
    1942 caaaaadak port
    +
    1943 
    +
    1944  m = 7
    +
    1945  IF(iprint.GT.1) print 199, hdr(7),m
    +
    1946  iyear = imsg
    +
    1947  IF(hdr(7).LT.xmsg) iyear = nint(hdr(7))
    +
    1948  m = 8
    +
    1949  IF(iprint.GT.1) print 199, hdr(8),m
    +
    1950  IF(hdr(8).LT.xmsg.AND.iyear.LT.imsg) THEN
    +
    1951 cvvvvvdak port
    +
    1952  iyear = mod(iyear,100)
    +
    1953 caaaaadak port
    +
    1954  iyear = nint(hdr(8)) + (iyear * 100)
    +
    1955 cvvvvvdak port
    +
    1956 cdak WRITE(COB,'(I6.6,2X)') IYEAR
    +
    1957  WRITE(cob,'(I4.4,4X)') iyear
    +
    1958 caaaaadak port
    +
    1959  idata(5) = iob
    +
    1960  nnnnn = 5
    +
    1961  IF(iprint.GT.1) print 9196, nnnnn,cob(1:6)
    +
    1962  9196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a6,'"')
    +
    1963  ELSE
    +
    1964  GO TO 30
    +
    1965  END IF
    +
    1966 
    +
    1967 C LOAD THE DAY/HOUR (STORED AS CHARACTER IN FORM DDHH)
    +
    1968 C AND THE OBSERVATION TIME (STORED AS REAL)
    +
    1969 
    +
    1970  m = 9
    +
    1971  IF(iprint.GT.1) print 199, hdr(9),m
    +
    1972  m = 10
    +
    1973  IF(iprint.GT.1) print 199, hdr(10),m
    +
    1974  IF(hdr(10).LT.xmsg.AND.hdr(9).LT.imsg) THEN
    +
    1975  m = 11
    +
    1976  IF(iprint.GT.1) print 199, hdr(11),m
    +
    1977  IF(hdr(11).GE.xmsg) GO TO 30
    +
    1978  m = 12
    +
    1979  IF(iprint.GT.1) print 199, hdr(12),m
    +
    1980  IF(hdr(12).GE.xmsg) GO TO 30
    +
    1981  rdatx(4) = nint(((hdr(10) + ((hdr(11) * 60.) + hdr(12))/3600.)
    +
    1982  $ * 100.) + 0.0000000001)
    +
    1983  nnnnn = 4
    +
    1984  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
    +
    1985  idayhr = nint(hdr(10)) + (nint(hdr(9)) * 100)
    +
    1986  WRITE(cob(1:4),'(I4.4)') idayhr
    +
    1987  idata(6) = iob
    +
    1988  nnnnn = 6
    +
    1989  IF(iprint.GT.1) print 196, nnnnn,cob(1:4)
    +
    1990  ELSE
    +
    1991  GO TO 30
    +
    1992  END IF
    +
    1993  rdata(1:1200) = rdatx(1:1200)
    +
    1994  RETURN
    +
    1995  30 CONTINUE
    +
    1996  iret = 4
    +
    1997  RETURN
    +
    1998  END
    +
    1999 C> @brief Fills cat. 12,8 to o-put array -goes sndg
    +
    2000 C> @author Dennis Keyser @date 1997-06-05
    +
    2001 
    +
    2002 C> For report (subset) read out of bufr message (passed in
    +
    2003 C> internally via bufrlib storage), calls bufrlib routine to decode
    +
    2004 C> upper-air (sounding) and additional data for goes sounding. Upper-
    +
    2005 C> air data are then filled into the output array as category 12
    +
    2006 C> (satellite sounding) and additional data are filled as category 8.
    +
    2007 C> The ouput array holds a single goes sounding in the quasi-office
    +
    2008 C> note 29 unpacked format.
    +
    2009 C>
    +
    2010 C> ### Program History Log:
    +
    2011 C> Date | Programmer | Comment
    +
    2012 C> -----|------------|--------
    +
    2013 C> 1997-06-05 | Dennis Keyser NP22 | Initial.
    +
    2014 C>
    +
    2015 C> @param[in] LUNIT Fortran unit number for input data file
    +
    2016 C> @param[inout] RDATA Single wind profiler report in a quasi-office note 29 unpacked format with [out] header information filled in [in] all data initialized as missing
    +
    2017 C> @param[out] IRET Return code as described in w3unpk77 docblock
    +
    2018 C>
    +
    2019 C> @author Dennis Keyser @date 1997-06-05
    +
    2020  SUBROUTINE unpk7709(LUNIT,RDATA,IRET)
    +
    2021  CHARACTER*1 CQMFLG
    +
    2022  CHARACTER*8 COB
    +
    2023  CHARACTER*37 CAT8A,CAT8B
    +
    2024  CHARACTER*48 UAIR1,RAD1
    +
    2025  INTEGER IDATA(1200),ICDFG(12)
    +
    2026  REAL(8) UAIR_8(4,255),CAT8_8(12),RTCSF_8,RAD_8(2,255)
    +
    2027  REAL UAIR(4,255),CAT8(12),RDATA(*),RDATX(1200),SC8(12),RAD(2,255)
    +
    2028  COMMON /pk77bb/kdate(8),ldate(8),iprint
    +
    2029  COMMON /pk77ff/ifov(3),kntsat(250:260)
    +
    2030 
    +
    2031  SAVE
    +
    2032 
    +
    2033  equivalence(rdatx,idata),(cob,iob)
    +
    2034  DATA xmsg/99999./,ymsg/99999.8/
    +
    2035  DATA uair1/'PRLC HGHT TMDB TMDP '/
    +
    2036  DATA rad1 /'CHNM TMBR '/
    +
    2037  DATA cat8a/'GLFTI PH2O PH2O19 PH2O97 PH2O73 TMSK '/
    +
    2038  DATA cat8b/'GCDTT CDTP CLAM SIDU SOEL ELEV '/
    +
    2039  DATA icdfg/ 50 , 51 , 52 , 53 , 54 , 55 , 56 ,57 ,58,59, 60 , 61 /
    +
    2040  DATA sc8/100.,100.,100.,100.,100.,100.,100.,10.,1.,1.,100.,100./
    +
    2041  rdatx(1:1200) = rdata(1:1200)
    +
    2042 
    +
    2043 C ALL NON-RADIANCE DATA WILL BE Q.C.'D ACCORDING TO NUMBER OF FIELDS-OF-
    +
    2044 C VIEW FOR RETRIEVAL: 0-2 --> BAD, 3-9 --> SUSPECT, 10-25 OR MISSING
    +
    2045 C --> NEUTRAL
    +
    2046 
    +
    2047  cqmflg = ' '
    +
    2048  IF(idata(3).LT.3) THEN
    +
    2049  cqmflg = 'F'
    +
    2050  ifov(1) = ifov(1) + 1
    +
    2051  ELSE IF(idata(3).LT.10.OR.idata(10).EQ.1) THEN
    +
    2052  cqmflg = 'Q'
    +
    2053  IF(idata(3).LT.10) ifov(2) = ifov(2) + 1
    +
    2054  END IF
    +
    2055  IF(idata(3).GT.9) ifov(3) = ifov(3) + 1
    +
    2056 
    +
    2057 C***********************************************************************
    +
    2058 C FILL CATEGORY 12 PART OF OUTPUT
    +
    2059 C***********************************************************************
    +
    2060 
    +
    2061  ilvl = 0
    +
    2062  ilc = 0
    +
    2063  uair_8 = 10.0e10
    +
    2064  CALL ufbint(lunit,uair_8,4,255,nlev,uair1);uair=uair_8
    +
    2065  IF(nlev.EQ.0) THEN
    +
    2066 C.......................................................................
    +
    2067 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
    +
    2068  print 217
    +
    2069  217 FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ',
    +
    2070  $ 'FOR THIS REPORT -- NLEV = 0'/)
    +
    2071  GO TO 98
    +
    2072  ELSE IF(nlev.GT.50) THEN
    +
    2073 C.......................................................................
    +
    2074 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 50 --
    +
    2075  print 218
    +
    2076  218 FORMAT(/' ##W3UNPK77: NO UPPER-AIR (SOUNDING) DATA PROCESSED ',
    +
    2077  $ 'FOR THIS REPORT -- NLEV > 50'/)
    +
    2078  GO TO 98
    +
    2079 C.......................................................................
    +
    2080  END IF
    +
    2081  IF(iprint.GT.1) print 1068, nlev
    +
    2082  1068 FORMAT(' THIS REPORT CONTAINS',i4,' INPUT LEVELS OF SOUNDING ',
    +
    2083  $ 'DATA')
    +
    2084  DO i = 1,nlev
    +
    2085  IF(iprint.GT.1) print 1079, i,ilc,ilvl
    +
    2086  1079 FORMAT(' ATTEMPTING NEW CAT. 12 INPUT LEVEL NUMBER',i4,' WITH ',
    +
    2087  $ 'ILC =',i5,'; NO. LEVELS PROCESSED TO NOW =',i5)
    +
    2088 
    +
    2089 C LEVEL PRESSURE (STORED AS REAL)
    +
    2090 
    +
    2091  m = 1
    +
    2092  IF(iprint.GT.1) print 199, uair(1,i),m
    +
    2093  199 FORMAT(5x,'UAIR HERE IS: ',f17.4,'; INDEX IS: ',i3)
    +
    2094  IF(i.EQ.1) THEN
    +
    2095  psfc = uair(1,i) * 0.1
    +
    2096  ELSE IF(uair(1,i)*0.1.GE.ymsg) THEN
    +
    2097 C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THERE IS NO VALID PRESSURE
    +
    2098 C -- GO ON TO NEXT INPUT LEVEL (IF SFC LEVEL MSG, CONTINUE PROCESSING)
    +
    2099  IF(iprint.GT.1) print *, 'PRESSURE MISSING ON INPUT',
    +
    2100  $ ' LEVEL ',i,', SKIP THE PROCESSING OF THIS LEVEL'
    +
    2101  GO TO 10
    +
    2102  ELSE IF(uair(1,i)*0.1.GE.psfc) THEN
    +
    2103 C WE DO NOT HAVE A VALID CATEGORY 12 LEVEL -- THE INPUT LEVEL PRESSURE
    +
    2104 C IS BELOW THE SURFACE PRESSURE -- GO ON TO THE NEXT INPUT LEVEL
    +
    2105  IF(iprint.GT.1) print *,'PRESSURE ON INPUT LEVEL ',i,
    +
    2106  $ ' IS BELOW GROUND, SKIP THE PROCESSING OF THIS LEVEL'
    +
    2107  GO TO 10
    +
    2108  END IF
    +
    2109 
    +
    2110 C WE HAVE A VALID CATEGORY 12 LEVEL -- THERE IS A VALID PRESSURE
    +
    2111 
    +
    2112  IF(uair(1,i)*0.1.LT.xmsg) rdatx(43+ilc) = nint(uair(1,i)*0.1)
    +
    2113  ilvl = ilvl + 1
    +
    2114  IF(iprint.GT.1) print 198, 43+ilc,rdatx(43+ilc)
    +
    2115  198 FORMAT(5x,'RDATA(',i5,') STORED AS: ',f10.2)
    +
    2116 
    +
    2117 C GEOPOTENTIAL HEIGHT (STORED AS REAL)
    +
    2118 
    +
    2119  m = 2
    +
    2120  IF(iprint.GT.1) print 199, uair(2,i),m
    +
    2121  IF(uair(2,i).LT.xmsg) rdatx(43+ilc+1) = nint(uair(2,i))
    +
    2122  IF(iprint.GT.1) print 198, 43+ilc+1,rdatx(43+ilc+1)
    +
    2123  IF(i.EQ.1) THEN
    +
    2124  IF(iprint.GT.1) print *, 'THIS IS SURFACE LEVEL, SO ',
    +
    2125  $ 'STORE HEIGHT ALSO AS ELEVATION IN HEADER'
    +
    2126  IF(uair(2,1).LT.xmsg) rdatx(7) = nint(uair(2,1))
    +
    2127  nnnnn = 7
    +
    2128  IF(iprint.GT.1) print 198, nnnnn,rdatx(nnnnn)
    +
    2129  END IF
    +
    2130 
    +
    2131 C TEMPERATURE (STORED AS REAL)
    +
    2132 
    +
    2133  m = 3
    +
    2134  IF(iprint.GT.1) print 199, uair(3,i),m
    +
    2135  itmp = nint(uair(3,i)*100.)
    +
    2136  IF(uair(3,i).LT.xmsg)
    +
    2137  $ rdatx(43+ilc+2) = nint((itmp - 27315) * 0.1)
    +
    2138  IF(iprint.GT.1) print 198, 43+ilc+2,rdatx(43+ilc+2)
    +
    2139 
    +
    2140 C DEWPOINT TEMPERATURE (STORED AS REAL)
    +
    2141 
    +
    2142  m = 4
    +
    2143  IF(iprint.GT.1) print 199, uair(4,i),m
    +
    2144  itmp = nint(uair(4,i)*100.)
    +
    2145  IF(uair(4,i).LT.xmsg)
    +
    2146  $ rdatx(43+ilc+3) = nint((itmp - 27315) * 0.1)
    +
    2147  IF(iprint.GT.1) print 198, 43+ilc+3,rdatx(43+ilc+3)
    +
    2148 
    +
    2149 C QUALITY MARKERS (STORED AS CHARACTER)
    +
    2150 
    +
    2151  cob = cqmflg//cqmflg//cqmflg//' '
    +
    2152  idata(43+ilc+6) = iob
    +
    2153  IF(iprint.GT.1) print 196, 43+ilc+6,cob(1:4)
    +
    2154  196 FORMAT(5x,'IDATA(',i5,') STORED IN CHARACTER AS: "',a4,'"')
    +
    2155 C.......................................................................
    +
    2156  ilc = ilc + 7
    +
    2157  IF(i+1.LE.nlev.AND.iprint.GT.1) print *,'HAVE COMPLETED ',
    +
    2158  $ 'LEVEL ',ilvl,'; GOING INTO NEXT LEVEL WITH ILC=',ilc
    +
    2159 
    +
    2160  10 CONTINUE
    +
    2161  ENDDO
    +
    2162 
    +
    2163 C SET CATEGORY COUNTERS FOR CATEGORY 12 (SOUNDING) DATA
    +
    2164 
    +
    2165  idata(39) = ilvl
    +
    2166  98 CONTINUE
    +
    2167  IF(iprint.GT.1) print *, idata(39),' CAT. 12 LEVELS PROCESSED'
    +
    2168  IF(idata(39).GT.0) idata(40) = 43
    +
    2169 
    +
    2170 C***********************************************************************
    +
    2171 C FILL CATEGORY 8 PART OF OUTPUT
    +
    2172 C WILL ATTEMPT TO FILL 12 "LEVELS"
    +
    2173 C LVL 1- LIFTED INDEX (DEG. K X 100 - RELATIVE) -------- CODE FIG. 250.
    +
    2174 C LVL 2- TOTAL COLUMN PRECIPITABLE WATER (MM X 100) ---- CODE FIG. 251.
    +
    2175 C LVL 3- 1. TO .9 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 252.
    +
    2176 C LVL 4- .9 TO .7 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 253.
    +
    2177 C LVL 5- .7 TO .3 SIGMA LAYER PRECIP. WATER (MM X 100) - CODE FIG. 254.
    +
    2178 C LVL 6- SKIN TEMPERATURE (DEG. K X 100) --------------- CODE FIG. 255.
    +
    2179 C LVL 7- CLOUD TOP TEMPERATURE (DEG. K X 100) ---------- CODE FIG. 256.
    +
    2180 C LVL 8- CLOUD TOP PRESSURE (MB X 10) ------------------ CODE FIG. 257.
    +
    2181 C LVL 9- CLOUD AMOUNT (C. FIG. BUFR TABLE 0-20-011) ---- CODE FIG. 258.
    +
    2182 C LVL 10- INSTR. DATA USED IN PROC.
    +
    2183 C (C. FIG. BUFR TABLE 0-02-021) --- CODE FIG. 259.
    +
    2184 C LVL 11- SOLAR ZENITH ANGLE (SOLAR ELEV) (DEG. X 100) -- CODE FIG. 260.
    +
    2185 C LVL 12- SATELLITE ZENITH ANGLE (ELEV) (DEG. X 100) --- CODE FIG. 261.
    +
    2186 C
    +
    2187 C IF DATA ONE ANY LEVEL ARE MISSING, THAT LEVEL IS NOT PROCESSED
    +
    2188 C***********************************************************************
    +
    2189 
    +
    2190  ilvl = 0
    +
    2191  ilc = 0
    +
    2192  cat8_8 = 10.0e10
    +
    2193  CALL ufbint(lunit,cat8_8,12,1,nlev8,cat8a//cat8b);cat8=cat8_8
    +
    2194  IF(nlev8.NE.1) THEN
    +
    2195  IF(nlev8.EQ.0) THEN
    +
    2196 C.......................................................................
    +
    2197 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
    +
    2198  print 318
    +
    2199  318 FORMAT(/' ##W3UNPK77: NO ADDITIONAL (CAT. 8) DATA PROCESSED FOR ',
    +
    2200  $ 'THIS REPORT -- NLEV8 = 0'/)
    +
    2201  GO TO 99
    +
    2202 C.......................................................................
    +
    2203  ELSE
    +
    2204 C.......................................................................
    +
    2205 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS NOT WHAT IS EXPECTED --
    +
    2206 C SET IRET = 7 AND RETURN
    +
    2207  print 219, nlev8
    +
    2208  219 FORMAT(/' ##W3UNPK77: THE NUMBER OF DECODED "LEVELS" (=',i5,') ',
    +
    2209  $ 'IS NOT WHAT IS EXPECTED (1) - IRET = 7'/)
    +
    2210  iret = 7
    +
    2211  RETURN
    +
    2212 C.......................................................................
    +
    2213  END IF
    +
    2214  END IF
    +
    2215 
    +
    2216 C THE TEMPERATURE CHANNEL SELECTION FLAG WILL BE USED LATER TO
    +
    2217 C DETERMINE Q. MARK FOR SKIN TEMPERATURE (IF 0 - OK, OTHERWISE - BAD)
    +
    2218 
    +
    2219  rtcsf_8 = 10.0e10
    +
    2220  CALL ufbint(lunit,rtcsf_8,1,1,nlev0,'TCSF');rtcsf=rtcsf_8
    +
    2221  itcsf = 1
    +
    2222  m = 1
    +
    2223  IF(iprint.GT.1) print 299, rtcsf,m
    +
    2224  299 FORMAT(5x,'RTCSF HERE IS: ',f17.4,'; INDEX IS: ',i3)
    +
    2225  IF(rtcsf.LT.xmsg) itcsf = nint(rtcsf)
    +
    2226  IF(iprint.GT.1) print 1798, itcsf
    +
    2227  1798 FORMAT(5x,'ITCSF IS: ',i10)
    +
    2228 
    +
    2229 C LOOP THROUGH THE 12 POSSIBLE ADDITIONAL DATA
    +
    2230 
    +
    2231  DO m = 1,12
    +
    2232  IF(iprint.GT.1) print 6079, m,ilc,ilvl
    +
    2233  6079 FORMAT(' ATTEMPTING MISCEL. INPUT',i5,' WITH ILC =',i5,'; NO. ',
    +
    2234  $ 'OUTPUT CAT. 8 LVLS PROCESSED TO NOW =',i5)
    +
    2235  IF(iprint.GT.1) print 399, cat8(m),m
    +
    2236  399 FORMAT(5x,'CAT8 HERE IS: ',f17.4,'; INDEX IS: ',i3)
    +
    2237  IF(cat8(m).LT.xmsg) THEN
    +
    2238 
    +
    2239 C WE HAVE A VALID CATEGORY 8 "LEVEL"
    +
    2240 
    +
    2241  ilvl = ilvl + 1
    +
    2242 
    +
    2243 C STORE THE DATUM IN WORD 1 OF THE CAT. 8 LEVEL
    +
    2244 
    +
    2245  rdatx(393+ilc) = nint(cat8(m) * sc8(m))
    +
    2246  IF(iprint.GT.1) print 198, 393+ilc,rdatx(393+ilc)
    +
    2247 
    +
    2248 C STORE THE CAT. 8 CODE FIGURE IN WORD 2 OF THE CAT. 8 LEVEL
    +
    2249 
    +
    2250  rdatx(393+ilc+1) = real(200+icdfg(m))
    +
    2251  IF(iprint.GT.1) print 198, 393+ilc+1,rdatx(393+ilc+1)
    +
    2252 
    +
    2253 C STORE THE QUALITY MARKER IN BYTE 1 OF WORD 3 OF THE CAT. 8 LEVEL
    +
    2254 
    +
    2255  cob = cqmflg//' '
    +
    2256 
    +
    2257 C IF THIS DATUM IS SKIN TEMPERATURE AND THE TEMPERATURE CHANNEL
    +
    2258 C SELECTION FLAG IS BAD (.NE. 0), SET QUALITY MARKER TO "F"
    +
    2259 
    +
    2260  IF(m.EQ.6.AND.itcsf.NE.0) cob(1:1) = 'F'
    +
    2261  idata(393+ilc+2) = iob
    +
    2262  IF(iprint.GT.1) print 196, 393+ilc+2,cob(1:4)
    +
    2263  ilc = ilc + 3
    +
    2264  IF(m.LT.12.AND.iprint.GT.1) print *,'HAVE COMPLETED OUTPUT',
    +
    2265  $ ' LVL',ilvl,'; GOING INTO NEXT INPUT DATUM WITH ILC=',ilc
    +
    2266  ELSE
    +
    2267  IF(iprint.GT.1) print *, 'DATUM MISSING ON INPUT ',m,
    +
    2268  $ ', GO ON TO NEXT INPUT DATUM (NO. LVLS PROCESSED SO ',
    +
    2269  $ 'FAR=',ilvl,'; ILC=',ilc,')'
    +
    2270  END IF
    +
    2271  ENDDO
    +
    2272 
    +
    2273 C SET CATEGORY COUNTERS FOR CATEGORY 8 (ADDITIONAL) DATA
    +
    2274 
    +
    2275  idata(27) = ilvl
    +
    2276  99 CONTINUE
    +
    2277  IF(iprint.GT.1) print *, idata(27),' CAT. 08 LEVELS PROCESSED'
    +
    2278  IF(idata(27).GT.0) idata(28) = 393
    +
    2279 
    +
    2280 C***********************************************************************
    +
    2281 C FILL CATEGORY 13 PART OF OUTPUT (RADIANCES)
    +
    2282 C***********************************************************************
    +
    2283 
    +
    2284  ilvl = 0
    +
    2285  ilc = 0
    +
    2286  rad_8 = 10.0e10
    +
    2287  CALL ufbint(lunit,rad_8,2,255,nlev13,rad1);rad=rad_8
    +
    2288  IF(nlev13.EQ.0) THEN
    +
    2289 C.......................................................................
    +
    2290 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS ZERO --
    +
    2291  print 417
    +
    2292  417 FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ',
    +
    2293  $ 'REPORT -- NLEV13 = 0'/)
    +
    2294  GO TO 100
    +
    2295  ELSE IF(nlev13.GT.60) THEN
    +
    2296 C.......................................................................
    +
    2297 C PROBLEM: THE NUMBER OF DECODED "LEVELS" IS GREATER THAN LIMIT OF 60 --
    +
    2298  print 418
    +
    2299  418 FORMAT(/' ##W3UNPK77: NO RADIANCE DATA PROCESSED FOR THIS ',
    +
    2300  $ 'REPORT -- NLEV13 > 60'/)
    +
    2301  GO TO 100
    +
    2302 C.......................................................................
    +
    2303  END IF
    +
    2304  IF(iprint.GT.1) print 2068, nlev13
    +
    2305  2068 FORMAT(' THIS REPORT CONTAINS',i4,' INPUT LEVELS (CHANNELS) OF ',
    +
    2306  $ 'RADIANCE DATA')
    +
    2307  DO i = 1,nlev13
    +
    2308  IF(iprint.GT.1) print 2079, i,ilc,ilvl
    +
    2309  2079 FORMAT(' ATTEMPTING NEW CAT. 13 INPUT "LEVEL" NUMBER',i4,' WITH ',
    +
    2310  $ 'ILC =',i5,'; NO. LEVELS (CHANNELS) PROCESSED TO NOW =',i5)
    +
    2311 
    +
    2312 C CHANNEL NUMBER (STORED AS INTEGER)
    +
    2313 
    +
    2314  m = 1
    +
    2315  IF(iprint.GT.1) print 499, rad(1,i),m
    +
    2316  499 FORMAT(5x,'RAD HERE IS: ',f17.4,'; INDEX IS: ',i3)
    +
    2317  IF(rad(1,i).GE.ymsg) THEN
    +
    2318 C WE DO NOT HAVE A VALID CATEGORY 13 LEVEL -- THERE IS NO VALID CHANNEL
    +
    2319 C NUMBER -- GO ON TO NEXT INPUT LEVEL
    +
    2320  IF(iprint.GT.1) print *, 'CHANNEL NUMBER MISSING ON INPUT',
    +
    2321  $ ' LEVEL ',i,', SKIP THE PROCESSING OF THIS LEVEL'
    +
    2322  GO TO 210
    +
    2323  END IF
    +
    2324 
    +
    2325 C WE HAVE A VALID CATEGORY 13 LEVEL -- THERE IS A VALID CHANNEL NUMBER
    +
    2326 
    +
    2327  idata(429+ilc) = nint(rad(1,i))
    +
    2328  ilvl = ilvl + 1
    +
    2329  IF(iprint.GT.1) print 197, 429+ilc,idata(429+ilc)
    +
    2330  197 FORMAT(5x,'IDATA(',i5,') STORED AS: ',i10)
    +
    2331 
    +
    2332 C BRIGHTNESS TEMPERATURE (STORED AS REAL)
    +
    2333 
    +
    2334  m = 2
    +
    2335  IF(iprint.GT.1) print 499, rad(2,i),m
    +
    2336  IF(rad(2,i).LT.xmsg) rdatx(429+ilc+1) = nint(rad(2,i) * 100.)
    +
    2337  IF(iprint.GT.1) print 198, 429+ilc+1,rdatx(429+ilc+1)
    +
    2338 
    +
    2339 C QUALITY MARKERS (STORED AS CHARACTER)
    +
    2340 
    +
    2341  cob = ' '
    +
    2342  idata(429+ilc+2) = iob
    +
    2343  IF(iprint.GT.1) print 196, 429+ilc+2,cob(1:4)
    +
    2344 C.......................................................................
    +
    2345  ilc = ilc + 3
    +
    2346  IF(i+1.LE.nlev13.AND.iprint.GT.1) print *,'HAVE COMPLETED ',
    +
    2347  $ 'LEVEL ',ilvl,'; GOING INTO NEXT LEVEL WITH ILC=',ilc
    +
    2348 
    +
    2349  210 CONTINUE
    +
    2350  ENDDO
    +
    2351 
    +
    2352 C SET CATEGORY COUNTERS FOR CATEGORY 13 (RADIANCE) DATA
    +
    2353 
    +
    2354  idata(41) = ilvl
    +
    2355  100 CONTINUE
    +
    2356  IF(iprint.GT.1) print *, idata(41),' CAT. 13 LEVELS PROCESSED'
    +
    2357  IF(idata(41).GT.0) idata(42) = 429
    +
    2358 
    +
    2359  IF(idata(27)+idata(39)+idata(41).EQ.0) iret = 5
    +
    2360 
    +
    2361  IF(iprint.GT.1) print *,'IDATA(39)=',idata(39),'; IDATA(40)=',
    +
    2362  $ idata(40),'; IDATA(27)=',idata(27),'; IDATA(28)=',idata(28),
    +
    2363  $ '; IDATA(41)=',idata(41),'; IDATA(42)=',idata(42)
    +
    2364 
    +
    2365  rdata(1:1200) = rdatx(1:1200)
    +
    2366  RETURN
    +
    2367  END
    +
    +
    +
    unpk7704
    subroutine unpk7704(LUNIT, RDATA)
    Fills cat.10 into o-put array - pflr rpt.
    Definition: w3unpk77.f:1116
    +
    unpk7705
    subroutine unpk7705(LUNIT, RDATA)
    Fills cat.11 into o-put array - pflr rpt.
    Definition: w3unpk77.f:1222
    +
    unpk7706
    subroutine unpk7706(LUNIT, RDATA, IRET)
    Fills in header in o-put array - vadw rpt.
    Definition: w3unpk77.f:1451
    +
    unpk7702
    subroutine unpk7702(RDATA, ITP)
    Initializes the output array for a report.
    Definition: w3unpk77.f:800
    +
    w3unpk77
    subroutine w3unpk77(IDATE, IHE, IHL, LUNIT, RDATA, IRET)
    This subroutine decodes a single report from bufr messages in a jbufr-type data file.
    Definition: w3unpk77.f:346
    +
    errexit
    subroutine errexit(IRET)
    Exit with a return code.
    Definition: errexit.f:20
    +
    unpk7703
    subroutine unpk7703(LUNIT, RDATA, IRET)
    Fills in header in o-put array - pflr rpt.
    Definition: w3unpk77.f:896
    +
    unpk7701
    subroutine unpk7701(LUNIT, ITP, IRET)
    Reads a single report out of bufr dataset.
    Definition: w3unpk77.f:649
    +
    unpk7707
    subroutine unpk7707(LUNIT, RDATA, IRET)
    Fills cat.
    Definition: w3unpk77.f:1615
    +
    unpk7709
    subroutine unpk7709(LUNIT, RDATA, IRET)
    Fills cat.
    Definition: w3unpk77.f:2021
    +
    unpk7708
    subroutine unpk7708(LUNIT, RDATA, KOUNT, IRET)
    Fills in header in o-put array - goes snd.
    Definition: w3unpk77.f:1794
    +
    w3difdat
    subroutine w3difdat(jdat, idat, it, rinc)
    Returns the elapsed time interval from an NCEP absolute date and time given in the second argument un...
    Definition: w3difdat.f:29
    +
    w3movdat
    subroutine w3movdat(rinc, idat, jdat)
    This subprogram returns the date and time that is a given NCEP relative time interval from an NCEP ab...
    Definition: w3movdat.f:24
    +
    w3fi04
    subroutine w3fi04(IENDN, ITYPEC, LW)
    Subroutine computes word size, the type of character set, ASCII or EBCDIC, and if the computer is big...
    Definition: w3fi04.f:30
    + + + + diff --git a/ver-2.10.0/w3utcdat_8f.html b/ver-2.10.0/w3utcdat_8f.html new file mode 100644 index 00000000..8e713f8e --- /dev/null +++ b/ver-2.10.0/w3utcdat_8f.html @@ -0,0 +1,163 @@ + + + + + + + +NCEPLIBS-w3emc: w3utcdat.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3utcdat.f File Reference
    +
    +
    + +

    Return the utc date and time. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3utcdat (idat)
     This subprogram returns the utc (greenwich) date and time in the NCEP absolute date and time data structure. More...
     
    +

    Detailed Description

    +

    Return the utc date and time.

    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition in file w3utcdat.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3utcdat()

    + +
    +
    + + + + + + + + +
    subroutine w3utcdat (integer, dimension(8) idat)
    +
    + +

    This subprogram returns the utc (greenwich) date and time in the NCEP absolute date and time data structure.

    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    1998-01-05 Mark Iredell Initial.
    1999-04-28 Stephen 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 | Stephen Gilbert | Changed so that czone variable is saved and the system call is only done for first invocation of this routine.

    +
    Parameters
    + + +
    [in]IDATNCEP absolute date and time (year, month, day, time zone, hour, minute, second, millisecond)
    +
    +
    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition at line 23 of file w3utcdat.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3utcdat_8f.js b/ver-2.10.0/w3utcdat_8f.js new file mode 100644 index 00000000..a5f1a14c --- /dev/null +++ b/ver-2.10.0/w3utcdat_8f.js @@ -0,0 +1,4 @@ +var w3utcdat_8f = +[ + [ "w3utcdat", "w3utcdat_8f.html#aa33d08dc203b9cc4e7c96e566c7db42a", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3utcdat_8f_source.html b/ver-2.10.0/w3utcdat_8f_source.html new file mode 100644 index 00000000..c0fae910 --- /dev/null +++ b/ver-2.10.0/w3utcdat_8f_source.html @@ -0,0 +1,137 @@ + + + + + + + +NCEPLIBS-w3emc: w3utcdat.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3utcdat.f
    +
    +
    +Go to the documentation of this file.
    1 
    +
    4 
    +
    22  subroutine w3utcdat(idat)
    +
    23  integer idat(8)
    +
    24  character cdate*8,ctime*10,czone*5
    +
    25 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    26 ! get local date and time but use the character time zone
    +
    27  call date_and_time(cdate,ctime,czone,idat)
    +
    28  read(czone,'(i5)') idat(4)
    +
    29 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    30 ! convert to hours and minutes to UTC time
    +
    31 ! and possibly adjust the date as well
    +
    32  idat(6)=idat(6)-mod(idat(4),100)
    +
    33  idat(5)=idat(5)-idat(4)/100
    +
    34  idat(4)=0
    +
    35  if(idat(6).lt.00) then
    +
    36  idat(6)=idat(6)+60
    +
    37  idat(5)=idat(5)-1
    +
    38  elseif(idat(6).ge.60) then
    +
    39  idat(6)=idat(6)-60
    +
    40  idat(5)=idat(5)+1
    +
    41  endif
    +
    42  if(idat(5).lt.00) then
    +
    43  idat(5)=idat(5)+24
    +
    44  jldayn=iw3jdn(idat(1),idat(2),idat(3))-1
    +
    45  call w3fs26(jldayn,idat(1),idat(2),idat(3),idaywk,idayyr)
    +
    46  elseif(idat(5).ge.24) then
    +
    47  idat(5)=idat(5)-24
    +
    48  jldayn=iw3jdn(idat(1),idat(2),idat(3))+1
    +
    49  call w3fs26(jldayn,idat(1),idat(2),idat(3),idaywk,idayyr)
    +
    50  endif
    +
    51 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    52  end
    +
    +
    +
    w3fs26
    subroutine w3fs26(JLDAYN, IYEAR, MONTH, IDAY, IDAYWK, IDAYYR)
    Computes year (4 digits), month, day, day of week, day of year from julian day number.
    Definition: w3fs26.f:56
    +
    w3utcdat
    subroutine w3utcdat(idat)
    This subprogram returns the utc (greenwich) date and time in the NCEP absolute date and time data str...
    Definition: w3utcdat.f:23
    +
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    + + + + diff --git a/ver-2.10.0/w3valdat_8f.html b/ver-2.10.0/w3valdat_8f.html new file mode 100644 index 00000000..495ac7e8 --- /dev/null +++ b/ver-2.10.0/w3valdat_8f.html @@ -0,0 +1,161 @@ + + + + + + + +NCEPLIBS-w3emc: w3valdat.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3valdat.f File Reference
    +
    +
    + +

    Determine the validity of a date and time. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    logical function w3valdat (idat)
     This logical function returns true if the input is a valid NCEP absolute date and time. More...
     
    +

    Detailed Description

    +

    Determine the validity of a date and time.

    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition in file w3valdat.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3valdat()

    + +
    +
    + + + + + + + + +
    logical function w3valdat (integer, dimension(8) idat)
    +
    + +

    This logical function returns true if the input is a valid NCEP absolute date and time.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1998-01-05 Mark Iredell Initial.
    +
    Parameters
    + + +
    [in]IDATNCEP absolute date and time (year, month, day, time zone, hour, minute, second, millisecond)
    +
    +
    +
    Returns
    W3VALDAT True if idat is a valid NCEP date and time
    +
    Author
    Mark Iredell
    +
    Date
    1998-01-05
    + +

    Definition at line 18 of file w3valdat.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3valdat_8f.js b/ver-2.10.0/w3valdat_8f.js new file mode 100644 index 00000000..e2ae0782 --- /dev/null +++ b/ver-2.10.0/w3valdat_8f.js @@ -0,0 +1,4 @@ +var w3valdat_8f = +[ + [ "w3valdat", "w3valdat_8f.html#a8a051a793c804f190e2da69fd1e16ebe", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3valdat_8f_source.html b/ver-2.10.0/w3valdat_8f_source.html new file mode 100644 index 00000000..81392657 --- /dev/null +++ b/ver-2.10.0/w3valdat_8f_source.html @@ -0,0 +1,126 @@ + + + + + + + +NCEPLIBS-w3emc: w3valdat.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3valdat.f
    +
    +
    +Go to the documentation of this file.
    1 
    +
    4 
    +
    17  logical function w3valdat(idat)
    +
    18  integer idat(8)
    +
    19  real rinc1(5),rinc2(5)
    +
    20  integer jdat(8)
    +
    21 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    22 ! essentially move the date and time by a zero time interval
    +
    23 ! and see if the same date and time is returned
    +
    24  rinc1(1)=0
    +
    25  rinc1(2:5)=idat(5:8)
    +
    26  call w3reddat(-1,rinc1,rinc2)
    +
    27  jldayn=iw3jdn(idat(1),idat(2),idat(3))+nint(rinc2(1))
    +
    28  call w3fs26(jldayn,jdat(1),jdat(2),jdat(3),jdow,jdoy)
    +
    29 ! the time zone is valid if it is in signed hhmm format
    +
    30 ! with hh between -23 and 23 and mm equal to 00 or 30
    +
    31  jdat(4)=mod(idat(4)/100,24)*100+mod(mod(idat(4),100),60)/30*30
    +
    32  jdat(5:8)=nint(rinc2(2:5))
    +
    33  w3valdat=all(idat.eq.jdat)
    +
    34 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    +
    35  end
    +
    +
    +
    w3fs26
    subroutine w3fs26(JLDAYN, IYEAR, MONTH, IDAY, IDAYWK, IDAYYR)
    Computes year (4 digits), month, day, day of week, day of year from julian day number.
    Definition: w3fs26.f:56
    +
    w3valdat
    logical function w3valdat(idat)
    This logical function returns true if the input is a valid NCEP absolute date and time.
    Definition: w3valdat.f:18
    +
    w3reddat
    subroutine w3reddat(it, rinc, dinc)
    This subprogram reduces an ncep relative time interval into one of seven canonical forms,...
    Definition: w3reddat.f:86
    +
    iw3jdn
    function iw3jdn(IYEAR, MONTH, IDAY)
    Computes julian day number from year (4 digits), month, and day.
    Definition: iw3jdn.f:42
    + + + + diff --git a/ver-2.10.0/w3ymdh4_8f.html b/ver-2.10.0/w3ymdh4_8f.html new file mode 100644 index 00000000..44212209 --- /dev/null +++ b/ver-2.10.0/w3ymdh4_8f.html @@ -0,0 +1,214 @@ + + + + + + + +NCEPLIBS-w3emc: w3ymdh4.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    w3ymdh4.f File Reference
    +
    +
    + +

    4-byte date word unpacker and packer. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine w3ymdh4 (IDATE, IYEAR, MONTH, IDAY, IHOUR, NN)
     Obtains the components of the nmc date word (ncep y2k compliant form), or given its components, forms an nmc type date word. More...
     
    +

    Detailed Description

    +

    4-byte date word unpacker and packer.

    +
    Author
    K. F. Brill
    +
    Date
    1998-07-29
    + +

    Definition in file w3ymdh4.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ w3ymdh4()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine w3ymdh4 (character, dimension(4) IDATE,
     IYEAR,
     MONTH,
     IDAY,
     IHOUR,
     NN 
    )
    +
    + +

    Obtains the components of the nmc date word (ncep y2k compliant form), or given its components, forms an nmc type date word.

    +

    The packing is done using base 32.

    +

    If the first byte of IDATE is less than 101, then the old Office Note 84 packing is assumed. A four-digit year is always returned. To pack the "old" way, pass in a 2-digit year.

    +

    This program will work for the years ranging from A.D. 101 through 79359.

    +

    On unpacking, years less than or equal to 100 are returned as follows:

    +
      +
    • 0-50 2000–2050
      • +
    • 51-100 1951–2000
      • +
    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    1998-07-29 K. F. Brill Initial.
    1999-03-15 Gilbert Removed Call to W3FS11() and put its processing inline.
    +

    W3FS11 was deleted from the W3LIB.

    +
    Parameters
    + + + + + + + +
    [in,out]IDATELeft 4 bytes of integer 64 bit word, or can be IDATE(4) or CHARACTER*4 IDATE.
    [in,out]IYEARYear (4 digits or 2 digits for on84)
    [in,out]MONTHMonth
    [in,out]IDAYDay
    [in,out]IHOURHour
    [in]NNCode:
      +
    • .eq. 0 pack iyear, month, iday, ihour into idate
      • +
    • .ne. 0 unpack idate into iyear, month, iday, ihour
      • +
    +
    +
    +
    +
    Author
    K. F. Brill
    +
    Date
    1998-07-29
    + +

    Definition at line 43 of file w3ymdh4.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/w3ymdh4_8f.js b/ver-2.10.0/w3ymdh4_8f.js new file mode 100644 index 00000000..3e772cad --- /dev/null +++ b/ver-2.10.0/w3ymdh4_8f.js @@ -0,0 +1,4 @@ +var w3ymdh4_8f = +[ + [ "w3ymdh4", "w3ymdh4_8f.html#a78ffe9a370f362c71bcb5573f595f105", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/w3ymdh4_8f_source.html b/ver-2.10.0/w3ymdh4_8f_source.html new file mode 100644 index 00000000..1cccafd1 --- /dev/null +++ b/ver-2.10.0/w3ymdh4_8f_source.html @@ -0,0 +1,197 @@ + + + + + + + +NCEPLIBS-w3emc: w3ymdh4.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    w3ymdh4.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief 4-byte date word unpacker and packer.
    +
    3 C> @author K. F. Brill @date 1998-07-29
    +
    4 
    +
    5 C> Obtains the components of the nmc date word (ncep y2k
    +
    6 C> compliant form), or given its components, forms an nmc type date
    +
    7 C> word. The packing is done using base 32.
    +
    8 C>
    +
    9 C> If the first byte of IDATE is less than 101, then the old
    +
    10 C> Office Note 84 packing is assumed. A four-digit year is
    +
    11 C> always returned. To pack the "old" way, pass in a 2-digit
    +
    12 C> year.
    +
    13 C>
    +
    14 C> This program will work for the years ranging from A.D. 101
    +
    15 C> through 79359.
    +
    16 C>
    +
    17 C> On unpacking, years less than or equal to 100 are returned
    +
    18 C> as follows:
    +
    19 C>
    +
    20 C> - 0-50 2000--2050
    +
    21 C> - 51-100 1951--2000
    +
    22 C>
    +
    23 C>
    +
    24 C> ### Program History Log:
    +
    25 C> Date | Programmer | Comment
    +
    26 C> -----|------------|--------
    +
    27 C> 1998-07-29 | K. F. Brill | Initial.
    +
    28 C> 1999-03-15 | Gilbert | Removed Call to W3FS11() and put its processing inline.
    +
    29 C> W3FS11 was deleted from the W3LIB.
    +
    30 C>
    +
    31 C> @param[inout] IDATE Left 4 bytes of integer 64 bit word, or can be
    +
    32 C> IDATE(4) or CHARACTER*4 IDATE.
    +
    33 C> @param[inout] IYEAR Year (4 digits or 2 digits for on84)
    +
    34 C> @param[inout] MONTH Month
    +
    35 C> @param[inout] IDAY Day
    +
    36 C> @param[inout] IHOUR Hour
    +
    37 C> @param[in] NN Code:
    +
    38 C> - .eq. 0 pack iyear, month, iday, ihour into idate
    +
    39 C> - .ne. 0 unpack idate into iyear, month, iday, ihour
    +
    40 C>
    +
    41 C> @author K. F. Brill @date 1998-07-29
    +
    42  SUBROUTINE w3ymdh4 (IDATE,IYEAR,MONTH,IDAY,IHOUR,NN)
    +
    43 C
    +
    44  CHARACTER IDATE(4)
    +
    45 C
    +
    46  IF (nn.NE.0) THEN
    +
    47 C
    +
    48  itemp = mova2i(idate(1))
    +
    49  IF ( itemp .lt. 101 ) THEN
    +
    50  iyear = mova2i(idate(1))
    +
    51  month = mova2i(idate(2))
    +
    52  iday = mova2i(idate(3))
    +
    53  ihour = mova2i(idate(4))
    +
    54  IF(iyear.LE.100) iyear=2050-mod(2050-iyear,100)
    +
    55  RETURN
    +
    56  END IF
    +
    57  itemp = itemp - 101
    +
    58  itemp = itemp * 256 + mova2i(idate(2))
    +
    59  itemp = itemp * 256 + mova2i(idate(3))
    +
    60  itemp = itemp * 256 + mova2i(idate(4))
    +
    61  ihour = mod( itemp, 32 )
    +
    62  itemp = itemp / 32
    +
    63  iday = mod( itemp, 32 )
    +
    64  itemp = itemp / 32
    +
    65  month = mod( itemp, 32 )
    +
    66  iyear = itemp / 32
    +
    67 C
    +
    68  ELSE
    +
    69 C
    +
    70  itemp = iyear
    +
    71  IF ( itemp .lt. 101 ) THEN
    +
    72  idate(1) = char(iyear)
    +
    73  idate(2) = char(month)
    +
    74  idate(3) = char(iday)
    +
    75  idate(4) = char(ihour)
    +
    76  RETURN
    +
    77  END IF
    +
    78  itemp = itemp * 32 + month
    +
    79  itemp = itemp * 32 + iday
    +
    80  itemp = itemp * 32 + ihour
    +
    81 C*
    +
    82  idate(4)=char(mod(itemp,256))
    +
    83  itemp = itemp / 256
    +
    84  idate(3)=char(mod(itemp,256))
    +
    85  itemp = itemp / 256
    +
    86  idate(2)=char(mod(itemp,256))
    +
    87  itemp = itemp / 256
    +
    88  itemp = itemp + 101
    +
    89  idate(1)=char(itemp)
    +
    90 C
    +
    91  ENDIF
    +
    92 C
    +
    93  RETURN
    +
    94  END
    +
    +
    +
    mova2i
    integer function mova2i(a)
    This Function copies a bit string from a Character*1 variable to an integer variable.
    Definition: mova2i.f:25
    +
    w3ymdh4
    subroutine w3ymdh4(IDATE, IYEAR, MONTH, IDAY, IHOUR, NN)
    Obtains the components of the nmc date word (ncep y2k compliant form), or given its components,...
    Definition: w3ymdh4.f:43
    + + + + diff --git a/ver-2.10.0/xdopen_8f.html b/ver-2.10.0/xdopen_8f.html new file mode 100644 index 00000000..6f4eb109 --- /dev/null +++ b/ver-2.10.0/xdopen_8f.html @@ -0,0 +1,151 @@ + + + + + + + +NCEPLIBS-w3emc: xdopen.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    xdopen.f File Reference
    +
    +
    + +

    Dummy subroutine. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine xdopen
     This subroutine and the corresponding entries: "errset", "xdchek", "xdclos", "xdwrit", "xdread", and "xdform" are placed here to allow calling routines which reside on both the nas and the cray to compile. More...
     
    +

    Detailed Description

    +

    Dummy subroutine.

    +
    Author
    Dennis Keyser
    +
    Date
    1992-07-02
    + +

    Definition in file xdopen.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ xdopen()

    + +
    +
    + + + + +
    subroutine xdopen
    +
    + +

    This subroutine and the corresponding entries: "errset", "xdchek", "xdclos", "xdwrit", "xdread", and "xdform" are placed here to allow calling routines which reside on both the nas and the cray to compile.

    +

    These subroutines perform nas-specific functions, but have no corresponding function on the cray. There- fore this subroutine is a "dummy". ft06 print is provided to alert the user that the call to the subroutine results in an immediate return with no function.

    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    1992-07-02 Dennis Keyser (W/NMC22) Initial.
    +
    Author
    Dennis Keyser
    +
    Date
    1992-07-02
    + +

    Definition at line 21 of file xdopen.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/xdopen_8f.js b/ver-2.10.0/xdopen_8f.js new file mode 100644 index 00000000..64add31c --- /dev/null +++ b/ver-2.10.0/xdopen_8f.js @@ -0,0 +1,4 @@ +var xdopen_8f = +[ + [ "xdopen", "xdopen_8f.html#a941a5a5172e73a4d75553437ad275ece", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/xdopen_8f_source.html b/ver-2.10.0/xdopen_8f_source.html new file mode 100644 index 00000000..4256caba --- /dev/null +++ b/ver-2.10.0/xdopen_8f_source.html @@ -0,0 +1,154 @@ + + + + + + + +NCEPLIBS-w3emc: xdopen.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    xdopen.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Dummy subroutine
    +
    3 C> @author Dennis Keyser @date 1992-07-02
    +
    4 
    +
    5 C> This subroutine and the corresponding entries: "errset",
    +
    6 C> "xdchek", "xdclos", "xdwrit", "xdread", and "xdform" are placed
    +
    7 C> here to allow calling routines which reside on both the nas and
    +
    8 C> the cray to compile. These subroutines perform nas-specific
    +
    9 C> functions, but have no corresponding function on the cray. There-
    +
    10 C> fore this subroutine is a "dummy". ft06 print is provided to
    +
    11 C> alert the user that the call to the subroutine results in an
    +
    12 C> immediate return with no function.
    +
    13 C>
    +
    14 C> ### Program History Log:
    +
    15 C> Date | Programmer | Comment
    +
    16 C> -----|------------|--------
    +
    17 C> 1992-07-02 | Dennis Keyser (W/NMC22) | Initial.
    +
    18 C>
    +
    19 C> @author Dennis Keyser @date 1992-07-02
    +
    20  SUBROUTINE xdopen
    +
    21 C
    +
    22  CHARACTER*6 ROUTIN(7)
    +
    23 C
    +
    24  DATA routin/'XDOPEN','ERRSET','XDCHEK','XDCLOS','XDWRIT',
    +
    25  $ 'XDREAD','XDFORM'/
    +
    26 C
    +
    27  icall = 1
    +
    28  GO TO 99
    +
    29  entry errset
    +
    30  icall = 2
    +
    31  GO TO 99
    +
    32  entry xdchek
    +
    33  icall = 3
    +
    34  GO TO 99
    +
    35  entry xdclos
    +
    36  icall = 4
    +
    37  GO TO 99
    +
    38  entry xdwrit
    +
    39  icall = 5
    +
    40  GO TO 99
    +
    41  entry xdread
    +
    42  icall = 6
    +
    43  GO TO 99
    +
    44  entry xdform
    +
    45  icall = 7
    +
    46  99 CONTINUE
    +
    47  print 1, routin(icall)
    +
    48  1 FORMAT(/2x,'%%%% SUBR. ',a6,' HAS NO FCN ON THE CRAY, BUT IS ',
    +
    49  $ 'PROVIDED TO ALLOW CODES TO COMPILE ON THE NAS & CRAY; RETURN ',
    +
    50  $ 'TO CALLING PGM'//)
    +
    51  RETURN
    +
    52  END
    +
    +
    +
    xdopen
    subroutine xdopen
    This subroutine and the corresponding entries: "errset", "xdchek", "xdclos", "xdwrit",...
    Definition: xdopen.f:21
    + + + + diff --git a/ver-2.10.0/xmovex_8f.html b/ver-2.10.0/xmovex_8f.html new file mode 100644 index 00000000..e0438f5d --- /dev/null +++ b/ver-2.10.0/xmovex_8f.html @@ -0,0 +1,175 @@ + + + + + + + +NCEPLIBS-w3emc: xmovex.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    xmovex.f File Reference
    +
    +
    + +

    Assembler language to move data. +More...

    + +

    Go to the source code of this file.

    + + + + +

    +Functions/Subroutines

    subroutine xmovex (OUT, IN, IBYTES)
     
    +

    Detailed Description

    +

    Assembler language to move data.

    +
    Author
    Unknown
    +
    Date
    Unknown
    + +

    Definition in file xmovex.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ xmovex()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine xmovex (character*1, dimension(*) OUT,
    character*1, dimension(*) IN,
    integer IBYTES 
    )
    +
    +

    +Program History Log:

    + + + + + +
    Date Programmer Comment
    Unkonwn Unknonw Initial.
    +
    Parameters
    + + + + +
    [out]OUT
    [in]IN
    IBYTESThis subroutine may not be needed, its was in assembler language to move data, it ran about three times faster than a fortan do loop, it was used to make sure the data to be unpacked was on a word boundary, this may not be needed on some brands of computers.
    +
    +
    +
    Author
    Unknown
    +
    Date
    Unknown
    + +

    Definition at line 21 of file xmovex.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/xmovex_8f.js b/ver-2.10.0/xmovex_8f.js new file mode 100644 index 00000000..85b8a2f5 --- /dev/null +++ b/ver-2.10.0/xmovex_8f.js @@ -0,0 +1,4 @@ +var xmovex_8f = +[ + [ "xmovex", "xmovex_8f.html#a4736b412fd765dc34e51e7ebf774cc61", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/xmovex_8f_source.html b/ver-2.10.0/xmovex_8f_source.html new file mode 100644 index 00000000..b8c95ff7 --- /dev/null +++ b/ver-2.10.0/xmovex_8f_source.html @@ -0,0 +1,133 @@ + + + + + + + +NCEPLIBS-w3emc: xmovex.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    xmovex.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Assembler language to move data
    +
    3 C> @author Unknown @date Unknown
    +
    4 
    +
    5 C> ### Program History Log:
    +
    6 C> Date | Programmer | Comment
    +
    7 C> -----|------------|--------
    +
    8 C> Unkonwn | Unknonw | Initial.
    +
    9 C>
    +
    10 C> @param[out] OUT
    +
    11 C> @param[in] IN
    +
    12 C> @param IBYTES
    +
    13 C> This subroutine may not be needed, its was in
    +
    14 C> assembler language to move data, it ran about three
    +
    15 C> times faster than a fortan do loop, it was used to
    +
    16 C> make sure the data to be unpacked was on a word boundary,
    +
    17 C> this may not be needed on some brands of computers.
    +
    18 C>
    +
    19 C> @author Unknown @date Unknown
    +
    20  SUBROUTINE xmovex(OUT,IN,IBYTES)
    +
    21  CHARACTER*1 OUT(*)
    +
    22  CHARACTER*1 IN(*)
    +
    23 C
    +
    24  INTEGER IBYTES
    +
    25 C
    +
    26  DO 100 i = 1,ibytes
    +
    27  out(i) = in(i)
    +
    28  100 CONTINUE
    +
    29 C
    +
    30  RETURN
    +
    31  END
    +
    +
    +
    xmovex
    subroutine xmovex(OUT, IN, IBYTES)
    Definition: xmovex.f:21
    + + + + diff --git a/ver-2.10.0/xstore_8f.html b/ver-2.10.0/xstore_8f.html new file mode 100644 index 00000000..6be08490 --- /dev/null +++ b/ver-2.10.0/xstore_8f.html @@ -0,0 +1,182 @@ + + + + + + + +NCEPLIBS-w3emc: xstore.f File Reference + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +Functions/Subroutines
    +
    +
    xstore.f File Reference
    +
    +
    + +

    Stores a constant value into an array. +More...

    + +

    Go to the source code of this file.

    + + + + + +

    +Functions/Subroutines

    subroutine xstore (COUT, CON, MWORDS)
     Stores an 8-byte (fullword) value through consecutive storage locations. More...
     
    +

    Detailed Description

    +

    Stores a constant value into an array.

    +
    Author
    Dennis Keyser
    +
    Date
    1992-07-02
    + +

    Definition in file xstore.f.

    +

    Function/Subroutine Documentation

    + +

    ◆ xstore()

    + +
    +
    + + + + + + + + + + + + + + + + + + + + + + + + +
    subroutine xstore (dimension(*) COUT,
     CON,
     MWORDS 
    )
    +
    + +

    Stores an 8-byte (fullword) value through consecutive storage locations.

    +

    (moving is accomplished with a do loop.)

    +

    +Program History Log:

    + + + + + + + +
    Date Programmer Comment
    1992-07-02 Dennis Keyser (W/NMC22) Initial.
    1995-10-31 Mark Iredell Removed saves and prints.
    +
    Parameters
    + + + + +
    [in]CONConstant to be stored into "mwords" consecutive fullwords beginning with "cout" array
    [in]MWORDSNumber of fullwords in "cout" array to store "con"; must be .gt. zero (not checked for this)
    [out]COUTStarting address for array of "mwords" fullwords set to the contents of the value "con"
    +
    +
    +
    Remarks
    The version of this subroutine on the hds common library is nas-specific subr. written in assembly lang. to allow fast computation time. subr. placed in cray w3lib to allow codes to compile on both the hds and cray machines. subprogram can be called from a multiprocessing environment.
    +
    Author
    Dennis Keyser
    +
    Date
    1992-07-02
    + +

    Definition at line 29 of file xstore.f.

    + +
    +
    +
    +
    + + + + diff --git a/ver-2.10.0/xstore_8f.js b/ver-2.10.0/xstore_8f.js new file mode 100644 index 00000000..07d11501 --- /dev/null +++ b/ver-2.10.0/xstore_8f.js @@ -0,0 +1,4 @@ +var xstore_8f = +[ + [ "xstore", "xstore_8f.html#a31e695d6327ff9328c6604bc9d72a245", null ] +]; \ No newline at end of file diff --git a/ver-2.10.0/xstore_8f_source.html b/ver-2.10.0/xstore_8f_source.html new file mode 100644 index 00000000..26ab465d --- /dev/null +++ b/ver-2.10.0/xstore_8f_source.html @@ -0,0 +1,139 @@ + + + + + + + +NCEPLIBS-w3emc: xstore.f Source File + + + + + + + + + + + + + +
    +
    + + + + + + +
    +
    NCEPLIBS-w3emc +  2.10.0 +
    +
    +
    + + + + + + + +
    +
    + +
    +
    +
    + +
    + +
    +
    + + +
    + +
    + +
    +
    +
    xstore.f
    +
    +
    +Go to the documentation of this file.
    1 C> @file
    +
    2 C> @brief Stores a constant value into an array
    +
    3 C> @author Dennis Keyser @date 1992-07-02
    +
    4 
    +
    5 C> Stores an 8-byte (fullword) value through consecutive storage locations.
    +
    6 C> (moving is accomplished with a do loop.)
    +
    7 C>
    +
    8 C> ### Program History Log:
    +
    9 C> Date | Programmer | Comment
    +
    10 C> -----|------------|--------
    +
    11 C> 1992-07-02 | Dennis Keyser (W/NMC22) | Initial.
    +
    12 C> 1995-10-31 | Mark Iredell | Removed saves and prints.
    +
    13 C>
    +
    14 C> @param[in] CON Constant to be stored into "mwords" consecutive
    +
    15 C> fullwords beginning with "cout" array
    +
    16 C> @param[in] MWORDS Number of fullwords in "cout" array to store "con";
    +
    17 C> must be .gt. zero (not checked for this)
    +
    18 C> @param[out] COUT Starting address for array of "mwords" fullwords
    +
    19 C> set to the contents of the value "con"
    +
    20 C>
    +
    21 C> @remark The version of this subroutine on the hds common library
    +
    22 C> is nas-specific subr. written in assembly lang. to allow fast
    +
    23 C> computation time. subr. placed in cray w3lib to allow codes to
    +
    24 C> compile on both the hds and cray machines.
    +
    25 C> subprogram can be called from a multiprocessing environment.
    +
    26 C>
    +
    27 C> @author Dennis Keyser @date 1992-07-02
    +
    28  SUBROUTINE xstore(COUT,CON,MWORDS)
    +
    29 C
    +
    30  dimension cout(*)
    +
    31 C
    +
    32  DO 1000 i = 1,mwords
    +
    33  cout(i) = con
    +
    34 1000 CONTINUE
    +
    35 C
    +
    36  RETURN
    +
    37  END
    +
    +
    +
    xstore
    subroutine xstore(COUT, CON, MWORDS)
    Stores an 8-byte (fullword) value through consecutive storage locations.
    Definition: xstore.f:29
    + + + +